2 10 CONSTANT linefeed-char
\r
3 13 CONSTANT carriage-return-char
\r
4 32 CONSTANT blank-char-value
\r
8 cell-size 8 * CONSTANT cell-size-in-bits
\r
11 0FF CONSTANT max-char
\r
12 7FFF CONSTANT max-signed
\r
13 0FFFF CONSTANT max-unsigned
\r
14 8000 CONSTANT max-negative
\r
22 258 CONSTANT size-of-PAD
\r
31 0E890 CONSTANT call-code
\r
35 \ System dependent words -- Must be re-definded for each system.
\r
37 \ I/O words must be redefined if serial communication is used instead of
\r
38 \ keyboard. Following words are for MS-DOS system.
\r
41 \ Return true if output device is ready or device state is
\r
44 \ $CONST NameTXQ,TXQ,TRUEE ;always true for MS-DOS
\r
47 \ Carriage return and linefeed.
\r
49 : CR carriage-return-char EMIT linefeed-char EMIT ;
\r
52 \ DW DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT
\r
57 S" CPU" ENVIRONMENT? DROP TYPE SPACE
\r
58 S" model" ENVIRONMENT? DROP TYPE SPACE [CHAR] v EMIT
\r
59 S" version" ENVIRONMENT? DROP TYPE
\r
60 ." by Wonyong Koh, 1997" CR
\r
61 ." ALL noncommercial and commercial uses are granted." CR
\r
62 ." Please send comment, bug report and suggestions to:" CR
\r
63 ." wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr" CR ;
\r
66 \ DW CR,DoLIT,HiStr1,COUNT,TYPEE
\r
67 \ DW DoLIT,CPUQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE,SPACE
\r
68 \ DW DoLIT,ModelQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE
\r
69 \ DW SPACE,DoLIT,'v',EMIT
\r
70 \ DW DoLIT,VersionQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE
\r
71 \ DW DoLIT,HiStr2,COUNT,TYPEE,CR
\r
72 \ DW DoLIT,HiStr3,COUNT,TYPEE,CR
\r
73 \ DW DoLIT,HiStr4,COUNT,TYPEE,CR
\r
74 \ DW DoLIT,HiStr5,COUNT,TYPEE,CR,EXIT
\r
77 \ The cold start sequence execution word.
\r
79 : COLD sp0 sp! rp0 rp! \ initialize stack
\r
82 QUIT ; \ start interpretation
\r
84 \ $COLON NameCOLD,COLD
\r
85 \ DW SPZero,SPStore,RPZero,RPStore
\r
86 \ DW TickINIT_IO,EXECUTE,TickBoot,EXECUTE
\r
90 \ Set input/output device.
\r
92 : set-i/o S" CON" stdin ; \ MS-DOS only
\r
94 \ $COLON NameSet_IO,Set_IO
\r
95 \ Nick removed this, want to use ordinary DOS redirection instead
\r
96 \ DW DoLIT,Set_IOstr ;MS-DOS only
\r
97 \ DW COUNT,STDIN ;MS-DOS only
\r
100 \ asciiz ( ca1 u -- ca2 )
\r
101 \ Return ASCIIZ string.
\r
103 : asciiz HERE SWAP 2DUP + 0 SWAP C! CHARS MOVE HERE ;
\r
105 \ $COLON NameASCIIZ,ASCIIZ
\r
106 \ DW HERE,SWAP,TwoDUP,Plus,DoLIT,0
\r
107 \ DW SWAP,CStore,CHARS,MOVE,HERE,EXIT
\r
109 \ stdin ( ca u -- )
\r
111 : stdin asciiz redirect ?DUP
\r
112 IF -38 THROW THEN \ non-existent file
\r
115 \ $COLON NameSTDIN,STDIN
\r
116 \ DW ASCIIZ,Redirect,QuestionDUP,ZBranch,STDIN1
\r
117 \ DW DoLIT,-38,THROW
\r
120 \ << ( "<spaces>ccc" -- )
\r
121 \ Redirect input from the file 'ccc'. Should be used only in
\r
122 \ interpretation state.
\r
124 : << STATE @ IF ." Do not use '<<' in a definition." ABORT THEN
\r
125 PARSE-WORD stdin SOURCE >IN ! DROP ; IMMEDIATE
\r
127 \ $COLON NameFROM,FROM
\r
128 \ DW DoLIT,AddrSTATE,Fetch,ZBranch,FROM1
\r
131 \ DW COUNT,TYPEE,ABORT
\r
132 \ FROM1 DW PARSE_WORD,STDIN,SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT
\r
135 \ Non-Standard words - Processor-dependent definitions
\r
136 \ 16 bit Forth for 8086/8
\r
140 \ Stop current task and transfer control to the task of which
\r
141 \ 'status' USER variable is stored in 'follower' USER variable
\r
145 \ : PAUSE rp@ DUP sp@ stackTop ! follower @ code@ >R ; COMPILE-ONLY
\r
147 \ $COLON NamePAUSE,PAUSE
\r
148 \ DW RPFetch,DUPP,SPFetch,StackTop,Store
\r
149 \ DW Follower,Fetch,CodeFetch,ToR,EXIT
\r
151 \ $CODE NamePAUSE,PAUSE
\r
157 \ MOV BX,WORD PTR AddrUserP
\r
158 \ StackTopOffset = SysStackTop - SysUserP
\r
159 \ MOV [BX+StackTopOffset],SP
\r
160 \ FollowerOffset = SysFollower - SysUserP
\r
161 \ MOV BX,[BX+FollowerOffset]
\r
166 \ Wake current task.
\r
168 : wake R> CELL+ code@ userP ! \ userP points 'follower' of current task
\r
169 stackTop @ sp! DROP \ set data stack
\r
170 rp! ; COMPILE-ONLY \ set return stack
\r
172 \ $COLON NameWake,Wake
\r
173 \ DW RFrom,CELLPlus,CodeFetch,DoLIT,AddrUserP,Store
\r
174 \ DW StackTop,Fetch,SPStore,DROP,RPStore,EXIT
\r
176 \ $CODE NameWake,Wake
\r
177 \ MOV BX,CS:[SI+CELLL]
\r
178 \ MOV WORD PTR AddrUserP,BX
\r
179 \ MOV SP,[BX+StackTopOffset]
\r
187 \ same? ( c-addr1 c-addr2 u -- -1|0|1 )
\r
188 \ Return 0 if two strings, ca1 u and ca2 u, are same; -1 if
\r
189 \ string, ca1 u is smaller than ca2 u; 1 otherwise. Used by
\r
190 \ '(search-wordlist)'. Code definition is preferred to speed up
\r
191 \ interpretation. Colon definition is shown below.
\r
193 : same? ?DUP IF \ null strings are always same
\r
194 0 DO OVER C@ OVER C@ XOR
\r
195 IF UNLOOP C@ SWAP C@ > 2* 1+ EXIT THEN
\r
196 CHAR+ SWAP CHAR+ SWAP
\r
200 \ $COLON NameSameQ,SameQ
\r
201 \ DW QuestionDUP,ZBranch,SAMEQ4
\r
203 \ SAMEQ3 DW OVER,CFetch,OVER,CFetch,XORR,ZBranch,SAMEQ2
\r
204 \ DW UNLOOP,CFetch,SWAP,CFetch,GreaterThan
\r
205 \ DW TwoStar,OnePlus,EXIT
\r
206 \ SAMEQ2 DW CHARPlus,SWAP,CHARPlus
\r
208 \ SAMEQ4 DW TwoDROP,DoLIT,0,EXIT
\r
210 \ $CODE NameSameQ,SameQ
\r
214 \ MOV DX,SI ;save SI
\r
225 \ SAMEQ1: MOV SI,DX
\r
228 \ (search-wordlist) ( c-addr u wid -- 0 | xt f 1 | xt f -1)
\r
229 \ Search word list for a match with the given name.
\r
230 \ Return execution token and not-compile-only flag and
\r
231 \ -1 or 1 ( IMMEDIATE) if found. Return 0 if not found.
\r
233 \ format is: wid---->[ a ]
\r
236 \ [ xt' ][ a' ][ccbbaann][ggffeedd]...
\r
240 \ [ xt'' ][ a'' ][ccbbaann][ggffeedd]...
\r
242 \ a, a' etc. point to the cell that contains the name of the
\r
243 \ word. The length is in the low byte of the cell (little byte
\r
244 \ for little-endian, big byte for big-endian).
\r
245 \ Eventually, a''' contains 0 to indicate the end of the wordlist
\r
246 \ (oldest entry). a=0 indicates an empty wordlist.
\r
247 \ xt is the xt of the word. aabbccddeedd etc. is the name of
\r
248 \ the word, packed into cells.
\r
250 : (search-wordlist)
\r
251 ROT >R SWAP DUP 0= IF -16 THROW THEN
\r
252 \ attempt to use zero-length string as a name
\r
254 BEGIN @ \ ca2 R: ca1 u
\r
255 DUP 0= IF R> R> 2DROP EXIT THEN \ not found
\r
256 DUP COUNT [ =mask ] LITERAL AND R@ = \ ca2 ca2+char f
\r
257 IF R> R@ SWAP DUP >R \ ca2 ca2+char ca1 u
\r
259 \ ELSE DROP -1 \ unnecessary since ca2+char is not 0.
\r
261 WHILE cell- \ pointer to next word in wordlist
\r
263 R> R> 2DROP DUP name>xt SWAP \ xt ca2
\r
264 C@ 2DUP [ =seman ] LITERAL AND 0= 0= \ xt char xt f
\r
265 AND TO specialComp?
\r
266 DUP [ =compo ] LITERAL AND 0= SWAP
\r
267 [ =immed ] LITERAL AND 0= 2* 1+ ;
\r
269 \ $COLON NameParenSearch_Wordlist,ParenSearch_Wordlist
\r
270 \ DW ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6
\r
273 \ DW DUPP,ZBranch,PSRCH9
\r
274 \ DW DUPP,COUNT,DoLIT,MASKK,ANDD,RFetch,Equals
\r
275 \ DW ZBranch,PSRCH5
\r
276 \ DW RFrom,RFetch,SWAP,DUPP,ToR,SameQ
\r
277 \ PSRCH5 DW ZBranch,PSRCH3
\r
278 \ DW CellMinus,Branch,PSRCH1
\r
279 \ PSRCH3 DW RFrom,RFrom,TwoDROP,DUPP,NameToXT,SWAP
\r
280 \ DW CFetch,TwoDUP,DoLIT,SEMAN,ANDD,ZeroEquals,ZeroEquals
\r
281 \ DW ANDD,DoTO,AddrSpecialCompQ
\r
282 \ DW DUPP,DoLIT,COMPO,ANDD,ZeroEquals,SWAP
\r
283 \ DW DoLIT,IMMED,ANDD,ZeroEquals,TwoStar,OnePlus,EXIT
\r
284 \ PSRCH9 DW RFrom,RFrom,TwoDROP,EXIT
\r
285 \ PSRCH6 DW DoLIT,-16,THROW
\r
287 \ $CODE NameParenSearch_Wordlist,ParenSearch_Wordlist
\r
296 \ PSRCH2: MOV BX,[BX]
\r
298 \ JZ PSRCH4 ; end of wordlist?
\r
300 \ SUB BX,CELLL ;pointer to nextword
\r
301 \ AND CL,MASKK ;max name length = MASKK
\r
306 \ ADD DI,CELLL+CHARR
\r
310 \ PUSH [BX-CELLL] ;xt
\r
312 \ MOV CL,[BX+CELLL]
\r
313 \ AND AL,CL ;test SEMAN = 080h
\r
316 \ AND DX,[BX-CELLL]
\r
317 \ MOV AddrSpecialCompQ,DX
\r
328 \ PSRCH1: MOV BX,-16 ;attempt to use zero-length string as a name
\r
333 \ ?call ( xt1 -- xt1 0 | code-addr xt2 )
\r
334 \ Return xt of the CALLed run-time word if xt starts with machine
\r
335 \ CALL instruction and leaves the next cell address after the
\r
336 \ CALL instruction. Otherwise leaves the original xt1 and zero.
\r
338 : ?call DUP code@ call-code =
\r
339 IF CELL+ DUP code@ SWAP CELL+ DUP ROT + EXIT THEN
\r
340 \ Direct Threaded Code 8086 relative call
\r
343 \ $COLON NameQCall,QCall
\r
344 \ DW DUPP,CodeFetch,DoLIT,CALLL,Equals,ZBranch,QCALL1
\r
345 \ DW CELLPlus,DUPP,CodeFetch,SWAP,CELLPlus,DUPP,ROT,Plus
\r
347 \ QCALL1 DW DoLIT,0,EXIT
\r
349 \ $CODE NameQCall,QCall
\r
356 \ QCALL1: ADD BX,2*CELLL
\r
358 \ ADD BX,CS:[BX-CELLL]
\r
361 \ xt, ( xt1 -- xt2 )
\r
362 \ Take a run-time word xt1 for :NONAME , CONSTANT , VARIABLE and
\r
363 \ CREATE . Return xt2 of current definition.
\r
365 : xt, xhere ALIGNED DUP TO xhere SWAP
\r
366 call-code code, \ Direct Threaded Code
\r
367 xhere CELL+ - code, ; \ 8086 relative call
\r
369 \ $COLON NamextComma,xtComma
\r
370 \ DW XHere,ALIGNED,DUPP,DoTO,AddrXHere,SWAP
\r
371 \ DW DoLIT,CALLL,CodeComma
\r
372 \ DW XHere,CELLPlus,Minus,CodeComma,EXIT
\r
374 \ $CODE NamextComma,xtComma
\r
379 \ MOV WORD PTR CS:[BX],CALLL
\r
384 \ MOV CS:[BX+CELLL],AX
\r
388 \ Push an inline literal. The inline literal is at the current
\r
389 \ value of the fpc, so put it onto the stack and point past it.
\r
391 \ $CODE NameDoLIT,DoLIT
\r
393 \ LODS WORD PTR CS:[SI]
\r
398 \ Run-time routine of CONSTANT and initializable system
\r
399 \ VARIABLE. When you quote a constant or variable you execute
\r
400 \ its code, which consists of a call to here, followed by an
\r
401 \ inline literal. The literal is a constant (for a CONSTANT) or
\r
402 \ the address at which a VARIABLE's value is stored. Although
\r
403 \ you come here as the result of a native machine call, you
\r
404 \ never go back to the return address -- you jump back up a
\r
405 \ level by continuing at the new fpc value. For 8086, Z80 the
\r
406 \ inline literal is at the return address stored on the top of
\r
407 \ the hardware stack.
\r
409 \ $CODE NameDoCONST,DoCONST
\r
416 \ Run-time routine of VALUE. Return the value of VALUE word.
\r
417 \ This is like an invocation of doCONST for a VARIABLE but
\r
418 \ instead of returning the address of the variable, we return
\r
419 \ the value of the variable -- in other words, there is another
\r
420 \ level of indirection.
\r
422 \ $CODE NameDoVALUE,DoVALUE
\r
429 \ doCREATE ( -- a-addr )
\r
430 \ Run-time routine of CREATE. For CREATEd words with an
\r
431 \ associated DOES>, get the address of the CREATEd word's data
\r
432 \ space and execute the DOES> actions. For CREATEd word without
\r
433 \ an associated DOES>, return the address of the CREATE'd word's
\r
434 \ data space. A CREATEd word starts its execution through this
\r
435 \ routine in exactly the same way as a colon definition uses
\r
436 \ doLIST. In other words, we come here through a native machine
\r
439 \ Structure of CREATEd word:
\r
440 \ | call-doCREATE | 0 or DOES> code addr | a-addr |
\r
442 \ The DOES> address holds a native call to doLIST. This routine
\r
443 \ doesn't alter the fpc. We never come back *here* so we never
\r
444 \ need to preserve an address that would bring us back *here*.
\r
446 \ Example : myVARIABLE CREATE , DOES> ;
\r
447 \ 56 myVARIABLE JIM
\r
448 \ JIM \ stacks the address of the data cell that contains 56
\r
450 : doCREATE SWAP \ switch BX and top of 8086 stack item
\r
451 DUP CELL+ code@ SWAP code@ ?DUP IF EXECUTE THEN
\r
454 \ $COLON NameDoCREATE,DoCREATE
\r
455 \ DW SWAP,CELLPlus,DUPP,CodeFetch,SWAP,CodeFetch
\r
456 \ DW QuestionDUP,ZBranch,DOCREAT1
\r
460 \ $CODE NameDoCREATE,DoCREATE
\r
464 \ MOV BX,CS:[BX+CELLL]
\r
472 \ Run-time routine of TO. Store x at the address in the
\r
473 \ following cell. The inline literal holds the address
\r
476 \ $CODE NameDoTO,DoTO
\r
477 \ LODS WORD PTR CS:[SI]
\r
483 \ doUSER ( -- a-addr )
\r
484 \ Run-time routine of USER. Return address of data space.
\r
485 \ This is like doCONST but a variable offset is added to the
\r
486 \ result. By changing the value at AddrUserP (which happens
\r
487 \ on a taskswap) the whole set of user variables is switched
\r
488 \ to the set for the new task.
\r
490 \ $CODE NameDoUSER,DoUSER
\r
497 \ doLIST ( -- ) ( R: -- nest-sys )
\r
498 \ Process colon list.
\r
499 \ The first word of a definition (the xt for the word) is a
\r
500 \ native machine-code instruction for the target machine. For
\r
501 \ high-level definitions, that code is emitted by xt, and
\r
502 \ performs a call to doLIST. doLIST executes the list of xt that
\r
503 \ make up the definition. The final xt in the definition is EXIT.
\r
504 \ The address of the first xt to be executed is passed to doLIST
\r
505 \ in a target-specific way. Two examples:
\r
506 \ Z80, 8086: native machine call, leaves the return address on
\r
507 \ the hardware stack pointer, which is used for the data stack.
\r
509 \ $CODE NameDoLIST,DoLIST
\r
511 \ MOV [BP],SI ;push return stack
\r
512 \ POP SI ;new list address
\r
515 \ doLOOP ( -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
516 \ Run time routine for LOOP.
\r
518 \ $CODE NameDoLOOP,DoLOOP
\r
519 \ INC WORD PTR [BP] ;increase loop count
\r
520 \ JO DoLOOP1 ;?loop end
\r
521 \ MOV SI,CS:[SI] ;no, go back
\r
523 \ DoLOOP1: ADD SI,CELLL ;yes, continue past the branch offset
\r
524 \ ADD BP,2*CELLL ;clear return stack
\r
527 \ do+LOOP ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
528 \ Run time routine for +LOOP.
\r
530 \ $CODE NameDoPLOOP,DoPLOOP
\r
531 \ ADD WORD PTR [BP],BX ;increase loop count
\r
532 \ JO DoPLOOP1 ;?loop end
\r
533 \ MOV SI,CS:[SI] ;no, go back
\r
536 \ DoPLOOP1: ADD SI,CELLL ;yes, continue past the branch offset
\r
537 \ ADD BP,2*CELLL ;clear return stack
\r
541 \ 0branch ( flag -- )
\r
542 \ Branch if flag is zero.
\r
544 \ $CODE NameZBranch,ZBranch
\r
545 \ OR BX,BX ;?flag=0
\r
546 \ JZ ZBRAN1 ;yes, so branch
\r
547 \ ADD SI,CELLL ;point IP to next cell
\r
550 \ ZBRAN1: MOV SI,CS:[SI] ;IP:=(IP)
\r
555 \ Branch to an inline address.
\r
557 \ $CODE NameBranch,Branch
\r
558 \ MOV SI,CS:[SI] ;IP:=(IP)
\r
561 \ rp@ ( -- a-addr )
\r
562 \ Push the current RP to the data stack.
\r
564 \ $CODE NameRPFetch,RPFetch
\r
569 \ rp! ( a-addr -- )
\r
570 \ Set the return stack pointer.
\r
572 \ $CODE NameRPStore,RPStore
\r
577 \ sp@ ( -- a-addr )
\r
578 \ Push the current data stack pointer.
\r
580 \ $CODE NameSPFetch,SPFetch
\r
585 \ sp! ( a-addr -- )
\r
586 \ Set the data stack pointer.
\r
588 \ $CODE NameSPStore,SPStore
\r
593 \ um+ ( u1 u2 -- u3 1|0 )
\r
594 \ Add two unsigned numbers, return the sum and carry.
\r
596 \ $CODE NameUMPlus,UMPlus
\r
600 \ PUSH BX ;push sum
\r
601 \ RCL CX,1 ;get carry
\r
605 \ code! ( x code-addr -- )
\r
606 \ Store x at a code space address.
\r
608 \ $CODE NameCodeStore,CodeStore
\r
613 \ codeB! ( b code-addr -- )
\r
614 \ Store byte at a code space address.
\r
616 \ $CODE NameCodeBStore,CodeBStore
\r
622 \ code@ ( code-addr -- x )
\r
623 \ Push the contents at code space addr to the data stack.
\r
625 \ $CODE NameCodeFetch,CodeFetch
\r
629 \ codeB@ ( code-addr -- b )
\r
630 \ Push the contents at code space byte addr to the data stack.
\r
632 \ $CODE NameCodeBFetch,CodeBFetch
\r
638 \ Reserve one cell in code space and store x in it.
\r
640 : code, xhere DUP CELL+ TO xhere code! ;
\r
642 \ $COLON NameCodeComma,CodeComma
\r
643 \ DW XHere,DUPP,CELLPlus,DoTO,AddrXHere,CodeStore,EXIT
\r
645 \ $CODE NameCodeComma,CodeComma
\r
654 \ Standard words - Processor-dependent definitions
\r
655 \ 16 bit Forth for 8086/8
\r
658 \ ALIGN ( -- ) \ CORE
\r
659 \ Align the data space pointer.
\r
661 : ALIGN HERE ALIGNED TO HERE ;
\r
663 \ $COLON NameALIGNN,ALIGNN
\r
664 \ DW HERE,ALIGNED,DoTO,AddrHERE,EXIT
\r
666 \ ALIGNED ( addr -- a-addr ) \ CORE
\r
667 \ Align address to the cell boundary.
\r
669 : ALIGNED DUP 0 cell-size UM/MOD DROP DUP
\r
670 IF cell-size SWAP - THEN + ;
\r
672 \ $COLON NameALIGNED,ALIGNED
\r
673 \ DW DUPP,DoLIT,0,DoLIT,CELLL
\r
674 \ DW UMSlashMOD,DROP,DUPP
\r
676 \ DW DoLIT,CELLL,SWAP,Minus
\r
677 \ ALGN1 DW Plus,EXIT
\r
679 \ $CODE NameALIGNED,ALIGNED
\r
684 \ CELLS ( n1 -- n2 ) \ CORE
\r
685 \ Calculate number of address units for n1 cells.
\r
687 \ : CELLS cell-size * ; \ slow, very portable
\r
688 : CELLS 2* ; \ fast, must be redefined for each system
\r
690 \ $COLON NameCELLS,CELLS
\r
693 \ $CODE NameCELLS,CELLS
\r
697 \ CHARS ( n1 -- n2 ) \ CORE
\r
698 \ Calculate number of address units for n1 characters.
\r
700 \ : CHARS char-size * ; \ slow, very portable
\r
701 : CHARS ; \ fast, must be redefined for each system
\r
703 \ $COLON NameCHARS,CHARS
\r
706 \ 1chars/ ( n1 -- n2 )
\r
707 \ Calculate number of chars for n1 address units.
\r
709 \ : 1chars/ 1 CHARS / ; \ slow, very portable
\r
710 : 1chars/ ; \ fast, must be redefined for each system
\r
712 \ $COLON NameOneCharsSlash,OneCharsSlash
\r
715 \ ! ( x a-addr -- ) \ CORE
\r
716 \ Store x at a aligned address.
\r
718 \ $CODE NameStore,Store
\r
723 \ 0< ( n -- flag ) \ CORE
\r
724 \ Return true if n is negative.
\r
726 \ $CODE NameZeroLess,ZeroLess
\r
732 \ 0= ( x -- flag ) \ CORE
\r
733 \ Return true if x is zero.
\r
735 \ $CODE NameZeroEquals,ZeroEquals
\r
742 \ 2* ( x1 -- x2 ) \ CORE
\r
743 \ Bit-shift left, filling the least significant bit with 0.
\r
745 \ $CODE NameTwoStar,TwoStar
\r
749 \ 2/ ( x1 -- x2 ) \ CORE
\r
750 \ Bit-shift right, leaving the most significant bit unchanged.
\r
752 \ $CODE NameTwoSlash,TwoSlash
\r
756 \ >R ( x -- ) ( R: -- x ) \ CORE
\r
757 \ Move top of the data stack item to the return stack.
\r
759 \ $CODE NameToR,ToR
\r
760 \ SUB BP,CELLL ;adjust RP
\r
765 \ @ ( a-addr -- x ) \ CORE
\r
766 \ Push the contents at a-addr to the data stack.
\r
768 \ $CODE NameFetch,Fetch
\r
772 \ AND ( x1 x2 -- x3 ) \ CORE
\r
775 \ $CODE NameANDD,ANDD
\r
780 \ C! ( char c-addr -- ) \ CORE
\r
781 \ Store char at c-addr.
\r
783 \ $CODE NameCStore,CStore
\r
789 \ C@ ( c-addr -- char ) \ CORE
\r
790 \ Fetch the character stored at c-addr.
\r
792 \ $CODE NameCFetch,CFetch
\r
797 \ DROP ( x -- ) \ CORE
\r
798 \ Discard top stack item.
\r
800 \ $CODE NameDROP,DROP
\r
804 \ DUP ( x -- x x ) \ CORE
\r
805 \ Duplicate the top stack item.
\r
807 \ $CODE NameDUPP,DUPP
\r
811 \ EXECUTE ( i*x xt -- j*x ) \ CORE
\r
812 \ Perform the semantics indentified by execution token, xt.
\r
814 \ $CODE NameEXECUTE,EXECUTE
\r
817 \ JMP AX ;jump to the code address
\r
820 \ EXIT ( -- ) ( R: nest-sys -- ) \ CORE
\r
821 \ Return control to the calling definition.
\r
823 \ $CODE NameEXIT,EXIT
\r
824 \ XCHG BP,SP ;exchange pointers
\r
825 \ POP SI ;pop return stack
\r
826 \ XCHG BP,SP ;restore the pointers
\r
829 \ MOVE ( addr1 addr2 u -- ) \ CORE
\r
830 \ Copy u address units from addr1 to addr2 if u is greater
\r
831 \ than zero. This word is CODE defined since no other Standard
\r
832 \ words can handle address unit directly.
\r
834 \ $CODE NameMOVE,MOVE
\r
840 \ XCHG DX,SI ;save SI
\r
842 \ MOV ES,AX ;set ES same as DS
\r
860 \ OR ( x1 x2 -- x3 ) \ CORE
\r
861 \ Return bitwise inclusive-or of x1 with x2.
\r
863 \ $CODE NameORR,ORR
\r
868 \ OVER ( x1 x2 -- x1 x2 x1 ) \ CORE
\r
869 \ Copy second stack item to top of the stack.
\r
871 \ $CODE NameOVER,OVER
\r
877 \ R> ( -- x ) ( R: x -- ) \ CORE
\r
878 \ Move x from the return stack to the data stack.
\r
880 \ $CODE NameRFrom,RFrom
\r
883 \ ADD BP,CELLL ;adjust RP
\r
886 \ R@ ( -- x ) ( R: x -- x ) \ CORE
\r
887 \ Copy top of return stack to the data stack.
\r
889 \ $CODE NameRFetch,RFetch
\r
894 \ SWAP ( x1 x2 -- x2 x1 ) \ CORE
\r
895 \ Exchange top two stack items.
\r
897 \ $CODE NameSWAP,SWAP
\r
902 \ XOR ( x1 x2 -- x3 ) \ CORE
\r
903 \ Bitwise exclusive OR.
\r
905 \ $CODE NameXORR,XORR
\r
911 \ System constants and variables
\r
914 \ #order0 ( -- a-addr )
\r
915 \ Start address of default search order.
\r
917 \ $CONST NameNumberOrder0,NumberOrder0,AddrNumberOrder0
\r
919 \ 'ekey? ( -- a-addr )
\r
920 \ Execution vector of EKEY?.
\r
922 \ $VALUE NameTickEKEYQ,TickEKEYQ,AddrTickEKEYQ
\r
924 \ 'ekey ( -- a-addr )
\r
925 \ Execution vector of EKEY.
\r
927 \ $VALUE NameTickEKEY,TickEKEY,AddrTickEKEY
\r
929 \ 'emit? ( -- a-addr )
\r
930 \ Execution vector of EMIT?.
\r
932 \ $VALUE NameTickEMITQ,TickEMITQ,AddrTickEMITQ
\r
934 \ 'emit ( -- a-addr )
\r
935 \ Execution vector of EMIT.
\r
937 \ $VALUE NameTickEMIT,TickEMIT,AddrTickEMIT
\r
939 \ 'init-i/o ( -- a-addr )
\r
940 \ Execution vector to initialize input/output devices.
\r
942 \ $VALUE NameTickINIT_IO,TickINIT_IO,AddrTickINIT_IO
\r
944 \ 'prompt ( -- a-addr )
\r
945 \ Execution vector of '.prompt'.
\r
947 \ $VALUE NameTickPrompt,TickPrompt,AddrTickPrompt
\r
949 \ 'boot ( -- a-addr )
\r
950 \ Execution vector of COLD.
\r
952 \ $VALUE NameTickBoot,TickBoot,AddrTickBoot
\r
954 \ SOURCE-ID ( -- 0 | -1 ) \ CORE EXT
\r
955 \ Identify the input source. -1 for string (via EVALUATE) and
\r
956 \ 0 for user input device.
\r
958 \ $VALUE NameSOURCE_ID,SOURCE_ID,AddrSOURCE_ID
\r
960 \ HERE ( -- addr ) \ CORE
\r
961 \ Return data space pointer.
\r
963 \ $VALUE NameHERE,HERE,AddrHERE
\r
965 \ xhere ( -- code-addr )
\r
966 \ Return next available code space address.
\r
968 \ $VALUE NameXHere,XHere,AddrXHere
\r
970 \ 'doWord ( -- a-addr )
\r
971 \ Execution vectors for 'interpret'.
\r
973 \ $CONST NameTickDoWord,TickDoWord,AddrTickDoWord
\r
975 \ BASE ( -- a-addr ) \ CORE
\r
976 \ Return the address of the radix base for numeric I/O.
\r
978 \ $CONST NameBASE,BASE,AddrBASE
\r
980 \ THROWMsgTbl ( -- a-addr ) \ CORE
\r
981 \ Return the address of the THROW message table.
\r
983 \ $CONST NameTHROWMsgTbl,THROWMsgTbl,AddrTHROWMsgTbl
\r
985 \ memTop ( -- a-addr )
\r
986 \ Top of free memory.
\r
988 \ $VALUE NameMemTop,MemTop,AddrMemTop
\r
991 \ Return the depth of control-flow stack.
\r
993 \ $VALUE NameBal,Bal,AddrBal
\r
995 \ notNONAME? ( -- f )
\r
996 \ Used by ';' whether to do 'linkLast' or not
\r
998 \ $VALUE NameNotNONAMEQ,NotNONAMEQ,AddrNotNONAMEQ
\r
1000 \ rakeVar ( -- a-addr )
\r
1001 \ Used by 'rake' to gather LEAVE.
\r
1003 \ $CONST NameRakeVar,RakeVar,AddrRakeVar
\r
1005 \ #order ( -- a-addr )
\r
1006 \ Hold the search order stack depth.
\r
1008 \ $CONST NameNumberOrder,NumberOrder,AddrNumberOrder
\r
1010 \ current ( -- a-addr )
\r
1011 \ Point to the wordlist to be extended.
\r
1013 \ $CONST NameCurrent,Current,AddrCurrent
\r
1015 \ FORTH-WORDLIST ( -- wid ) \ SEARCH
\r
1016 \ Return wid of Forth wordlist.
\r
1018 \ $CONST NameFORTH_WORDLIST,FORTH_WORDLIST,AddrFORTH_WORDLIST
\r
1020 \ NONSTANDARD-WORDLIST ( -- wid )
\r
1021 \ Return wid of non-standard wordlist.
\r
1023 \ $CONST NameNONSTANDARD_WORDLIST,NONSTANDARD_WORDLIST,AddrNONSTANDARD_WORDLIST
\r
1025 \ envQList ( -- wid )
\r
1026 \ Return wid of ENVIRONMENT? string list. Never put this wid in
\r
1027 \ search-order. It should be used only by SET-CURRENT to add new
\r
1028 \ environment query string after addition of a complete wordset.
\r
1030 \ $CONST NameEnvQList,EnvQList,AddrEnvQList
\r
1032 \ userP ( -- a-addr )
\r
1033 \ Return address of USER variable area of current task.
\r
1035 \ $CONST NameUserP,UserP,AddrUserP
\r
1037 \ SystemTask ( -- a-addr )
\r
1038 \ Return system task's tid.
\r
1040 \ $CONST NameSystemTask,SystemTask,SysTask
\r
1042 \ follower ( -- a-addr )
\r
1043 \ Point next task's 'status' USER variable.
\r
1045 \ $USER NameFollower,Follower,SysFollower-SysUserP
\r
1047 \ status ( -- a-addr )
\r
1048 \ Status of current task. Point 'pass' or 'wake'.
\r
1050 \ $USER NameStatus,Status,SysStatus-SysUserP
\r
1052 \ stackTop ( -- a-addr )
\r
1053 \ Store current task's top of stack position.
\r
1055 \ $USER NameStackTop,StackTop,SysStackTop-SysUserP
\r
1057 \ throwFrame ( -- a-addr )
\r
1058 \ THROW frame for CATCH and THROW need to be saved for eack task.
\r
1060 \ $USER NameThrowFrame,ThrowFrame,SysThrowFrame-SysUserP
\r
1062 \ taskName ( -- a-addr )
\r
1063 \ Current task's task ID.
\r
1065 \ $USER NameTaskName,TaskName,SysTaskName-SysUserP
\r
1067 \ user1 ( -- a-addr )
\r
1068 \ One free USER variable for each task.
\r
1070 \ $USER NameUser1,User1,SysUser1-SysUserP
\r
1072 \ ENVIRONMENT? strings can be searched using SEARCH-WORDLIST and can be
\r
1073 \ EXECUTEd. This wordlist is completely hidden to Forth system except
\r
1079 \ DW DoLIT,CPUStr,COUNT,EXIT
\r
1084 \ DW DoLIT,ModelStr,COUNT,EXIT
\r
1089 \ DW DoLIT,VersionStr,COUNT,EXIT
\r
1091 \ SlashCOUNTED_STRING:
\r
1106 \ ADDRESS_UNIT_BITS:
\r
1124 \ DW MaxChar ;max value of character set
\r
1129 \ DW DoLIT,MaxUnsigned,DoLIT,MaxSigned,EXIT
\r
1144 \ DW MAX_U,MAX_U,EXIT
\r
1146 \ RETURN_STACK_CELLS:
\r
1172 \ Non-Standard words - Colon definitions
\r
1175 \ (') ( "<spaces>name" -- xt 1 | xt -1 )
\r
1176 \ Parse a name, find it and return execution token and
\r
1177 \ -1 or 1 ( IMMEDIATE) if found
\r
1179 : (') PARSE-WORD search-word ?DUP IF NIP EXIT THEN
\r
1180 errWord 2! \ if not found error
\r
1181 -13 THROW ; \ undefined word
\r
1183 \ $COLON NameParenTick,ParenTick
\r
1184 \ DW PARSE_WORD,Search_word,QuestionDUP,ZBranch,PTICK1
\r
1186 \ PTICK1 DW DoLIT,AddrErrWord,TwoStore,DoLIT,-13,THROW
\r
1188 \ (d.) ( d -- c-addr u )
\r
1189 \ Convert a double number to a string.
\r
1191 : (d.) SWAP OVER DUP 0< IF DNEGATE THEN
\r
1192 <# #S ROT SIGN #> ;
\r
1194 \ $COLON NameParenDDot,ParenDDot
\r
1195 \ DW SWAP,OVER,DUPP,ZeroLess,ZBranch,PARDD1
\r
1197 \ PARDD1 DW LessNumberSign,NumberSignS,ROT
\r
1198 \ DW SIGN,NumberSignGreater,EXIT
\r
1205 \ $COLON NameDotOK,DotOK
\r
1206 \ DW DoLIT,DotOKStr
\r
1207 \ DW COUNT,TYPEE,EXIT
\r
1210 \ Disply Forth prompt. This word is vectored.
\r
1212 : .prompt 'prompt EXECUTE ;
\r
1214 \ $COLON NameDotOK,DotPrompt
\r
1215 \ DW TickPrompt,EXECUTE,EXIT
\r
1220 \ $CONST NameZero,Zero,0
\r
1225 \ $CONST NameOne,One,1
\r
1230 \ $CONST NameMinusOne,MinusOne,-1
\r
1232 \ abort"msg ( -- a-addr )
\r
1233 \ Abort" error message string address.
\r
1235 \ $CONST NameAbortQMsg,AbortQMsg,AddrAbortQMsg
\r
1238 \ Increase bal by 1.
\r
1240 : bal+ bal 1+ TO bal ;
\r
1242 \ $COLON 4,'bal+',BalPlus,_SLINK
\r
1243 \ DW Bal,OnePlus,DoTO,AddrBal,EXIT
\r
1245 \ $CODE NameBalPlus,BalPlus
\r
1250 \ Decrease bal by 1.
\r
1252 : bal- bal 1- TO bal ;
\r
1254 \ $COLON NameBalMinus,BalMinus
\r
1255 \ DW Bal,OneMinus,DoTO,AddrBal,EXIT
\r
1257 \ $CODE NameBalMinus,BalMinus
\r
1261 \ cell- ( a-addr1 -- a-addr2 )
\r
1262 \ Return previous aligned cell address.
\r
1264 : cell- [ cell-size NEGATE ] LITERAL + ;
\r
1266 \ $COLON NameCellMinus,CellMinus
\r
1267 \ DW DoLIT,0-CELLL,Plus,EXIT
\r
1269 \ $CODE NameCellMinus,CellMinus
\r
1273 \ COMPILE-ONLY ( -- )
\r
1274 \ Make the most recent definition an compile-only word.
\r
1276 : COMPILE-ONLY lastName [ =compo ] LITERAL OVER @ OR SWAP ! ;
\r
1278 \ $COLON NameCOMPILE_ONLY,COMPILE_ONLY
\r
1279 \ DW LastName,DoLIT,COMPO,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
1281 \ doDO ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )
\r
1282 \ Run-time funtion of DO.
\r
1284 : doDO >R max-negative + R> OVER - SWAP R> SWAP >R SWAP >R >R ;
\r
1286 \ $COLON NameDoDO,DoDO
\r
1287 \ DW ToR,DoLIT,MaxNegative,Plus,RFrom
\r
1288 \ DW OVER,Minus,SWAP,RFrom,SWAP,ToR,SWAP,ToR,ToR,EXIT
\r
1290 \ $CODE NameDoDO,DoDO
\r
1293 \ ADD AX,MaxNegative
\r
1294 \ MOV [BP+CELLL],AX
\r
1300 \ errWord ( -- a-addr )
\r
1301 \ Last found word. To be used to display the word causing error.
\r
1303 \ $CONST NameErrWord,ErrWord,AddrErrWord
\r
1305 \ head, ( xt "<spaces>name" -- )
\r
1306 \ Parse a word and build a dictionary entry.
\r
1308 : head, >R PARSE-WORD DUP 0=
\r
1309 IF errWord 2! -16 THROW THEN
\r
1310 \ attempt to use zero-length string as a name
\r
1311 DUP =mask > IF -19 THROW THEN \ definition name too long
\r
1312 2DUP GET-CURRENT SEARCH-WORDLIST \ name exist?
\r
1313 IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined
\r
1314 ALIGN R@ , \ align and store xt
\r
1315 GET-CURRENT @ , \ build wordlist link
\r
1316 HERE DUP >R pack" ALIGNED TO HERE \ pack the name in name space
\r
1317 R> DUP R> cell- code! \ store name addr in code space
\r
1320 \ $COLON NameHeadComma,HeadComma
\r
1321 \ DW ToR,PARSE_WORD,DUPP,ZBranch,HEADC1
\r
1322 \ DW DUPP,DoLIT,MASKK,GreaterThan,ZBranch,HEADC3
\r
1323 \ DW DoLIT,-19,THROW
\r
1324 \ HEADC3 DW TwoDUP,GET_CURRENT,SEARCH_WORDLIST,ZBranch,HEADC2
\r
1326 \ DW DoLIT,HEADCstr
\r
1327 \ DW COUNT,TYPEE,TwoDUP,TYPEE,SPACE
\r
1328 \ HEADC2 DW ALIGNN,RFetch,Comma
\r
1329 \ DW GET_CURRENT,Fetch,Comma
\r
1330 \ DW HERE,DUPP,ToR,PackQuote,ALIGNED,DoTO,AddrHERE
\r
1331 \ DW RFrom,DUPP,RFrom,CellMinus,CodeStore
\r
1332 \ DW DoTO,AddrLastName,EXIT
\r
1333 \ HEADC1 DW DoLIT,AddrErrWord,TwoStore,DoLIT,-16,THROW
\r
1335 \ hld ( -- a-addr )
\r
1336 \ Hold a pointer in building a numeric output string.
\r
1338 \ $CONST NameHLD,HLD,AddrHLD
\r
1340 \ interpret ( i*x -- j*x )
\r
1341 \ Intrepret input string.
\r
1343 : interpret BEGIN DEPTH 0< IF -4 THROW THEN \ stack underflow
\r
1345 WHILE 2DUP errWord 2!
\r
1346 search-word \ ca u 0 | xt f -1 | xt f 1
\r
1348 SWAP STATE @ OR 0= \ compile-only in interpretation
\r
1349 IF -14 THROW THEN \ interpreting a compile-only word
\r
1351 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE
\r
1354 \ $COLON NameInterpret,Interpret
\r
1355 \ INTERP1 DW DEPTH,ZeroLess,ZBranch,INTERP2
\r
1356 \ DW DoLIT,-4,THROW
\r
1357 \ INTERP2 DW PARSE_WORD,DUPP,ZBranch,INTERP3
\r
1358 \ DW TwoDUP,DoLIT,AddrErrWord,TwoStore
\r
1359 \ DW Search_word,DUPP,ZBranch,INTERP5
\r
1360 \ DW SWAP,DoLIT,AddrSTATE,Fetch,ORR,ZBranch,INTERP4
\r
1361 \ INTERP5 DW OnePlus,TwoStar,DoLIT,AddrSTATE,Fetch,OnePlus,Plus,CELLS
\r
1362 \ DW DoLIT,AddrTickDoWord,Plus,Fetch,EXECUTE
\r
1363 \ DW Branch,INTERP1
\r
1364 \ INTERP3 DW TwoDROP,EXIT
\r
1365 \ INTERP4 DW DoLIT,-14,THROW
\r
1367 \ optiCOMPILE, ( xt -- )
\r
1368 \ Optimized COMPILE, . Reduce doLIST ... EXIT sequence if
\r
1369 \ xt is COLON definition which contains less than two words.
\r
1372 DUP ?call ['] doLIST = IF
\r
1373 DUP code@ ['] EXIT = IF \ if first word is EXIT
\r
1375 DUP CELL+ code@ ['] EXIT = IF \ if second word is EXIT
\r
1376 code@ DUP ['] doLIT XOR \ make sure it is not literal
\r
1378 THEN DROP COMPILE, ;
\r
1380 \ $COLON NameOptiCOMPILEComma,OptiCOMPILEComma
\r
1381 \ DW DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2
\r
1382 \ DW DUPP,CodeFetch,DoLIT,EXIT,Equals,ZBranch,OPTC1
\r
1384 \ OPTC1 DW DUPP,CELLPlus,CodeFetch,DoLIT,EXIT,Equals
\r
1385 \ DW ZBranch,OPTC2
\r
1386 \ DW CodeFetch,DUPP,DoLIT,DoLIT,XORR,ZBranch,OPTC2
\r
1388 \ OPTC2 DW DROP,COMPILEComma,EXIT
\r
1390 \ $CODE NameOptiCOMPILEComma,OptiCOMPILEComma
\r
1391 \ CMP WORD PTR CS:[BX],CALLL
\r
1393 \ MOV AX,CS:[BX+CELLL]
\r
1396 \ CMP AX,OFFSET DoLIST
\r
1398 \ MOV DX,OFFSET EXIT
\r
1399 \ MOV AX,CS:[BX+2*CELLL]
\r
1402 \ CMP DX,CS:[BX+3*CELLL]
\r
1404 \ CMP AX,OFFSET DoLIT
\r
1407 \ OPTC1: JMP COMPILEComma
\r
1411 \ singleOnly ( c-addr u -- x )
\r
1412 \ Handle the word not found in the search-order. If the string
\r
1413 \ is legal, leave a single cell number in interpretation state.
\r
1416 0 DUP 2SWAP OVER C@ [CHAR] -
\r
1417 = DUP >R IF 1 /STRING THEN
\r
1418 >NUMBER IF -13 THROW THEN \ undefined word
\r
1419 2DROP R> IF NEGATE THEN ;
\r
1421 \ $COLON NameSingleOnly,SingleOnly
\r
1422 \ DW DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\r
1423 \ DW Equals,DUPP,ToR,ZBranch,SINGLEO4
\r
1424 \ DW DoLIT,1,SlashSTRING
\r
1425 \ SINGLEO4 DW ToNUMBER,ZBranch,SINGLEO1
\r
1426 \ DW DoLIT,-13,THROW
\r
1427 \ SINGLEO1 DW TwoDROP,RFrom,ZBranch,SINGLEO2
\r
1429 \ SINGLEO2 DW EXIT
\r
1430 \ singleOnly, ( c-addr u -- )
\r
1431 \ Handle the word not found in the search-order. Compile a
\r
1432 \ single cell number in compilation state.
\r
1435 singleOnly POSTPONE LITERAL ;
\r
1437 \ $COLON NameSingleOnlyComma,SingleOnlyComma
\r
1438 \ DW SingleOnly,LITERAL,EXIT
\r
1440 \ (doubleAlso) ( c-addr u -- x 1 | x x 2 )
\r
1441 \ If the string is legal, leave a single or double cell number
\r
1442 \ and size of the number.
\r
1445 0 DUP 2SWAP OVER C@ [CHAR] -
\r
1446 = DUP >R IF 1 /STRING THEN
\r
1448 IF 1- IF -13 THROW THEN \ more than one char is remained
\r
1449 DUP C@ [CHAR] . XOR \ last char is not '.'
\r
1450 IF -13 THROW THEN \ undefined word
\r
1451 R> IF DNEGATE THEN
\r
1453 2DROP R> IF NEGATE THEN \ single number
\r
1456 \ $COLON NameParenDoubleAlso,ParenDoubleAlso
\r
1457 \ DW DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\r
1458 \ DW Equals,DUPP,ToR,ZBranch,DOUBLEA1
\r
1459 \ DW DoLIT,1,SlashSTRING
\r
1460 \ DOUBLEA1 DW ToNUMBER,QuestionDUP,ZBranch,DOUBLEA4
\r
1461 \ DW OneMinus,ZBranch,DOUBLEA3
\r
1462 \ DOUBLEA2 DW DoLIT,-13,THROW
\r
1463 \ DOUBLEA3 DW CFetch,DoLIT,'.',Equals,ZBranch,DOUBLEA2
\r
1464 \ DW RFrom,ZBranch,DOUBLEA5
\r
1466 \ DOUBLEA5 DW DoLIT,2,EXIT
\r
1467 \ DOUBLEA4 DW TwoDROP,RFrom,ZBranch,DOUBLEA6
\r
1469 \ DOUBLEA6 DW DoLIT,1,EXIT
\r
1471 \ doubleAlso ( c-addr u -- x | x x )
\r
1472 \ Handle the word not found in the search-order. If the string
\r
1473 \ is legal, leave a single or double cell number in
\r
1474 \ interpretation state.
\r
1477 (doubleAlso) DROP ;
\r
1479 \ $COLON NameDoubleAlso,DoubleAlso
\r
1480 \ DW ParenDoubleAlso,DROP,EXIT
\r
1482 \ doubleAlso, ( c-addr u -- )
\r
1483 \ Handle the word not found in the search-order. If the string
\r
1484 \ is legal, compile a single or double cell number in
\r
1485 \ compilation state.
\r
1488 (doubleAlso) 1- IF SWAP POSTPONE LITERAL THEN POSTPONE LITERAL ;
\r
1490 \ $COLON NameDoubleAlsoComma,DoubleAlsoComma
\r
1491 \ DW ParenDoubleAlso,OneMinus,ZBranch,DOUBC1
\r
1493 \ DOUBC1 DW LITERAL,EXIT
\r
1496 \ You don't need this word unless you care that '-.' returns
\r
1497 \ double cell number 0. Catching illegal number '-.' in this way
\r
1498 \ is easier than make 'interpret' catch this exception.
\r
1500 : -. -13 THROW ; IMMEDIATE \ undefined word
\r
1502 \ $COLON NameMinusDot,MinusDot
\r
1503 \ DW DoLIT,-13,THROW
\r
1505 \ lastName ( -- c-addr )
\r
1506 \ Return the address of the last definition name.
\r
1508 \ $VALUE NameLastName,LastName,AddrLastName
\r
1511 \ Link the word being defined to the current wordlist.
\r
1512 \ Do nothing if the last definition is made by :NONAME .
\r
1514 : linkLast lastName GET-CURRENT ! ;
\r
1516 \ $COLON NameLinkLast,LinkLast
\r
1517 \ DW LastName,GET_CURRENT,Store,EXIT
\r
1519 \ $CODE NameLinkLast,LinkLast
\r
1520 \ MOV AX,AddrLastName
\r
1521 \ MOV DI,AddrCurrent
\r
1525 \ name>xt ( c-addr -- xt )
\r
1526 \ Return execution token using counted string at c-addr.
\r
1528 : name>xt cell- cell- @ ;
\r
1530 \ $COLON NameNameToXT,NameToXT
\r
1531 \ DW CellMinus,CellMinus,Fetch,EXIT
\r
1533 \ $CODE NameNameToXT,NameToXT
\r
1534 \ MOV BX,[BX-2*CELLL]
\r
1537 \ pack" ( c-addr u a-addr -- a-addr2 )
\r
1538 \ Place a string c-addr u at a-addr and gives the next
\r
1539 \ cell-aligned address. Fill the rest of the last cell with
\r
1542 : pack" 2DUP SWAP CHARS + CHAR+ DUP >R \ ca u aa aa+u+1
\r
1543 ALIGNED cell- 0 SWAP ! \ fill 0 at the end of string
\r
1544 2DUP C! CHAR+ SWAP \ c-addr a-addr+1 u
\r
1545 CHARS MOVE R> ALIGNED ;
\r
1547 \ $COLON 5,'pack"',PackQuote,_SLINK
\r
1548 \ DW TwoDUP,SWAP,CHARS,Plus,CHARPlus,DUPP,ToR
\r
1549 \ DW ALIGNED,CellMinus,Zero,SWAP,Store
\r
1550 \ DW TwoDUP,CStore,CHARPlus,SWAP
\r
1551 \ DW CHARS,MOVE,RFrom,ALIGNED,EXIT
\r
1553 \ $CODE NamePackQuote,PackQuote
\r
1560 \ MOV BYTE PTR [DI],CL
\r
1563 \ TEST DI,1 ;odd address?
\r
1565 \ MOV BYTE PTR [DI],0
\r
1567 \ PACKQ2: MOV BX,DI
\r
1571 \ PARSE-WORD ( "<spaces>ccc<space>" -- c-addr u )
\r
1572 \ Skip leading spaces and parse a word. Return the name.
\r
1574 : PARSE-WORD BL skipPARSE ;
\r
1576 \ $COLON NamePARSE_WORD,PARSE_WORD
\r
1577 \ DW DoLIT,' ',SkipPARSE,EXIT
\r
1579 \ $CODE NamePARSE_WORD,PARSE_WORD
\r
1585 \ pipe ( -- ) ( R: xt -- )
\r
1586 \ Connect most recently defined word to code following DOES>.
\r
1587 \ Structure of CREATEd word:
\r
1588 \ |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |
\r
1590 : pipe lastName name>xt ?call DUP IF \ code-addr xt2
\r
1592 R> SWAP code! \ change DOES> code of CREATEd word
\r
1595 -32 THROW \ invalid name argument, no-CREATEd last name
\r
1598 \ $COLON NamePipe,Pipe
\r
1599 \ DW LastName,NameToXT,QCall,DUPP,ZBranch,PIPE1
\r
1600 \ DW DoLIT,DoCREATE,Equals,ZBranch,PIPE1
\r
1601 \ DW RFrom,SWAP,CodeStore,EXIT
\r
1602 \ PIPE1 DW DoLIT,-32,THROW
\r
1604 \ skipPARSE ( char "<chars>ccc<char>" -- c-addr u )
\r
1605 \ Skip leading chars and parse a word using char as a
\r
1606 \ delimeter. Return the name.
\r
1609 >R SOURCE >IN @ /STRING \ c_addr u R: char
\r
1611 BEGIN OVER C@ R@ =
\r
1612 WHILE 1- SWAP CHAR+ SWAP DUP 0=
\r
1613 UNTIL R> DROP EXIT
\r
1615 DROP SOURCE DROP - 1chars/ >IN ! R> PARSE EXIT
\r
1618 \ $COLON NameSkipPARSE,SkipPARSE
\r
1619 \ DW ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING
\r
1620 \ DW DUPP,ZBranch,SKPAR1
\r
1621 \ SKPAR2 DW OVER,CFetch,RFetch,Equals,ZBranch,SKPAR3
\r
1622 \ DW OneMinus,SWAP,CHARPlus,SWAP
\r
1623 \ DW DUPP,ZeroEquals,ZBranch,SKPAR2
\r
1624 \ DW RFrom,DROP,EXIT
\r
1625 \ SKPAR3 DW DROP,SOURCE,DROP,Minus,OneCharsSlash
\r
1626 \ DW DoLIT,AddrToIN,Store,RFrom,PARSE,EXIT
\r
1627 \ SKPAR1 DW RFrom,DROP,EXIT
\r
1629 \ $CODE NameSkipPARSE,SkipPARSE
\r
1632 \ MOV SI,AddrSourceVar+CELLL
\r
1633 \ MOV BX,AddrSourceVar
\r
1646 \ MOV AX,AddrSourceVar
\r
1652 \ SUB SI,AddrSourceVar+CELLL
\r
1660 \ specialComp? ( -- xt|0 )
\r
1661 \ Return xt for special compilation semantics of the last found
\r
1662 \ word. Return 0 if there is no special compilation action.
\r
1664 \ $VALUE NameSpecialCompQ,SpecialCompQ,AddrSpecialCompQ
\r
1666 \ rake ( C: do-sys -- )
\r
1669 : rake DUP code, rakeVar @
\r
1671 WHILE DUP code@ xhere ROT code!
\r
1672 REPEAT rakeVar ! DROP
\r
1673 ?DUP IF \ check for ?DO
\r
1674 1 bal+ POSTPONE THEN \ orig type is 1
\r
1675 THEN bal- ; COMPILE-ONLY
\r
1677 \ $COLON Namerake,rake
\r
1678 \ DW DUPP,CodeComma,DoLIT,AddrRakeVar,Fetch
\r
1679 \ RAKE1 DW TwoDUP,ULess,ZBranch,RAKE2
\r
1680 \ DW DUPP,CodeFetch,XHere,ROT,CodeStore,Branch,RAKE1
\r
1681 \ RAKE2 DW DoLIT,AddrRakeVar,Store,DROP
\r
1682 \ DW QuestionDUP,ZBranch,RAKE3
\r
1683 \ DW One,BalPlus,THENN
\r
1684 \ RAKE3 DW BalMinus,EXIT
\r
1686 \ rp0 ( -- a-addr )
\r
1687 \ Pointer to bottom of the return stack.
\r
1689 : rp0 userP @ CELL+ CELL+ @ ;
\r
1691 \ $COLON NameRPZero,RPZero
\r
1692 \ DW DoLIT,AddrUserP,Fetch,CELLPlus,CELLPlus,Fetch,EXIT
\r
1694 \ search-word ( c-addr u -- c-addr u 0 | xt f 1 | xt f -1)
\r
1695 \ Search dictionary for a match with the given name. Return
\r
1696 \ execution token, not-compile-only flag and -1 or 1
\r
1697 \ ( IMMEDIATE) if found; c-addr u 0 if not.
\r
1700 #order @ DUP \ not found if #order is 0
\r
1702 DO 2DUP \ ca u ca u
\r
1703 I CELLS #order CELL+ + @ \ ca u ca u wid
\r
1704 (search-wordlist) \ ca u; 0 | w f 1 | w f -1
\r
1705 ?DUP IF \ ca u; 0 | w f 1 | w f -1
\r
1706 >R 2SWAP 2DROP R> UNLOOP EXIT \ xt f 1 | xt f -1
\r
1711 \ $COLON NameSearch_word,Search_word
\r
1712 \ DW NumberOrder,Fetch,DUPP,ZBranch,SEARCH1
\r
1714 \ SEARCH2 DW TwoDUP,I,CELLS,NumberOrder,CELLPlus,Plus,Fetch
\r
1715 \ DW ParenSearch_Wordlist,QuestionDUP,ZBranch,SEARCH3
\r
1716 \ DW ToR,TwoSWAP,TwoDROP,RFrom,UNLOOP,EXIT
\r
1717 \ SEARCH3 DW DoLOOP,SEARCH2
\r
1721 \ sourceVar ( -- a-addr )
\r
1722 \ Hold the current count and address of the terminal input buffer.
\r
1724 \ $CONST NameSourceVar,SourceVar,AddrSourceVar
\r
1726 \ sp0 ( -- a-addr )
\r
1727 \ Pointer to bottom of the data stack.
\r
1729 : sp0 userP @ CELL+ @ ;
\r
1731 \ $COLON NameSPZero,SPZero
\r
1732 \ DW DoLIT,AddrUserP,Fetch,CELLPlus,Fetch,EXIT
\r
1735 \ Essential Standard words - Colon definitions
\r
1738 \ # ( ud1 -- ud2 ) \ CORE
\r
1739 \ Extract one digit from ud1 and append the digit to
\r
1740 \ pictured numeric output string. ( ud2 = ud1 / BASE )
\r
1742 : # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP
\r
1743 9 OVER < [ CHAR A CHAR 9 1 + - ] LITERAL AND +
\r
1744 [ CHAR 0 ] LITERAL + HOLD R> ;
\r
1746 \ $COLON NameNumberSign,NumberSign
\r
1747 \ DW DoLIT,0,DoLITFetch,AddrBASE,UMSlashMOD,ToR
\r
1748 \ DW DoLITFetch,AddrBASE,UMSlashMOD,SWAP
\r
1749 \ DW DoLIT,9,OVER,LessThan,DoLIT,'A'-'9'-1,ANDD,Plus
\r
1750 \ DW DoLIT,'0',Plus,HOLD,RFrom,EXIT
\r
1752 \ $CODE NameNumberSign,NumberSign
\r
1756 \ DIV CX ;0:TOS / BASE
\r
1757 \ MOV BX,AX ;quotient
\r
1760 \ PUSH AX ;BX:AX = ud2
\r
1764 \ ADD AL,'A'-'9'-1
\r
1765 \ NUMSN1: ADD AL,'0'
\r
1772 \ #> ( xd -- c-addr u ) \ CORE
\r
1773 \ Prepare the output string to be TYPE'd.
\r
1774 \ ||HERE>WORD/#-work-area|
\r
1776 : #> 2DROP hld @ HERE size-of-PAD + OVER - 1chars/ ;
\r
1778 \ $COLON NameNumberSignGreater,NumberSignGreater
\r
1779 \ DW TwoDROP,DoLIT,AddrHLD,Fetch,HERE,DoLIT,PADSize*CHARR,Plus
\r
1780 \ DW OVER,Minus,OneCharsSlash,EXIT
\r
1782 \ #S ( ud -- 0 0 ) \ CORE
\r
1783 \ Convert ud until all digits are added to the output string.
\r
1785 : #S BEGIN # 2DUP OR 0= UNTIL ;
\r
1787 \ $COLON NameNumberSignS,NumberSignS
\r
1788 \ NUMSS1 DW NumberSign,TwoDUP,ORR
\r
1789 \ DW ZeroEquals,ZBranch,NUMSS1
\r
1792 \ ' ( "<spaces>name" -- xt ) \ CORE
\r
1793 \ Parse a name, find it and return xt.
\r
1797 \ $COLON NameTick,Tick
\r
1798 \ DW ParenTick,DROP,EXIT
\r
1800 \ + ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
1801 \ Add top two items and gives the sum.
\r
1805 \ $COLON NamePlus,Plus
\r
1806 \ DW UMPlus,DROP,EXIT
\r
1808 \ $CODE NamePlus,Plus
\r
1813 \ +! ( n|u a-addr -- ) \ CORE
\r
1814 \ Add n|u to the contents at a-addr.
\r
1816 : +! SWAP OVER @ + SWAP ! ;
\r
1818 \ $COLON NamePlusStore,PlusStore
\r
1819 \ DW SWAP,OVER,Fetch,Plus
\r
1820 \ DW SWAP,Store,EXIT
\r
1822 \ $CODE NamePlusStore,PlusStore
\r
1828 \ , ( x -- ) \ CORE
\r
1829 \ Reserve one cell in data space and store x in it.
\r
1831 : , HERE ! HERE CELL+ TO HERE ;
\r
1833 \ $COLON NameComma,Comma
\r
1834 \ DW HERE,Store,HERE,CELLPlus,DoTO,AddrHERE,EXIT
\r
1836 \ $CODE NameComma,Comma
\r
1844 \ - ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
1845 \ Subtract n2|u2 from n1|u1, giving the difference n3|u3.
\r
1849 \ $COLON NameMinus,Minus
\r
1850 \ DW NEGATE,Plus,EXIT
\r
1852 \ $CODE NameMinus,Minus
\r
1858 \ . ( n -- ) \ CORE
\r
1859 \ Display a signed number followed by a space.
\r
1863 \ $COLON NameDot,Dot
\r
1864 \ DW SToD,DDot,EXIT
\r
1866 \ / ( n1 n2 -- n3 ) \ CORE
\r
1867 \ Divide n1 by n2, giving single-cell quotient n3.
\r
1871 \ $COLON NameSlash,Slash
\r
1872 \ DW SlashMOD,NIP,EXIT
\r
1874 \ /MOD ( n1 n2 -- n3 n4 ) \ CORE
\r
1875 \ Divide n1 by n2, giving single-cell remainder n3 and
\r
1876 \ single-cell quotient n4.
\r
1878 : /MOD >R S>D R> FM/MOD ;
\r
1880 \ $COLON NameSlashMOD,SlashMOD
\r
1881 \ DW ToR,SToD,RFrom,FMSlashMOD,EXIT
\r
1883 \ $CODE NameSlashMOD,SlashMOD
\r
1891 \ /STRING ( c-addr1 u1 n -- c-addr2 u2 ) \ STRING
\r
1892 \ Adjust the char string at c-addr1 by n chars.
\r
1894 : /STRING DUP >R - SWAP R> CHARS + SWAP ;
\r
1896 \ $COLON NameSlashSTRING,SlashSTRING
\r
1897 \ DW DUPP,ToR,Minus,SWAP,RFrom,CHARS,Plus,SWAP,EXIT
\r
1899 \ $CODE NameSlashSTRING,SlashSTRING
\r
1908 \ 1+ ( n1|u1 -- n2|u2 ) \ CORE
\r
1909 \ Increase top of the stack item by 1.
\r
1913 \ $COLON NameOnePlus,OnePlus
\r
1914 \ DW DoLIT,1,Plus,EXIT
\r
1916 \ $CODE NameOnePlus,OnePlus
\r
1920 \ 1- ( n1|u1 -- n2|u2 ) \ CORE
\r
1921 \ Decrease top of the stack item by 1.
\r
1925 \ $COLON NameOneMinus,OneMinus
\r
1926 \ DW DoLIT,-1,Plus,EXIT
\r
1928 \ $CODE NameOneMinus,OneMinus
\r
1932 \ 2! ( x1 x2 a-addr -- ) \ CORE
\r
1933 \ Store the cell pare x1 x2 at a-addr, with x2 at a-addr and
\r
1934 \ x1 at the next consecutive cell.
\r
1936 : 2! SWAP OVER ! CELL+ ! ;
\r
1938 \ $COLON NameTwoStore,TwoStore
\r
1939 \ DW SWAP,OVER,Store,CELLPlus,Store,EXIT
\r
1941 \ $CODE NameTwoStore,TwoStore
\r
1947 \ 2@ ( a-addr -- x1 x2 ) \ CORE
\r
1948 \ Fetch the cell pair stored at a-addr. x2 is stored at a-addr
\r
1949 \ and x1 at the next consecutive cell.
\r
1951 : 2@ DUP CELL+ @ SWAP @ ;
\r
1953 \ $COLON NameTwoFetch,TwoFetch
\r
1954 \ DW DUPP,CELLPlus,Fetch,SWAP,Fetch,EXIT
\r
1956 \ $CODE NameTwoFetch,TwoFetch
\r
1961 \ 2DROP ( x1 x2 -- ) \ CORE
\r
1962 \ Drop cell pair x1 x2 from the stack.
\r
1964 : 2DROP DROP DROP ;
\r
1966 \ $COLON NameTwoDROP,TwoDROP
\r
1967 \ DW DROP,DROP,EXIT
\r
1969 \ $CODE NameTwoDROP,TwoDROP
\r
1974 \ 2DUP ( x1 x2 -- x1 x2 x1 x2 ) \ CORE
\r
1975 \ Duplicate cell pair x1 x2.
\r
1977 : 2DUP OVER OVER ;
\r
1979 \ $COLON NameTwoDUP,TwoDUP
\r
1980 \ DW OVER,OVER,EXIT
\r
1982 \ $CODE NameTwoDUP,TwoDUP
\r
1988 \ 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) \ CORE
\r
1989 \ Exchange the top two cell pairs.
\r
1991 : 2SWAP ROT >R ROT R> ;
\r
1993 \ $COLON NameTwoSWAP,TwoSWAP
\r
1994 \ DW ROT,ToR,ROT,RFrom,EXIT
\r
1996 \ $CODE NameTwoSWAP,TwoSWAP
\r
2006 \ : ( "<spaces>name" -- colon-sys ) \ CORE
\r
2007 \ Start a new colon definition using next word as its name.
\r
2009 : : xhere ALIGNED CELL+ TO xhere \ reserve a cell for name pointer
\r
2010 :NONAME ROT head, -1 TO notNONAME? ;
\r
2012 \ $COLON NameCOLON,COLON
\r
2013 \ DW XHere,ALIGNED,CELLPlus,DoTO,AddrXHere
\r
2014 \ DW ColonNONAME,ROT,HeadComma
\r
2015 \ DW DoLIT,-1,DoTO,AddrNotNONAMEQ,EXIT
\r
2017 \ :NONAME ( -- xt colon-sys ) \ CORE EXT
\r
2018 \ Create an execution token xt, enter compilation state and
\r
2019 \ start the current definition.
\r
2021 : :NONAME bal IF -29 THROW THEN \ compiler nesting
\r
2022 ['] doLIST xt, DUP -1
\r
2023 0 TO notNONAME? 1 TO bal ] ;
\r
2026 \ $COLON NameColonNONAME,ColonNONAME
\r
2027 \ DW Bal,ZBranch,NONAME1
\r
2028 \ DW DoLIT,-29,THROW
\r
2029 \ NONAME1 DW DoLIT,DoLIST,xtComma,DUPP,DoLIT,-1
\r
2030 \ DW DoLIT,0,DoTO,AddrNotNONAMEQ
\r
2031 \ DW One,DoTO,AddrBal,RightBracket,EXIT
\r
2033 \ ; ( colon-sys -- ) \ CORE
\r
2034 \ Terminate a colon definition.
\r
2036 : ; bal 1- IF -22 THROW THEN \ control structure mismatch
\r
2037 NIP 1+ IF -22 THROW THEN \ colon-sys type is -1
\r
2038 notNONAME? IF \ if the last definition is not created by ':'
\r
2039 linkLast 0 TO notNONAME? \ link the word to wordlist
\r
2040 THEN POSTPONE EXIT \ add EXIT at the end of the definition
\r
2041 0 TO bal POSTPONE [ ; COMPILE-ONLY IMMEDIATE
\r
2043 \ $COLON NameSemicolon,Semicolon
\r
2044 \ DW Bal,OneMinus,ZBranch,SEMI1
\r
2045 \ DW DoLIT,-22,THROW
\r
2046 \ SEMI1 DW NIP,OnePlus,ZBranch,SEMI2
\r
2047 \ DW DoLIT,-22,THROW
\r
2048 \ SEMI2 DW NotNONAMEQ,ZBranch,SEMI3
\r
2049 \ DW LinkLast,DoLIT,0,DoTO,AddrNotNONAMEQ
\r
2050 \ SEMI3 DW DoLIT,EXIT,COMPILEComma
\r
2051 \ DW DoLIT,0,DoTO,AddrBal,LeftBracket,EXIT
\r
2053 \ < ( n1 n2 -- flag ) \ CORE
\r
2054 \ Returns true if n1 is less than n2.
\r
2056 : < 2DUP XOR 0< \ same sign?
\r
2057 IF DROP 0< EXIT THEN \ different signs, true if n1 <0
\r
2058 - 0< ; \ same signs, true if n1-n2 <0
\r
2060 \ $COLON NameLessThan,LessThan
\r
2061 \ DW TwoDUP,XORR,ZeroLess,ZBranch,LESS1
\r
2062 \ DW DROP,ZeroLess,EXIT
\r
2063 \ LESS1 DW Minus,ZeroLess,EXIT
\r
2065 \ $CODE NameLessThan,LessThan
\r
2073 \ <# ( -- ) \ CORE
\r
2074 \ Initiate the numeric output conversion process.
\r
2075 \ ||HERE>WORD/#-work-area|
\r
2077 : <# HERE size-of-PAD + hld ! ;
\r
2079 \ $COLON NameLessNumberSign,LessNumberSign
\r
2080 \ DW HERE,DoLIT,PADSize*CHARR,Plus,DoLIT,AddrHLD,Store,EXIT
\r
2082 \ = ( x1 x2 -- flag ) \ CORE
\r
2083 \ Return true if top two are equal.
\r
2087 \ $COLON NameEquals,Equals
\r
2088 \ DW XORR,ZeroEquals,EXIT
\r
2090 \ $CODE NameEquals,Equals
\r
2098 \ > ( n1 n2 -- flag ) \ CORE
\r
2099 \ Returns true if n1 is greater than n2.
\r
2103 \ $COLON NameGreaterThan,GreaterThan
\r
2104 \ DW SWAP,LessThan,EXIT
\r
2106 \ $CODE NameGreaterThan,GreaterThan
\r
2114 \ >IN ( -- a-addr )
\r
2115 \ Hold the character pointer while parsing input stream.
\r
2117 \ $CONST NameToIN,ToIN,AddrToIN
\r
2119 \ >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ CORE
\r
2120 \ Add number string's value to ud1. Leaves string of any
\r
2121 \ unconverted chars.
\r
2123 : >NUMBER BEGIN DUP
\r
2124 WHILE >R DUP >R C@ \ ud char R: u c-addr
\r
2125 DUP [ CHAR 9 1+ ] LITERAL [CHAR] A WITHIN
\r
2126 IF DROP R> R> EXIT THEN
\r
2127 [ CHAR 0 ] LITERAL - 9 OVER <
\r
2128 [ CHAR A CHAR 9 1 + - ] LITERAL AND -
\r
2129 DUP 0 BASE @ WITHIN
\r
2130 WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> R> 1 /STRING
\r
2134 \ $COLON NameToNUMBER,ToNUMBER
\r
2135 \ TONUM1 DW DUPP,ZBranch,TONUM3
\r
2136 \ DW ToR,DUPP,ToR,CFetch,DUPP
\r
2137 \ DW DoLIT,'9'+1,DoLIT,'A',WITHIN,ZeroEquals,ZBranch,TONUM2
\r
2138 \ DW DoLIT,'0',Minus,DoLIT,9,OVER,LessThan
\r
2139 \ DW DoLIT,'A'-'9'-1,ANDD,Minus,DUPP
\r
2140 \ DW DoLIT,0,DoLIT,AddrBASE,Fetch,WITHIN,ZBranch,TONUM2
\r
2141 \ DW SWAP,DoLIT,AddrBASE,Fetch,UMStar,DROP,ROT,DoLIT,AddrBASE,Fetch
\r
2142 \ DW UMStar,DPlus,RFrom,RFrom,DoLIT,1,SlashSTRING
\r
2143 \ DW Branch,TONUM1
\r
2144 \ TONUM2 DW DROP,RFrom,RFrom
\r
2147 \ $CODE NameToNUMBER,ToNUMBER
\r
2149 \ TONUM4: OR BX,BX
\r
2154 \ JS TONUM2 ;not valid digit
\r
2158 \ JL TONUM2 ;not valid digit
\r
2159 \ SUB CX,'A'-'9'-1
\r
2160 \ TONUM3: CMP CX,AddrBASE
\r
2161 \ JGE TONUM2 ;not valid digit
\r
2179 \ ?DUP ( x -- x x | 0 ) \ CORE
\r
2180 \ Duplicate top of the stack if it is not zero.
\r
2182 : ?DUP DUP IF DUP THEN ;
\r
2184 \ $COLON NameQuestionDUP,QuestionDUP
\r
2185 \ DW DUPP,ZBranch,QDUP1
\r
2189 \ $CODE NameQuestionDUP,QuestionDUP
\r
2195 \ ABORT ( i*x -- ) ( R: j*x -- ) \ EXCEPTION EXT
\r
2196 \ Reset data stack and jump to QUIT.
\r
2198 : ABORT -1 THROW ;
\r
2200 \ $COLON NameABORT,ABORT
\r
2201 \ DW DoLIT,-1,THROW
\r
2203 \ ACCEPT ( c-addr +n1 -- +n2 ) \ CORE
\r
2204 \ Accept a string of up to +n1 chars. Return with actual count.
\r
2205 \ Implementation-defined editing. Stops at EOL# .
\r
2206 \ Supports backspace and delete editing.
\r
2209 BEGIN DUP R@ < \ ca n2 f R: n1
\r
2210 WHILE EKEY max-char AND
\r
2212 IF DUP cr# = IF ROT 2DROP R> DROP EXIT THEN
\r
2214 IF DROP 2DUP + BL DUP EMIT SWAP C! 1+
\r
2218 \ discard the last char if not 1st char
\r
2219 IF 1- bsp# EMIT BL EMIT bsp# EMIT THEN THEN
\r
2221 ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+ \ Nick THEN
\r
2223 REPEAT SWAP R> 2DROP ;
\r
2225 \ $COLON NameACCEPT,ACCEPT
\r
2227 \ ACCPT1 DW DUPP,RFetch,LessThan,ZBranch,ACCPT5
\r
2228 \ DW EKEY,DoLIT,MaxChar,ANDD
\r
2229 \ DW DUPP,DoLIT,' ',LessThan,ZBranch,ACCPT3
\r
2230 \ DW DUPP,DoLIT,CRR,Equals,ZBranch,ACCPT4
\r
2231 \ DW ROT,TwoDROP,RFrom,DROP,EXIT
\r
2232 \ ACCPT4 DW DUPP,DoLIT,TABB,Equals,ZBranch,ACCPT6
\r
2233 \ DW DROP,TwoDUP,Plus,DoLIT,' ',DUPP,EMIT,SWAP,CStore,OnePlus
\r
2234 \ DW Branch,ACCPT1
\r
2235 \ ACCPT6 DW DUPP,DoLIT,BKSPP,Equals
\r
2236 \ DW SWAP,DoLIT,DEL,Equals,ORR,ZBranch,ACCPT1
\r
2237 \ DW DUPP,ZBranch,ACCPT1
\r
2238 \ DW OneMinus,DoLIT,BKSPP,EMIT,DoLIT,' ',EMIT,DoLIT,BKSPP,EMIT
\r
2239 \ DW Branch,ACCPT1
\r
2240 \ ACCPT3 DW ToR,TwoDUP,CHARS,Plus,RFrom,DUPP,EMIT,SWAP,CStore
\r
2241 \ DW OnePlus,Branch,ACCPT1
\r
2242 \ ACCPT5 DW SWAP,RFrom,TwoDROP,EXIT
\r
2244 \ AGAIN ( C: dest -- ) \ CORE EXT
\r
2245 \ Resolve backward reference dest. Typically used as
\r
2246 \ BEGIN ... AGAIN . Move control to the location specified by
\r
2247 \ dest on execution.
\r
2249 : AGAIN IF -22 THROW THEN \ control structure mismatch; dest type is 0
\r
2250 POSTPONE branch code, bal- ; COMPILE-ONLY IMMEDIATE
\r
2252 \ $COLON NameAGAIN,AGAIN
\r
2253 \ DW ZBranch,AGAIN1
\r
2254 \ DW DoLIT,-22,THROW
\r
2255 \ AGAIN1 DW DoLIT,Branch,COMPILEComma,CodeComma,BalMinus,EXIT
\r
2257 \ AHEAD ( C: -- orig ) \ TOOLS EXT
\r
2258 \ Put the location of a new unresolved forward reference onto
\r
2259 \ control-flow stack.
\r
2261 : AHEAD POSTPONE branch xhere 0 code,
\r
2262 1 bal+ \ orig type is 1
\r
2263 ; COMPILE-ONLY IMMEDIATE
\r
2265 \ $COLON NameAHEAD,AHEAD
\r
2266 \ DW DoLIT,Branch,COMPILEComma,XHere,DoLIT,0,CodeComma
\r
2267 \ DW One,BalPlus,EXIT
\r
2269 \ BL ( -- char ) \ CORE
\r
2270 \ Return the value of the blank character.
\r
2272 : BL blank-char-value EXIT ;
\r
2274 \ $CONST NameBLank,BLank,' '
\r
2276 \ CATCH ( i*x xt -- j*x 0 | i*x n ) \ EXCEPTION
\r
2277 \ Push an exception frame on the exception stack and then execute
\r
2278 \ the execution token xt in such a way that control can be
\r
2279 \ transferred to a point just after CATCH if THROW is executed
\r
2280 \ during the execution of xt.
\r
2282 : CATCH sp@ >R throwFrame @ >R \ save error frame
\r
2283 rp@ throwFrame ! EXECUTE \ execute
\r
2284 R> throwFrame ! \ restore error frame
\r
2285 R> DROP 0 ; \ no error
\r
2287 \ $COLON NameCATCH,CATCH
\r
2288 \ DW SPFetch,ToR,ThrowFrame,Fetch,ToR
\r
2289 \ DW RPFetch,ThrowFrame,Store,EXECUTE
\r
2290 \ DW RFrom,ThrowFrame,Store
\r
2291 \ DW RFrom,DROP,DoLIT,0,EXIT
\r
2293 \ CELL+ ( a-addr1 -- a-addr2 ) \ CORE
\r
2294 \ Return next aligned cell address.
\r
2296 : CELL+ cell-size + ;
\r
2298 \ $COLON NameCELLPlus,CELLPlus
\r
2299 \ DW DoLIT,CELLL,Plus,EXIT
\r
2301 \ $CODE NameCELLPlus,CELLPlus
\r
2305 \ CHAR+ ( c-addr1 -- c-addr2 ) \ CORE
\r
2306 \ Returns next character-aligned address.
\r
2308 : CHAR+ char-size + ;
\r
2310 \ $COLON NameCHARPlus,CHARPlus
\r
2311 \ DW DoLIT,CHARR,Plus,EXIT
\r
2313 \ $CODE NameCHARPlus,CHARPlus
\r
2317 \ COMPILE, ( xt -- ) \ CORE EXT
\r
2318 \ Compile the execution token on data stack into current
\r
2319 \ colon definition.
\r
2320 \ Structure of words with special compilation action
\r
2321 \ for default compilation behavior
\r
2322 \ |compile_xt|name_ptr| execution_code |
\r
2324 : COMPILE, DUP specialComp? = IF DUP cell- cell- code@ EXECUTE EXIT THEN
\r
2327 \ $COLON NameCOMPILEComma,COMPILEComma
\r
2328 \ DW DUPP,SpecialCompQ,Equals,ZBranch,COMPILEC1
\r
2329 \ DW DUPP,CellMinus,CellMinus,CodeFetch,EXECUTE,EXIT
\r
2330 \ COMPILEC1 DW CodeComma,EXIT
\r
2332 \ $CODE NameCOMPILEComma,COMPILEComma
\r
2333 \ CMP BX,AddrSpecialCompQ
\r
2335 \ MOV DI,AddrXHere
\r
2339 \ MOV AddrXHere,DI
\r
2341 \ COMPILEC1: MOV AX,CS:[BX-2*CELLL]
\r
2345 \ compileCONST ( xt -- )
\r
2346 \ Compile a CONSTANT word of which xt is given.
\r
2347 \ Structure of CONSTANT word:
\r
2348 \ |compile_xt|name_ptr| call-doCONST | x |
\r
2351 CELL+ CELL+ code@ POSTPONE LITERAL ;
\r
2353 \ $COLON NameCompileCONST,CompileCONST
\r
2354 \ DW CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT
\r
2356 \ $CODE NameCompileCONST,CompileCONST
\r
2357 \ MOV CX,CS:[BX+2*CELLL]
\r
2358 \ MOV DI,AddrXHere
\r
2359 \ MOV AX,OFFSET DoLIT
\r
2361 \ MOV CS:[DI+CELLL],CX
\r
2364 \ MOV AddrXHere,DI
\r
2367 \ CONSTANT ( x "<spaces>name" -- ) \ CORE
\r
2368 \ name Execution: ( -- x )
\r
2369 \ Create a definition for name which pushes x on the stack on
\r
2372 : CONSTANT bal IF -29 THROW THEN \ compiler nesting
\r
2373 xhere ALIGNED TO xhere
\r
2374 ['] compileCONST code,
\r
2375 xhere CELL+ TO xhere
\r
2376 ['] doCONST xt, head,
\r
2378 lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;
\r
2380 \ $COLON NameCONSTANT,CONSTANT
\r
2381 \ DW Bal,ZBranch,CONST1
\r
2382 \ DW DoLIT,-29,THROW
\r
2383 \ CONST1 DW XHere,ALIGNED,DoTO,AddrXHere
\r
2384 \ DW DoLIT,CompileCONST,CodeComma
\r
2385 \ DW XHere,CELLPlus,DoTO,AddrXHere
\r
2386 \ DW DoLIT,DoCONST,xtComma,HeadComma
\r
2387 \ DW CodeComma,LinkLast
\r
2388 \ DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
2390 \ COUNT ( c-addr1 -- c-addr2 u ) \ CORE
\r
2391 \ Convert counted string to string specification. c-addr2 is
\r
2392 \ the next char-aligned address after c-addr1 and u is the
\r
2393 \ contents at c-addr1.
\r
2395 : COUNT DUP CHAR+ SWAP C@ ;
\r
2397 \ $COLON NameCOUNT,COUNT
\r
2398 \ DW DUPP,CHARPlus,SWAP,CFetch,EXIT
\r
2400 \ $CODE NameCOUNT,COUNT
\r
2408 \ compileCREATE ( xt -- )
\r
2409 \ Compile a CREATEd word of which xt is given.
\r
2410 \ Structure of CREATEd word:
\r
2411 \ |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |
\r
2414 DUP CELL+ CELL+ code@ \ 0 or DOES>_xt
\r
2415 IF code, EXIT THEN
\r
2416 CELL+ CELL+ CELL+ code@ POSTPONE LITERAL ;
\r
2418 \ $COLON NameCompileCREATE,CompileCREATE
\r
2419 \ DW DUPP,CELLPlus,CELLPlus,CodeFetch,ZBranch,COMPCREAT1
\r
2420 \ DW CodeComma,EXIT
\r
2421 \ COMPCREAT1 DW CELLPlus,CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT
\r
2423 \ CREATE ( "<spaces>name" -- ) \ CORE
\r
2424 \ name Execution: ( -- a-addr )
\r
2425 \ Create a data object in RAM/ROM data space, which return
\r
2426 \ data object address on execution
\r
2428 : CREATE bal IF -29 THROW THEN \ compiler nesting
\r
2429 xhere ALIGNED TO xhere
\r
2430 ['] compileCREATE code,
\r
2431 xhere CELL+ TO xhere \ reserve space for nfa
\r
2432 ['] doCREATE xt, head,
\r
2433 0 code, \ no DOES> code yet
\r
2434 ALIGN HERE code, \ >BODY returns this address
\r
2435 linkLast \ link CREATEd word to current wordlist
\r
2436 lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;
\r
2438 \ $COLON NameCREATE,CREATE
\r
2439 \ DW Bal,ZBranch,CREAT1
\r
2440 \ DW DoLIT,-29,THROW
\r
2441 \ CREAT1 DW XHere,ALIGNED,DoTO,AddrXHere
\r
2442 \ DW DoLIT,CompileCREATE,CodeComma
\r
2443 \ DW XHere,CELLPlus,DoTO,AddrXHere
\r
2444 \ DW DoLIT,DoCREATE,xtComma,HeadComma,DoLIT,0,CodeComma
\r
2445 \ DW ALIGNN,HERE,CodeComma,LinkLast
\r
2446 \ DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
2448 \ D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE
\r
2449 \ Add double-cell numbers.
\r
2451 : D+ >R SWAP >R um+ R> R> + + ;
\r
2453 \ $COLON NameDPlus,DPlus
\r
2454 \ DW ToR,SWAP,ToR,UMPlus
\r
2455 \ DW RFrom,RFrom,Plus,Plus,EXIT
\r
2457 \ $CODE NameDPlus,DPlus
\r
2466 \ D. ( d -- ) \ DOUBLE
\r
2467 \ Display d in free field format followed by a space.
\r
2469 : D. (d.) TYPE SPACE ;
\r
2471 \ $COLON NameDDot,DDot
\r
2472 \ DW ParenDDot,TYPEE,SPACE,EXIT
\r
2474 \ DECIMAL ( -- ) \ CORE
\r
2475 \ Set the numeric conversion radix to decimal 10.
\r
2477 : DECIMAL 10 BASE ! ;
\r
2479 \ $COLON NameDECIMAL,DECIMAL
\r
2480 \ DW DoLIT,10,DoLIT,AddrBASE,Store,EXIT
\r
2482 \ DEPTH ( -- +n ) \ CORE
\r
2483 \ Return the depth of the data stack.
\r
2485 : DEPTH sp@ sp0 SWAP - cell-size / ;
\r
2487 \ $COLON NameDEPTH,DEPTH
\r
2488 \ DW SPFetch,SPZero,SWAP,Minus
\r
2489 \ DW DoLIT,CELLL,Slash,EXIT
\r
2491 \ $CODE NameDEPTH,DEPTH
\r
2493 \ MOV BX,AddrUserP
\r
2494 \ MOV BX,[BX+CELLL]
\r
2499 \ DNEGATE ( d1 -- d2 ) \ DOUBLE
\r
2500 \ Two's complement of double-cell number.
\r
2502 : DNEGATE INVERT >R INVERT 1 um+ R> + ;
\r
2504 \ $COLON NameDNEGATE,DNEGATE
\r
2505 \ DW INVERT,ToR,INVERT
\r
2506 \ DW DoLIT,1,UMPlus
\r
2507 \ DW RFrom,Plus,EXIT
\r
2509 \ $CODE NameDNEGATE,DNEGATE
\r
2517 \ EKEY ( -- u ) \ FACILITY EXT
\r
2518 \ Receive one keyboard event u.
\r
2520 : EKEY BEGIN PAUSE EKEY? UNTIL 'ekey EXECUTE ;
\r
2522 \ $COLON NameEKEY,EKEY
\r
2523 \ EKEY1 DW PAUSE,EKEYQuestion,ZBranch,EKEY1
\r
2524 \ DW TickEKEY,EXECUTE,EXIT
\r
2526 \ EMIT ( x -- ) \ CORE
\r
2527 \ Send a character to the output device.
\r
2529 : EMIT 'emit EXECUTE ;
\r
2531 \ $COLON NameEMIT,EMIT
\r
2532 \ DW TickEMIT,EXECUTE,EXIT
\r
2534 \ $CODE NameEMIT,EMIT
\r
2535 \ MOV AX,AddrTickEMIT
\r
2539 \ FM/MOD ( d n1 -- n2 n3 ) \ CORE
\r
2540 \ Signed floored divide of double by single. Return mod n2
\r
2541 \ and quotient n3.
\r
2543 : FM/MOD DUP >R 2DUP XOR >R >R DUP 0< IF DNEGATE THEN
\r
2544 R@ ABS UM/MOD DUP 0<
\r
2545 IF DUP [ 16 BASE ! ] 8000 [ DECIMAL ] XOR IF -11 THROW THEN THEN \ result out of range
\r
2546 SWAP R> 0< IF NEGATE THEN
\r
2547 SWAP R> 0< IF NEGATE OVER IF R@ ROT - SWAP 1- THEN THEN
\r
2550 \ $COLON 6,'FM/MOD',FMSlashMOD,_FLINK
\r
2551 \ DW DUPP,ToR,TwoDUP,XORR,ToR,ToR,DUPP,ZeroLess
\r
2552 \ DW ZBranch,FMMOD1
\r
2554 \ FMMOD1 DW RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,FMMOD2
\r
2555 \ DW DUPP,DoLIT,08000h,XORR,ZBranch,FMMOD2
\r
2556 \ DW DoLIT,-11,THROW
\r
2557 \ FMMOD2 DW SWAP,RFrom,ZeroLess,ZBranch,FMMOD3
\r
2559 \ FMMOD3 DW SWAP,RFrom,ZeroLess,ZBranch,FMMOD4
\r
2560 \ DW NEGATE,OVER,ZBranch,FMMOD4
\r
2561 \ DW RFetch,ROT,Minus,SWAP,OneMinus
\r
2562 \ FMMOD4 DW RFrom,DROP,EXIT
\r
2564 \ $CODE NameFMSlashMOD,FMSlashMOD
\r
2574 \ DIV BX ;positive dividend, positive divisor
\r
2580 \ FMMOD3: NEG BX ;positive dividend, negative divisor
\r
2587 \ JZ FMMOD7 ;modulo = 0
\r
2589 \ NOT AX ;AX=-AX-1
\r
2593 \ FMMOD2: NEG AX ;DNEGATE
\r
2599 \ CMP DX,BX ;negative dividend, positive divisor
\r
2607 \ NOT AX ;AX=-AX-1
\r
2615 \ FMMOD4: NEG BX ;negative dividend, negative divisor
\r
2625 \ FMMOD6: MOV BX,-11 ;result out of range
\r
2627 \ FMMOD1: MOV BX,-10 ;divide by zero
\r
2631 \ GET-CURRENT ( -- wid ) \ SEARCH
\r
2632 \ Return the indentifier of the compilation wordlist.
\r
2634 : GET-CURRENT current @ ;
\r
2636 \ $COLON NameGET_CURRENT,GET_CURRENT
\r
2637 \ DW DoLIT,AddrCurrent,Fetch,EXIT
\r
2639 \ HOLD ( char -- ) \ CORE
\r
2640 \ Add char to the beginning of pictured numeric output string.
\r
2642 : HOLD hld @ 1 CHARS - DUP hld ! C! ;
\r
2644 \ $COLON NameHOLD,HOLD
\r
2645 \ DW DoLIT,AddrHLD,Fetch,DoLIT,0-CHARR,Plus
\r
2646 \ DW DUPP,DoLIT,AddrHLD,Store,CStore,EXIT
\r
2648 \ $CODE NameHOLD,HOLD
\r
2656 \ I ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE
\r
2657 \ Push the innermost loop index.
\r
2659 : I rp@ [ 1 CELLS ] LITERAL + @
\r
2660 rp@ [ 2 CELLS ] LITERAL + @ + ; COMPILE-ONLY
\r
2663 \ DW RPFetch,DoLIT,CELLL,Plus,Fetch
\r
2664 \ DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT
\r
2672 \ IF Compilation: ( C: -- orig ) \ CORE
\r
2673 \ Run-time: ( x -- )
\r
2674 \ Put the location of a new unresolved forward reference orig
\r
2675 \ onto the control flow stack. On execution jump to location
\r
2676 \ specified by the resolution of orig if x is zero.
\r
2678 : IF POSTPONE 0branch xhere 0 code,
\r
2679 1 bal+ ; \ orig type is 1
\r
2680 COMPILE-ONLY IMMEDIATE
\r
2682 \ $COLON NameIFF,IFF
\r
2683 \ DW DoLIT,ZBranch,COMPILEComma,XHere,DoLIT,0,CodeComma
\r
2684 \ DW One,BalPlus,EXIT
\r
2686 \ INVERT ( x1 -- x2 ) \ CORE
\r
2687 \ Return one's complement of x1.
\r
2691 \ $COLON NameINVERT,INVERT
\r
2692 \ DW DoLIT,-1,XORR,EXIT
\r
2694 \ $CODE NameINVERT,INVERT
\r
2698 \ KEY ( -- char ) \ CORE
\r
2699 \ Receive a character. Do not display char.
\r
2701 : KEY EKEY max-char AND ;
\r
2703 \ $COLON NameKEY,KEY
\r
2704 \ DW EKEY,DoLIT,MaxChar,ANDD,EXIT
\r
2706 \ LITERAL Compilation: ( x -- ) \ CORE
\r
2707 \ Run-time: ( -- x )
\r
2708 \ Append following run-time semantics. Put x on the stack on
\r
2711 : LITERAL POSTPONE doLIT code, ; COMPILE-ONLY IMMEDIATE
\r
2713 \ $COLON NameLITERAL,LITERAL
\r
2714 \ DW DoLIT,DoLIT,COMPILEComma,CodeComma,EXIT
\r
2716 \ NEGATE ( n1 -- n2 ) \ CORE
\r
2717 \ Return two's complement of n1.
\r
2719 : NEGATE INVERT 1+ ;
\r
2721 \ $COLON NameNEGATE,NEGATE
\r
2722 \ DW INVERT,OnePlus,EXIT
\r
2724 \ $CODE NameNEGATE,NEGATE
\r
2728 \ NIP ( n1 n2 -- n2 ) \ CORE EXT
\r
2729 \ Discard the second stack item.
\r
2733 \ $COLON NameNIP,NIP
\r
2734 \ DW SWAP,DROP,EXIT
\r
2736 \ $CODE NameNIP,NIP
\r
2740 \ PARSE ( char "ccc<char>"-- c-addr u ) \ CORE EXT
\r
2741 \ Scan input stream and return counted string delimited by char.
\r
2743 : PARSE >R SOURCE >IN @ /STRING \ c-addr u R: char
\r
2745 OVER CHARS + OVER \ c-addr c-addr+u c-addr R: char
\r
2746 BEGIN DUP C@ R@ XOR
\r
2747 WHILE CHAR+ 2DUP =
\r
2748 UNTIL DROP OVER - 1chars/ DUP
\r
2749 ELSE NIP OVER - 1chars/ DUP CHAR+
\r
2751 THEN R> DROP EXIT ;
\r
2753 \ $COLON 5,'PARSE',PARSE,_FLINK
\r
2754 \ DW ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING
\r
2755 \ DW DUPP,ZBranch,PARSE4
\r
2756 \ DW OVER,CHARS,Plus,OVER
\r
2757 \ PARSE1 DW DUPP,CFetch,RFetch,XORR,ZBranch,PARSE3
\r
2758 \ DW CHARPlus,TwoDUP,Equals,ZBranch,PARSE1
\r
2759 \ PARSE2 DW DROP,OVER,Minus,DUPP,OneCharsSlash,Branch,PARSE5
\r
2760 \ PARSE3 DW NIP,OVER,Minus,DUPP,OneCharsSlash,CHARPlus
\r
2761 \ PARSE5 DW DoLIT,AddrToIN,PlusStore
\r
2762 \ PARSE4 DW RFrom,DROP,EXIT
\r
2764 \ $CODE NamePARSE,PARSE
\r
2767 \ MOV SI,AddrSourceVar+CELLL
\r
2768 \ MOV BX,AddrSourceVar
\r
2783 \ SUB SI,AddrSourceVar+CELLL
\r
2786 \ PARSE1: MOV SI,DX
\r
2788 \ PARSE4: MOV BX,SI
\r
2789 \ SUB SI,AddrSourceVar+CELLL
\r
2796 \ QUIT ( -- ) ( R: i*x -- ) \ CORE
\r
2797 \ Empty the return stack, store zero in SOURCE-ID, make the user
\r
2798 \ input device the input source, and start text interpreter.
\r
2801 rp0 rp! 0 TO SOURCE-ID 0 TO bal POSTPONE [
\r
2802 BEGIN CR REFILL DROP SPACE \ REFILL returns always true
\r
2803 ['] interpret CATCH ?DUP 0=
\r
2804 WHILE STATE @ 0= IF .prompt THEN
\r
2806 DUP -1 XOR IF \ ABORT
\r
2807 DUP -2 = IF SPACE abort"msg 2@ TYPE ELSE \ ABORT"
\r
2808 SPACE errWord 2@ TYPE
\r
2809 SPACE [CHAR] ? EMIT SPACE
\r
2810 DUP -1 -58 WITHIN IF ." Exception # " . ELSE \ undefined exception
\r
2811 CELLS THROWMsgTbl + @ COUNT TYPE THEN THEN THEN
\r
2815 \ $COLON NameQUIT,QUIT
\r
2816 \ QUIT1 DW RPZero,RPStore,DoLIT,0,DoTO,AddrSOURCE_ID
\r
2817 \ DW DoLIT,0,DoTO,AddrBal,LeftBracket
\r
2818 \ QUIT2 DW CR,REFILL,DROP,SPACE
\r
2819 \ DW DoLIT,Interpret,CATCH,QuestionDUP,ZeroEquals
\r
2820 \ DW ZBranch,QUIT3
\r
2821 \ DW DoLIT,AddrSTATE,Fetch,ZeroEquals,ZBranch,QUIT2
\r
2822 \ DW DotPrompt,Branch,QUIT2
\r
2823 \ QUIT3 DW DUPP,DoLIT,-1,XORR,ZBranch,QUIT5
\r
2824 \ DW DUPP,DoLIT,-2,Equals,ZBranch,QUIT4
\r
2825 \ DW SPACE,DoLIT,AddrAbortQMsg,TwoFetch,TYPEE,Branch,QUIT5
\r
2826 \ QUIT4 DW SPACE,DoLIT,AddrErrWord,TwoFetch,TYPEE
\r
2827 \ DW SPACE,DoLIT,'?',EMIT,SPACE
\r
2828 \ DW DUPP,DoLIT,-1,DoLIT,-58,WITHIN,ZBranch,QUIT7
\r
2829 \ DW DoLIT,QUITstr
\r
2830 \ DW COUNT,TYPEE,Dot,Branch,QUIT5
\r
2831 \ QUIT7 DW CELLS,DoLIT,AddrTHROWMsgTbl,Plus,Fetch,COUNT,TYPEE
\r
2832 \ QUIT5 DW SPZero,SPStore,Branch,QUIT1
\r
2834 \ REFILL ( -- flag ) \ CORE EXT
\r
2835 \ Attempt to fill the input buffer from the input source. Make
\r
2836 \ the result the input buffer, set >IN to zero, and return true
\r
2837 \ if successful. Return false if the input source is a string
\r
2840 \ Nick, possible problem here
\r
2841 \ : REFILL SOURCE-ID IF 0 EXIT THEN
\r
2842 \ memTop [ size-of-PAD CHARS ] LITERAL - DUP
\r
2843 \ size-of-PAD ACCEPT sourceVar 2!
\r
2846 \ $COLON NameREFILL,REFILL
\r
2847 \ DW SOURCE_ID,ZBranch,REFIL1
\r
2849 \ REFIL1 DW MemTop,DoLIT,0-PADSize*CHARR,Plus,DUPP
\r
2850 \ DW DoLIT,PADSize*CHARR,ACCEPT,DoLIT,AddrSourceVar,TwoStore
\r
2851 \ DW DoLIT,0,DoLIT,AddrToIN,Store,DoLIT,-1,EXIT
\r
2853 \ ROT ( x1 x2 x3 -- x2 x3 x1 ) \ CORE
\r
2854 \ Rotate the top three data stack items.
\r
2856 : ROT >R SWAP R> SWAP ;
\r
2858 \ $COLON NameROT,ROT
\r
2859 \ DW ToR,SWAP,RFrom,SWAP,EXIT
\r
2861 \ $CODE NameROT,ROT
\r
2869 \ S>D ( n -- d ) \ CORE
\r
2870 \ Convert a single-cell number n to double-cell number.
\r
2874 \ $COLON NameSToD,SToD
\r
2875 \ DW DUPP,ZeroLess,EXIT
\r
2877 \ $CODE NameSToD,SToD
\r
2884 \ SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1) \ SEARCH
\r
2885 \ Search word list for a match with the given name.
\r
2886 \ Return execution token and -1 or 1 ( IMMEDIATE) if found.
\r
2887 \ Return 0 if not found.
\r
2890 (search-wordlist) DUP IF NIP THEN ;
\r
2892 \ $COLON NameSEARCH_WORDLIST,SEARCH_WORDLIST
\r
2893 \ DW ParenSearch_Wordlist,DUPP,ZBranch,SRCHW1
\r
2897 \ SIGN ( n -- ) \ CORE
\r
2898 \ Add a minus sign to the numeric output string if n is negative.
\r
2900 : SIGN 0< IF [CHAR] - HOLD THEN ;
\r
2902 \ $COLON NameSIGN,SIGN
\r
2903 \ DW ZeroLess,ZBranch,SIGN1
\r
2904 \ DW DoLIT,'-',HOLD
\r
2907 \ $CODE NameSIGN,SIGN
\r
2918 \ SOURCE ( -- c-addr u ) \ CORE
\r
2919 \ Return input buffer string.
\r
2921 : SOURCE sourceVar 2@ ;
\r
2923 \ $COLON NameSOURCE,SOURCE
\r
2924 \ DW DoLIT,AddrSourceVar,TwoFetch,EXIT
\r
2926 \ SPACE ( -- ) \ CORE
\r
2927 \ Send the blank character to the output device.
\r
2931 \ $COLON NameSPACE,SPACE
\r
2932 \ DW DoLIT,' ',EMIT,EXIT
\r
2934 \ $CODE NameSPACE,SPACE
\r
2937 \ MOV AX,AddrTickEMIT
\r
2941 \ STATE ( -- a-addr ) \ CORE
\r
2942 \ Return the address of a cell containing compilation-state flag
\r
2943 \ which is true in compilation state or false otherwise.
\r
2945 \ $CONST NameSTATE,STATE,AddrSTATE
\r
2947 \ THEN Compilation: ( C: orig -- ) \ CORE
\r
2948 \ Run-time: ( -- )
\r
2949 \ Resolve the forward reference orig.
\r
2951 : THEN 1- IF -22 THROW THEN \ control structure mismatch
\r
2953 xhere SWAP code! bal- ; COMPILE-ONLY IMMEDIATE
\r
2955 \ $COLON NameTHENN,THENN
\r
2956 \ DW OneMinus,ZBranch,THEN1
\r
2957 \ DW DoLIT,-22,THROW
\r
2958 \ THEN1 DW XHere,SWAP,CodeStore,BalMinus,EXIT
\r
2960 \ THROW ( k*x n -- k*x | i*x n ) \ EXCEPTION
\r
2961 \ If n is not zero, pop the topmost exception frame from the
\r
2962 \ exception stack, along with everything on the return stack
\r
2963 \ above the frame. Then restore the condition before CATCH and
\r
2964 \ transfer control just after the CATCH that pushed that
\r
2965 \ exception frame.
\r
2968 IF throwFrame @ rp! \ restore return stack
\r
2969 R> throwFrame ! \ restore THROW frame
\r
2970 R> SWAP >R sp! \ restore data stack
\r
2975 \ $COLON NameTHROW,THROW
\r
2976 \ DW QuestionDUP,ZBranch,THROW1
\r
2977 \ DW ThrowFrame,Fetch,RPStore,RFrom,ThrowFrame,Store
\r
2978 \ DW RFrom,SWAP,ToR,SPStore,DROP,RFrom
\r
2979 \ DW TickINIT_IO,EXECUTE
\r
2982 \ TYPE ( c-addr u -- ) \ CORE
\r
2983 \ Display the character string if u is greater than zero.
\r
2985 : TYPE ?DUP IF 0 DO DUP C@ EMIT CHAR+ LOOP THEN DROP ;
\r
2987 \ $COLON NameTYPEE,TYPEE
\r
2988 \ DW QuestionDUP,ZBranch,TYPE2
\r
2990 \ TYPE1 DW DUPP,CFetch,EMIT,CHARPlus,DoLOOP,TYPE1
\r
2991 \ TYPE2 DW DROP,EXIT
\r
2993 \ $CODE NameTYPEE,TYPEE
\r
3001 \ TYPE4: MOV DI,BX
\r
3006 \ MOV SI,OFFSET TYPE3
\r
3007 \ MOV AX,AddrTickEMIT
\r
3009 \ TYPE1: DEC WORD PTR [BP]
\r
3017 \ U< ( u1 u2 -- flag ) \ CORE
\r
3018 \ Unsigned compare of top two items. True if u1 < u2.
\r
3020 : U< 2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;
\r
3022 \ $COLON NameULess,ULess
\r
3023 \ DW TwoDUP,XORR,ZeroLess
\r
3024 \ DW ZBranch,ULES1
\r
3025 \ DW NIP,ZeroLess,EXIT
\r
3026 \ ULES1 DW Minus,ZeroLess,EXIT
\r
3028 \ $CODE NameULess,ULess
\r
3036 \ UM* ( u1 u2 -- ud ) \ CORE
\r
3037 \ Unsigned multiply. Return double-cell product.
\r
3039 : UM* 0 SWAP cell-size-in-bits 0 DO
\r
3040 DUP um+ >R >R DUP um+ R> +
\r
3041 R> IF >R OVER um+ R> + THEN \ if carry
\r
3044 \ $COLON NameUMStar,UMStar
\r
3045 \ DW DoLIT,0,SWAP,DoLIT,CELLL*8,DoLIT,0,DoDO
\r
3046 \ UMST1 DW DUPP,UMPlus,ToR,ToR
\r
3047 \ DW DUPP,UMPlus,RFrom,Plus,RFrom
\r
3048 \ DW ZBranch,UMST2
\r
3049 \ DW ToR,OVER,UMPlus,RFrom,Plus
\r
3050 \ UMST2 DW DoLOOP,UMST1
\r
3051 \ DW ROT,DROP,EXIT
\r
3053 \ $CODE NameUMStar,UMStar
\r
3060 \ UM/MOD ( ud u1 -- u2 u3 ) \ CORE
\r
3061 \ Unsigned division of a double-cell number ud by a single-cell
\r
3062 \ number u1. Return remainder u2 and quotient u3.
\r
3064 : UM/MOD DUP 0= IF -10 THROW THEN \ divide by zero
\r
3066 NEGATE cell-size-in-bits 0
\r
3067 DO >R DUP um+ >R >R DUP um+ R> + DUP
\r
3068 R> R@ SWAP >R um+ R> OR
\r
3072 LOOP DROP SWAP EXIT
\r
3073 ELSE -11 THROW \ result out of range
\r
3076 \ $COLON NameUMSlashMOD,UMSlashMOD
\r
3077 \ DW DUPP,ZBranch,UMM5
\r
3078 \ DW TwoDUP,ULess,ZBranch,UMM4
\r
3079 \ DW NEGATE,DoLIT,CELLL*8,DoLIT,0,DoDO
\r
3080 \ UMM1 DW ToR,DUPP,UMPlus,ToR,ToR,DUPP,UMPlus,RFrom,Plus,DUPP
\r
3081 \ DW RFrom,RFetch,SWAP,ToR,UMPlus,RFrom,ORR,ZBranch,UMM2
\r
3082 \ DW ToR,DROP,OnePlus,RFrom,Branch,UMM3
\r
3084 \ UMM3 DW RFrom,DoLOOP,UMM1
\r
3085 \ DW DROP,SWAP,EXIT
\r
3086 \ UMM5 DW DoLIT,-10,THROW
\r
3087 \ UMM4 DW DoLIT,-11,THROW
\r
3089 \ $CODE NameUMSlashMOD,UMSlashMOD
\r
3100 \ UMM1: MOV BX,-10 ;divide by zero
\r
3102 \ UMM2: MOV BX,-11 ;result out of range
\r
3106 \ UNLOOP ( -- ) ( R: loop-sys -- ) \ CORE
\r
3107 \ Discard loop-control parameters for the current nesting level.
\r
3108 \ An UNLOOP is required for each nesting level before the
\r
3109 \ definition may be EXITed.
\r
3111 : UNLOOP R> R> R> 2DROP >R ;
\r
3113 \ $COLON NameUNLOOP,UNLOOP
\r
3114 \ DW RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT
\r
3116 \ $CODE NameUNLOOP,UNLOOP
\r
3120 \ WITHIN ( n1|u1 n2|n2 n3|u3 -- flag ) \ CORE EXT
\r
3121 \ Return true if (n2|u2<=n1|u1 and n1|u1<n3|u3) or
\r
3122 \ (n2|u2>n3|u3 and (n2|u2<=n1|u1 or n1|u1<n3|u3)).
\r
3124 : WITHIN OVER - >R - R> U< ;
\r
3126 \ $COLON NameWITHIN,WITHIN
\r
3127 \ DW OVER,Minus,ToR ;ul <= u < uh
\r
3128 \ DW Minus,RFrom,ULess,EXIT
\r
3130 \ $CODE NameWITHIN,WITHIN
\r
3142 \ Enter interpretation state.
\r
3144 : [ 0 STATE ! ; COMPILE-ONLY IMMEDIATE
\r
3146 \ $COLON NameLeftBracket,LeftBracket
\r
3147 \ DW DoLIT,0,DoLIT,AddrSTATE,Store,EXIT
\r
3150 \ Enter compilation state.
\r
3154 \ $COLON NameRightBracket,RightBracket
\r
3155 \ DW DoLIT,-1,DoLIT,AddrSTATE,Store,EXIT
\r
3158 \ Rest of CORE words and two facility words, EKEY? and EMIT?
\r
3160 \ Following definitions can be removed from assembler source and
\r
3161 \ can be colon-defined later.
\r
3163 \ ( ( "ccc<)>" -- ) \ CORE
\r
3164 \ Ignore following string up to next ) . A comment.
\r
3166 : ( [CHAR] ) PARSE 2DROP ; IMMEDIATE
\r
3168 \ $COLON NameParen,Paren
\r
3169 \ DW DoLIT,')',PARSE,TwoDROP,EXIT
\r
3171 \ * ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
3172 \ Multiply n1|u1 by n2|u2 giving a single product.
\r
3176 \ $COLON NameStar,Star
\r
3177 \ DW UMStar,DROP,EXIT
\r
3179 \ $CODE NameStar,Star
\r
3185 \ */ ( n1 n2 n3 -- n4 ) \ CORE
\r
3186 \ Multiply n1 by n2 producing double-cell intermediate,
\r
3187 \ then divide it by n3. Return single-cell quotient.
\r
3191 \ $COLON NameStarSlash,StarSlash
\r
3192 \ DW StarSlashMOD,NIP,EXIT
\r
3194 \ */MOD ( n1 n2 n3 -- n4 n5 ) \ CORE
\r
3195 \ Multiply n1 by n2 producing double-cell intermediate,
\r
3196 \ then divide it by n3. Return single-cell remainder and
\r
3197 \ single-cell quotient.
\r
3199 : */MOD >R M* R> FM/MOD ;
\r
3201 \ $COLON NameStarSlashMOD,StarSlashMOD
\r
3202 \ DW ToR,MStar,RFrom,FMSlashMOD,EXIT
\r
3204 \ $CODE NameStarSlashMOD,StarSlashMOD
\r
3213 \ +LOOP Compilation: ( C: do-sys -- ) \ CORE
\r
3214 \ Run-time: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
3215 \ Terminate a DO-+LOOP structure. Resolve the destination of all
\r
3216 \ unresolved occurences of LEAVE.
\r
3217 \ On execution add n to the loop index. If loop index did not
\r
3218 \ cross the boundary between loop_limit-1 and loop_limit,
\r
3219 \ continue execution at the beginning of the loop. Otherwise,
\r
3220 \ finish the loop.
\r
3222 : +LOOP POSTPONE do+LOOP rake ; COMPILE-ONLY IMMEDIATE
\r
3224 \ $COLON NamePlusLOOP,PlusLOOP
\r
3225 \ DW DoLIT,DoPLOOP,COMPILEComma,rake,EXIT
\r
3227 \ ." ( "ccc<">" -- ) \ CORE
\r
3229 \ Compile an inline string literal to be typed out at run time.
\r
3231 : ." POSTPONE S" POSTPONE TYPE ; COMPILE-ONLY IMMEDIATE
\r
3233 \ $COLON NameDotQuote,DotQuote
\r
3234 \ DW SQuote,DoLIT,TYPEE,COMPILEComma,EXIT
\r
3236 \ 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) \ CORE
\r
3237 \ Copy cell pair x1 x2 to the top of the stack.
\r
3239 : 2OVER >R >R 2DUP R> R> 2SWAP ;
\r
3241 \ $COLON NameTwoOVER,TwoOVER
\r
3242 \ DW ToR,ToR,TwoDUP,RFrom,RFrom,TwoSWAP,EXIT
\r
3244 \ $CODE NameTwoOVER,TwoOVER
\r
3247 \ PUSH [DI+2*CELLL]
\r
3248 \ MOV BX,[DI+CELLL]
\r
3251 \ >BODY ( xt -- a-addr ) \ CORE
\r
3252 \ Push data field address of CREATEd word.
\r
3254 : >BODY ?call DUP IF \ code-addr xt2
\r
3255 ['] doCREATE = IF \ should be call-doCREATE
\r
3258 -31 THROW ; \ >BODY used on non-CREATEd definition
\r
3260 \ $COLON NameToBODY,ToBODY
\r
3261 \ DW QCall,DUPP,ZBranch,TBODY1
\r
3262 \ DW DoLIT,DoCREATE,Equals,ZBranch,TBODY1
\r
3263 \ DW CELLPlus,CodeFetch,EXIT
\r
3264 \ TBODY1 DW DoLIT,-31,THROW
\r
3266 \ ABORT" ( "ccc<">" -- ) \ EXCEPTION EXT
\r
3267 \ Run-time ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )
\r
3268 \ Conditional abort with an error message.
\r
3270 : ABORT" POSTPONE S" POSTPONE ROT
\r
3271 POSTPONE IF POSTPONE abort"msg POSTPONE 2!
\r
3272 -2 POSTPONE LITERAL POSTPONE THROW
\r
3273 POSTPONE ELSE POSTPONE 2DROP POSTPONE THEN
\r
3274 ; COMPILE-ONLY IMMEDIATE
\r
3276 \ $COLON NameABORTQuote,ABORTQuote
\r
3277 \ DW SQuote,DoLIT,ROT,COMPILEComma
\r
3278 \ DW IFF,DoLIT,AbortQMsg,COMPILEComma ; IF is immediate
\r
3279 \ DW DoLIT,TwoStore,COMPILEComma
\r
3280 \ DW DoLIT,-2,LITERAL ; LITERAL is immediate
\r
3281 \ DW DoLIT,THROW,COMPILEComma
\r
3282 \ DW ELSEE,DoLIT,TwoDROP,COMPILEComma ; ELSE and THEN are
\r
3283 \ DW THENN,EXIT ; immediate
\r
3285 \ ABS ( n -- u ) \ CORE
\r
3286 \ Return the absolute value of n.
\r
3288 : ABS DUP 0< IF NEGATE THEN ;
\r
3290 \ $COLON NameABSS,ABSS
\r
3291 \ DW DUPP,ZeroLess,ZBranch,ABS1
\r
3295 \ $CODE NameABSS,ABSS
\r
3301 \ ALLOT ( n -- ) \ CORE
\r
3302 \ Allocate n bytes in data space.
\r
3304 : ALLOT HERE + TO HERE ;
\r
3306 \ $COLON NameALLOT,ALLOT
\r
3307 \ DW HERE,Plus,DoTO,AddrHERE,EXIT
\r
3309 \ BEGIN ( C: -- dest ) \ CORE
\r
3310 \ Start an infinite or indefinite loop structure. Put the next
\r
3311 \ location for a transfer of control, dest, onto the data
\r
3314 : BEGIN xhere 0 bal+ \ dest type is 0
\r
3315 ; COMPILE-ONLY IMMEDIATE
\r
3317 \ $COLON NameBEGIN,BEGIN
\r
3318 \ DW XHere,DoLIT,0,BalPlus,EXIT
\r
3320 \ C, ( char -- ) \ CORE
\r
3321 \ Compile a character into data space.
\r
3323 : C, HERE C! HERE CHAR+ TO HERE ;
\r
3325 \ $COLON NameCComma,CComma
\r
3326 \ DW HERE,CStore,HERE,CHARPlus,DoTO,AddrHERE,EXIT
\r
3328 \ $CODE NameCComma,CComma
\r
3336 \ CHAR ( "<spaces>ccc" -- char ) \ CORE
\r
3337 \ Parse next word and return the value of first character.
\r
3339 : CHAR PARSE-WORD DROP C@ ;
\r
3341 \ $COLON NameCHAR,CHAR
\r
3342 \ DW PARSE_WORD,DROP,CFetch,EXIT
\r
3344 \ DO Compilation: ( C: -- do-sys ) \ CORE
\r
3345 \ Run-time: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )
\r
3346 \ Start a DO-LOOP structure in a colon definition. Place do-sys
\r
3347 \ on control-flow stack, which will be resolved by LOOP or +LOOP.
\r
3349 : DO 0 rakeVar ! 0 \ ?DO-orig is 0 for DO
\r
3350 POSTPONE doDO xhere bal+ ; \ DO-dest
\r
3351 COMPILE-ONLY IMMEDIATE
\r
3353 \ $COLON NameDO,DO
\r
3354 \ DW DoLIT,0,RakeVar,Store,DoLIT,0
\r
3355 \ DW DoLIT,DoDO,COMPILEComma,XHere,BalPlus,EXIT
\r
3357 \ DOES> ( C: colon-sys1 -- colon-sys2 ) \ CORE
\r
3358 \ Build run time code of the data object CREATEd.
\r
3360 : DOES> bal 1- IF -22 THROW THEN \ control structure mismatch
\r
3361 NIP 1+ IF -22 THROW THEN \ colon-sys type is -1
\r
3362 POSTPONE pipe ['] doLIST xt, -1 ; COMPILE-ONLY IMMEDIATE
\r
3364 \ $COLON NameDOESGreater,DOESGreater
\r
3365 \ DW Bal,OneMinus,ZBranch,DOES1
\r
3366 \ DW DoLIT,-22,THROW
\r
3367 \ DOES1 DW NIP,OnePlus,ZBranch,DOES2
\r
3368 \ DW DoLIT,-22,THROW
\r
3369 \ DOES2 DW DoLIT,Pipe,COMPILEComma
\r
3370 \ DW DoLIT,DoLIST,xtComma,DoLIT,-1,EXIT
\r
3372 \ ELSE Compilation: ( C: orig1 -- orig2 ) \ CORE
\r
3373 \ Run-time: ( -- )
\r
3374 \ Start the false clause in an IF-ELSE-THEN structure.
\r
3375 \ Put the location of new unresolved forward reference orig2
\r
3376 \ onto control-flow stack.
\r
3378 : ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMEDIATE
\r
3380 \ $COLON NameELSEE,ELSEE
\r
3381 \ DW AHEAD,TwoSWAP,THENN,EXIT
\r
3383 \ ENVIRONMENT? ( c-addr u -- false | i*x true ) \ CORE
\r
3384 \ Environment query.
\r
3387 envQList SEARCH-WORDLIST
\r
3388 DUP >R IF EXECUTE THEN R> ;
\r
3390 \ $COLON NameENVIRONMENTQuery,ENVIRONMENTQuery
\r
3391 \ DW DoLIT,AddrEnvQList,SEARCH_WORDLIST
\r
3392 \ DW DUPP,ToR,ZBranch,ENVRN1
\r
3394 \ ENVRN1 DW RFrom,EXIT
\r
3396 \ EVALUATE ( i*x c-addr u -- j*x ) \ CORE
\r
3397 \ Evaluate the string. Save the input source specification.
\r
3398 \ Store -1 in SOURCE-ID.
\r
3400 : EVALUATE SOURCE >R >R >IN @ >R SOURCE-ID >R
\r
3402 sourceVar 2! 0 >IN ! interpret
\r
3404 R> >IN ! R> R> sourceVar 2! ;
\r
3406 \ $COLON NameEVALUATE,EVALUATE
\r
3407 \ DW SOURCE,ToR,ToR,DoLIT,AddrToIN,Fetch,ToR,SOURCE_ID,ToR
\r
3408 \ DW DoLIT,-1,DoTO,AddrSOURCE_ID
\r
3409 \ DW DoLIT,AddrSourceVar,TwoStore,DoLIT,0,DoLIT,AddrToIN,Store,Interpret
\r
3410 \ DW RFrom,DoTO,AddrSOURCE_ID
\r
3411 \ DW RFrom,DoLIT,AddrToIN,Store,RFrom,RFrom,DoLIT,AddrSourceVar,TwoStore,EXIT
\r
3413 \ FILL ( c-addr u char -- ) \ CORE
\r
3414 \ Store char in each of u consecutive characters of memory
\r
3415 \ beginning at c-addr.
\r
3417 : FILL ROT ROT ?DUP IF 0 DO 2DUP C! CHAR+ LOOP THEN 2DROP ;
\r
3419 \ $COLON NameFILL,FILL
\r
3420 \ DW ROT,ROT,QuestionDUP,ZBranch,FILL2
\r
3422 \ FILL1 DW TwoDUP,CStore,CHARPlus,DoLOOP,FILL1
\r
3423 \ FILL2 DW TwoDROP,EXIT
\r
3425 \ $CODE NameFILL,FILL
\r
3438 \ FILL1: MOV SI,DX
\r
3442 \ FIND ( c-addr -- c-addr 0 | xt 1 | xt -1) \ SEARCH
\r
3443 \ Search dictionary for a match with the given counted name.
\r
3444 \ Return execution token and -1 or 1 ( IMMEDIATE) if found;
\r
3445 \ c-addr 0 if not found.
\r
3447 : FIND DUP COUNT search-word ?DUP IF NIP ROT DROP EXIT THEN
\r
3450 \ $COLON NameFIND,FIND
\r
3451 \ DW DUPP,COUNT,Search_word,QuestionDUP,ZBranch,FIND1
\r
3452 \ DW NIP,ROT,DROP,EXIT
\r
3453 \ FIND1 DW TwoDROP,DoLIT,0,EXIT
\r
3455 \ IMMEDIATE ( -- ) \ CORE
\r
3456 \ Make the most recent definition an immediate word.
\r
3458 : IMMEDIATE lastName [ =immed ] LITERAL OVER @ OR SWAP ! ;
\r
3460 \ $COLON NameIMMEDIATE,IMMEDIATE
\r
3461 \ DW LastName,DoLIT,IMMED,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
3463 \ J ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE
\r
3464 \ Push the index of next outer loop.
\r
3466 : J rp@ [ 3 CELLS ] LITERAL + @
\r
3467 rp@ [ 4 CELLS ] LITERAL + @ + ; COMPILE-ONLY
\r
3470 \ DW RPFetch,DoLIT,3*CELLL,Plus,Fetch
\r
3471 \ DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT
\r
3475 \ MOV BX,[BP+2*CELLL]
\r
3476 \ ADD BX,[BP+3*CELLL]
\r
3479 \ LEAVE ( -- ) ( R: loop-sys -- ) \ CORE
\r
3480 \ Terminate definite loop, DO|?DO ... LOOP|+LOOP, immediately.
\r
3482 : LEAVE POSTPONE UNLOOP POSTPONE branch
\r
3483 xhere rakeVar DUP @ code, ! ; COMPILE-ONLY IMMEDIATE
\r
3485 \ $COLON NameLEAVEE,LEAVEE
\r
3486 \ DW DoLIT,UNLOOP,COMPILEComma,DoLIT,Branch,COMPILEComma
\r
3487 \ DW XHere,DoLIT,AddrRakeVar,DUPP,Fetch,CodeComma,Store,EXIT
\r
3489 \ LOOP Compilation: ( C: do-sys -- ) \ CORE
\r
3490 \ Run-time: ( -- ) ( R: loop-sys1 -- loop-sys2 )
\r
3491 \ Terminate a DO|?DO ... LOOP structure. Resolve the destination
\r
3492 \ of all unresolved occurences of LEAVE.
\r
3494 : LOOP POSTPONE doLOOP rake ; COMPILE-ONLY IMMEDIATE
\r
3496 \ $COLON NameLOOPP,LOOPP
\r
3497 \ DW DoLIT,DoLOOP,COMPILEComma,rake,EXIT
\r
3499 \ LSHIFT ( x1 u -- x2 ) \ CORE
\r
3500 \ Perform a logical left shift of u bit-places on x1, giving x2.
\r
3501 \ Put 0 into the least significant bits vacated by the shift.
\r
3503 : LSHIFT ?DUP IF 0 DO 2* LOOP THEN ;
\r
3505 \ $COLON NameLSHIFT,LSHIFT
\r
3506 \ DW QuestionDUP,ZBranch,LSHIFT2
\r
3508 \ LSHIFT1 DW TwoStar,DoLOOP,LSHIFT1
\r
3511 \ $CODE NameLSHIFT,LSHIFT
\r
3519 \ M* ( n1 n2 -- d ) \ CORE
\r
3520 \ Signed multiply. Return double product.
\r
3522 : M* 2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;
\r
3524 \ $COLON NameMStar,MStar
\r
3525 \ DW TwoDUP,XORR,ZeroLess,ToR,ABSS,SWAP,ABSS
\r
3526 \ DW UMStar,RFrom,ZBranch,MSTAR1
\r
3530 \ $CODE NameMStar,MStar
\r
3537 \ MAX ( n1 n2 -- n3 ) \ CORE
\r
3538 \ Return the greater of two top stack items.
\r
3540 : MAX 2DUP < IF SWAP THEN DROP ;
\r
3542 \ $COLON NameMAX,MAX
\r
3543 \ DW TwoDUP,LessThan,ZBranch,MAX1
\r
3545 \ MAX1 DW DROP,EXIT
\r
3547 \ $CODE NameMAX,MAX
\r
3554 \ MIN ( n1 n2 -- n3 ) \ CORE
\r
3555 \ Return the smaller of top two stack items.
\r
3557 : MIN 2DUP > IF SWAP THEN DROP ;
\r
3559 \ $COLON NameMIN,MIN
\r
3560 \ DW TwoDUP,GreaterThan,ZBranch,MIN1
\r
3562 \ MIN1 DW DROP,EXIT
\r
3564 \ $CODE NameMIN,MIN
\r
3571 \ MOD ( n1 n2 -- n3 ) \ CORE
\r
3572 \ Divide n1 by n2, giving the single cell remainder n3.
\r
3573 \ Returns modulo of floored division in this implementation.
\r
3577 \ $COLON NameMODD,MODD
\r
3578 \ DW SlashMOD,DROP,EXIT
\r
3580 \ PICK ( x_u ... x1 x0 u -- x_u ... x1 x0 x_u ) \ CORE EXT
\r
3581 \ Remove u and copy the uth stack item to top of the stack. An
\r
3582 \ ambiguous condition exists if there are less than u+2 items
\r
3583 \ on the stack before PICK is executed.
\r
3585 : PICK DEPTH DUP 2 < IF -4 THROW THEN \ stack underflow
\r
3586 2 - OVER U< IF -4 THROW THEN
\r
3587 1+ CELLS sp@ + @ ;
\r
3589 \ $COLON NamePICK,PICK
\r
3590 \ DW DEPTH,DUPP,DoLIT,2,LessThan,ZBranch,PICK1
\r
3591 \ DW DoLIT,-4,THROW
\r
3592 \ PICK1 DW DoLIT,2,Minus,OVER,ULess,ZBranch,PICK2
\r
3593 \ DW DoLIT,-4,THROW
\r
3594 \ PICK2 DW OnePlus,CELLS,SPFetch,Plus,Fetch,EXIT
\r
3596 \ $CODE NamePICK,PICK
\r
3597 \ MOV DI,AddrUserP
\r
3598 \ MOV DI,[DI+CELLL] ; sp0
\r
3600 \ SAR DI,1 ; depth-1 in DI
\r
3609 \ PICK1: MOV BX,-4
\r
3613 \ POSTPONE ( "<spaces>name" -- ) \ CORE
\r
3614 \ Parse name and find it. Append compilation semantics of name
\r
3615 \ to current definition.
\r
3616 \ Structure of words with special compilation action
\r
3617 \ for default compilation behavior
\r
3618 \ |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |
\r
3620 : POSTPONE (') 0< IF
\r
3621 specialComp? OVER = IF \ special compilation action
\r
3622 DUP POSTPONE LITERAL
\r
3625 POSTPONE EXECUTE EXIT THEN
\r
3626 POSTPONE LITERAL \ non-IMMEDIATE
\r
3627 POSTPONE code, EXIT THEN
\r
3628 code, ; COMPILE-ONLY IMMEDIATE \ IMMEDIATE
\r
3630 \ $COLON NamePOSTPONE,POSTPONE
\r
3631 \ DW ParenTick,ZeroLess,ZBranch,POSTP1
\r
3632 \ DW SpecialCompQ,OVER,Equals,ZBranch,POSTP2
\r
3633 \ DW DUPP,LITERAL,CellMinus,CellMinus,CodeFetch
\r
3634 \ DW LITERAL,DoLIT,EXECUTE,CodeComma,EXIT
\r
3635 \ POSTP2 DW LITERAL,DoLIT,CodeComma
\r
3636 \ POSTP1 DW CodeComma,EXIT
\r
3638 \ RECURSE ( -- ) \ CORE
\r
3639 \ Append the execution semactics of the current definition to
\r
3640 \ the current definition.
\r
3642 : RECURSE bal 1- 2* PICK 1+ IF -22 THROW THEN
\r
3643 \ control structure mismatch; colon-sys type is -1
\r
3644 bal 1- 2* 1+ PICK \ xt of current definition
\r
3645 COMPILE, ; COMPILE-ONLY IMMEDIATE
\r
3647 \ $COLON NameRECURSE,RECURSE
\r
3648 \ DW Bal,OneMinus,TwoStar,PICK,OnePlus,ZBranch,RECUR1
\r
3649 \ DW DoLIT,-22,THROW
\r
3650 \ RECUR1 DW Bal,OneMinus,TwoStar,OnePlus,PICK
\r
3651 \ DW COMPILEComma,EXIT
\r
3653 \ REPEAT ( C: orig dest -- ) \ CORE
\r
3654 \ Terminate a BEGIN-WHILE-REPEAT indefinite loop. Resolve
\r
3655 \ backward reference dest and forward reference orig.
\r
3657 : REPEAT POSTPONE AGAIN POSTPONE THEN ; COMPILE-ONLY IMMEDIATE
\r
3659 \ $COLON NameREPEAT,REPEATT
\r
3660 \ DW AGAIN,THENN,EXIT
\r
3662 \ RSHIFT ( x1 u -- x2 ) \ CORE
\r
3663 \ Perform a logical right shift of u bit-places on x1, giving x2.
\r
3664 \ Put 0 into the most significant bits vacated by the shift.
\r
3667 0 SWAP cell-size-in-bits SWAP -
\r
3672 \ $COLON NameRSHIFT,RSHIFT
\r
3673 \ DW QuestionDUP,ZBranch,RSHIFT2
\r
3674 \ DW DoLIT,0,SWAP,DoLIT,CELLL*8,SWAP,Minus,DoLIT,0,DoDO
\r
3675 \ RSHIFT1 DW TwoDUP,DPlus,DoLOOP,RSHIFT1
\r
3679 \ $CODE NameRSHIFT,RSHIFT
\r
3687 \ SLITERAL ( c-addr1 u -- ) \ STRING
\r
3688 \ Run-time ( -- c-addr2 u )
\r
3689 \ Compile a string literal. Return the string on execution.
\r
3691 : SLITERAL ALIGN HERE POSTPONE LITERAL DUP POSTPONE LITERAL
\r
3692 CHARS HERE 2DUP + ALIGNED TO HERE
\r
3693 SWAP MOVE ; COMPILE-ONLY IMMEDIATE
\r
3695 \ $COLON NameSLITERAL,SLITERAL
\r
3696 \ DW ALIGNN,HERE,LITERAL,DUPP,LITERAL
\r
3697 \ DW CHARS,HERE,TwoDUP,Plus,ALIGNED,DoTO,AddrHERE
\r
3698 \ DW SWAP,MOVE,EXIT
\r
3700 \ S" Compilation: ( "ccc<">" -- ) \ CORE
\r
3701 \ Run-time: ( -- c-addr u )
\r
3702 \ Parse ccc delimetered by " . Return the string specification
\r
3703 \ c-addr u on execution.
\r
3705 : S" [CHAR] " PARSE POSTPONE SLITERAL ; COMPILE-ONLY IMMEDIATE
\r
3707 \ $COLON NameSQuote,SQuote
\r
3708 \ DW DoLIT,'"',PARSE,SLITERAL,EXIT
\r
3710 \ SM/REM ( d n1 -- n2 n3 ) \ CORE
\r
3711 \ Symmetric divide of double by single. Return remainder n2
\r
3712 \ and quotient n3.
\r
3714 : SM/REM OVER >R >R DUP 0< IF DNEGATE THEN
\r
3715 R@ ABS UM/MOD DUP 0<
\r
3716 IF DUP [ 16 BASE ! ] 8000 [ DECIMAL ] XOR IF -11 THROW THEN THEN \ result out of range
\r
3717 R> R@ XOR 0< IF NEGATE THEN
\r
3718 R> 0< IF SWAP NEGATE SWAP THEN ;
\r
3720 \ $COLON 6,'SM/REM',SMSlashREM,_FLINK
\r
3721 \ DW OVER,ToR,ToR,DUPP,ZeroLess,ZBranch,SMREM1
\r
3723 \ SMREM1 DW RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,SMREM4
\r
3724 \ DW DUPP,DoLIT,08000h,XORR,ZBranch,SMREM4
\r
3725 \ DW DoLIT,-11,THROW
\r
3726 \ SMREM4 DW RFrom,RFetch,XORR,ZeroLess,ZBranch,SMREM2
\r
3728 \ SMREM2 DW RFrom,ZeroLess,ZBranch,SMREM3
\r
3729 \ DW SWAP,NEGATE,SWAP
\r
3732 \ $CODE NameSMSlashREM,SMSlashREM
\r
3742 \ DIV BX ;positive dividend, positive divisor
\r
3748 \ SMREM3: NEG BX ;positive dividend, negative divisor
\r
3758 \ SMREM2: NEG AX ;DNEGATE
\r
3764 \ CMP DX,BX ;negative dividend, positive divisor
\r
3774 \ SMREM4: NEG BX ;negative dividend, negative divisor
\r
3784 \ SMREM6: MOV BX,-11 ;result out of range
\r
3786 \ SMREM1: MOV BX,-10 ;divide by zero
\r
3790 \ SPACES ( n -- ) \ CORE
\r
3791 \ Send n spaces to the output device if n is greater than zero.
\r
3793 : SPACES DUP 0 > IF 0 DO SPACE LOOP EXIT THEN DROP ;
\r
3795 \ $COLON 6,'SPACES',SPACES,_FLINK
\r
3796 \ DW DUPP,Zero,GreaterThan,ZBranch,SPACES1
\r
3798 \ SPACES2 DW SPACE,DoLOOP,SPACES2
\r
3800 \ SPACES1 DW DROP,EXIT
\r
3802 \ $CODE NameSPACES,SPACES
\r
3809 \ SPACES4: PUSH BX
\r
3810 \ MOV SI,OFFSET SPACES3
\r
3811 \ MOV AX,AddrTickEMIT
\r
3813 \ SPACES1: DEC WORD PTR [BP]
\r
3819 \ SPACES3 DW SPACES1
\r
3821 \ TO Interpretation: ( x "<spaces>name" -- ) \ CORE EXT
\r
3822 \ Compilation: ( "<spaces>name" -- )
\r
3823 \ Run-time: ( x -- )
\r
3824 \ Store x in name.
\r
3826 : TO ' ?call ?DUP IF \ should be CALL
\r
3827 ['] doVALUE = \ verify VALUE marker
\r
3829 IF POSTPONE doTO code, EXIT THEN
\r
3832 -32 THROW ; IMMEDIATE \ invalid name argument (e.g. TO xxx)
\r
3834 \ $COLON NameTO,TO
\r
3835 \ DW Tick,QCall,QuestionDUP,ZBranch,TO1
\r
3836 \ DW DoLIT,DoVALUE,Equals,ZBranch,TO1
\r
3837 \ DW CodeFetch,DoLIT,AddrSTATE,Fetch,ZBranch,TO2
\r
3838 \ DW DoLIT,DoTO,COMPILEComma,CodeComma,EXIT
\r
3839 \ TO2 DW Store,EXIT
\r
3840 \ TO1 DW DoLIT,-32,THROW
\r
3842 \ U. ( u -- ) \ CORE
\r
3843 \ Display u in free field format followed by space.
\r
3847 \ $COLON NameUDot,UDot
\r
3848 \ DW DoLIT,0,DDot,EXIT
\r
3850 \ UNTIL ( C: dest -- ) \ CORE
\r
3851 \ Terminate a BEGIN-UNTIL indefinite loop structure.
\r
3853 : UNTIL IF -22 THROW THEN \ control structure mismatch; dest type is 0
\r
3854 POSTPONE 0branch code, bal- ; COMPILE-ONLY IMMEDIATE
\r
3856 \ $COLON NameUNTIL,UNTIL
\r
3857 \ DW ZBranch,UNTIL1
\r
3858 \ DW DoLIT,-22,THROW
\r
3859 \ UNTIL1 DW DoLIT,ZBranch,COMPILEComma,CodeComma,BalMinus,EXIT
\r
3861 \ VALUE ( x "<spaces>name" -- ) \ CORE EXT
\r
3862 \ name Execution: ( -- x )
\r
3863 \ Create a value object with initial value x.
\r
3865 : VALUE bal IF -29 THROW THEN \ compiler nesting
\r
3866 xhere ALIGNED CELL+ TO xhere
\r
3867 ['] doVALUE xt, head,
\r
3869 , linkLast ; \ store x and link CREATEd word to current wordlist
\r
3871 \ $COLON NameVALUE,VALUE
\r
3872 \ DW Bal,ZBranch,VALUE1
\r
3873 \ DW DoLIT,-29,THROW
\r
3874 \ VALUE1 DW XHere,ALIGNED,CELLPlus,DoTO,AddrXHere
\r
3875 \ DW DoLIT,DoVALUE,xtComma,HeadComma
\r
3876 \ DW ALIGNN,HERE,CodeComma
\r
3877 \ DW Comma,LinkLast,EXIT
\r
3879 \ VARIABLE ( "<spaces>name" -- ) \ CORE
\r
3880 \ name Execution: ( -- a-addr )
\r
3881 \ Parse a name and create a variable with the name.
\r
3882 \ Resolve one cell of data space at an aligned address.
\r
3883 \ Return the address on execution.
\r
3885 : VARIABLE bal IF -29 THROW THEN \ compiler nesting
\r
3886 xhere ALIGNED TO xhere
\r
3887 ['] compileCONST code,
\r
3888 xhere CELL+ TO xhere
\r
3889 ['] doCONST xt, head,
\r
3891 1 CELLS ALLOT \ allocate one cell in data space
\r
3893 lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;
\r
3895 \ $COLON NameVARIABLE,VARIABLE
\r
3896 \ DW Bal,ZBranch,VARIA1
\r
3897 \ DW DoLIT,-29,THROW
\r
3898 \ VARIA1 DW XHere,ALIGNED,DoTO,AddrXHere
\r
3899 \ DW DoLIT,CompileCONST,CodeComma
\r
3900 \ DW XHere,CELLPlus,DoTO,AddrXHere
\r
3901 \ DW DoLIT,DoCONST,xtComma,HeadComma
\r
3902 \ DW ALIGNN,HERE,DoLIT,1*CELLL,ALLOT
\r
3903 \ DW CodeComma,LinkLast
\r
3904 \ DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
3906 \ WHILE ( C: dest -- orig dest ) \ CORE
\r
3907 \ Put the location of a new unresolved forward reference orig
\r
3908 \ onto the control flow stack under the existing dest. Typically
\r
3909 \ used in BEGIN ... WHILE ... REPEAT structure.
\r
3911 : WHILE POSTPONE IF 2SWAP ; COMPILE-ONLY IMMEDIATE
\r
3913 \ $COLON NameWHILE,WHILEE
\r
3914 \ DW IFF,TwoSWAP,EXIT
\r
3916 \ WORD ( char "<chars>ccc<char>" -- c-addr ) \ CORE
\r
3917 \ Skip leading delimeters and parse a word. Return the address
\r
3918 \ of a transient region containing the word as counted string.
\r
3920 : WORD skipPARSE HERE pack" DROP HERE ;
\r
3922 \ $COLON NameWORDD,WORDD
\r
3923 \ DW SkipPARSE,HERE,PackQuote,DROP,HERE,EXIT
\r
3925 \ ['] Compilation: ( "<spaces>name" -- ) \ CORE
\r
3926 \ Run-time: ( -- xt )
\r
3927 \ Parse name. Return the execution token of name on execution.
\r
3929 : ['] ' POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE
\r
3931 \ $COLON NameBracketTick,BracketTick
\r
3932 \ DW Tick,LITERAL,EXIT
\r
3934 \ [CHAR] Compilation: ( "<spaces>name" -- ) \ CORE
\r
3935 \ Run-time: ( -- char )
\r
3936 \ Parse name. Return the value of the first character of name
\r
3939 : [CHAR] CHAR POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE
\r
3941 \ $COLON NameBracketCHAR,BracketCHAR
\r
3942 \ DW CHAR,LITERAL,EXIT
\r
3944 \ \ ( "ccc<eol>" -- ) \ CORE EXT
\r
3945 \ Parse and discard the remainder of the parse area.
\r
3947 : \ SOURCE >IN ! DROP ; IMMEDIATE
\r
3949 \ $COLON NameBackslash,Backslash
\r
3950 \ DW SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT
\r
3952 \ Optional Facility words
\r
3954 \ EKEY? ( -- flag ) \ FACILITY EXT
\r
3955 \ If a keyboard event is available, return true.
\r
3957 : EKEY? 'ekey? EXECUTE ;
\r
3959 \ $COLON NameEKEYQuestion,EKEYQuestion
\r
3960 \ DW TickEKEYQ,EXECUTE,EXIT
\r
3962 \ $CODE NameEKEYQuestion,EKEYQuestion
\r
3963 \ MOV AX,AddrTickEKEYQ
\r
3967 \ EMIT? ( -- flag ) \ FACILITY EXT
\r
3968 \ flag is true if the user output device is ready to accept data
\r
3969 \ and the execution of EMIT in place of EMIT? would not have
\r
3970 \ suffered an indefinite delay. If device state is indeterminate,
\r
3973 : EMIT? 'emit? EXECUTE ;
\r
3975 \ $COLON NameEMITQuestion,EMITQuestion
\r
3976 \ DW TickEMITQ,EXECUTE,EXIT
\r
3978 \ $CODE NameEMITQuestion,EMITQuestion
\r
3979 \ MOV AX,AddrTickEMITQ
\r
3988 ' set-i/o TO 'init-i/o
\r
3991 ' optiCOMPILE, 'doWord !
\r
3992 \ ' EXECUTE 'doWord 2 + !
\r
3993 ' doubleAlso, 'doWord 4 + !
\r
3994 ' doubleAlso 'doWord 6 + !
\r
3995 \ ' EXECUTE 'doWord 8 + !
\r
3996 \ ' EXECUTE 'doWord 10 + !
\r
public / hf86v099.git / blob