home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / bstring.seq < prev    next >
Text File  |  1990-04-21  |  5KB  |  171 lines
  1.  
  2. \  This string package originally appeared in
  3. \  Dr. Dobbs Number 50 and was written by
  4. \  Mr. Ralph Dean
  5.  
  6. \ Search for end of string adr and leave  string length on top.
  7. : SEARCH ( addr -- len )
  8.     DUP BEGIN                   \ addr addr
  9.         DUP C@                  \ addr addr char
  10.         SWAP 1+ SWAP            \ addr addr+1 char
  11.         0= UNTIL                \ addr addr+1+len
  12.         SWAP -  1- ;            \ len
  13.  
  14. \ Defining word to create new strings.
  15. : STRING ( len -- )      \ when compiling
  16.          ( -- addr len ) \ when executing
  17.      CREATE ABS 255 MIN 1 MAX   \ len  has been range checked.
  18.      DUP C,
  19.      0 DO 0 C, LOOP 0 C,        \ --   initialize as nulls.
  20.      DOES> 1+ DUP SEARCH ;
  21.  
  22. \ Store string. Usage:  string1  string2  S!
  23. \ Target string is replaced by new string.
  24. : S!   ( addr1 len1 addr2 len2  -- )
  25.     DROP DUP 1- C@     \ addr1 len1 addr2 mlen
  26.     ROT MIN 1 MAX      \ addr1 addr2 len  <- length to store
  27.     2DUP + 0 SWAP C!   \ addr1 addr2 len  mark end with a null
  28.     MOVE ;
  29.  
  30. \ Store substring. Usage: string1 string2  SUB!
  31. \ Only substring of target is replaced.
  32. : SUB! ( addr1 len1 addr2 len2  -- )
  33.         ROT MIN 1 MAX      \ addr1 addr2 len <- sub string length.
  34.         MOVE ;
  35.  
  36. \ Temporary storage for string operations.
  37. CREATE TEMP 256 ALLOT
  38.  
  39. \ Usage:  5 10 string MID$
  40. : MID$ ( posn len1 addr2 len2 -- addr len )
  41.      SWAP >R ROT MIN 1 MAX     \ len1 len2 posn
  42.      SWAP OVER MAX OVER - 1+
  43.      SWAP R> + 1- SWAP
  44.      OVER SEARCH MIN ;
  45.  
  46. \ Usage: 6 string LEFT$
  47. : LEFT$ ( posn addr1 len1 -- addr len )
  48.     >R >R 1 SWAP R> R> MID$ ;
  49.  
  50. \ Usage: 6 string RIGHT$
  51. : RIGHT$ ( posn addr1 len1 -- addr len )
  52.     256 -ROT MID$ ;
  53.  
  54. \ Concatenate two strings.
  55. \ Usage:  string1 string2 S+ string3 S!
  56. : S+ ( addr1 len1 addr2 len2 -- addr len )
  57.      ROT >R ROT R> TUCK
  58.      TEMP SWAP MOVE
  59.      TUCK + 255 MIN DUP >R
  60.      OVER - SWAP TEMP + SWAP MOVE
  61.      R> 0 OVER TEMP + C!
  62.      TEMP SWAP ;
  63.  
  64. \ Return current string length. Usage: string LEN
  65. : LEN  ( addr len -- len )
  66.      NIP ;
  67.  
  68. \ Return max string length.  Usage:  string MLEN
  69. : MLEN ( addr len -- mlen )
  70.     DROP 1- C@ ;
  71.  
  72. \ Convert single number to a string.
  73. : STR$ ( n -- addr len )
  74.      S>D TUCK DABS
  75.      <# 0 HOLD #S ROT SIGN #> 1- ;
  76.  
  77. \ Convert string to a number.
  78. : VAL ( addr len -- dn )
  79.          PAD 2DUP  C!  1+  SWAP  CMOVE  \ Move string to PAD
  80.          BL PAD COUNT + C!              \ Add a blank at the end
  81.          PAD NUMBER DROP ;
  82.  
  83. : "   \  " {text}"  ( -- addr len )
  84.     STATE @ IF [COMPILE] "
  85.             ELSE ASCII " WORD
  86.                  PAD 257 ERASE DUP COUNT
  87.                  PAD SWAP MOVE PAD SWAP C@
  88.             THEN ;  IMMEDIATE
  89.  
  90. \ String input.  Usage:  string $IN
  91. : $IN  ( addr len  -- )
  92.     OVER SWAP MLEN EXPECT ;
  93.  
  94. \ String equality.  Usage  string1 string2 S=
  95. \ Leaves a true flag if strings are equal.
  96. : S= ( addr1 len1 addr2 len2 -- flag )
  97.      ROT OVER =
  98.      IF  TRUE SWAP 0 ?DO DROP OVER C@ OVER C@ =
  99.          IF 1 1 D+ TRUE
  100.          ELSE FALSE LEAVE
  101.          THEN LOOP
  102.      ELSE DROP FALSE
  103.      THEN NIP  NIP ;
  104.  
  105. \ String array.
  106. \ Usage:   5 20 SARRAY NAMES
  107. \         " JACK" 1 NAME  S!     1 NAME  TYPE
  108. \         " JOHN" 2 NAME  S!     2 NAME  TYPE      etc...
  109. : SARRAY  ( n len -- )  \ when compiling
  110.         CREATE  ABS 255 MIN 1 MAX SWAP
  111.                 0 ?DO DUP DUP C,
  112.                 0 ?DO BL C, LOOP 0 C,
  113.                 LOOP DROP
  114.         DOES>   SWAP 1- OVER C@
  115.                 2+ * + 1+ DUP SEARCH ;
  116.  
  117. \  Ralph Dean's FORTH implementation of SOUNDEX program that
  118. \  originally  appeared in the May 1980 Byte Magazine.
  119. \
  120. \  Executing SOUND will cause a prompt for the name.
  121. \  The name is terminated after 30 characters or <enter>.
  122. \  The soundex code is then computed and typed out.
  123. \  The string variable S$ conatains the code produced.
  124. \  For more information on Soundex codes see the original
  125. \  Byte article.
  126.  
  127.  
  128. FORTH DEFINITIONS DECIMAL
  129. 30 STRING N$   \ Input string whose soundex code is to be found.
  130.  4 STRING S$   \ Output string containing soundex code.
  131.  1 STRING K$   1 STRING L$
  132.  
  133. : NAME ( --  )  \ Prompt for input of last name.
  134.         CR ." Last Name? "  N$  $IN ;
  135.  
  136. : FIRST1 ( -- ) \ Move first character to S$
  137.         1 N$ LEFT$ S$ S! ;
  138.  
  139. : ITH  ( n m  --  k )
  140.         N$  MID$ DROP C@ 64 - ;
  141.  
  142. : KTH ( k -- )
  143.         DUP " 01230120022455012623010202"
  144.         MID$ K$ S! ;
  145.  
  146. : BLS ( -- )
  147.         S$ K$ S+ S$ S! ;
  148.  
  149. : TEST ( -- flag )
  150.         K$ L$ S= K$ " 0" S= OR 0= ;
  151.  
  152. : IST  ( n   n flag )
  153.         DUP 1 < OVER 26 > OR 0= ;
  154.  
  155. \ Compute soundex code
  156. : COMP ( -- )
  157.         N$ LEN 1+ 2
  158.         DO I I ITH IST
  159.            IF   KTH TEST IF BLS THEN
  160.            ELSE DROP
  161.            THEN
  162.         K$ L$ S!
  163.         LOOP ;
  164.  
  165. \ This is the Program.   BROWN , BRUN , BRAWN  all give B650
  166. : SOUNDEX ( -- )
  167.         NAME FIRST1 N$ LEN 2 >
  168.         IF COMP THEN S$ " 0000" S+ S$ S!
  169.         CR ." Soundex Code =  " S$ TYPE CR ;
  170.  
  171.