home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / kernel2.seq < prev    next >
Text File  |  1991-04-12  |  48KB  |  1,228 lines
  1. \ KERNEL2.SEQ   More kernel stuff
  2.  
  3. FILES DEFINITIONS
  4.  
  5. VARIABLE KERNEL2.SEQ
  6.  
  7. FORTH DEFINITIONS
  8.  
  9. USER DEFINITIONS
  10. VARIABLE  TOS         ( top of stack )
  11. VARIABLE  ENTRY       ( entry point, contains machine code )
  12. VARIABLE  LINK        ( link to next task )
  13. VARIABLE  ES0         ( initial ES: segment )
  14. VARIABLE  SP0         ( initial parameter stack )
  15. VARIABLE  RP0         ( initial return stack )
  16. VARIABLE  DP          ( dictionary pointer )
  17. VARIABLE  OFFSET      ( relative to absolute disk block 0 )
  18. VARIABLE  BASE        ( for numeric input and output )
  19. VARIABLE  HLD         ( points to last character held in pad )
  20. VARIABLE  PRINTING    ( indicates if printing is enabled )
  21.  
  22.    DEFER  EMIT        ( send a character to ouput device )
  23.    DEFER  KEY?        ( test if a character is ready to be received )
  24.    DEFER  KEY         ( get the next character from the keyboard )
  25.    DEFER  TYPE        ( send a string of characters to the console )
  26.    DEFER  TYPEL       ( send a string from extended memory to console )
  27.  
  28. META DEFINITIONS
  29. VARIABLE  PRIOR       ( used for dictionary searches )
  30. VARIABLE  STATE       ( compilation or interpretation )
  31. VARIABLE  WARNING     ( give user duplicate warnings if on )
  32. VARIABLE  DPL         ( numeric input punctuation )
  33. VARIABLE  R#          ( editing cursor position )
  34. VARIABLE  LAST        ( points to nfa of latest definition )
  35. VARIABLE  CSP         ( holds stack pointer for error checking )
  36. VARIABLE  CURRENT     ( vocabulary which gets definitions )
  37. 12 CONSTANT #VOCS     ( the number of vocabularies to search )
  38. VARIABLE  CONTEXT     ( vocabulary searched first )
  39. HERE THERE #VOCS 2* DUP ALLOT CS:ERASE
  40.  
  41. VARIABLE  'TIB        ( address of terminal input buffer )
  42. VARIABLE  WIDTH       ( width of name field )
  43. VARIABLE  VOC-LINK    ( points to newest vocabulary )
  44. VARIABLE  >IN         ( offset into input stream )
  45. VARIABLE  SPAN        ( number of characters expected )
  46. VARIABLE  #TIB        ( number of characters to interpret )
  47. VARIABLE  END?        ( true if input stream exhausted )
  48. VARIABLE  #OUT        ( number of characters emitted )
  49. VARIABLE  #LINE       ( the number of lines sent so far )
  50.  
  51. VARIABLE XDP          ( offset to next available location in list space )
  52. VARIABLE XDPSEG       ( segment to next available location in list space )
  53. VARIABLE YDP          ( offset to next available location in head space )
  54. VARIABLE YSTART       ( offset to beginning of head space in .COM file )
  55. VARIABLE DPSTART      ( beginning of list space in .COM or .EXE file )
  56. VARIABLE XSEGLEN      ( length of list space in segments )
  57. VARIABLE XMOVED       ( flag to tell if list has been moved )
  58. VARIABLE SSEG         ( search & scan segment )
  59. VARIABLE PHEAD        ( pointer linked list head pointer )
  60. VARIABLE #PARS        ( number of paragraphs already used by the system )
  61.  
  62. 0  VALUE SEQHANDLE    ( the sequential handle pointer )
  63. VARIABLE LOADLINE     ( line # last read by LINEREAD )
  64.  
  65. 32 CONSTANT BL          \ ASCII space
  66.  8 CONSTANT BS          \ ASCII backspace
  67.  7 CONSTANT BELL        \ ASCII bell
  68.  
  69. VARIABLE CAPS           \ Flag: if true, convert names to upper case.
  70. VARIABLE >IN_WORD       \ offset in line to word just parsed out with WORD
  71.  
  72. CODE FILL       (  start-addr count char -- )
  73. \ Fill each byte of memory in the specified address range with "char".
  74.                 CLD             MOV BX, DS
  75.                 POP AX          POP CX          POP DI
  76.                 PUSH ES         MOV ES, BX
  77.                 REPNZ           STOSB           POP ES
  78.                 NEXT            END-CODE
  79.  
  80. CODE LFILL      (  seg start-addr count char -- )
  81. \ Fill each byte of memory in the specified address range with "char".
  82.                 CLD             POP AX          POP CX
  83.                 POP DI          POP BX
  84.                 PUSH ES         MOV ES, BX
  85.                 REPNZ           STOSB           POP ES
  86.                 NEXT            END-CODE
  87.  
  88. : ERASE         ( addr len -- )   \ Put zeros in the area at addr.
  89.                 0 FILL   ;
  90. : BLANK         ( addr len -- )   \ Put ASCII spaces in the area at addr.
  91.                 BL FILL   ;
  92.  
  93. CODE COUNT      ( addr -- addr+1 len )
  94. \ Convert from the address of a counted string to an address and count.
  95.                 POP BX          SUB AX, AX      MOV AL, 0 [BX]
  96.                 INC BX          PUSH BX
  97.                 1PUSH           END-CODE
  98.  
  99. CODE LENGTH     ( addr -- addr+2 len )  \ really word count
  100. \ Similiar to COUNT , except that the count is in a word, not a byte.
  101.                 POP BX          MOV AX, 0 [BX]
  102.                 ADD BX, # 2
  103.                 PUSH BX
  104.                 1PUSH           END-CODE
  105.  
  106.                                         \ 07/03/89 RB
  107. CODE COUNTL     ( seg addr -- seg addr+1 len )
  108. \ Like COUNT, but works with a LONG (seg/offset) address.
  109.                 POP BX          POP DS
  110.                 XOR AX, AX      MOV AL, 0 [BX]
  111.                 INC BX
  112.                 PUSH DS         PUSH BX
  113.                 MOV DX, CS      MOV DS, DX
  114.                 1PUSH           END-CODE
  115.  
  116. : MOVE          ( from to len -- )
  117. \ Move "len" bytes from "from" address to "to" address, non-destructively.
  118.                 -ROT   2DUP U< IF   ROT CMOVE>   ELSE   ROT CMOVE   THEN ;
  119.  
  120. DECIMAL
  121.  
  122. CREATE ATBL     \ Uppercase translation table
  123.  0  C,   1  C,   2  C,   3  C,   4  C,   5  C,   6  C,   7  C,
  124.  8  C,  32  C,  10  C,  11  C,  12  C,  13  C,  14  C,  15  C,
  125. 16  C,  17  C,  18  C,  19  C,  20  C,  21  C,  22  C,  23  C,
  126. 24  C,  25  C,  26  C,  27  C,  28  C,  29  C,  30  C,  31  C,
  127. 32  C,  '!' C,  '"' C,  '#' C,  '$' C,  '%' C,  '&' C,  ''' C,
  128. '(' C,  ')' C,  '*' C,  '+' C,  ',' C,  '-' C,  '.' C,  '/' C,
  129. '0' C,  '1' C,  '2' C,  '3' C,  '4' C,  '5' C,  '6' C,  '7' C,
  130. '8' C,  '9' C,  ':' C,  ';' C,  '<' C,  '=' C,  '>' C,  '?' C,
  131. '@' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  132. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  133. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  134. 'X' C,  'Y' C,  'Z' C,  '[' C,  '\' C,  ']' C,  '^' C,  '_' C,
  135. '`' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  136. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  137. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  138. 'X' C,  'Y' C,  'Z' C,  '{' C,  '|' C,  '}' C,  '~' C,  127 C,
  139. \ Characters above 127 are translated to below 127
  140.  0  C,   1  C,   2  C,   3  C,   4  C,   5  C,   6  C,   7  C,
  141.  8  C,   9  C,  10  C,  11  C,  12  C,  13  C,  14  C,  15  C,
  142. 16  C,  17  C,  18  C,  19  C,  20  C,  21  C,  22  C,  23  C,
  143. 24  C,  25  C,  26  C,  27  C,  28  C,  29  C,  30  C,  31  C,
  144. 32  C,  '!' C,  '"' C,  '#' C,  '$' C,  '%' C,  '&' C,  ''' C,
  145. '(' C,  ')' C,  '*' C,  '+' C,  ',' C,  '-' C,  '.' C,  '/' C,
  146. '0' C,  '1' C,  '2' C,  '3' C,  '4' C,  '5' C,  '6' C,  '7' C,
  147. '8' C,  '9' C,  ':' C,  ';' C,  '<' C,  '=' C,  '>' C,  '?' C,
  148. '@' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  149. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  150. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  151. 'X' C,  'Y' C,  'Z' C,  '[' C,  '\' C,  ']' C,  '^' C,  '_' C,
  152. '`' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  153. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  154. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  155. 'X' C,  'Y' C,  'Z' C,  '{' C,  '|' C,  '}' C,  '~' C,  127 C,
  156.  
  157. CODE UPC        ( char -- char' )
  158. \ Convert a character to upper case.
  159.                 POP AX
  160.                 MOV BX, # ATBL
  161.                 XLAT
  162.                 1PUSH
  163.                 END-CODE
  164.  
  165. CODE UPPER      ( addr len -- )         
  166. \ Convert a string to upper case.
  167.                 POP CX                  \ get length
  168.                 POP DI                  \ and starting address
  169.                 PUSH SI                 \ save IP
  170.                 MOV DX, ES              \ and LIST POINTER
  171.                 MOV BX, DS
  172.                 MOV ES, BX              \ set ES to DS
  173.                 MOV SI, DI              \ set SI to DI
  174.                 MOV BX, # ATBL          \ loadup BX with table
  175.                 CLD                     \ clear direction flag
  176.           CX<>0 IF
  177.                         HERE                    \ get a char and traslate it
  178.                                 LODSB   XLAT
  179.                                 STOSB
  180.                         LOOP                    \ until all chars are done
  181.                 THEN
  182.                 MOV ES, DX              \ restore ES=LIST
  183.                 POP SI                  \     and SI=IP
  184.                 NEXT    END-CODE
  185.  
  186. CODE ?UPPERCASE ( a1 -- a1 )           
  187. \ Conditionally convert a counted string to upper case
  188.                 MOV CX, CAPS            \ test CAPS variable
  189.   CX<>0 IF                              \ leave if CAPS is not on
  190.                 POP DI
  191.                 PUSH DI                 \ get a copy of address a1
  192.                 SUB CX, CX
  193.                 MOV CL, 0 [DI]
  194.                 INC DI                  \ Addr and Cnt in DI & CX
  195.                 PUSH SI                 \ save IP
  196.                 MOV DX, ES              \ and LIST POINTER
  197.                 MOV BX, DS
  198.                 MOV ES, BX              \ set ES to DS
  199.                 MOV SI, DI              \ set SI to DI
  200.                 MOV BX, # ATBL          \ loadup BX with table
  201.                 CLD                     \ clear direction flag
  202.           CX<>0 IF
  203.                         HERE                    \ get a char and traslate it
  204.                                 LODSB   XLAT
  205.                                 STOSB
  206.                         LOOP                    \ until all chars are done
  207.                 THEN
  208.                 MOV ES, DX              \ restore ES=LIST
  209.                 POP SI                  \     and SI=IP
  210.                 NEXT
  211.         THEN
  212.                 NEXT
  213.                 END-CODE
  214.  
  215. CODE HERE       ( -- adr )
  216. \ Return the address of the top of the dictionary.
  217.                 MOV BX, UP
  218.                 PUSH DP [BX]
  219.                 NEXT
  220.                 END-CODE
  221.  
  222. CODE PAD        ( -- adr )
  223. \ Return the address of a floating temporary storage area.
  224.                 MOV BX, UP
  225.                 MOV AX, DP [BX]
  226.                 ADD AX, # 80
  227.                 1PUSH           END-CODE
  228.  
  229. CODE -TRAILING  ( addr len -- addr len1 )
  230. \ The length of string is conditionally reduced by the number of trailing
  231. \ blanks.
  232.                 POP CX
  233.                 POP DI          PUSH DI
  234.           CX<>0 IF      MOV AX, DS
  235.                         PUSH ES
  236.                         STD
  237.                         MOV ES, AX
  238.                         ADD DI, CX
  239.                         DEC DI
  240.                         MOV AL, # $20
  241.                         REPE SCASB
  242.                     0<> IF      INC CX
  243.                         THEN
  244.                         CLD
  245.                         POP ES
  246.                 THEN
  247.                 PUSH CX
  248.                 NEXT            END-CODE
  249.  
  250. CODE COMP       ( addr1 addr2 len -- -1 | 0 | 1 )
  251. \ Compare two strings.  If equal, return 0.  If str1 < str2, return -1.
  252. \ If str1 > str2, return 1 .
  253.                 MOV DX, SI      POP CX
  254.                 POP DI          POP SI
  255.           CX<>0 IF      PUSH ES
  256.                         MOV ES, SSEG
  257.                         REPZ CMPSB
  258.                     0<> IF
  259.                              0< IF      MOV CX, # -1
  260.                                 ELSE    MOV CX, # 1
  261.                                 THEN
  262.                         THEN
  263.                         POP ES
  264.                 THEN
  265.                 MOV SI, DX
  266.                 PUSH CX
  267.                 NEXT            END-CODE
  268.  
  269. CODE CAPS-COMP  ( addr1 addr2 len -- -1 | 0 | 1 )
  270. \ Perform a comparison of two strings, but ignore Case differences.
  271.                 MOV DX, SI      POP CX
  272.                 POP DI          POP SI
  273.                 PUSH ES         MOV ES, SSEG
  274.                 BEGIN
  275.                     JCXZ  0 $
  276.                     MOV     AH, 0 [SI]      INC SI
  277.                     MOV ES: AL, 0 [DI]      INC DI
  278.                     OR AX, # $02020         CMP AH, AL
  279.                     JNE 1 $                 DEC CX
  280.                 AGAIN
  281.         1 $: 0< IF
  282.                    MOV CX, # -1
  283.                 ELSE
  284.                    MOV CX, # 1
  285.                 THEN
  286.         0 $:    MOV SI, DX
  287.                 POP ES
  288.                 PUSH CX
  289.                 NEXT            END-CODE
  290.  
  291. : COMPARE       ( addr1 addr2 len -- -1 | 0 | 1 )
  292. \ Compare two strings.  If CAPS is true, ignore case.
  293.                 CAPS @ IF   CAPS-COMP   ELSE   COMP   THEN   ;
  294.  
  295. CODE ?CS:       ( -- cs )
  296. \ Return the code segment CS
  297.                 PUSH CS         NEXT            END-CODE
  298.  
  299. CODE ?ES:       ( -- es )
  300. \ Return the extra segment ES
  301.                 PUSH ES         NEXT            END-CODE
  302.  
  303. CODE @L         ( seg addr -- word )
  304. \ Load a 16 bit word from the specified segment and offset.
  305.                 POP BX          POP DS          MOV AX, 0 [BX]
  306.                 MOV BX, CS      MOV DS, BX
  307.                 1PUSH           END-CODE
  308.  
  309. CODE C@L        ( seg addr -- byte )
  310. \ Load an 8 bit byte from the specified segment and offset.
  311.                 POP BX          POP DS          MOV AL, 0 [BX]
  312.                 XOR AH, AH      MOV BX, CS      MOV DS, BX
  313.                 1PUSH           END-CODE
  314.  
  315. CODE C!L        ( byte seg adr )
  316. \ Store the byte at the specified segment and offset.
  317.                 POP BX          POP DS          POP AX
  318.                 MOV 0 [BX], AL  MOV BX, CS      MOV DS, BX
  319.                 NEXT            END-CODE
  320.  
  321. CODE !L         ( n seg adr -- )
  322. \ Store the 16 bit word n at the specified segment and offset.
  323.                 POP BX          POP DS          POP AX
  324.                 MOV 0 [BX], AX  MOV BX, CS      MOV DS, BX
  325.                 NEXT            END-CODE
  326.  
  327. CODE <BDOS>     ( n fun -- m )
  328. \ Perform a simple DOS call.  fun is the function number, and n
  329. \ is the value of the DX register.  The result code is pushed as m .
  330.                 POP AX          MOV AH, AL      POP DX
  331.                 INT $21         SUB AH, AH
  332.                 1PUSH           END-CODE
  333.  
  334. DEFER BDOS      ' <BDOS> IS BDOS
  335. \ A defered DOS call.
  336.  
  337. CODE BDOS2      ( CX DX AX -- CX DX AX )
  338. \ Similiar to BDOS, except that an additional register, CX , is used.
  339.                 POP AX          POP DX          POP CX
  340.                 MOV AH, AL      INT $21
  341.                 PUSH CX         PUSH DX         PUSH AX
  342.                 NEXT            END-CODE
  343.  
  344. : OS2           BDOS2 255 AND ;
  345.  
  346. VARIABLE BIOSCHAR       \ Holds the char from BIOS on scan by BIOSKEY?
  347. VARIABLE BIOSKEYVAL     \ Holds the key value from BIOSKEY
  348.  
  349. CODE BIOSKEY?   ( -- f1 )
  350. \ Return a true flag if a key, other than control break, has been pressed.
  351.         BEGIN
  352.                 MOV AH, # 1
  353.                 PUSH SI         PUSH BP
  354.                 INT $16
  355.                 POP BP          POP SI
  356.                 MOV BIOSCHAR AX
  357.           0= IF
  358.                 MOV AX, # 0
  359.                 1PUSH
  360.              THEN
  361.                 CMP AX, # 0     \ Ignore Control Break keys
  362.      0= WHILE
  363.                 MOV AH, # 0     \ That is, throw them away
  364.                 PUSH SI         PUSH BP
  365.                 INT $16
  366.                 POP BP          POP SI
  367.         REPEAT
  368.                 MOV AX, # -1
  369.                 1PUSH           END-CODE
  370.  
  371. CODE BIOSKEY    ( -- c1 )
  372. \ Return the value of the next key, other than control break.
  373.         BEGIN
  374.                 MOV AH, # 0
  375.                 PUSH SI         PUSH BP
  376.                 INT $16
  377.                 POP BP          POP SI
  378.                 CMP AX, # 0             \ Ignore Control BREAK, 00 Hex.
  379.     0<> UNTIL
  380.                 MOV BIOSKEYVAL AX
  381.                 1PUSH           END-CODE
  382.  
  383. DEFER KEYFILTER ' NOOP IS KEYFILTER     \ Pre-filter keys before passing on.
  384.  
  385. DEFER BGSTUFF   ' NOOP IS BGSTUFF       \ BACKGROUND STUFF
  386.  
  387. : (KEY?)        ( -- f )
  388. \ Returns TRUE if user depressed a key.  Otherwise, FALSE.
  389.                 BGSTUFF BIOSKEY? ;
  390.  
  391. : (KEY)         ( -- char )
  392. \ Wait until the user presses a key, then return its value.
  393.                 BEGIN   PAUSE KEY? UNTIL
  394.                 BIOSKEY DUP 127 AND 0=
  395.                 IF      FLIP DUP 3 =
  396.                         IF      DROP 0          \ allow a NULL
  397.                         ELSE    127 AND 128 OR
  398.                         THEN
  399.                 ELSE    255 AND
  400.                 THEN    KEYFILTER ;
  401.  
  402. DEFER OUTPAUSE  ( ' PAUSE ) ' NOOP IS OUTPAUSE
  403. \ A defered word for background tasks while sending characters to screen.
  404.  
  405. DEFER CONSOLE
  406. \ A defered word for sending characters to the screen.
  407.  
  408. CODE CMOVEL     ( sseg sptr dseg dptr cnt )
  409. \ Move "cnt" characters from source segment and offset to destination
  410. \ segment and offset.
  411.                 CLD             MOV BX, SI
  412.                 POP CX          POP DI
  413.                 POP AX          POP SI
  414.                 POP DS          PUSH ES         MOV ES, AX
  415.                 OR CX, CX
  416.             0<> IF
  417.                 REPNZ           MOVSB
  418.             THEN
  419.                 POP ES
  420.                 MOV AX, CS      MOV DS, AX
  421.                 MOV SI, BX
  422.                 NEXT            END-CODE
  423.  
  424. CODE CMOVEL>    ( sseg sptr dseg dptr cnt )
  425. \ Similiar to CMOVEL , except move is in the "reverse" direction,
  426. \ i.e., from high memory to low memory.
  427.                 STD             MOV BX, SI
  428.                 POP CX          POP DI
  429.                 POP AX          POP SI
  430.                 POP DS          PUSH ES         MOV ES, AX
  431.                 OR CX, CX
  432.             0<> IF
  433.                 DEC CX          ADD DI, CX
  434.                 ADD SI, CX      INC CX
  435.                 REPNZ           MOVSB
  436.             THEN
  437.                 POP ES
  438.                 MOV AX, CS      MOV DS, AX
  439.                 MOV SI, BX
  440.                 CLD
  441.                 NEXT            END-CODE
  442.  
  443. \ **********************************************************************
  444. \ THERE MUST BE AT LEAST 160 BYTES BETWEEN THE SOURCE AND DESTINATION
  445. \ PARAGRAPHS FOR "CMOVE-PARS" AND "CMOVE-PARS>" TO WORK PROPERLY.
  446. \ **********************************************************************
  447.  
  448. : CMOVE-PARS    ( source-par destination-par length-pars --- )
  449. \ move paragraphs from source to destination, of length.
  450. \ source and destination must be greater than 160 bytes (10 paragraphs) apart.
  451.                 ?dup                    \ is there anything to move?
  452.         if      0 10 um/mod             \ calculate blocks of 10 segments
  453.                 swap >r                 \ save the remainder for later
  454.                 0
  455.                 ?do     2dup 0 tuck     \ setup as seg-off seg-off
  456.                         160 cmovel      \ move 160 bytes
  457.                         10 10 d+        \ adj for next move
  458.                 loop    0 tuck          \ prepare for final move
  459.                 r> 16 * cmovel          \ move remainder of data
  460.         else    2drop                   \ nothing to move
  461.         then    ;
  462.  
  463. : CMOVE-PARS>   ( source-par destination-par length-pars --- )
  464. \ reverse move paragraphs from source to destination, of length.
  465. \ source and destination must be greater than 160 bytes (10 paragraphs) apart.
  466.                 ?dup                    \ is there anything to move?
  467.         if      dup>r dup d+            \ adjust to end for backwards move
  468.                 r>
  469.                 0 10 um/mod             \ calculate blocks of 10 segments
  470.                 >r                      \ save main move blocks
  471.                                         \ move remainder first
  472.                 dup>r dup d-            \ adj from end back by remainder
  473.                 2dup 0 tuck r> 16 * cmovel
  474.                 r> 0
  475.                 ?do     10 10 d-        \ adjust for this move
  476.                         2dup 0 tuck     \ setup as seg-off seg-off
  477.                         160 cmovel      \ move 160 bytes
  478.                 loop                    \ -- seg seg
  479.         then    2drop ;                 \ cleanup stack
  480.  
  481. $01000 VALUE #CODESEGS \ Number of segments needed for CODE.            64k
  482. $01800 VALUE #LISTSEGS \ Number of segments needed for : definitions.   96k
  483. $01000 VALUE #HEADSEGS \ Number of segments needed for HEADS.           64K
  484. $00100 VALUE #OVSEGS   \ Number of segments needed for OVERLAYS.         4k
  485. $01000 VALUE #OVBYTES  \ Number of BYTES    needed for OVERLAYS.         4k
  486.  
  487.  
  488. : MEMCHK        ( f1 -- )
  489. \ If flag is true, Terminate execution and return to DOS with error message.
  490.                 IF      ." Insufficient Memory"
  491.                         0 0 BDOS
  492.                 THEN ;
  493.  
  494. CODE DOS_DEALLOC ( n1 -- f1 )
  495. \ n1 = block to de-allocate, f1 = 0 is ok.
  496. \ f1 = 9 means invalid block address.
  497.                 MOV AH, # $49 
  498.                 POP DX
  499.                 PUSH ES         MOV ES, DX      INT $21
  500.              U< IF
  501.                 SUB AH, AH
  502.              ELSE
  503.                 MOV AX, # 0
  504.              THEN
  505.                 POP ES          1PUSH           END-CODE
  506.  
  507. CODE DOS_ALLOC  ( n1 -- n2 n3 f1 )
  508. \ n1 = size needed, n3 = segment
  509. \ n2 = largest segment available
  510. \ f1 =  8 not enough memory.
  511.                 MOV AH, # $48            
  512.                 POP BX
  513.                 INT $21
  514.                 PUSH BX         PUSH AX
  515.              U< IF
  516.                 SUB AH, AH
  517.              ELSE
  518.                 MOV AX, # 0
  519.              THEN
  520.                 1PUSH           END-CODE
  521.  
  522. CODE DOS_SETBLOCK ( seg siz -- f1 )
  523. \ Re-adjust the memory block specified by "seg" to the new size "siz"
  524. \ in segments.
  525.                 POP BX                  \ get new size
  526.                 MOV AH, # $4A           \ setblock call
  527.                 POP DX
  528.                 PUSH ES
  529.                 MOV ES, DX
  530.                 INT $21
  531.              U< IF      SUB AH, AH
  532.                 ELSE    MOV AX, # 0
  533.                 THEN
  534.                 POP ES
  535.                 1PUSH           END-CODE
  536.  
  537. : DOS_MAXBLOCK  ( -- max_segs )
  538. \ Return max_segs of how much more memory can be allocated.
  539.                 -1 DOS_ALLOC 2DROP ;
  540.  
  541. DEFER DEALLOC   ' DOS_DEALLOC  IS DEALLOC
  542. DEFER ALLOC     ' DOS_ALLOC    IS ALLOC
  543. DEFER SETBLOCK  ' DOS_SETBLOCK IS SETBLOCK
  544. DEFER MAXBLOCK  ' DOS_MAXBLOCK IS MAXBLOCK
  545. DEFER CURSORSET ' NOOP         IS CURSORSET
  546.  
  547. : DOSVER        ( -- n1 )
  548. \ Get the DOS version number.
  549.                 0 $030 BDOS $0FF AND ;
  550.  
  551.                                         \ 07/03/89 RB
  552. CODE +XSEG      ( n1 -- n2 )            \ Add XSEG to n1, returning n2.
  553.                 POP AX
  554.                 ADD AX, XSEG
  555.                 1PUSH           END-CODE
  556.  
  557. \ the base structure for all pointers to follow
  558.  
  559. 0.0 POINTER F-PC
  560.  
  561. : SETYSEG       ( -- )
  562. \ Sets head segment + more space
  563.                 [ LABEL 'SETYSEG ]
  564.                 ?CS: SSEG !
  565.                 XSEGLEN @ +XSEG XDPSEG !
  566.                 XDP OFF
  567.                 DPSTART @ DP !
  568.                 DOSVER 2 <
  569.                 IF      ." Must have DOS 2.x or higher."
  570.                         0 0 BDOS
  571.                 THEN
  572.                 #CODESEGS #OVSEGS + #LISTSEGS + #HEADSEGS +
  573.                 ['] F-PC >BODY 4 + !            \ set the size of F-PC
  574.                 0POINTERS                       \ clear out the pointer list
  575.                 F-PC 0= MEMCHK                  \ adjust memory usage
  576.                 #OUT 0! $018 ( 24 DECIMAL ) #LINE !
  577.                 CURSORSET ;
  578.  
  579. CODE YHERE      ( -- adr )
  580. \ The next available location in "Head" space.
  581.                 PUSH YDP        NEXT
  582.                 END-CODE
  583.  
  584. CODE YS:        ( w -- yseg w )
  585. \ Insert the base of the head segment under the offset at the top.
  586.                 POP AX          PUSH YSEG
  587.                 1PUSH           END-CODE
  588.  
  589. CODE Y@         ( addr -- n )
  590. \ Fetch the word at the specified offset in the head segment.
  591.                 POP BX
  592.                 MOV DS, YSEG
  593.                 PUSH 0 [BX]
  594.                 MOV BX, CS      MOV DS, BX
  595.                 NEXT            END-CODE
  596.  
  597. CODE Y!         ( n addr -- )
  598. \ Store word n at the offset in the head segment.
  599.                 POP BX
  600.                 MOV DS, YSEG
  601.                 POP 0 [BX]
  602.                 MOV BX, CS      MOV DS, BX
  603.                 NEXT            END-CODE
  604.  
  605. CODE YC@        ( addr -- char )
  606. \ Fetch the byte at the offset in the head segment.
  607.                 POP BX          SUB AX, AX
  608.                 MOV DS, YSEG
  609.                 MOV AL, 0 [BX]
  610.                 MOV BX, CS      MOV DS, BX
  611.                 1PUSH           END-CODE
  612.  
  613. CODE YC!        ( char addr -- )
  614. \ Store the byte at the specified offset in the head segment.
  615.                 POP BX          POP AX
  616.                 MOV DS, YSEG
  617.                 MOV 0 [BX], AL
  618.                 MOV BX, CS      MOV DS, BX
  619.                 NEXT            END-CODE
  620.  
  621. CODE Y,         ( n -- )
  622. \ Add the 16 bit value  n  to the end of the working head space.
  623.                 MOV BX, YDP
  624.                 ADD YDP # 2 WORD
  625.                 POP CX
  626.                 MOV DS, YSEG
  627.                 MOV 0 [BX], CX
  628.                 MOV BX, CS      MOV DS, BX
  629.                 NEXT
  630.                 END-CODE
  631.  
  632. CODE YCSET      ( byte addr -- )
  633. \ Set the bits at offset in the head segment according to "b".
  634.                 POP BX          POP AX
  635.                 MOV DS, YSEG
  636.                 OR 0 [BX], AL
  637.                 MOV BX, CS      MOV DS, BX
  638.                 NEXT            END-CODE
  639.  
  640. CODE YHASH      ( ystr vocaddr -- thread )
  641. \ Find the vocabulary thread corresponding to a counted string in head 
  642. \ space.
  643.                 POP DX          POP BX
  644.                 MOV DS, YSEG
  645.                 MOV AX, 1 [BX]          \ Get first and second chars
  646.                 SHL AL, # 1             \ Shift first char left one
  647.                 MOV CL, 0 [BX]          \ Get count
  648.                 AND CX, # 31            \ mask out all but actual word length
  649.                 DEC CX                  \ dec, and if zero then use a blank.
  650.     CX<>0  IF   ADD AL, AH
  651.            ELSE MOV AH, # 32
  652.                 ADD AL, AH              \ Plus second char
  653.            THEN SHL AX, # 1             \ The sum shifted left one again
  654.                 ADD AL, 0 [BX]          \ Plus count byte
  655.                 AND AX, # #THREADS 1-
  656.                 SHL AX, # 1     ADD AX, DX
  657.                 MOV CX, CS      MOV DS, CX
  658.                 1PUSH           END-CODE
  659.  
  660. CODE XHERE      ( -- seg adr )
  661. \ Returns segment an offset of next available byte in list space.
  662.                 PUSH XDPSEG     PUSH XDP
  663.                 NEXT            END-CODE
  664.  
  665. CODE X,         ( n -- )        \ XHERE !L  2 XDP +!
  666. \ Adds a 16 bit value to the end of list space.
  667.                 POP AX
  668.                 MOV BX, XDP
  669.                 MOV DS, XDPSEG
  670.                 MOV 0 [BX], AX
  671.                 MOV BX, CS
  672.                 MOV DS, BX
  673.                 ADD XDP # 2 WORD
  674.                 NEXT            END-CODE
  675.  
  676. CODE XC,        ( n -- )        \ XHERE C!L 1 XDP +!
  677. \ Adds an 8 bit value to the end of list space.
  678.                 POP AX
  679.                 MOV BX, XDP
  680.                 MOV DS, XDPSEG
  681.                 MOV 0 [BX], AL
  682.                 MOV BX, CS
  683.                 MOV DS, BX
  684.                 INC XDP WORD
  685.                 NEXT            END-CODE
  686.  
  687. CODE PR-STATUS  ( n1 -- b1 )
  688. \ n1 is the printer number.  Return the printer status byte.
  689.                 POP DX          \ PRINTER NUMBER
  690.                 MOV AH, # 2
  691.                 PUSH SI         PUSH BP
  692.                 INT $17
  693.                 POP BP          POP SI
  694.                 MOV AL, AH
  695.                 MOV AH, # 0
  696.                 1PUSH           END-CODE
  697.  
  698. : <?PTR.READY> ( -- f1 )
  699. \ $090 is printer not busy & printer selected.
  700.                 0 PR-STATUS ( $090 AND ) $090 = ;
  701.  
  702. DEFER ?PRINTER.READY    ' <?PTR.READY> IS ?PRINTER.READY
  703. \ A defered word.  Returns  TRUE  if printer is ready.
  704.  
  705. DEFER CR
  706. \ Send a carraige-return and line-feed to the console.
  707.  
  708. DEFER PEMIT     \ ' (PRINT) IS PEMIT
  709. \ A version of  EMIT  that sends a character to the printer.
  710.  
  711. : (EMIT)        ( char -- )
  712. \ Send a character to the console, and optionally to the printer.
  713.                 PRINTING @
  714.                 IF      PEMIT
  715.                 ELSE    CONSOLE
  716.                 THEN    ;
  717.  
  718. : CRLF          ( -- )
  719. \ Sends a carriage return line feed sequence.
  720.                 13 EMIT 10 EMIT #OUT OFF
  721.                 #LINE DUP @ 1+
  722.                 PRINTING @ 0=
  723.                 IF      ROWS 1- MIN  THEN SWAP ! ;
  724.  
  725. : FEMIT         ( c1 -- )
  726. \ A fast version of EMIT.  Control characters show graphic equivalence.
  727.                 SP@ 1 TYPE DROP ;
  728.  
  729. CREATE SPCS     ( -- a1 )      \ An array of 80 spaces for use by SPACES
  730.                 $02020
  731.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  732.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  733.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  734.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  735.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP ,     ,
  736.  
  737. : SPACE         ( -- )    \ Display a space on the terminal.
  738.                 SPCS 1 TYPE ;
  739.  
  740. : SPACES        ( n -- )
  741. \ Send a sequence of  n  spaces to the console.
  742.                 0MAX    DUP 80 <
  743.                 IF      SPCS SWAP TYPE
  744.                 ELSE    80 /MOD 0
  745.                         ?DO     SPCS   80 TYPE
  746.                         LOOP    SPCS SWAP TYPE
  747.                 THEN    ;
  748.  
  749. : BACKSPACES    ( n -- )
  750. \ Send a sequence of  n  backspaces to the console.
  751.                 0 ?DO   BS EMIT -2 #OUT +! LOOP  ;
  752.  
  753. : %BEEP         ( -- )
  754.                 BELL (EMIT) #OUT DECR ;
  755.  
  756. DEFER BEEP      ( -- )          ' %BEEP IS BEEP
  757. \ Ring the bell on the terminal
  758.  
  759.  
  760. : BS-IN         ( n c -- 0 | n-1 )
  761. \ If at beginning of line, beep, otherwise back up 1.
  762.                 >R DUP
  763.                 IF      1-   BS EMIT
  764.                         #OUT @ 2- 0MAX #OUT !
  765.                 ELSE    BEEP
  766.                 THEN    R> ;
  767.  
  768. : (DEL-IN)      ( n c -- 0 | n-1 )
  769. \ If at beginning of line, beep, otherwise back up and erase 1.
  770.                 >R DUP
  771.                 IF      1- BS EMIT SPACE BS EMIT
  772.                         #OUT @ 4 - 0MAX #OUT !
  773.                 ELSE    BEEP
  774.                 THEN    R> ;
  775.  
  776. DEFER DEL-IN    ' (DEL-IN) IS DEL-IN
  777. \ If at beginning of line, beep, otherwise back up and erase 1.
  778.  
  779. : BACK-UP       ( n c -- 0 c )
  780. \ Wipe out the current line by overwriting it with spaces.
  781.                 >R DUP BACKSPACES   DUP SPACES   BACKSPACES   0  R> ;
  782.  
  783. : RESET-IN      ( -- )
  784. \ Reset the system to a relatively clean state.
  785.                 FORTH   TRUE ABORT" Reset"  ;
  786.  
  787. DEFER RES-IN    ' RESET-IN IS RES-IN
  788. \ Reset the system to a relatively clean state.
  789.  
  790. : P-IN          ( -- )
  791. \ Toggle the printer on or off
  792.                 PRINTING @ 0= PRINTING !  ;
  793.  
  794. : (ESC-IN)      ( a n char -- a n+1 char )
  795. \ Default handler of ESC character
  796.                 >R 2DUP + @ EMIT 1+ R> ;
  797.  
  798. DEFER ESC-IN    ' (ESC-IN) IS ESC-IN
  799. \ A defered word to handle ESC character
  800.  
  801. : CR-IN         ( m a n c -- m a m c )
  802. \ Finish input and remember the number of chars in SPAN
  803.                 >R SPAN !   OVER   BL EMIT R>  ;
  804.  
  805. : (CHAR)        ( a n char -- a n+1 char )
  806. \ Process an ordinary character by appending it to the buffer.
  807.                 DUP>R 3DUP EMIT + C!   1+  R> ;
  808.  
  809. DEFER CHAR      ' (CHAR) IS CHAR
  810. \ is usually (CHAR). Executed for most characters.
  811.  
  812. DEFER ^CHAR     ' CHAR   IS ^CHAR
  813. \ Similiar to  CHAR  for control characters.
  814.  
  815. : NORM-KEYTABLE    ( a n1 char n2 -- a n1+1 char )
  816. \ Execute the control character corresponding to n2
  817.                EXEC:
  818.    ^CHAR   ^CHAR  ^CHAR  RES-IN ^CHAR  ^CHAR   ^CHAR  ^CHAR
  819.    DEL-IN  ^CHAR  ^CHAR  ^CHAR  ^CHAR  CR-IN   ^CHAR  ^CHAR
  820.    P-IN    ^CHAR  ^CHAR  ^CHAR  ^CHAR  BACK-UP ^CHAR  ^CHAR
  821.    BACK-UP ^CHAR  ^CHAR  ESC-IN ^CHAR  ^CHAR   ^CHAR  ^CHAR ;
  822.  
  823. DEFER KEYTABLE  ( a n1 char n2 -- a n1+1 char )
  824. \ A defered word to execute the control character corresponding to n2 .
  825. ' NORM-KEYTABLE IS KEYTABLE
  826.  
  827.  
  828. : NEXPECT       ( adr len start -- )
  829. \ expect to a buffer that may already contain some data.
  830.                 DUP>R IF OVER R@ TYPE THEN
  831.                 DUP SPAN !   SWAP R> ( LEN ADR 0_SOFAR )
  832.                 BEGIN   2 PICK OVER - ( len adr #so-far #left )
  833.                 WHILE   2>R >R KEY R> SWAP 2R> ROT
  834.                                 \ The above looks silly no doubt, it is done
  835.                                 \ to assure the stack is empty of the
  836.                                 \ parameters used by NEXPECT, so a background
  837.                                 \ task can display the stack when both shift
  838.                                 \ keys are pressed together.
  839.                         DUP BL <
  840.                         IF      DUP KEYTABLE DROP
  841.                         ELSE    DUP 127 =
  842.                                 IF   DEL-IN   ELSE   CHAR   THEN  DROP
  843.                         THEN
  844.                 REPEAT  3DROP ;
  845.  
  846. : (EXPECT)      ( adr len --- )
  847. \ Accept text into the buffer at "adr" for "len" bytes.
  848.                 0   NEXPECT  ;          ( len adr 0 )
  849.  
  850. DEFER EXPECT    ' (EXPECT) IS EXPECT
  851. \ Get a string from the terminal and place it in the buffer provided.
  852.  
  853. CODE TIB        ( -- addr )
  854. \ Leaves address of text input buffer.
  855.                 PUSH 'TIB       NEXT    END-CODE
  856.  
  857.                                         \ 07/03/89 RB
  858. CODE MORE?      ( -- Flag )             \ Is words left in input stream?
  859.                 MOV AX, >IN
  860.                 SUB AX, #TIB
  861.                 SBB AX, AX
  862.                 1PUSH   END-CODE
  863.  
  864. : QUERY         ( -- )
  865. \  Get more input from the user and place it at TIB.
  866.                 TIB COLS EXPECT  SPAN @ #TIB ! >IN OFF  ;
  867.  
  868.       VARIABLE DISK-ERROR
  869. \ Returns the address of a variable which contains error information on the
  870. \ most recent attempt to access the disk.
  871.  
  872.    -2 CONSTANT LIMIT
  873. \ The highest address in the Code Segment used by Forth.
  874.  
  875. LIMIT 10 - CONSTANT FIRST
  876. \ This is a simple constant having the value 10 less than  LIMIT .
  877.  
  878. FIRST 10 - CONSTANT INIT-R0
  879. \ Address of the base of the Return Stack.
  880.  
  881. DECIMAL
  882.  
  883. FORTH DEFINITIONS
  884.  
  885. : HEX           ( -- )   
  886. \ Set the contents of BASE to 16 (i.e., Hexadecimal).
  887.                 16 BASE !  ;
  888.  
  889. : DECIMAL       ( -- )
  890. \ Restore the contents of base to 10 (i.e., Decimal)
  891.                 10 BASE !  ;
  892.  
  893. : OCTAL         ( -- )
  894. \ Set the contents of BASE to 8 (i.e., Octal)
  895.                 8 BASE !  ;
  896.  
  897. DEFER DEFAULT
  898. \ Opens the default file per the execute line.  
  899. \ Does nothing if no file was given.
  900.  
  901. CODE DIGIT      ( char base -- n f )
  902. \ If the character is equivalent to a digit in the specified base,
  903. \ convert the character and return a  TRUE  flag, else leave char and  FALSE.
  904.                 POP DX          POP AX          PUSH AX
  905.                 SUB AL, # ASCII 0
  906.                 JB 0 $
  907.                         CMP AL, # 9
  908.               > IF
  909.                         CMP AL, # 17
  910.                         JB 0 $
  911.                         SUB AL, # 7
  912.                 THEN
  913.                 CMP AL, DL
  914.                 JAE 0 $
  915.                         MOV DL, AL
  916.                         POP AX
  917.                         MOV AX, # TRUE
  918.                 2PUSH
  919.         0 $:    SUB AX, AX      1PUSH           END-CODE
  920.  
  921. : DOUBLE?       ( -- f )
  922. \ Returns non-zero if a period was encountered during last numeric scan. 
  923.                 DPL @ 1+   0<> ;
  924.  
  925. : CONVERT       ( +d1 adr1 -- +d2 adr2 )
  926. \ Convert the string at adr1 to a double number until an unconvertable
  927. \ character is encountered (pointed to by adr2).  Accumulate in +d1.
  928.                 BEGIN   1+  DUP>R  C@  BASE @  DIGIT
  929.                 WHILE   SWAP  BASE @ UM*  DROP  ROT  BASE @ UM*  D+
  930.                         DOUBLE?  IF  DPL INCR THEN  R>
  931.                 REPEAT  DROP  R>  ;
  932.  
  933. : (NUMBER?)     ( adr -- d flag )
  934. \ Convert string at  adr  to a number.  If successful, leave  TRUE  flag.  
  935. \ The string should terminate with an ASCII space.
  936.                 0 0  ROT  DUP 1+  C@  ASCII -  =  DUP  >R  -  DPL -1!
  937.                 BEGIN   CONVERT  DUP C@  ASCII , ASCII / BETWEEN
  938.                 WHILE   DPL 0!
  939.                 REPEAT  -ROT  R> IF  DNEGATE  THEN   ROT C@ BL =  ;
  940.  
  941. : NUMBER?       ( adr -- d flag )
  942. \ Convert a counted string to a number.  The string should terminate
  943. \ with an ASCII space and contain a valid, possibly signed, number.
  944.                 FALSE  OVER COUNT BOUNDS
  945.                 ?DO     I C@ BASE @ DIGIT NIP
  946.                         IF      DROP TRUE LEAVE THEN
  947.                 LOOP
  948.                 IF  (NUMBER?)  ELSE  DROP  0 0 FALSE  THEN  ;
  949.  
  950. : %$NUM         ( a1 -- d1 f1 )         \ process as a hex number $A123
  951.                 dup>r DUP COUNT 1- 0MAX >R
  952.                 DUP 1+ SWAP R> CMOVE    \ Extract the $.
  953.                 DUP C@ 1- OVER C!       \ Shorten count by 1.
  954.                 BL OVER COUNT + C!      \ Append a blank to string.
  955.                 BASE @ >R               \ Save the base for later restoral.
  956.                 HEX NUMBER?             \ Try to convert the number in HEX
  957.                 R> BASE !               \ Restore the BASE.
  958.                 DUP 0=                  \ If its not a number, restore the $.
  959.                 IF      R@ COUNT >R DUP 1+ R> CMOVE>
  960.                         1 R@ C+!
  961.                         ASCII $ R@ 1+ C!
  962.                 THEN    R>DROP ;
  963.  
  964. : %'NUM         ( a1 -- d1 f1 )         \ process as an ascii char 'A'
  965.                 2+ C@         0 TRUE DPL ON ;
  966.  
  967. : %^NUM         ( a1 -- d1 f1 )         \ process as a control char ^A
  968.                 2+ C@ $1F AND 0 TRUE DPL ON ;
  969.  
  970. : %NUMH         ( a1 -- d1 f1 )         \ process as a hex number A123H
  971.                 DUP COUNT + 1- >R       \ save addr of end last char
  972.                 BL R@ DUP C@ >R  C!     \ save last char of string & set to bl
  973.                 BASE @ >R               \ save the base to restore later
  974.                 HEX                     \ set the BASE to HEX
  975.                 NUMBER?                 \ convert the number in BINARY
  976.                 R> BASE !               \ restore the base
  977.                 R> R> C! ;              \ restore trailing B
  978.  
  979. DEFER $NUM      ' %$NUM   IS $NUM       \ HEX
  980. DEFER 'NUM      ' %'NUM   IS 'NUM       \ ASCII
  981. DEFER ^NUM      ' %^NUM   IS ^NUM       \ CONTROL
  982. DEFER #NUM      ' NUMBER? IS #NUM       \ A NUMBER
  983. DEFER NUMH      ' %NUMH   IS NUMH       \ HEX
  984.  
  985. : %NUMB         ( a1 -- d1 f1 )         \ process as a BINARY number 10101B
  986.                 BASE @ $0A =            \ but ONLY if in DECIMAL number base
  987.         IF      DUP COUNT + 1- >R       \ save addr of end last char
  988.                 BL R@ DUP C@ >R  C!     \ save last char of string & set to bl
  989.                 2 BASE !                \ set BASE=2 (binary)
  990.                 NUMBER?                 \ convert the number in BINARY
  991.                 R> R> C!                \ restore trailing B
  992.                 DECIMAL                 \ return to DECIMAL
  993.         ELSE    #NUM                    \ else convert as normal number
  994.         THEN    ;
  995.  
  996. DEFER NUMB      ' %NUMB   IS NUMB
  997.  
  998. \ Extend the special number handling done by F-PC to include
  999. \ HEX numbers entered with an 'H' or 'h' postfix character
  1000. \ and binary numbers entered with a '&' postfix char.
  1001.  
  1002. CODE %NUMBER    ( a1 -- d1 f1 )
  1003. \ Convert count delimited string at a1 into double number.  Special
  1004. \ prefixes and sufixes allowed.
  1005.                 MOV DI, SP
  1006.                 MOV BX, 0 [DI]
  1007.                 MOV AL, 1 [BX]
  1008.                 CMP AL, # ASCII $               \ test for leading $
  1009.              0= IF      JMP ' $NUM              \ process as HEX
  1010.                 THEN
  1011.                 MOV AL, 1 [BX]
  1012.                 MOV AH, 3 [BX]
  1013.                 CMP AX, # ASCII '  dup flip +   \ test for lead & trail '
  1014.              0= IF      JMP ' 'NUM              \ process as ascii char
  1015.                 THEN
  1016.                 MOV AX, 0 [BX]
  1017.                 CMP AX, # ASCII ^ flip $02 +    \ test for lead ^ & cnt = 2
  1018.              0= IF      JMP ' ^NUM              \ process as control char
  1019.                 THEN
  1020.                 MOV AL, 0 [BX]                  \ get count
  1021.                 SUB AH, AH                      \ clear AH
  1022.                 ADD BX, AX                      \ add to base address
  1023.                 MOV AL, 0 [BX]                  \ get last character
  1024.                 CMP AL, # ASCII h               \ test for trailing 'h'
  1025.              0= IF      JMP ' NUMH              \ process as HEX
  1026.                 THEN
  1027.                 CMP AL, # ASCII H               \ test for trailing 'H'
  1028.              0= IF      JMP ' NUMH              \ process as HEX
  1029.                 THEN
  1030.                 CMP AL, # ASCII b               \ test for trailing 'b'
  1031.              0= IF      JMP ' NUMB              \ process as BINARY
  1032.                 THEN
  1033.                 CMP AL, # ASCII B               \ test for trailing 'B'
  1034.              0= IF      JMP ' NUMB              \ process as BINARY
  1035.                 THEN
  1036.                 JMP ' #NUM                      \ else process as a number
  1037.                 END-CODE
  1038.  
  1039. : (NUMBER)      ( a1 -- d1 )
  1040. \ Convert count delimited string at a1 into a double number.
  1041.                 %NUMBER NOT ?MISSING ;
  1042.  
  1043. DEFER NUMBER    ' (NUMBER) IS NUMBER
  1044. \ Convert count delimited string at a1 into a double number.
  1045.  
  1046. : HOLD          ( char -- )
  1047. \ Save the character for later output.  Characters are entered in a
  1048. \ right to left sequence!
  1049.                 HLD DECR HLD @ C!   ;
  1050.  
  1051. : <#            ( -- )  
  1052. \ Start numeric conversion.
  1053.                 PAD  HLD  !  ;
  1054.  
  1055. : #>            ( d# -- addr len )
  1056. \ Terminate numeric conversion.
  1057.                 2DROP  HLD  @  PAD  OVER  -  ;
  1058.  
  1059. : SIGN          ( n1 -- )
  1060. \ If n1 is negative insert a minus sign into the string.
  1061.                 0< IF  ASCII -  HOLD  THEN  ;
  1062.  
  1063. : #             ( d1 -- d2 )
  1064. \ Convert a single digit in the current base.
  1065.                 BASE @ MU/MOD ROT 9 OVER <
  1066.                 IF  7 + THEN ASCII 0  +  HOLD  ;
  1067.  
  1068. : #S            ( d -- 0 0 )
  1069. \ Convert a number until it is finished.
  1070.                 BEGIN  #  2DUP  OR  0=  UNTIL  ;
  1071.  
  1072. : (U.)          ( u -- a l )
  1073. \ Convert an unsigned 16 bit number to a string.
  1074.                 0    <# #S #>   ;
  1075.  
  1076. : U.            ( u -- )
  1077. \ Convert an unsigned 16 bit number to a string.
  1078.                 (U.)   TYPE SPACE   ;
  1079.  
  1080. : U.R           ( u l -- )
  1081. \ Output as an unsigned single number right justified.
  1082.                 >R   (U.)   R> OVER - SPACES   TYPE   ;
  1083.  
  1084. : (.)           ( n -- a l )
  1085. \ Convert a signed 16 bit number to a string.
  1086.                 DUP ABS 0   <# #S   ROT SIGN   #>   ;
  1087.  
  1088. : .             ( n -- )
  1089. \ Output as a signed single number with a trailing space.
  1090.                 (.)   TYPE SPACE   ;
  1091.  
  1092. : .R            ( n l -- )
  1093. \ Output as a signed single number right justified.
  1094.                 >R   (.)   R> OVER - SPACES   TYPE   ;
  1095.  
  1096. : (UD.)         ( ud -- a l )
  1097. \ Convert an unsigned double number to a string.
  1098.                 <# #S #>   ;
  1099.  
  1100. : UD.           ( ud -- )
  1101. \ Output as an unsigned double number with a trailing space
  1102.                 (UD.)   TYPE SPACE   ;
  1103.  
  1104. : UD.R          ( ud l -- )
  1105. \ Output as an unsigned double number right justified.
  1106.                 >R   (UD.)   R> OVER - SPACES   TYPE  ;
  1107.  
  1108. : (D.)          ( d -- a l )
  1109. \ Convert a signed double number to a string.
  1110.                 TUCK DABS   <# #S   ROT SIGN  #>   ;
  1111.  
  1112. : D.            ( d -- )
  1113. \ Output as a signed double number with a trailing space.
  1114.                 (D.)   TYPE SPACE   ;
  1115.  
  1116. : D.R           ( d l -- )
  1117. \ Output as a signed double number right justified.
  1118.                 >R   (D.)   R> OVER - SPACES   TYPE   ;
  1119.  
  1120. CODE  SKIP      ( addr len char -- addr' len' )
  1121. \ Skip char through addr for len, returning addr' and len' of char+1.
  1122.                 POP AX          POP CX
  1123.                 JCXZ 0 $
  1124.                 POP DI
  1125.                 MOV DX, ES      MOV ES, SSEG
  1126.                 REPZ            SCASB
  1127.                 MOV ES, DX
  1128.             0<> IF
  1129.                 INC CX          DEC DI
  1130.             THEN
  1131.                 PUSH DI         PUSH CX
  1132.                 NEXT
  1133.         0 $:    PUSH CX         NEXT            END-CODE
  1134.  
  1135. CODE  SCAN      ( addr len char -- addr' len' )
  1136. \ Scan for char through addr for len, returning addr' and len' of char.
  1137.                 POP AX          POP CX
  1138.                 JCXZ 0 $
  1139.                 POP DI
  1140.                 MOV DX, ES      MOV ES, SSEG
  1141.                 REPNZ           SCASB
  1142.                 MOV ES, DX
  1143.              0= IF
  1144.                 INC CX          DEC DI
  1145.              THEN
  1146.                 PUSH DI         PUSH CX
  1147.                 NEXT
  1148.         0 $:    PUSH CX         NEXT            END-CODE
  1149.  
  1150. CODE /STRING    ( addr len n -- addr' len' )
  1151. \ Index into the string by n.  Returns addr+n and len-n.
  1152.                 POP AX          POP BX
  1153.                 PUSH BX
  1154.                 CMP AX, # 0
  1155.             >=  IF      CMP BX, AX
  1156.                     U<= IF
  1157.                         XCHG BX, AX     \ AX = SMALLER OF AX BX
  1158.                      THEN
  1159.                 THEN
  1160.                 POP BX          POP DX
  1161.                 ADD DX, AX      PUSH DX
  1162.                 SUB BX, AX      PUSH BX
  1163.                 NEXT            END-CODE
  1164.  
  1165. CODE SOURCE     ( -- addr len )         \ TIB #TIB @
  1166. \ Return address and count of the input string in the Text input buffer.
  1167.                 MOV DX, 'TIB
  1168.                 MOV AX, #TIB
  1169.                 2PUSH
  1170.                 END-CODE
  1171.  
  1172. : PARSE         ( char -- addr len )
  1173. \ Scan the input stream until char is encountered.
  1174.                 >R   SOURCE >IN @ /STRING   OVER SWAP R> SCAN
  1175.                 >R OVER -  DUP R>  0<> -  >IN +!  ;
  1176.  
  1177. CODE WORD       ( c1 --- addr )
  1178. \  Parse the input stream for char and return a count delimited
  1179. \  string at here.  Note there is always a blank following it.
  1180.                 MOV DI, 'TIB
  1181.                 MOV CX, #TIB
  1182.                 POP BX
  1183.                 PUSH ES                         \ Save ES for later restoral
  1184.                 MOV DX, DS      MOV ES, DX      \ ES = DS from now to END
  1185.                 MOV AX, >IN
  1186.                 CMP CX, AX
  1187.             U<= IF              MOV AX, CX      \ AX = SMALLER OF AX CX
  1188.                 THEN
  1189.                 ADD DI, AX
  1190.                 SUB CX, AX
  1191.                 MOV AX, BX
  1192.           CX<>0 IF              REPZ            SCASB
  1193.                             0<> IF              INC CX
  1194.                                                 DEC DI
  1195.                                 THEN
  1196.                 THEN
  1197.                 MOV DX, #TIB            \ 04/12/91 added to save start of
  1198.                 SUB DX, CX              \ word just parsed out
  1199.                 MOV >IN_WORD DX         \
  1200.                 MOV DX, DI
  1201.                 MOV AX, BX
  1202.           CX<>0 IF              REPNZ           SCASB
  1203.                              0= IF              INC CX
  1204.                                                 DEC DI
  1205.                                 THEN
  1206.                 THEN
  1207.                 SUB DI, DX
  1208.                 MOV BX, #TIB
  1209.                 MOV AX, DX
  1210.           CX<>0 IF      DEC CX
  1211.                 THEN
  1212.                 SUB BX, CX      MOV >IN BX
  1213.                 MOV BX, UP
  1214.                 MOV DX, DP [BX]
  1215.                 MOV CX, DI
  1216.                 MOV DI, DX
  1217.                 MOV 0 [DI], CL
  1218.                 INC DI          \ CLD
  1219.                 MOV BX, IP
  1220.                 MOV IP, AX
  1221.                 REPNZ           MOVSB
  1222.                 MOV AL, # 32    STOSB
  1223.                 MOV IP, BX
  1224.                 POP ES                          \ Restore ES
  1225.                 PUSH DX
  1226.                 NEXT            END-CODE
  1227.  
  1228.