home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / FORTHCMP.ZIP / TR.4TH < prev    next >
Encoding:
Text File  |  1992-03-30  |  11.9 KB  |  407 lines
  1. \ TR PROGRAM
  2. \ TRANSLATES SOURCE FILE INTO DESTINATION FILE.
  3. \ WORKS LIKE UNIX tr WITH FOLLOWING EXCEPTIONS:
  4. \ 1. -A OPTION NEEDED FOR ASCII FILES.
  5. \ 2. HANDLES NULL CHARACTERS!
  6.  
  7. \ This program Copyright (C) 1985 by Thomas Almy.
  8. \ Permission is granted to registered users of ForthCMP to sell or distribute
  9. \ computer programs incorporating the compiled contents of this file.
  10.  
  11.  
  12. 0 #IF
  13.  
  14. ( note -- program has been modified since writing this paper, and
  15.   this paper benchmarks the original CP/M version of the compiler)
  16.  
  17.                               TRANSLATE PROGRAM
  18.                                  by Tom Almy
  19.                                  August 1985
  20.  
  21. PROGRAM DESCRIPTION     
  22.  
  23.      This program was designed to mimic the functionality of the "tr"
  24. program provided on UNIX (tm Bell Labs) systems.  While written to be
  25. compiled with the author's ForthCMP Forth Compiler, it can be
  26. utilized on any 83 Standard system by providing an appropriate file
  27. system interface.
  28.  
  29.      TR is used to make one or more single character substitutions in
  30. a file.  ForthCMP's FILTER file interface allows specifying an input
  31. file and an optional output file (if no output file is specified,
  32. output goes to the display).  The file name(s) are followed by an
  33. optional option specification and one or two character specifying
  34. strings. 
  35.  
  36.      Characters in the strings may be any character except "\"
  37. (backslash) or "-" (hyphen).  Any of the 256 possible character codes
  38. can be specified by backslash followed by one, two, or three octal
  39. digits.  Backslash followed by a lower case character becomes an
  40. upper-case character (done to allow putting the string on a CP/M
  41. command line).  Backslash followed by any other character is that
  42. character, so "-" can be represented as "\-" and "\" can be
  43. represented as "\\".  A range of characters can be represented by the
  44. first character followed by a hyphen followed by the last character.
  45.  
  46.      If no options are specified, a translation occurs in which each
  47. character which is in the first specification string is replaced with
  48. the character in the same position in the second specification
  49. string.  If the second string is shorter than the first then the
  50. string is extended by appending copies of its last character.
  51.  
  52.      The option specifcation can contain any or all of the following
  53. characters:
  54.  
  55. A ASCII mode: On input CR is deleted (leaving just LF of CR-LF pairs)
  56.      and on output LF is replaced with CR-LF pairs.  This allows 
  57.      translating to or from CR-LF pairs.  Additionally, Control-Z denotes
  58.      end of file.
  59.  
  60. C Complement first string: The first string is replaced with a new
  61.      string consisting of the characters in the range 0 through 255
  62.      not in the first string.  This string is sorted.
  63.  
  64. D Delete instead of translate: No translation takes place; 
  65.      instead any characters in the first specification string are deleted.
  66.  
  67. S Squeeze output: Sequential occurrences in the character stream
  68.      (after translation/deletion) of two or more identical
  69.      characters in the second specification string are squeezed to a
  70.      single occurrence.
  71.  
  72. Example commands:
  73.  
  74. Options   String1        String2        Function
  75.           a-z            A-Z            Upcase file
  76.           a-zA-Z         A-Za-z         Swap case file
  77. AS        \12            \12            Delete blank lines
  78. ACS       !-~            \12            Put all words on separate lines
  79. AS        \40            \12            Put all words on separate lines
  80. ACDS      A-Za-z\12\40                  Delete all non alphabetics, except
  81.                                         spaces and newlines.
  82.           \200-\377      \0-\177        Clear parity bits.
  83.  
  84. PERFORMANCE
  85.  
  86.      I compared the performance of the Forth program, using the
  87. ForthCMP compiler, with that of C, using the MANX (AZTEC) compiler.
  88. The system used was a LOBO MAX-80, which has a 5-Mhz Z-80 processor,
  89. 1.2 MByte 8" floppy drives, and runs CP/M+.
  90.  
  91.  
  92. Characteristic                          Forth          C
  93.  
  94. Source file lines (not blank)           163            139
  95.  
  96. Compilation time    Compile Step        44             44   seconds
  97.                     Assemble Step       none           32
  98.                     Link Step           none           38         
  99.                     TOTAL               44             114
  100.  
  101. COM file size                           3584           9984 bytes
  102.  
  103. Test case execution time                21             138  seconds
  104.  
  105.      The test case involved upcasing a 14k byte file.  The PIP
  106. program (which is written in assembly language) took 16 seconds.
  107.  
  108.      The ForthCMP compiler compiles and links in a single step.  5
  109. seconds was spent producing a load map (not done in the C example),
  110. so the ForthCMP compilation time could really be considered to be 39
  111. seconds.  
  112.  
  113.  
  114.  
  115. READING THE LISTING
  116.  
  117.      First, ignore the INCLUDE, ROMABLE, and IN/OUT commands, as they
  118. are directives for the compiler.  The definition of CARRAY is "CREATE
  119. ALLOT DOES> +".  The definition of C<- is "SWAP C!". The non-standard
  120. words ?DO " <= >= ON OFF ASCII CONTROL SKIP and SCAN and Eaker' case
  121. statement (CASE OF ENDOF ENDCASE) have their usual definitions.
  122.  
  123.      The file interface redefines KEY and EXPECT to read from the
  124. input file.  KEY returns -1 on end of file; otherwise it returns the
  125. next character as an integer in the range 0 through 255.  Because the
  126. new EXPECT does not echo and has no editing, OLD- EXPECT (which is
  127. system dependent) had to be provided.  Output (EMIT and words which
  128. call it) is rewritten to send output to the output file when FILTER
  129. is executed, or to the display when CONSOLE is executed.
  130.  
  131.      SETFILES is used to initialize the input and output files, and
  132. returns TRUE if successful.  The double variable OPTIONSTRING is set
  133. to contain a pointer to and length of the command tail (that part
  134. excluding the file specifications).  ENDFILES does any necessary file
  135. closing.
  136.  
  137.  
  138.  
  139. #THEN
  140.  
  141.  
  142.  
  143. \ Modified for new filter August, 1986
  144. \ Modified for newest DOS interface 12/91
  145. 100 MSDOS
  146. HEX 4000 DECIMAL CONSTANT BUFSIZ
  147. INCLUDE VARS
  148. INCLUDE DOS1
  149.  
  150.  
  151. 256 CARRAY TRTABLE  \ translation table 
  152. 256 CARRAY SQTABLE  \ squeeze duplicates table 
  153. CREATE  INLIST  512 ALLOT  \ instring values 
  154. CREATE  OUTLIST 512 ALLOT  \ outstring values 
  155. VARIABLE DEL-FLAG   \ deletion flag specified 
  156. VARIABLE COM-FLAG   \ reverse sense flag specified 
  157. VARIABLE SQU-FLAG   \ squeeze output string flag 
  158. VARIABLE ASC-FLAG   \ ascii-mode --> CR dropped on input, added
  159.                     \ before LF's on output , CONTROL-Z terminates file 
  160. VARIABLE ^LIST
  161. VARIABLE LASTCHAR
  162.  
  163. -1 CONSTANT TRUE
  164. 0 CONSTANT FALSE
  165. CONTROL M CONSTANT ACR    \ Carriage Return
  166. CONTROL J CONSTANT ALF    \ Line Feed
  167.  
  168.  
  169. \ OUTPUT FILE HANDLING ( basically filter.4th )
  170.  
  171. VARIABLE outhandle  stderr outhandle !
  172. VARIABLE outbuffer
  173. VARIABLE outbufptr
  174. VARIABLE outbufend
  175.  
  176. 0 0 IN/OUT 
  177. : flushout   outbuffer @ outbufptr @ <> IF
  178.     outhandle @ outbuffer @  outbufptr @ outbuffer @ - DUP >R write
  179.     outbuffer @ outbufptr ! R> <> IF  stderr outhandle !
  180.         ." DISK FULL " flushout 4 RETURN THEN 
  181.     THEN ;
  182.  
  183. : EMIT  outbufptr @ DUP outbuffer @ BUFSIZ + = IF flushout
  184.    DROP outbuffer @ THEN C! 1 outbufptr +! ;
  185.  
  186. 0 0 IN/OUT 
  187. : CONSOLE flushout stderr outhandle ! ;
  188.  
  189. 0 0 IN/OUT 
  190. : FILTER  flushout stdout outhandle ! ;
  191.  
  192. 0 0 IN/OUT : BYE flushout  bye ;
  193.  
  194. 0 0 IN/OUT : ABORT flushout 4 RETURN ;
  195.  
  196. \ INPUT FILE PROCESSING
  197. VARIABLE inbuffer  ( pointer to allocated buffer )
  198. VARIABLE inbufptr  
  199. VARIABLE inbufend
  200.  
  201. 0 0 IN/OUT
  202. : SETBUFS  ( must execute before any I/O to allocate buffers )
  203.   129 TIB 127 CMOVE ( parse from command line )
  204.   128 C@ #TIB !
  205.   HERE inbuffer !
  206.   BUFSIZ ALLOT
  207.   HERE DUP outbuffer ! outbufptr !
  208.   BUFSIZ ALLOT
  209.   ; 
  210.  
  211.  
  212.  
  213. \ This version of KEY returns -1 on end of file!
  214. : KEY  inbufptr @ inbufend @ = IF ( fetch block )
  215.     stdin inbuffer @ BUFSIZ read ?DUP 0= IF ( EOF/ERROR ) -1  EXIT THEN
  216.     inbuffer @ + inbufend !
  217.     inbuffer @ inbufptr ! THEN
  218.     inbufptr @ C@  1 inbufptr +!  ;
  219.  
  220.  
  221. \ Commentary
  222. 0 0 IN/OUT
  223. : HELLO
  224.   ." TRANSLATE PROGRAM" CR
  225.   ." Copyright (C) 1985 by Thomas Almy." CR ;
  226.  
  227. 0 0 IN/OUT
  228. : USAGE
  229.     CONSOLE 
  230.     CR ." [-[A][C][D][S]] str1 [str2]"
  231.     CR  ." Options are Ascii Complement-str1 Delete Squeeze"
  232.     CR  ." strings may have \octal or range specifications."
  233.     ABORT
  234. ;
  235.  
  236. \ List Accessing
  237. 1 0 IN/OUT
  238. : ISLIST ( list -- ) ^LIST ! ;
  239.  
  240. 1 0 IN/OUT
  241. : !LIST ( char -- ) ^LIST @ !  2 ^LIST +! ;
  242.  
  243. 0 1 IN/OUT
  244. : @LIST ( -- char ) ^LIST @ @  2 ^LIST +! ;
  245.  
  246. \ Miscellaneous Subroutines
  247. 1 1 IN/OUT
  248. : UPCASE  ( char -- char )
  249.    DUP ASCII a >= IF DUP ASCII z <= IF BL - THEN THEN ;
  250.  
  251. PRIMITIVE
  252. : NEXT-CHAR ( addr len -- addr+1 len-1 char, or zero if end )
  253.    DUP IF 1- SWAP COUNT ROT SWAP ELSE FALSE THEN ;
  254.  
  255. PRIMITIVE
  256. : OCTAL? ( addr len -- addr len boolean )
  257.    OVER C@ DUP ASCII 0 >= SWAP ASCII 7 <= AND ;
  258.  
  259. : ?BACKSLASH ( addr len char -- addr' len' value )
  260.    DUP ASCII \ = IF DROP
  261.    OCTAL? IF NEXT-CHAR ASCII 0 - >R
  262.         OCTAL? IF NEXT-CHAR ASCII 0 - R> 8 * + >R
  263.           OCTAL? IF NEXT-CHAR ASCII 0 - R> 8 * + >R
  264.         THEN THEN R>
  265.     ELSE
  266.         NEXT-CHAR  
  267.    THEN THEN ;
  268.  
  269. : FILL-LIST ( string length list -- )
  270.   ISLIST
  271.   BEGIN  NEXT-CHAR ?DUP  WHILE
  272.     DUP ASCII - = IF DROP NEXT-CHAR ?BACKSLASH 1+
  273.         ^LIST @ 2- @ 1+  DO I !LIST LOOP  ELSE
  274.     ?BACKSLASH !LIST  THEN  REPEAT
  275.   -1 !LIST ( delimit list )
  276.   2DROP ;
  277.  
  278.  
  279. \ Handle option string
  280. 0 0 IN/OUT
  281. : DO-OPTION-STRING
  282.     HERE COUNT SWAP 1+ SWAP 1 ?DO
  283.         COUNT UPCASE CASE
  284.             ASCII A OF  ASC-FLAG ON ENDOF
  285.             ASCII D OF  DEL-FLAG ON ENDOF
  286.             ASCII C OF  COM-FLAG ON ENDOF
  287.             ASCII S OF  SQU-FLAG ON ENDOF
  288.             ." UNKNOWN OPTION -- " EMIT USAGE ENDCASE
  289.         LOOP 
  290.     DROP
  291.     BL WORD DROP  ( scan next word )
  292.     ;
  293.  
  294. 0 0 IN/OUT
  295. : SET-OPTIONS
  296.     ASC-FLAG OFF
  297.     DEL-FLAG OFF
  298.     COM-FLAG OFF
  299.     SQU-FLAG OFF
  300.     BL WORD COUNT 0> SWAP C@ ASCII - = AND IF ( an option string )
  301.         DO-OPTION-STRING  
  302.     THEN
  303.     ;
  304.  
  305.  
  306. \ Various Table handling routines
  307. 1 0 IN/OUT 
  308. : SET-SQUTABLE    ( hostlist -- )  ISLIST
  309.   ['] SQTABLE >BODY 256 0 FILL
  310.    BEGIN  @LIST DUP 0< NOT WHILE
  311.             SQTABLE TRUE C<- ( set flag in byte )
  312.    REPEAT DROP ;
  313.  
  314. 0 0 IN/OUT 
  315. : COMPLEMENT-LIST ( complements INLIST )
  316.   INLIST  SET-SQUTABLE  INLIST ISLIST
  317.   256 0 DO I SQTABLE C@ 0= IF I !LIST THEN LOOP
  318.   -1 !LIST  ;
  319.  
  320. 0 0 IN/OUT
  321. : FILL-TRTABLE   ( TRTABLE gets filled from INLIST )
  322.   ['] TRTABLE >BODY 256 0 FILL
  323.      INLIST ISLIST BEGIN  @LIST DUP 0< NOT WHILE
  324.            TRTABLE TRUE C<-  ( set flag in byte )
  325.       REPEAT  DROP ;
  326.  
  327. 0 0 IN/OUT
  328. : SET-TRTABLE  ( TRTABLE is translation table from INLIST to OUTLIST )
  329.    256 0 DO I DUP TRTABLE C! LOOP   INLIST ISLIST
  330.    OUTLIST BEGIN  ^LIST @ @ 0< NOT WHILE
  331.       DUP @ 0< IF DUP 2- @ ELSE DUP @ SWAP 2+ SWAP THEN
  332.       @LIST TRTABLE C! REPEAT
  333.    DROP ;
  334.  
  335. \ Information from user?
  336. 0 0 IN/OUT
  337. : GET-RANGES
  338.     HERE COUNT INLIST FILL-LIST
  339.     COM-FLAG @ IF 
  340.         COMPLEMENT-LIST 
  341.     THEN
  342.     
  343.     BL WORD COUNT OUTLIST FILL-LIST
  344.     SQU-FLAG @ IF 
  345.         OUTLIST SET-SQUTABLE 
  346.     THEN
  347.     DEL-FLAG @ IF 
  348.         FILL-TRTABLE 
  349.     ELSE 
  350.         SET-TRTABLE 
  351.     THEN
  352. ;
  353.  
  354. \ Translate functions
  355. PRIMITIVE
  356. : NOT-DELETED? ( key -- key TRUE OR FALSE )
  357.     DUP TRTABLE C@  IF DROP FALSE  ELSE TRUE THEN ;
  358.  
  359. 1 0 IN/OUT
  360. : SEND-IT SQU-FLAG @ IF
  361.            DUP SQTABLE C@ IF
  362.              DUP LASTCHAR @ = IF  ( a duplicate! )
  363.                 DROP EXIT THEN THEN
  364.            DUP LASTCHAR ! THEN
  365.     DUP ALF = IF
  366.     ASC-FLAG @ IF
  367.         ACR EMIT THEN THEN
  368.    EMIT ;
  369.  
  370. : NEW-KEY? ( -- key TRUE OR FALSE )
  371.     ASC-FLAG @ IF 
  372.           BEGIN KEY DUP ACR = WHILE DROP REPEAT
  373.         DUP 0< OVER CONTROL Z = OR   
  374.     ELSE
  375.         KEY DUP 0<  
  376.     THEN  
  377.     IF DROP FALSE ELSE TRUE THEN ;
  378.  
  379. 0 0 IN/OUT
  380. : TRANSLATE  
  381.     LASTCHAR ON
  382.     BEGIN 
  383.         NEW-KEY? 
  384.     WHILE
  385.         DEL-FLAG @ IF 
  386.             NOT-DELETED? IF SEND-IT THEN
  387.         ELSE  
  388.             TRTABLE C@  SEND-IT 
  389.         THEN
  390.     REPEAT
  391.    ;
  392.  
  393. \ TOP LEVEL
  394. : MAIN   
  395.     SETBUFS
  396.     HELLO
  397.     FILTER
  398.     SET-OPTIONS
  399.     GET-RANGES
  400.     TRANSLATE
  401.     BYE
  402. ;
  403.  
  404. INCLUDE DOS2
  405. INCLUDE FORTHLIB
  406. END
  407.