home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / dtx9203 / naxos / fthsourc / string.fth < prev    next >
Encoding:
Text File  |  1992-03-11  |  13.5 KB  |  466 lines
  1. ( *** NAXOS System-Vocabulary Version 1.0 ***  )
  2.  
  3. ( Name:    string.fth    )
  4. ( Version: 1.0           )
  5. ( Datum:   9.9.88        )
  6. ( Autor:   Volker Everts )
  7. ( Neu      2.6.91        )
  8.  
  9. include    kern
  10.  
  11. ( *********************** )
  12. ( ***** STRING.FTH: ***** )
  13. ( *********************** )
  14.  
  15.  
  16.  
  17. ( ** Such- und Vergleichsbefehle ** )
  18.  
  19. : .$=.   ( str1:- => -:- ) ( f )
  20.          ( str => str )
  21. ( ** Stringvergleich im Codesegment ** )
  22. ( f := .T. wenn Strings gleich         )
  23. ( f := .F. wenn counts ungleich        )
  24. (          oder Strings ungleich       )
  25. [ $51 ]      ( push cx     )
  26. [ $87 $F2 ]  ( xchg si,dx  )
  27. [ $89 $DF ]  ( mov di,bx   )
  28. [ $8C $C8 ]  ( mov ax,cs   )
  29. [ $8E $C0 ]  ( mov es,ax   )
  30. [ $8A $0C ]  ( mov cl,[si] )
  31. [ $30 $ED ]  ( xor ch,ch   )
  32. [ $A6 ]      ( cmpsb       )
  33. [ $75 $0F ]  ( jnz ex      )
  34. [ $F8 ]      ( clc         )
  35. [ $D0 $D9 ]  ( rcr cl,1    )
  36. [ $73 $03 ]  ( jnc rep     )
  37. [ $4E ]      ( dec si      )
  38. [ $4F ]      ( dec di      )
  39. [ $41 ]      ( inc cx      )
  40. [ $F3 $A7 ]  ( rep cmpsw   )
  41. [ $75 $03 ]  ( jnz ex      )
  42. [ $F9 ]      ( stc         )
  43. [ $EB $01 ]  ( jmp 1       )
  44. [ $F8 ]      ( ex: clc     )
  45. [ $89 $D6 ]  ( mov si,dx   )
  46. [ $59 ]      ( pop cx      )
  47. ;
  48.  
  49. : .^$=.   ( ptr1:- => -:- ) ( f ) 
  50.           ( ptr => ptr )
  51. ( ** Stringvergleich im Farmemory ** )
  52. ( f := .T. wenn gleich               )
  53. ( f := .F. wenn counts ungleich      )
  54. (          oder Strings ungleich     )
  55. [ $51 ]      ( push cx     )
  56. [ $1E ]      ( push ds     )
  57. [ $56 ]      ( push si     )
  58. [ $89 $D7 ]  ( mov di,dx   )
  59. [ $C4 $3D ]  ( les di,[di] )
  60. [ $C5 $37 ]  ( lds si,[bx] )
  61. [ $8A $0C ]  ( mov cl,[si] )
  62. [ $30 $ED ]  ( xor ch,ch   )
  63. [ $A6 ]      ( cmpsb       )
  64. [ $75 $0F ]  ( jnz ex      )
  65. [ $F8 ]      ( clc         )
  66. [ $D0 $D9 ]  ( rcr cl,1    )
  67. [ $73 $03 ]  ( jnc rep     )
  68. [ $4E ]      ( dec si      )
  69. [ $4F ]      ( dec di      )
  70. [ $41 ]      ( inc cx      )
  71. [ $F3 $A7 ]  ( rep cmpsw   )
  72. [ $75 $03 ]  ( jnz ex      )
  73. [ $F9 ]      ( stc         )
  74. [ $EB $01 ]  ( jmp 1       )
  75. [ $F8 ]      ( clc         )
  76. [ $89 $D6 ]  ( mov si,dx   )
  77. [ $5E ]      ( pop si      )
  78. [ $1F ]      ( pop ds      )
  79. [ $59 ]      ( pop cx      )
  80. ;
  81.  
  82.  
  83. proc ^.search.  ( str:len => -:- ) ( f )
  84.                 ( ptr => ptr' )
  85. ( ** Patternsearch über Pointer      ** )
  86. ( ** Patterlänge und Muster in str   ** )
  87. ( ** Suche nach Übereinstimmung      ** )
  88. ( ** ab seg:adr in ptr               ** )
  89. ( ** Suchlänge len                   ** )
  90. ( ** f := .T. : Muster gefunden      ** )
  91. ( ** ptr zeigt auf gefundene Adresse ** )
  92. ( ** f := .F. : kein Muster gefunden ** )
  93. ( ** ptr enthält ptr + len           ** )
  94. ( ** ptr vorher besser normalisieren ** )
  95.  
  96. [ $51 ]         (     push cx      ) ( retten )
  97. [ $89 $C1 ]     (     mov  cx,ax   ) ( len )
  98. [ $87 $F2 ]     (     xchg si,dx   )
  99. [ $C4 $3F ]     (     les  di,[bx] ) ( es:di pointer )
  100. [ $8B $04 ]     (     mov  ax,[si] ) ( char,count )
  101. [ $46 ]         (     inc si       )
  102. [ $86 $C4 ]     (     xchg  al,ah  ) ( count,char )
  103. [ $F2 $AE ]     ( LO: repnz scasb  ) ( Suche )
  104. [ $E8 $0E $00 ] (     call Vg      ) ( Vergleich )
  105. [ $72 $05 ]     (     jc   EX +1   ) ( gleich )
  106. [ $E3 $02 ]     (     jcxz  EX     ) ( len abgelaufen )
  107. [ $EB $F5 ]     (     jmp  LO      ) ( weiter )
  108. [ $F8 ]         ( EX: clc          )
  109. [ $4F ]         (     dec  di      )
  110. [ $89 $3F ]     (     mov  [bx],di ) ( Pointer setzen )
  111. [ $89 $D6 ]     (     mov  si,dx   )
  112. [ $59 ]         (     pop  cx      )
  113. [ $C3 ]         (     Ret          )
  114. ( ** Vergleichssubroutine ** )
  115. ( cf set if equal            )
  116. [ $51 ]         ( VG: push cx      ) ( retten )
  117. [ $57 ]         (     push di      ) ( retten )
  118. [ $56 ]         (     push si      )
  119. [ $4F ]         (     dec di       )
  120. [ $B5 $00 ]     (     mov  ch,0    ) ( cx auf count )
  121. [ $88 $E1 ]     (     mov  cl,ah   )
  122. [ $F3 $A6 ]     (     repz cmpb    ) ( String gleich? )
  123. [ $F8 ]         (     clc          ) ( flag false )
  124. [ $75 $01 ]     (     jnz   $1     ) ( ungleich )
  125. [ $F9 ]         (     stc          ) ( Flag true )
  126. [ $5E ]         ( $1: pop  si      )
  127. [ $5F ]         (     pop  di      )
  128. [ $59 ]         (     pop  cx      )
  129. ;
  130.  
  131.  
  132. : ^.scan.  ( len:c => -:- )( f )
  133.            ( ptr => ptr )
  134. ( ** Suche c über Pointer  ** )
  135. ( ** Suchlänge len         ** )
  136. ( f:= .T. wenn gefunden       )
  137. ( ptr zeigt auf adr c         )
  138. ( f:= .F. wenn nicht gefunden )
  139. ( ptr := len ptr +!           )
  140.  
  141. [ $87 $CA ] ( xchg cx,dx  ) ( cx retten )
  142. [ $C4 $3F ] ( les di,[bx] ) ( es:di laden )
  143. [ $F2 $AE ] ( repnz scasb ) ( scan )
  144. [ $F8 ]     ( clc         ) ( flag false )
  145. [ $75 $01 ] ( jnz +1      )
  146. [ $F9 ]     ( stc         ) ( true )
  147. [ $4F ]     ( dec di      ) ( adr korrigieren )
  148. [ $89 $3F ] ( mov [bx],di ) ( ptr setzen )
  149. [ $89 $D1 ] ( mov cx,dx   )
  150. ;
  151.  
  152. : .scan.  ( len:c => ?:? )( f )
  153.           ( adr => adr' )
  154. ( ** Suche c ab adr bis adr+len-1 ** )
  155. ( ** adr':= adr von c             ** )
  156. ( ** oder adr':= adr+len-1        ** )
  157. [ $51 ]     ( push cx     ) ( cx retten )
  158. [ $89 $D1 ] ( mov cx,dx   ) ( len setzen )
  159. [ $8C $CA ] ( mov dx,cs   ) ( cs holen )
  160. [ $8E $C2 ] ( mov es,dx   ) ( es setzen )
  161. [ $89 $DF ] ( mov di,bx   ) ( di laden )
  162. [ $F2 $AE ] ( repnz scasb ) ( scan )
  163. [ $F8 ]     ( clc         ) ( flag false )
  164. [ $75 $01 ] ( jnz  +1     )
  165. [ $F9 ]     ( stc         ) ( true )
  166. [ $4F ]     ( dec di      ) ( adr korrigieren )
  167. [ $89 $FB ] ( mov bx,di   ) ( adr setzen )
  168. [ $59 ]     ( pop cx      )
  169. ;
  170.  
  171. : .orscan.  ( len:chcl => -:c )( f )
  172.             ( adr => adr' )
  173. ( ** Suche ch or cl ab adr bis adr+len ** )
  174. ( ** adr' ist Suchende                 ** )
  175. ( ** f:= .T. wenn  gefunden            ** )
  176. ( ** c := ch oder cl                   ** )
  177. ( ** f:= .F. wenn nichts gefunden      ** )
  178.   [ $51 ]         (     push cx      ) ( rette cx )
  179.   [ $89 $D1 ]     (     mov  cx,dx   )
  180.   [ $4B ]         (     dec  bx      ) 
  181.   [ $43 ]         ( lo: inc  bx      ) 
  182.   [ $8A $17 ]     (     mov  dl,[bx] ) ( scan )
  183.   [ $38 $D0 ]     (     cmp  al,dl   )
  184.   [ $74 $0B ]     (     jz   cl      ) ( cl gefunden )
  185.   [ $38 $D4 ]     (     cmp  ah,dl   ) 
  186.   [ $74 $05 ]     (     jz   ch      ) ( ch gefunden )
  187.   [ $E2 $F3 ]     (     loop lo      ) ( loop )
  188.   [ $F8 ]         (     clc          ) ( flag false )
  189.   [ $EB $03 ]     (     jmp  ex      )
  190.   [ $88 $E0 ]     ( ch: mov  al,ah   ) 
  191.   [ $F9 ]         ( cl: stc          ) ( flag true )
  192.   [ $59 ]         ( ex: pop  cx      ) ( cx restore )
  193.   [ $B4 $00 ]     (     mov  ah,0    )
  194. ;
  195.  
  196. : ^replace  ( len:chcl => )
  197.             ( ptr => ptr )
  198. ( ** ersetze alle cl durch ch ** )
  199. ( ** Adressbereich ptr und len ** )
  200. [ $87 $CA ]         (     xchg cx,dx       )
  201. [ $41 ]             (     inc cx           )
  202. [ $C4 $3F ]         (     les di,[bx]      ) ( es:di )
  203. [ $F2 $AE ]         ( lo: repne scasb      ) ( suche c2 )
  204. [ $E3 $06 ]         (     jcxz ex          ) ( nichts gefunden )
  205. [ $26 $88 $65 $FF ] (     mov es:[di-1],ah ) ( ersetze d. ch )
  206. [ $EB $F6 ]         (     jmp lo           ) ( weitersuchen )
  207. [ $89 $D1 ]         ( ex: mov cx,dx        )
  208. ;
  209.  
  210. : .$pos.  ( -:c => -:pos ) ( f )
  211.           ( str => str )
  212. ( ** 1. Position von c im String ** )
  213. ( ** f := .T. wenn c gefunden    ** )
  214.   [ $51 ]      (     push cx      )
  215.   [ $8A $0F ]  (     mov  cl,[bx] )
  216.   [ $30 $ED ]  (     xor  ch,ch   )
  217.   [ $8C $CA ]  (     mov  dx,cs   )
  218.   [ $8E $C2 ]  (     mov  es,dx   )
  219.   [ $89 $DF ]  (     mov  di,bx   )
  220.   [ $47 ]      (     inc  di      )
  221.   [ $F2 $AE ]  ( repnz scasb      )
  222.   [ $B1 $00 ]  (     mov  cl,0    )
  223.   [ $75 $01 ]  (     jnz  + 1     )
  224.   [ $41 ]      (     inc  cx      )
  225.   [ $89 $F8 ]  (     mov  ax,di   )
  226.   [ $29 $D8 ]  (     sub  ax,bx   )
  227.   [ $D1 $E9 ]  (     shr  cl,1    ) ( CF setzen )
  228.   1-
  229.   [ $59 ]      (     pop  cx      )
  230. ;
  231.  
  232.  
  233.  
  234. ( ** String-Parse-Befehle ** )
  235.  
  236. ( ** Variable für Separierfunktionen ** )
  237. var    nextscan   word    ( Suchstartadr ) ;
  238. var    found$     word    ( Found$adr    ) ;
  239.  
  240.  
  241. : -trailing  ( -:- => ?:- ) 
  242.              ( str -- str ) ( TX )
  243. ( ** Endende Leerzeichen abschneiden ** )
  244. ( ** Count in str wird angepasst     ** )
  245. [ $8A $17 ]        (  MOV    DL,[BX] )
  246. [ $30 $F6 ]        (  XOR    DH,DH   )
  247. [ $89 $DF ]        (  MOV    DI,DX   )
  248. [ $01 $D7 ]        (  ADD    DI,DX   )
  249. [ $47 ]            (  INC    DI      )
  250.                    (  LOOP:          ) 
  251. [ $4F ]            (  DEC    DI      )
  252. [ $8A $15 ]        (  MOV    DL,[DI] )
  253. [ $80 $FA $20 ]    (  CMP    DL,20   )
  254. [ $76 $F8 ]        (  JNA    LOOP    )
  255. [ $89 $FA ]        (  MOV    DX,DI   )
  256. [ $29 $DA ]        (  SUB    DX,BX   )
  257. [ $88 $17 ]        (  MOV    [BX],DL )
  258. ;
  259.  
  260.  
  261. : .nextword.  ( -:start => str:next )( f ) 
  262.               ( => str )
  263. ( ** Separiere nächstes Wort       ** )
  264. ( ** Entferne führende Separatoren ** )
  265. ( ** Separator = Zeichen < 33      ** )
  266. ( ** f:= .F. wenn Separator= 0     ** )
  267. ( ** f:= .T. wenn gültiges Wort    ** )
  268. ( ** str ist gültige Stringadresse ** )
  269.   [ $89 $C3 ]      (     mov  bx,ax   )
  270.   [ $4B ]          (     dec  bx      ) 
  271.   [ $43 ]          ( L0: inc  bx      )
  272.   [ $8A $07 ]      (     mov  al,[bx] )
  273.   [ $3C $00 ]      (     cmp  al,0    )
  274.   [ $F8 ]          (     clc          )
  275.   [ $74 $18 ]      (     jz  ;        )
  276.   [ $3C $20 ]      (     cmp  al,20   )  
  277.   [ $76 $F4 ]      (     jna  L0      )
  278.   [ $4B ]          (     dec  bx      )
  279.   [ $89 $DF ]      (     mov  di,bx   )
  280.   [ $B4 $FF ]      (     mov  ah,FF   )
  281.   [ $47 ]          ( L1: inc  di      )
  282.   [ $FE $C4 ]      (     inc  ah      )
  283.   [ $80 $3D $20 ]  (     cmp  [di],20 )
  284.   [ $77 $F8 ]      (     ja   L1      )
  285.   [ $F9 ]          (     stc          ) 
  286.   [ $88 $27 ]      (     mov  [bx],ah )
  287.   [ $89 $F8 ]      (     mov  ax,di   )
  288.   [ $89 $DA ]      (     mov  dx,bx   )
  289. ;
  290.  
  291. : .parse.    ( => ?:? )( f )
  292.              ( => ? ) 
  293. ( ** Separiere Wort ab nextscan   ** )
  294. ( ** Wortseparator Zeichen 0 - 32 ** )
  295. ( ** Terminator Zeichen 0         ** )
  296. ( ** f := 0 bei Terminator        ** )
  297. ( ** gefundenes Wort in found$    ** )
  298. ( ** nextscan neu gesetzt         ** )
  299. nextscan @ .nextword. bx>dx
  300. found$ dx>!  nextscan !
  301. ;
  302.  
  303.  
  304.  
  305. ( ** Allgemeine Stringbefehle ** )
  306.  
  307.  
  308. : clr$  ( => )
  309.         ( str => str )
  310. ( ** Leerstring erzeugen ** )
  311.   0 c!
  312. ;
  313.  
  314. : len  (  => -:c )
  315.        ( str => str )
  316. ( ** Stringlänge ** )
  317.   c@
  318. ;
  319.  
  320.  
  321. : $.  ( => ?:? )
  322.       ( str => )
  323. ( ** String drucken ** )
  324.   count type
  325. ;
  326.  
  327.  
  328. : .$>d.  ( => d )( f )
  329.          ( str => )
  330. ( ** String in Doppelzahl wandeln  ** )
  331. ( ** f:=0 wenn erfolglos           ** )
  332.   .number.
  333. ;
  334.  
  335.  
  336. : $>dos  ( => ?:? )
  337.          ( str => ? )
  338. ( ** counted-String inplace in ASCIIZ-String wandeln ** )
  339.      c@  >bx+ bx+  0  c! 
  340. ;
  341.  
  342. : dos>$  ( => ?:? )
  343.          ( str => str )
  344. ( ** ASCIIZ-string inplace in counted-String wandeln ** )
  345.      255 c! 0 .$pos. 1- c!
  346. ;
  347.  
  348. : ucase    ( -:- => ?:? )( TX )
  349.            ( str => str )
  350. ( **  Ändere a-z in place auf A-Z  ** )
  351. [ $51 ]     (     push cx      )
  352. [ $8C $CA ] (     mov  dx,cs   )
  353. [ $8E $C2 ] (     mov  es,dx   )
  354. [ $89 $F2 ] (     mov  dx,si   )
  355. [ $8A $0F ] (     mov  cl,[bx] )
  356. [ $30 $ED ] (     xor  ch,ch   )
  357. [ $89 $DE ] (     mov  si,bx   )
  358. [ $46 ]     (     inc  si      )
  359. [ $89 $F7 ] (     mov  di,si   )
  360. [ $AC ]     ( uc: lodsb        )
  361. [ $3C $61 ] (     cmp  al,'a'  )
  362. [ $72 $06 ] (     jb   no      )
  363. [ $3C $7A ] (     cmp  al,'z'  )
  364. [ $77 $02 ] (     ja   no      )
  365. [ $2C $20 ] (     sub  al,20   )
  366. [ $AA ]     ( no: stosb        )
  367. [ $E2 $F2 ] (     loop uc      )
  368. [ $89 $D6 ] (     mov  si,dx   )
  369. [ $59 ]     (     pop  cx      )
  370. ;
  371.  
  372.  
  373.  
  374. ( ** Stringbefehle für den PAD-Bereich  ** )
  375.  
  376.  
  377. : $$.  ( => ?:? )
  378.        ( => ? )
  379. ( ** Drucke PAD-String ** )
  380.   pad count .0=.
  381.   if ." leer!" else type 
  382.   endif
  383. ;
  384.  
  385. : >$$  (  => ?:?  )
  386.        ( str => ? )
  387. ( ** String nach PAD kopieren ** )
  388.   bx>tx  pad bx>dx tx>bx c@ 2+ cmove
  389. ;
  390.  
  391. : $$>  ( => ?:? )
  392.        ( str => ? )
  393. ( ** PAD-String in Stringvariable speichern  ** )
  394. ( ** Der String wird abgeschnitten, wenn die ** )
  395. ( ** Variable nicht genug Platz bietet       ** )
  396.   bx>r bx-      ( Adresse speichern )
  397.   c@>dx pad c@  ( Längen holen )
  398.   min           ( neue aktuelle Länge )
  399.   >r c!         ( in pad eintragen )
  400.   pad  r> 1+    ( Quelle, Länge )
  401.   r>dx cmove    ( String kopieren )
  402. ;
  403.  
  404. : $$+  ( => )
  405.        ( str => )
  406. ( ** String aus str an String in PAD anhängen )
  407.   bx>r count >r >dx          ( Länge, Adr sichern )
  408.   pad c@ >tx + c!            ( Neue Padlänge )
  409.   pad tx> 1+ bx>+ >dx r> 1+  ( Ziel, Quelle )
  410.   r>bx bx+ cmove             ( String kopieren )
  411. ;
  412.  
  413. : n>$$  ( -:n => ?:? )
  414.         ( => ? )
  415. ( ** einfache Zahl in String wandeln ** )
  416. ( ** String liegt in PAD             ** )
  417.   n>d          ( doppeltgenaue Zahl erzeugen )
  418.   [ $8E $C2 ]  ( Vorzeichen-Byte )
  419.   dabs         ( Absolutwert )
  420.   <# # #s      ( Zahlenstring erzeugen )
  421.   sign #>      ( Vorzeichen )
  422.   bx- c!       ( Count-Byte ablegen )
  423.   >$$          ( String nach PAD bringen )
  424. ;
  425.  
  426. : left$$  ( -:n => ?:? )
  427.           ( => ? )
  428. ( ** n linke Zeichen von PAD ** )
  429.   >dx
  430.   pad c@ min   ( neue Länge )
  431.   c!           ( eintragen )
  432.   $>dos        ( 0-Byte )
  433. ;
  434.  
  435. : right$$  ( -:n => ?:? )
  436.            ( => ? )
  437. ( ** die n letzten Zeichen von PAD ** )
  438.   >dx
  439.   pad c@ push min >tx ( Länge festlegen )
  440.   c! >dx pop          ( speichern )
  441.   - .0>.
  442.   if
  443.     bx+ bx>dx         ( Ziel )
  444.     >bx+              ( Quelle )
  445.     tx> 1+ cmove      ( kopieren )
  446.   endif
  447. ;
  448.  
  449.  
  450. : mid$$  ( n pos => )
  451. ( ** n Zeichen von PAD ab pos ** )
  452.    dxpush
  453.    >dx
  454.    pad c@  - 1+ , 0 max
  455.    right$$
  456.    pop
  457.    left$$
  458. ;
  459.  
  460.  
  461. dictionary
  462.  
  463. : main  ." Hallo NAXOS-String" 
  464.   0 halt" 
  465. ;
  466.