home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / FORTHCMP.ZIP / UNIQ.4TH < prev    next >
Encoding:
Text File  |  1992-03-30  |  4.0 KB  |  167 lines
  1. \ UNIQ PROGRAM, BY TOM ALMY.
  2.  
  3. \ THIS PROGRAM IS COPYRIGHT (C) 1985 BY TOM ALMY,
  4. \ ALL RIGHTS RESERVED.
  5. \ Permission is granted to registered users of ForthCMP to sell or distribute
  6. \ computer programs incorporating the compiled contents of this file.
  7.  
  8. \ Based on the UNIX (TM Bell Labs) "uniq" program
  9.  
  10. \ DATA STORAGE
  11. 100 MSDOS
  12. HEX 4000 DECIMAL CONSTANT BUFSIZ
  13. INCLUDE FILTER
  14.  
  15. VARIABLE RAW-LINE   256 ALLOT   ( before preprocessing )
  16. VARIABLE LAST-RAW-LINE 256 ALLOT ( last before preproc. )
  17. VARIABLE LAST-LINE  256 ALLOT   ( first byte is length )
  18. VARIABLE THIS-LINE  256 ALLOT   ( first byte is length )
  19. VARIABLE UFLAG   ( Options )
  20. VARIABLE DFLAG
  21. VARIABLE CFLAG
  22. VARIABLE SKIPCOLUMNS
  23. VARIABLE SKIPFIELDS
  24. VARIABLE COUNTER       ( repetitions of a line )
  25.  
  26. \ MESSAGES
  27. 0 0 IN/OUT 
  28. : NOTICE  
  29.    ." UNIQ PROGRAM " CR
  30.    ." COPYRIGHT (C) 1985 BY THOMAS ALMY " CR ;
  31.  
  32. 0 0 IN/OUT 
  33. : USAGE   CONSOLE CR
  34.  ." USAGE:  UNIQ [-options] [infile] [outfile]" CR
  35.  ." To specify outfile without infile, give `-' for infile" CR
  36.  ." Options are:" CR
  37.  ."  U output non-repeated lines" CR
  38.  ."  D output one copy of repeated lines"  CR
  39.  ."  C give output report instead"  CR
  40.  ."  no specification is same as `-UD'" CR
  41.  ."  +n -- skip n fields" CR
  42.  ."  -n  -- skip n characters  (after fields)" CR
  43.  ABORT
  44.   ;
  45.  
  46. \ GET OPTION ARGUMENTS
  47.  
  48. 1 2 IN/OUT
  49. : GETNUMBER ( pointerToFirstChar -- PointerAfterEnd Value )
  50.     1- 0. ROT CONVERT -ROT DROP ;
  51.  
  52. 2 1 IN/OUT 
  53. : GET-MINUS-ARGS  ( string character -- string' )
  54.     DUP ASCII a >= OVER ASCII z <= AND IF BL - THEN
  55.     CASE
  56.        ASCII - OF ( IGNORE ) ENDOF
  57.        ASCII U OF UFLAG ON ENDOF
  58.        ASCII D OF DFLAG ON ENDOF
  59.        ASCII C OF CFLAG ON ENDOF
  60.        DUP ASCII 9 <= OVER ASCII 0 >= AND IF
  61.         SWAP 1- GETNUMBER SKIPCOLUMNS ! SWAP
  62.     ELSE
  63.         CONSOLE ." UNKNOWN OPTION " EMIT USAGE 
  64.     THEN
  65.        ENDCASE   ;
  66.  
  67. 0 0 IN/OUT 
  68. : GET-ARGS OPTIONSTRING 2+ @ ( address )
  69.   BEGIN  
  70.     DUP OPTIONSTRING 2+ @ - OPTIONSTRING @ < 
  71.   WHILE ( continue while args )
  72.     COUNT DUP ASCII + = IF
  73.         DROP GETNUMBER SKIPFIELDS ! 
  74.     ELSE
  75.         GET-MINUS-ARGS
  76.     THEN
  77.   REPEAT
  78.   DROP
  79.   UFLAG @ DFLAG @ CFLAG @ OR OR NOT IF ( dc&u not specified )
  80.       UFLAG ON DFLAG ON THEN ;
  81.  
  82.  
  83. \ GET A LINE
  84. PRIMITIVE
  85. : INDEX ( addr len index -- addr' len' )
  86.    TUCK - 0 MAX  ( addr index len' )
  87.    -ROT + SWAP ;
  88.  
  89. 2 2 IN/OUT
  90. : SKIP-FIELD ( addr len -- addr' len' )
  91.      BL SCAN BL SKIP ;
  92.  
  93. 2 2 IN/OUT
  94. : ?SKIP-COLUMNS ( addr len -- addr' len' )
  95.     SKIPCOLUMNS @ ?DUP IF  INDEX THEN ;
  96.  
  97. 2 2 IN/OUT
  98. : ?SKIP-FIELDS  ( addr len -- addr' len' )
  99.     SKIPFIELDS @ 0 ?DO SKIP-FIELD LOOP ;
  100.  
  101. 0 1 IN/OUT
  102. : GET-LINE? ( -- successflag )
  103.    RAW-LINE 1+ 255 EXPECT ( get that line )
  104.    SPAN @ DUP 0< IF DROP 0 EXIT THEN  ( EOF reached --> FAILED )
  105.     RAW-LINE C! ( store length of raw line )
  106.    RAW-LINE COUNT ?SKIP-FIELDS ?SKIP-COLUMNS
  107.    DUP THIS-LINE C!
  108.     THIS-LINE 1+ SWAP CMOVE ( move preprocessed line into place)
  109.    -1 ( success! )  ;
  110.  
  111. \ PERFORM-UNIQ AND HELP FUNCTIONS
  112. 0 0 IN/OUT
  113. : MAKE-IT-LAST
  114.   THIS-LINE DUP C@ 1+ LAST-LINE SWAP  CMOVE
  115.   RAW-LINE DUP C@ 1+ LAST-RAW-LINE SWAP CMOVE ;
  116.  
  117. 0 1 IN/OUT
  118. : LINES-SAME?  ( -- equalflag )
  119.   THIS-LINE COUNT LAST-LINE COUNT
  120.    ROT OVER = IF S= ELSE 2DROP DROP 0 THEN ;
  121.  
  122. 0 0 IN/OUT
  123. : SPIT-LINE
  124.     LAST-RAW-LINE COUNT TYPE CR ;
  125.  
  126. 0 0 IN/OUT
  127. : REPORT-LINE
  128.     COUNTER @ 1+ 4 .R  2 SPACES  SPIT-LINE ;
  129.  
  130. 0 0 IN/OUT
  131. : THE-SAME
  132.      COUNTER @ 0= IF  DFLAG @ IF SPIT-LINE THEN THEN
  133.      1 COUNTER +! ;
  134.  
  135. 0 0 IN/OUT
  136. : NOT-SAME
  137.    CFLAG @ IF REPORT-LINE  COUNTER OFF
  138.            ELSE COUNTER @ IF  COUNTER OFF  ELSE
  139.                             UFLAG @ IF SPIT-LINE THEN
  140.                           THEN
  141.            THEN
  142.    MAKE-IT-LAST ;
  143.  
  144. 0 0 IN/OUT
  145. : PERFORM-UNIQ
  146.     GET-LINE? NOT IF EXIT THEN   MAKE-IT-LAST
  147.     COUNTER OFF
  148.     BEGIN  GET-LINE? WHILE
  149.     LINES-SAME? IF THE-SAME  ELSE NOT-SAME THEN
  150.     REPEAT
  151.     NOT-SAME
  152. ;
  153.  
  154. \ MAIN PROGRAM
  155. : MAIN    
  156.   SETBUFS
  157.   NOTICE
  158.   SETFILES IF USAGE THEN
  159.   GET-ARGS
  160.   PERFORM-UNIQ
  161.   BYE ;
  162.  
  163. INCLUDE DOS2
  164. INCLUDE FORTHLIB
  165. END
  166.  
  167.