--- /dev/null
+\ Nick\r
+10 CONSTANT linefeed-char\r
+13 CONSTANT carriage-return-char\r
+32 CONSTANT blank-char-value\r
+\r
+1 CONSTANT char-size\r
+2 CONSTANT cell-size\r
+\r
+16 BASE !\r
+ 0FF CONSTANT max-char\r
+ 7FFF CONSTANT max-signed\r
+ 0FFFF CONSTANT max-unsigned\r
+ 8000 CONSTANT max-negative\r
+\r
+ 20 CONSTANT =compo\r
+ 40 CONSTANT =immed\r
+ 80 CONSTANT =seman\r
+ 1F CONSTANT =mask\r
+DECIMAL\r
+\r
+258 CONSTANT size-of-PAD\r
+\r
+8 CONSTANT bsp#\r
+9 CONSTANT tab#\r
+13 CONSTANT cr#\r
+10 CONSTANT lf#\r
+127 CONSTANT del#\r
+\r
+16 BASE !\r
+ 0E890 CONSTANT call-code\r
+DECIMAL\r
+\r
+\ ;;;;;;;;;;;;;;;\r
+\ System dependent words -- Must be re-definded for each system.\r
+\ ;;;;;;;;;;;;;;;\r
+\ I/O words must be redefined if serial communication is used instead of\r
+\ keyboard. Following words are for MS-DOS system.\r
+\r
+\ TX? ( -- flag )\r
+\ Return true if output device is ready or device state is\r
+\ indeterminate.\r
+\r
+\ $CONST NameTXQ,TXQ,TRUEE ;always true for MS-DOS\r
+\r
+\ CR ( -- ) \ CORE\r
+\ Carriage return and linefeed.\r
+\r
+: CR carriage-return-char EMIT linefeed-char EMIT ;\r
+\r
+\ $COLON NameCR,CR\r
+\ DW DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT\r
+\r
+\ hi ( -- )\r
+\r
+: hi CR ." hForth "\r
+ S" CPU" ENVIRONMENT? DROP TYPE SPACE\r
+ S" model" ENVIRONMENT? DROP TYPE SPACE [CHAR] v EMIT\r
+ S" version" ENVIRONMENT? DROP TYPE\r
+ ." by Wonyong Koh, 1997" CR\r
+ ." ALL noncommercial and commercial uses are granted." CR\r
+ ." Please send comment, bug report and suggestions to:" CR\r
+ ." wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr" CR ;\r
+\r
+\ $COLON NameHI,HI\r
+\ DW CR,DoLIT,HiStr1,COUNT,TYPEE\r
+\ DW DoLIT,CPUQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE,SPACE\r
+\ DW DoLIT,ModelQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE\r
+\ DW SPACE,DoLIT,'v',EMIT\r
+\ DW DoLIT,VersionQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE\r
+\ DW DoLIT,HiStr2,COUNT,TYPEE,CR\r
+\ DW DoLIT,HiStr3,COUNT,TYPEE,CR\r
+\ DW DoLIT,HiStr4,COUNT,TYPEE,CR\r
+\ DW DoLIT,HiStr5,COUNT,TYPEE,CR,EXIT\r
+\r
+\ COLD ( -- )\r
+\ The cold start sequence execution word.\r
+\r
+: COLD sp0 sp! rp0 rp! \ initialize stack\r
+ 'init-i/o EXECUTE\r
+ 'boot EXECUTE\r
+ QUIT ; \ start interpretation\r
+\r
+\ $COLON NameCOLD,COLD\r
+\ DW SPZero,SPStore,RPZero,RPStore\r
+\ DW TickINIT_IO,EXECUTE,TickBoot,EXECUTE\r
+\ DW QUIT\r
+\r
+\ set-i/o ( -- )\r
+\ Set input/output device.\r
+\r
+: set-i/o S" CON" stdin ; \ MS-DOS only\r
+\r
+\ $COLON NameSet_IO,Set_IO\r
+\ Nick removed this, want to use ordinary DOS redirection instead\r
+\ DW DoLIT,Set_IOstr ;MS-DOS only\r
+\ DW COUNT,STDIN ;MS-DOS only\r
+\ DW EXIT\r
+\r
+\ asciiz ( ca1 u -- ca2 )\r
+\ Return ASCIIZ string.\r
+\r
+: asciiz HERE SWAP 2DUP + 0 SWAP C! CHARS MOVE HERE ;\r
+\r
+\ $COLON NameASCIIZ,ASCIIZ\r
+\ DW HERE,SWAP,TwoDUP,Plus,DoLIT,0\r
+\ DW SWAP,CStore,CHARS,MOVE,HERE,EXIT\r
+\r
+\ stdin ( ca u -- )\r
+\r
+: stdin asciiz redirect ?DUP\r
+ IF -38 THROW THEN \ non-existent file\r
+ ; COMPILE-ONLY\r
+\r
+\ $COLON NameSTDIN,STDIN\r
+\ DW ASCIIZ,Redirect,QuestionDUP,ZBranch,STDIN1\r
+\ DW DoLIT,-38,THROW\r
+\ STDIN1 DW EXIT\r
+\r
+\ << ( "<spaces>ccc" -- )\r
+\ Redirect input from the file 'ccc'. Should be used only in\r
+\ interpretation state.\r
+\r
+: << STATE @ IF ." Do not use '<<' in a definition." ABORT THEN\r
+ PARSE-WORD stdin SOURCE >IN ! DROP ; IMMEDIATE\r
+\r
+\ $COLON NameFROM,FROM\r
+\ DW DoLIT,AddrSTATE,Fetch,ZBranch,FROM1\r
+\ DW CR\r
+\ DW DoLIT,FROMstr\r
+\ DW COUNT,TYPEE,ABORT\r
+\ FROM1 DW PARSE_WORD,STDIN,SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT\r
+\r
+\ ;;;;;;;;;;;;;;;\r
+\ Non-Standard words - Processor-dependent definitions\r
+\ 16 bit Forth for 8086/8\r
+\ ;;;;;;;;;;;;;;;\r
+\r
+\ PAUSE ( -- )\r
+\ Stop current task and transfer control to the task of which\r
+\ 'status' USER variable is stored in 'follower' USER variable\r
+\ of current task.\r
+\r
+: PAUSE rp@ DUP sp@ stackTop ! follower @ code@ >R ; COMPILE-ONLY\r
+\r
+\ $COLON NamePAUSE,PAUSE\r
+\ DW RPFetch,DUPP,SPFetch,StackTop,Store\r
+\ DW Follower,Fetch,CodeFetch,ToR,EXIT\r
+\r
+\ $CODE NamePAUSE,PAUSE\r
+\ PUSH BX\r
+\ XCHG BP,SP\r
+\ PUSH SI\r
+\ XCHG BP,SP\r
+\ PUSH BP\r
+\ MOV BX,WORD PTR AddrUserP\r
+\ StackTopOffset = SysStackTop - SysUserP\r
+\ MOV [BX+StackTopOffset],SP\r
+\ FollowerOffset = SysFollower - SysUserP\r
+\ MOV BX,[BX+FollowerOffset]\r
+\ MOV SI,CS:[BX]\r
+\ $NEXT\r
+\r
+\ wake ( -- )\r
+\ Wake current task.\r
+\r
+: wake R> CELL+ code@ userP ! \ userP points 'follower' of current task\r
+ stackTop @ sp! DROP \ set data stack\r
+ rp! ; COMPILE-ONLY \ set return stack\r
+\r
+\ $COLON NameWake,Wake\r
+\ DW RFrom,CELLPlus,CodeFetch,DoLIT,AddrUserP,Store\r
+\ DW StackTop,Fetch,SPStore,DROP,RPStore,EXIT\r
+\r
+\ $CODE NameWake,Wake\r
+\ MOV BX,CS:[SI+CELLL]\r
+\ MOV WORD PTR AddrUserP,BX\r
+\ MOV SP,[BX+StackTopOffset]\r
+\ POP BP\r
+\ XCHG BP,SP\r
+\ POP SI\r
+\ XCHG BP,SP\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ same? ( c-addr1 c-addr2 u -- -1|0|1 )\r
+\ Return 0 if two strings, ca1 u and ca2 u, are same; -1 if\r
+\ string, ca1 u is smaller than ca2 u; 1 otherwise. Used by\r
+\ '(search-wordlist)'. Code definition is preferred to speed up\r
+\ interpretation. Colon definition is shown below.\r
+\r
+: same? ?DUP IF \ null strings are always same\r
+ 0 DO OVER C@ OVER C@ XOR\r
+ IF UNLOOP C@ SWAP C@ > 2* 1+ EXIT THEN\r
+ CHAR+ SWAP CHAR+ SWAP\r
+ LOOP\r
+ THEN 2DROP 0 ;\r
+\r
+\ $COLON NameSameQ,SameQ\r
+\ DW QuestionDUP,ZBranch,SAMEQ4\r
+\ DW DoLIT,0,DoDO\r
+\ SAMEQ3 DW OVER,CFetch,OVER,CFetch,XORR,ZBranch,SAMEQ2\r
+\ DW UNLOOP,CFetch,SWAP,CFetch,GreaterThan\r
+\ DW TwoStar,OnePlus,EXIT\r
+\ SAMEQ2 DW CHARPlus,SWAP,CHARPlus\r
+\ DW DoLOOP,SAMEQ3\r
+\ SAMEQ4 DW TwoDROP,DoLIT,0,EXIT\r
+\r
+\ $CODE NameSameQ,SameQ\r
+\ MOV CX,BX\r
+\ MOV AX,DS\r
+\ MOV ES,AX\r
+\ MOV DX,SI ;save SI\r
+\ MOV BX,-1\r
+\ POP DI\r
+\ POP SI\r
+\ OR CX,CX\r
+\ JZ SAMEQ5\r
+\ REPE CMPSB\r
+\ JL SAMEQ1\r
+\ JZ SAMEQ5\r
+\ INC BX\r
+\ SAMEQ5: INC BX\r
+\ SAMEQ1: MOV SI,DX\r
+\ $NEXT\r
+\r
+\ (search-wordlist) ( c-addr u wid -- 0 | xt f 1 | xt f -1)\r
+\ Search word list for a match with the given name.\r
+\ Return execution token and not-compile-only flag and\r
+\ -1 or 1 ( IMMEDIATE) if found. Return 0 if not found.\r
+\\r
+\ format is: wid---->[ a ]\r
+\ |\r
+\ V\r
+\ [ xt' ][ a' ][ccbbaann][ggffeedd]...\r
+\ |\r
+\ +--------+\r
+\ V\r
+\ [ xt'' ][ a'' ][ccbbaann][ggffeedd]...\r
+\\r
+\ a, a' etc. point to the cell that contains the name of the\r
+\ word. The length is in the low byte of the cell (little byte\r
+\ for little-endian, big byte for big-endian).\r
+\ Eventually, a''' contains 0 to indicate the end of the wordlist\r
+\ (oldest entry). a=0 indicates an empty wordlist.\r
+\ xt is the xt of the word. aabbccddeedd etc. is the name of\r
+\ the word, packed into cells.\r
+\r
+: (search-wordlist)\r
+ ROT >R SWAP DUP 0= IF -16 THROW THEN\r
+ \ attempt to use zero-length string as a name\r
+ >R \ wid R: ca1 u\r
+ BEGIN @ \ ca2 R: ca1 u\r
+ DUP 0= IF R> R> 2DROP EXIT THEN \ not found\r
+ DUP COUNT [ =mask ] LITERAL AND R@ = \ ca2 ca2+char f\r
+ IF R> R@ SWAP DUP >R \ ca2 ca2+char ca1 u\r
+ same? \ ca2 flag\r
+ \ ELSE DROP -1 \ unnecessary since ca2+char is not 0.\r
+ THEN\r
+ WHILE cell- \ pointer to next word in wordlist\r
+ REPEAT\r
+ R> R> 2DROP DUP name>xt SWAP \ xt ca2\r
+ C@ 2DUP [ =seman ] LITERAL AND 0= 0= \ xt char xt f\r
+ AND TO specialComp?\r
+ DUP [ =compo ] LITERAL AND 0= SWAP\r
+ [ =immed ] LITERAL AND 0= 2* 1+ ;\r
+\r
+\ $COLON NameParenSearch_Wordlist,ParenSearch_Wordlist\r
+\ DW ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6\r
+\ DW ToR\r
+\ PSRCH1 DW Fetch\r
+\ DW DUPP,ZBranch,PSRCH9\r
+\ DW DUPP,COUNT,DoLIT,MASKK,ANDD,RFetch,Equals\r
+\ DW ZBranch,PSRCH5\r
+\ DW RFrom,RFetch,SWAP,DUPP,ToR,SameQ\r
+\ PSRCH5 DW ZBranch,PSRCH3\r
+\ DW CellMinus,Branch,PSRCH1\r
+\ PSRCH3 DW RFrom,RFrom,TwoDROP,DUPP,NameToXT,SWAP\r
+\ DW CFetch,TwoDUP,DoLIT,SEMAN,ANDD,ZeroEquals,ZeroEquals\r
+\ DW ANDD,DoTO,AddrSpecialCompQ\r
+\ DW DUPP,DoLIT,COMPO,ANDD,ZeroEquals,SWAP\r
+\ DW DoLIT,IMMED,ANDD,ZeroEquals,TwoStar,OnePlus,EXIT\r
+\ PSRCH9 DW RFrom,RFrom,TwoDROP,EXIT\r
+\ PSRCH6 DW DoLIT,-16,THROW\r
+\r
+\ $CODE NameParenSearch_Wordlist,ParenSearch_Wordlist\r
+\ POP AX ;u\r
+\ POP DX ;c-addr\r
+\ OR AX,AX\r
+\ JZ PSRCH1\r
+\ PUSH SI\r
+\ MOV CX,DS\r
+\ MOV ES,CX\r
+\ SUB CX,CX\r
+\ PSRCH2: MOV BX,[BX]\r
+\ OR BX,BX\r
+\ JZ PSRCH4 ; end of wordlist?\r
+\ MOV CL,[BX]\r
+\ SUB BX,CELLL ;pointer to nextword\r
+\ AND CL,MASKK ;max name length = MASKK\r
+\ CMP CL,AL\r
+\ JNZ PSRCH2\r
+\ MOV SI,DX\r
+\ MOV DI,BX\r
+\ ADD DI,CELLL+CHARR\r
+\ REPE CMPSB\r
+\ JNZ PSRCH2\r
+\ POP SI\r
+\ PUSH [BX-CELLL] ;xt\r
+\ MOV AL,0FFh\r
+\ MOV CL,[BX+CELLL]\r
+\ AND AL,CL ;test SEMAN = 080h\r
+\ CBW\r
+\ CWD\r
+\ AND DX,[BX-CELLL]\r
+\ MOV AddrSpecialCompQ,DX\r
+\ XOR DX,DX\r
+\ TEST CL,COMPO\r
+\ JNZ PSRCH5\r
+\ DEC DX\r
+\ PSRCH5: PUSH DX\r
+\ TEST CL,IMMED\r
+\ MOV BX,-1\r
+\ JZ PSRCH3\r
+\ NEG BX\r
+\ PSRCH3: $NEXT\r
+\ PSRCH1: MOV BX,-16 ;attempt to use zero-length string as a name\r
+\ JMP THROW\r
+\ PSRCH4: POP SI\r
+\ $NEXT\r
+\r
+\ ?call ( xt1 -- xt1 0 | code-addr xt2 )\r
+\ Return xt of the CALLed run-time word if xt starts with machine\r
+\ CALL instruction and leaves the next cell address after the\r
+\ CALL instruction. Otherwise leaves the original xt1 and zero.\r
+\r
+: ?call DUP code@ call-code =\r
+ IF CELL+ DUP code@ SWAP CELL+ DUP ROT + EXIT THEN\r
+ \ Direct Threaded Code 8086 relative call\r
+ 0 ;\r
+\r
+\ $COLON NameQCall,QCall\r
+\ DW DUPP,CodeFetch,DoLIT,CALLL,Equals,ZBranch,QCALL1\r
+\ DW CELLPlus,DUPP,CodeFetch,SWAP,CELLPlus,DUPP,ROT,Plus\r
+\ DW EXIT\r
+\ QCALL1 DW DoLIT,0,EXIT\r
+\r
+\ $CODE NameQCall,QCall\r
+\ MOV AX,CS:[BX]\r
+\ CMP AX,CALLL\r
+\ JE QCALL1\r
+\ PUSH BX\r
+\ XOR BX,BX\r
+\ $NEXT\r
+\ QCALL1: ADD BX,2*CELLL\r
+\ PUSH BX\r
+\ ADD BX,CS:[BX-CELLL]\r
+\ $NEXT\r
+\r
+\ xt, ( xt1 -- xt2 )\r
+\ Take a run-time word xt1 for :NONAME , CONSTANT , VARIABLE and\r
+\ CREATE . Return xt2 of current definition.\r
+\r
+: xt, xhere ALIGNED DUP TO xhere SWAP\r
+ call-code code, \ Direct Threaded Code\r
+ xhere CELL+ - code, ; \ 8086 relative call\r
+\r
+\ $COLON NamextComma,xtComma\r
+\ DW XHere,ALIGNED,DUPP,DoTO,AddrXHere,SWAP\r
+\ DW DoLIT,CALLL,CodeComma\r
+\ DW XHere,CELLPlus,Minus,CodeComma,EXIT\r
+\r
+\ $CODE NamextComma,xtComma\r
+\ MOV AX,AddrXHere\r
+\ XCHG BX,AX\r
+\ INC BX\r
+\ AND BX,0FFFEh\r
+\ MOV WORD PTR CS:[BX],CALLL\r
+\ MOV CX,BX\r
+\ ADD CX,2*CELLL\r
+\ MOV AddrXHere,CX\r
+\ SUB AX,CX\r
+\ MOV CS:[BX+CELLL],AX\r
+\ $NEXT\r
+\r
+\ doLIT ( -- x )\r
+\ Push an inline literal. The inline literal is at the current\r
+\ value of the fpc, so put it onto the stack and point past it.\r
+\r
+\ $CODE NameDoLIT,DoLIT\r
+\ PUSH BX\r
+\ LODS WORD PTR CS:[SI]\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\r
+\ doCONST ( -- x )\r
+\ Run-time routine of CONSTANT and initializable system\r
+\ VARIABLE. When you quote a constant or variable you execute\r
+\ its code, which consists of a call to here, followed by an\r
+\ inline literal. The literal is a constant (for a CONSTANT) or\r
+\ the address at which a VARIABLE's value is stored. Although\r
+\ you come here as the result of a native machine call, you\r
+\ never go back to the return address -- you jump back up a\r
+\ level by continuing at the new fpc value. For 8086, Z80 the\r
+\ inline literal is at the return address stored on the top of\r
+\ the hardware stack.\r
+\r
+\ $CODE NameDoCONST,DoCONST\r
+\ MOV DI,SP\r
+\ XCHG BX,[DI]\r
+\ MOV BX,CS:[BX]\r
+\ $NEXT\r
+\r
+\ doVALUE ( -- x )\r
+\ Run-time routine of VALUE. Return the value of VALUE word.\r
+\ This is like an invocation of doCONST for a VARIABLE but\r
+\ instead of returning the address of the variable, we return\r
+\ the value of the variable -- in other words, there is another\r
+\ level of indirection.\r
+\r
+\ $CODE NameDoVALUE,DoVALUE\r
+\ MOV DI,SP\r
+\ XCHG BX,[DI]\r
+\ MOV BX,CS:[BX]\r
+\ MOV BX,[BX]\r
+\ $NEXT\r
+\r
+\ doCREATE ( -- a-addr )\r
+\ Run-time routine of CREATE. For CREATEd words with an\r
+\ associated DOES>, get the address of the CREATEd word's data\r
+\ space and execute the DOES> actions. For CREATEd word without\r
+\ an associated DOES>, return the address of the CREATE'd word's\r
+\ data space. A CREATEd word starts its execution through this\r
+\ routine in exactly the same way as a colon definition uses\r
+\ doLIST. In other words, we come here through a native machine\r
+\ branch.\r
+\\r
+\ Structure of CREATEd word:\r
+\ | call-doCREATE | 0 or DOES> code addr | a-addr |\r
+\\r
+\ The DOES> address holds a native call to doLIST. This routine\r
+\ doesn't alter the fpc. We never come back *here* so we never\r
+\ need to preserve an address that would bring us back *here*.\r
+\\r
+\ Example : myVARIABLE CREATE , DOES> ;\r
+\ 56 myVARIABLE JIM\r
+\ JIM \ stacks the address of the data cell that contains 56\r
+\r
+: doCREATE SWAP \ switch BX and top of 8086 stack item\r
+ DUP CELL+ code@ SWAP code@ ?DUP IF EXECUTE THEN\r
+ ; COMPILE-ONLY\r
+\r
+\ $COLON NameDoCREATE,DoCREATE\r
+\ DW SWAP,CELLPlus,DUPP,CodeFetch,SWAP,CodeFetch\r
+\ DW QuestionDUP,ZBranch,DOCREAT1\r
+\ DW EXECUTE\r
+\ DOCREAT1 DW EXIT\r
+\r
+\ $CODE NameDoCREATE,DoCREATE\r
+\ MOV DI,SP\r
+\ XCHG BX,[DI]\r
+\ MOV AX,CS:[BX]\r
+\ MOV BX,CS:[BX+CELLL]\r
+\ OR AX,AX\r
+\ JNZ DOCREAT1\r
+\ $NEXT\r
+\ DOCREAT1: JMP AX\r
+\ $ALIGN\r
+\r
+\ doTO ( x -- )\r
+\ Run-time routine of TO. Store x at the address in the\r
+\ following cell. The inline literal holds the address\r
+\ to be modified.\r
+\r
+\ $CODE NameDoTO,DoTO\r
+\ LODS WORD PTR CS:[SI]\r
+\ XCHG BX,AX\r
+\ MOV [BX],AX\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ doUSER ( -- a-addr )\r
+\ Run-time routine of USER. Return address of data space.\r
+\ This is like doCONST but a variable offset is added to the\r
+\ result. By changing the value at AddrUserP (which happens\r
+\ on a taskswap) the whole set of user variables is switched\r
+\ to the set for the new task.\r
+\r
+\ $CODE NameDoUSER,DoUSER\r
+\ MOV DI,SP\r
+\ XCHG BX,[DI]\r
+\ MOV BX,CS:[BX]\r
+\ ADD BX,AddrUserP\r
+\ $NEXT\r
+\r
+\ doLIST ( -- ) ( R: -- nest-sys )\r
+\ Process colon list.\r
+\ The first word of a definition (the xt for the word) is a\r
+\ native machine-code instruction for the target machine. For\r
+\ high-level definitions, that code is emitted by xt, and\r
+\ performs a call to doLIST. doLIST executes the list of xt that\r
+\ make up the definition. The final xt in the definition is EXIT.\r
+\ The address of the first xt to be executed is passed to doLIST\r
+\ in a target-specific way. Two examples:\r
+\ Z80, 8086: native machine call, leaves the return address on\r
+\ the hardware stack pointer, which is used for the data stack.\r
+\r
+\ $CODE NameDoLIST,DoLIST\r
+\ SUB BP,2\r
+\ MOV [BP],SI ;push return stack\r
+\ POP SI ;new list address\r
+\ $NEXT\r
+\r
+\ doLOOP ( -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+\ Run time routine for LOOP.\r
+\r
+\ $CODE NameDoLOOP,DoLOOP\r
+\ INC WORD PTR [BP] ;increase loop count\r
+\ JO DoLOOP1 ;?loop end\r
+\ MOV SI,CS:[SI] ;no, go back\r
+\ $NEXT\r
+\ DoLOOP1: ADD SI,CELLL ;yes, continue past the branch offset\r
+\ ADD BP,2*CELLL ;clear return stack\r
+\ $NEXT\r
+\r
+\ do+LOOP ( n -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+\ Run time routine for +LOOP.\r
+\r
+\ $CODE NameDoPLOOP,DoPLOOP\r
+\ ADD WORD PTR [BP],BX ;increase loop count\r
+\ JO DoPLOOP1 ;?loop end\r
+\ MOV SI,CS:[SI] ;no, go back\r
+\ POP BX\r
+\ $NEXT\r
+\ DoPLOOP1: ADD SI,CELLL ;yes, continue past the branch offset\r
+\ ADD BP,2*CELLL ;clear return stack\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ 0branch ( flag -- )\r
+\ Branch if flag is zero.\r
+\r
+\ $CODE NameZBranch,ZBranch\r
+\ OR BX,BX ;?flag=0\r
+\ JZ ZBRAN1 ;yes, so branch\r
+\ ADD SI,CELLL ;point IP to next cell\r
+\ POP BX\r
+\ $NEXT\r
+\ ZBRAN1: MOV SI,CS:[SI] ;IP:=(IP)\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ branch ( -- )\r
+\ Branch to an inline address.\r
+\r
+\ $CODE NameBranch,Branch\r
+\ MOV SI,CS:[SI] ;IP:=(IP)\r
+\ $NEXT\r
+\r
+\ rp@ ( -- a-addr )\r
+\ Push the current RP to the data stack.\r
+\r
+\ $CODE NameRPFetch,RPFetch\r
+\ PUSH BX\r
+\ MOV BX,BP\r
+\ $NEXT\r
+\r
+\ rp! ( a-addr -- )\r
+\ Set the return stack pointer.\r
+\r
+\ $CODE NameRPStore,RPStore\r
+\ MOV BP,BX\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ sp@ ( -- a-addr )\r
+\ Push the current data stack pointer.\r
+\r
+\ $CODE NameSPFetch,SPFetch\r
+\ PUSH BX\r
+\ MOV BX,SP\r
+\ $NEXT\r
+\r
+\ sp! ( a-addr -- )\r
+\ Set the data stack pointer.\r
+\r
+\ $CODE NameSPStore,SPStore\r
+\ MOV SP,BX\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ um+ ( u1 u2 -- u3 1|0 )\r
+\ Add two unsigned numbers, return the sum and carry.\r
+\r
+\ $CODE NameUMPlus,UMPlus\r
+\ XOR CX,CX\r
+\ POP AX\r
+\ ADD BX,AX\r
+\ PUSH BX ;push sum\r
+\ RCL CX,1 ;get carry\r
+\ MOV BX,CX\r
+\ $NEXT\r
+\r
+\ code! ( x code-addr -- )\r
+\ Store x at a code space address.\r
+\r
+\ $CODE NameCodeStore,CodeStore\r
+\ POP CS:[BX]\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ codeB! ( b code-addr -- )\r
+\ Store byte at a code space address.\r
+\r
+\ $CODE NameCodeBStore,CodeBStore\r
+\ POP AX\r
+\ MOV CS:[BX],AL\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ code@ ( code-addr -- x )\r
+\ Push the contents at code space addr to the data stack.\r
+\r
+\ $CODE NameCodeFetch,CodeFetch\r
+\ MOV BX,CS:[BX]\r
+\ $NEXT\r
+\r
+\ codeB@ ( code-addr -- b )\r
+\ Push the contents at code space byte addr to the data stack.\r
+\r
+\ $CODE NameCodeBFetch,CodeBFetch\r
+\ MOV BL,CS:[BX]\r
+\ XOR BH,BH\r
+\ $NEXT\r
+\r
+\ code, ( x -- )\r
+\ Reserve one cell in code space and store x in it.\r
+\r
+: code, xhere DUP CELL+ TO xhere code! ; COMPILE-ONLY\r
+\r
+\ $COLON NameCodeComma,CodeComma\r
+\ DW XHere,DUPP,CELLPlus,DoTO,AddrXHere,CodeStore,EXIT\r
+\r
+\ $CODE NameCodeComma,CodeComma\r
+\ MOV DI,AddrXHere\r
+\ MOV CS:[DI],BX\r
+\ ADD DI,CELLL\r
+\ POP BX\r
+\ MOV AddrXHere,DI\r
+\ $NEXT\r
+\r
+\ ;;;;;;;;;;;;;;;\r
+\ Standard words - Processor-dependent definitions\r
+\ 16 bit Forth for 8086/8\r
+\ ;;;;;;;;;;;;;;;\r
+\r
+\ ALIGN ( -- ) \ CORE\r
+\ Align the data space pointer.\r
+\r
+: ALIGN HERE ALIGNED TO HERE ;\r
+\r
+\ $COLON NameALIGNN,ALIGNN\r
+\ DW HERE,ALIGNED,DoTO,AddrHERE,EXIT\r
+\r
+\ ALIGNED ( addr -- a-addr ) \ CORE\r
+\ Align address to the cell boundary.\r
+\r
+: ALIGNED DUP 0 cell-size UM/MOD DROP DUP\r
+ IF cell-size SWAP - THEN + ;\r
+\r
+\ $COLON NameALIGNED,ALIGNED\r
+\ DW DUPP,DoLIT,0,DoLIT,CELLL\r
+\ DW UMSlashMOD,DROP,DUPP\r
+\ DW ZBranch,ALGN1\r
+\ DW DoLIT,CELLL,SWAP,Minus\r
+\ ALGN1 DW Plus,EXIT\r
+\r
+\ $CODE NameALIGNED,ALIGNED\r
+\ INC BX\r
+\ AND BX,0FFFEh\r
+\ $NEXT\r
+\r
+\ CELLS ( n1 -- n2 ) \ CORE\r
+\ Calculate number of address units for n1 cells.\r
+\r
+\ : CELLS cell-size * ; \ slow, very portable\r
+: CELLS 2* ; \ fast, must be redefined for each system\r
+\r
+\ $COLON NameCELLS,CELLS\r
+\ DW TwoStar,EXIT\r
+\r
+\ $CODE NameCELLS,CELLS\r
+\ SHL BX,1\r
+\ $NEXT\r
+\r
+\ CHARS ( n1 -- n2 ) \ CORE\r
+\ Calculate number of address units for n1 characters.\r
+\r
+\ : CHARS char-size * ; \ slow, very portable\r
+: CHARS ; \ fast, must be redefined for each system\r
+\r
+\ $COLON NameCHARS,CHARS\r
+\ DW EXIT\r
+\r
+\ 1chars/ ( n1 -- n2 )\r
+\ Calculate number of chars for n1 address units.\r
+\r
+\ : 1chars/ 1 CHARS / ; \ slow, very portable\r
+: 1chars/ ; \ fast, must be redefined for each system\r
+\r
+\ $COLON NameOneCharsSlash,OneCharsSlash\r
+\ DW EXIT\r
+\r
+\ ! ( x a-addr -- ) \ CORE\r
+\ Store x at a aligned address.\r
+\r
+\ $CODE NameStore,Store\r
+\ POP [BX]\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ 0< ( n -- flag ) \ CORE\r
+\ Return true if n is negative.\r
+\r
+\ $CODE NameZeroLess,ZeroLess\r
+\ MOV AX,BX\r
+\ CWD ;sign extend\r
+\ MOV BX,DX\r
+\ $NEXT\r
+\r
+\ 0= ( x -- flag ) \ CORE\r
+\ Return true if x is zero.\r
+\r
+\ $CODE NameZeroEquals,ZeroEquals\r
+\ OR BX,BX\r
+\ MOV BX,TRUEE\r
+\ JZ ZEQUAL1\r
+\ INC BX\r
+\ ZEQUAL1: $NEXT\r
+\r
+\ 2* ( x1 -- x2 ) \ CORE\r
+\ Bit-shift left, filling the least significant bit with 0.\r
+\r
+\ $CODE NameTwoStar,TwoStar\r
+\ SHL BX,1\r
+\ $NEXT\r
+\r
+\ 2/ ( x1 -- x2 ) \ CORE\r
+\ Bit-shift right, leaving the most significant bit unchanged.\r
+\r
+\ $CODE NameTwoSlash,TwoSlash\r
+\ SAR BX,1\r
+\ $NEXT\r
+\r
+\ >R ( x -- ) ( R: -- x ) \ CORE\r
+\ Move top of the data stack item to the return stack.\r
+\r
+\ $CODE NameToR,ToR\r
+\ SUB BP,CELLL ;adjust RP\r
+\ MOV [BP],BX\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ @ ( a-addr -- x ) \ CORE\r
+\ Push the contents at a-addr to the data stack.\r
+\r
+\ $CODE NameFetch,Fetch\r
+\ MOV BX,[BX]\r
+\ $NEXT\r
+\r
+\ AND ( x1 x2 -- x3 ) \ CORE\r
+\ Bitwise AND.\r
+\r
+\ $CODE NameANDD,ANDD\r
+\ POP AX\r
+\ AND BX,AX\r
+\ $NEXT\r
+\r
+\ C! ( char c-addr -- ) \ CORE\r
+\ Store char at c-addr.\r
+\r
+\ $CODE NameCStore,CStore\r
+\ POP AX\r
+\ MOV [BX],AL\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ C@ ( c-addr -- char ) \ CORE\r
+\ Fetch the character stored at c-addr.\r
+\r
+\ $CODE NameCFetch,CFetch\r
+\ MOV BL,[BX]\r
+\ XOR BH,BH\r
+\ $NEXT\r
+\r
+\ DROP ( x -- ) \ CORE\r
+\ Discard top stack item.\r
+\r
+\ $CODE NameDROP,DROP\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ DUP ( x -- x x ) \ CORE\r
+\ Duplicate the top stack item.\r
+\r
+\ $CODE NameDUPP,DUPP\r
+\ PUSH BX\r
+\ $NEXT\r
+\r
+\ EXECUTE ( i*x xt -- j*x ) \ CORE\r
+\ Perform the semantics indentified by execution token, xt.\r
+\r
+\ $CODE NameEXECUTE,EXECUTE\r
+\ MOV AX,BX\r
+\ POP BX\r
+\ JMP AX ;jump to the code address\r
+\ $ALIGN\r
+\r
+\ EXIT ( -- ) ( R: nest-sys -- ) \ CORE\r
+\ Return control to the calling definition.\r
+\r
+\ $CODE NameEXIT,EXIT\r
+\ XCHG BP,SP ;exchange pointers\r
+\ POP SI ;pop return stack\r
+\ XCHG BP,SP ;restore the pointers\r
+\ $NEXT\r
+\r
+\ MOVE ( addr1 addr2 u -- ) \ CORE\r
+\ Copy u address units from addr1 to addr2 if u is greater\r
+\ than zero. This word is CODE defined since no other Standard\r
+\ words can handle address unit directly.\r
+\r
+\ $CODE NameMOVE,MOVE\r
+\ POP DI\r
+\ POP DX\r
+\ OR BX,BX\r
+\ JZ MOVE2\r
+\ MOV CX,BX\r
+\ XCHG DX,SI ;save SI\r
+\ MOV AX,DS\r
+\ MOV ES,AX ;set ES same as DS\r
+\ CMP SI,DI\r
+\ JC MOVE1\r
+\ REP MOVSB\r
+\ MOV SI,DX\r
+\ MOVE2: POP BX\r
+\ $NEXT\r
+\ MOVE1: STD\r
+\ ADD DI,CX\r
+\ DEC DI\r
+\ ADD SI,CX\r
+\ DEC SI\r
+\ REP MOVSB\r
+\ CLD\r
+\ MOV SI,DX\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ OR ( x1 x2 -- x3 ) \ CORE\r
+\ Return bitwise inclusive-or of x1 with x2.\r
+\r
+\ $CODE NameORR,ORR\r
+\ POP AX\r
+\ OR BX,AX\r
+\ $NEXT\r
+\r
+\ OVER ( x1 x2 -- x1 x2 x1 ) \ CORE\r
+\ Copy second stack item to top of the stack.\r
+\r
+\ $CODE NameOVER,OVER\r
+\ MOV DI,SP\r
+\ PUSH BX\r
+\ MOV BX,[DI]\r
+\ $NEXT\r
+\r
+\ R> ( -- x ) ( R: x -- ) \ CORE\r
+\ Move x from the return stack to the data stack.\r
+\r
+\ $CODE NameRFrom,RFrom\r
+\ PUSH BX\r
+\ MOV BX,[BP]\r
+\ ADD BP,CELLL ;adjust RP\r
+\ $NEXT\r
+\r
+\ R@ ( -- x ) ( R: x -- x ) \ CORE\r
+\ Copy top of return stack to the data stack.\r
+\r
+\ $CODE NameRFetch,RFetch\r
+\ PUSH BX\r
+\ MOV BX,[BP]\r
+\ $NEXT\r
+\r
+\ SWAP ( x1 x2 -- x2 x1 ) \ CORE\r
+\ Exchange top two stack items.\r
+\r
+\ $CODE NameSWAP,SWAP\r
+\ MOV DI,SP\r
+\ XCHG BX,[DI]\r
+\ $NEXT\r
+\r
+\ XOR ( x1 x2 -- x3 ) \ CORE\r
+\ Bitwise exclusive OR.\r
+\r
+\ $CODE NameXORR,XORR\r
+\ POP AX\r
+\ XOR BX,AX\r
+\ $NEXT\r
+\r
+\ ;;;;;;;;;;;;;;;\r
+\ System constants and variables\r
+\ ;;;;;;;;;;;;;;;\r
+\r
+\ #order0 ( -- a-addr )\r
+\ Start address of default search order.\r
+\r
+\ $CONST NameNumberOrder0,NumberOrder0,AddrNumberOrder0\r
+\r
+\ 'ekey? ( -- a-addr )\r
+\ Execution vector of EKEY?.\r
+\r
+\ $VALUE NameTickEKEYQ,TickEKEYQ,AddrTickEKEYQ\r
+\r
+\ 'ekey ( -- a-addr )\r
+\ Execution vector of EKEY.\r
+\r
+\ $VALUE NameTickEKEY,TickEKEY,AddrTickEKEY\r
+\r
+\ 'emit? ( -- a-addr )\r
+\ Execution vector of EMIT?.\r
+\r
+\ $VALUE NameTickEMITQ,TickEMITQ,AddrTickEMITQ\r
+\r
+\ 'emit ( -- a-addr )\r
+\ Execution vector of EMIT.\r
+\r
+\ $VALUE NameTickEMIT,TickEMIT,AddrTickEMIT\r
+\r
+\ 'init-i/o ( -- a-addr )\r
+\ Execution vector to initialize input/output devices.\r
+\r
+\ $VALUE NameTickINIT_IO,TickINIT_IO,AddrTickINIT_IO\r
+\r
+\ 'prompt ( -- a-addr )\r
+\ Execution vector of '.prompt'.\r
+\r
+\ $VALUE NameTickPrompt,TickPrompt,AddrTickPrompt\r
+\r
+\ 'boot ( -- a-addr )\r
+\ Execution vector of COLD.\r
+\r
+\ $VALUE NameTickBoot,TickBoot,AddrTickBoot\r
+\r
+\ SOURCE-ID ( -- 0 | -1 ) \ CORE EXT\r
+\ Identify the input source. -1 for string (via EVALUATE) and\r
+\ 0 for user input device.\r
+\r
+\ $VALUE NameSOURCE_ID,SOURCE_ID,AddrSOURCE_ID\r
+\r
+\ HERE ( -- addr ) \ CORE\r
+\ Return data space pointer.\r
+\r
+\ $VALUE NameHERE,HERE,AddrHERE\r
+\r
+\ xhere ( -- code-addr )\r
+\ Return next available code space address.\r
+\r
+\ $VALUE NameXHere,XHere,AddrXHere\r
+\r
+\ 'doWord ( -- a-addr )\r
+\ Execution vectors for 'interpret'.\r
+\r
+\ $CONST NameTickDoWord,TickDoWord,AddrTickDoWord\r
+\r
+\ BASE ( -- a-addr ) \ CORE\r
+\ Return the address of the radix base for numeric I/O.\r
+\r
+\ $CONST NameBASE,BASE,AddrBASE\r
+\r
+\ THROWMsgTbl ( -- a-addr ) \ CORE\r
+\ Return the address of the THROW message table.\r
+\r
+\ $CONST NameTHROWMsgTbl,THROWMsgTbl,AddrTHROWMsgTbl\r
+\r
+\ memTop ( -- a-addr )\r
+\ Top of free memory.\r
+\r
+\ $VALUE NameMemTop,MemTop,AddrMemTop\r
+\r
+\ bal ( -- n )\r
+\ Return the depth of control-flow stack.\r
+\r
+\ $VALUE NameBal,Bal,AddrBal\r
+\r
+\ notNONAME? ( -- f )\r
+\ Used by ';' whether to do 'linkLast' or not\r
+\r
+\ $VALUE NameNotNONAMEQ,NotNONAMEQ,AddrNotNONAMEQ\r
+\r
+\ rakeVar ( -- a-addr )\r
+\ Used by 'rake' to gather LEAVE.\r
+\r
+\ $CONST NameRakeVar,RakeVar,AddrRakeVar\r
+\r
+\ #order ( -- a-addr )\r
+\ Hold the search order stack depth.\r
+\r
+\ $CONST NameNumberOrder,NumberOrder,AddrNumberOrder\r
+\r
+\ current ( -- a-addr )\r
+\ Point to the wordlist to be extended.\r
+\r
+\ $CONST NameCurrent,Current,AddrCurrent\r
+\r
+\ FORTH-WORDLIST ( -- wid ) \ SEARCH\r
+\ Return wid of Forth wordlist.\r
+\r
+\ $CONST NameFORTH_WORDLIST,FORTH_WORDLIST,AddrFORTH_WORDLIST\r
+\r
+\ NONSTANDARD-WORDLIST ( -- wid )\r
+\ Return wid of non-standard wordlist.\r
+\r
+\ $CONST NameNONSTANDARD_WORDLIST,NONSTANDARD_WORDLIST,AddrNONSTANDARD_WORDLIST\r
+\r
+\ envQList ( -- wid )\r
+\ Return wid of ENVIRONMENT? string list. Never put this wid in\r
+\ search-order. It should be used only by SET-CURRENT to add new\r
+\ environment query string after addition of a complete wordset.\r
+\r
+\ $CONST NameEnvQList,EnvQList,AddrEnvQList\r
+\r
+\ userP ( -- a-addr )\r
+\ Return address of USER variable area of current task.\r
+\r
+\ $CONST NameUserP,UserP,AddrUserP\r
+\r
+\ SystemTask ( -- a-addr )\r
+\ Return system task's tid.\r
+\r
+\ $CONST NameSystemTask,SystemTask,SysTask\r
+\r
+\ follower ( -- a-addr )\r
+\ Point next task's 'status' USER variable.\r
+\r
+\ $USER NameFollower,Follower,SysFollower-SysUserP\r
+\r
+\ status ( -- a-addr )\r
+\ Status of current task. Point 'pass' or 'wake'.\r
+\r
+\ $USER NameStatus,Status,SysStatus-SysUserP\r
+\r
+\ stackTop ( -- a-addr )\r
+\ Store current task's top of stack position.\r
+\r
+\ $USER NameStackTop,StackTop,SysStackTop-SysUserP\r
+\r
+\ throwFrame ( -- a-addr )\r
+\ THROW frame for CATCH and THROW need to be saved for eack task.\r
+\r
+\ $USER NameThrowFrame,ThrowFrame,SysThrowFrame-SysUserP\r
+\r
+\ taskName ( -- a-addr )\r
+\ Current task's task ID.\r
+\r
+\ $USER NameTaskName,TaskName,SysTaskName-SysUserP\r
+\r
+\ user1 ( -- a-addr )\r
+\ One free USER variable for each task.\r
+\r
+\ $USER NameUser1,User1,SysUser1-SysUserP\r
+\r
+\ ENVIRONMENT? strings can be searched using SEARCH-WORDLIST and can be\r
+\ EXECUTEd. This wordlist is completely hidden to Forth system except\r
+\ ENVIRONMENT? .\r
+\r
+\ CPU:\r
+\ NOP\r
+\ CALL DoLIST\r
+\ DW DoLIT,CPUStr,COUNT,EXIT\r
+\r
+\ Model:\r
+\ NOP\r
+\ CALL DoLIST\r
+\ DW DoLIT,ModelStr,COUNT,EXIT\r
+\r
+\ Version:\r
+\ NOP\r
+\ CALL DoLIST\r
+\ DW DoLIT,VersionStr,COUNT,EXIT\r
+\r
+\ SlashCOUNTED_STRING:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW MaxChar\r
+\r
+\ SlashHOLD:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW PADSize\r
+\r
+\ SlashPAD:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW PADSize\r
+\r
+\ ADDRESS_UNIT_BITS:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW 8\r
+\r
+\ CORE:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW TRUEE\r
+\r
+\ FLOORED:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW TRUEE\r
+\r
+\ MAX_CHAR:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW MaxChar ;max value of character set\r
+\r
+\ MAX_D:\r
+\ NOP\r
+\ CALL DoLIST\r
+\ DW DoLIT,MaxUnsigned,DoLIT,MaxSigned,EXIT\r
+\r
+\ MAX_N:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW MaxSigned\r
+\r
+\ MAX_U:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW MaxUnsigned\r
+\r
+\ MAX_UD:\r
+\ NOP\r
+\ CALL DoLIST\r
+\ DW MAX_U,MAX_U,EXIT\r
+\r
+\ RETURN_STACK_CELLS:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW RTCells\r
+\r
+\ STACK_CELLS:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW DTCells\r
+\r
+\ EXCEPTION:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW TRUEE\r
+\r
+\ EXCEPTION_EXT:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW TRUEE\r
+\r
+\ WORDLISTS:\r
+\ NOP\r
+\ CALL DoCONST\r
+\ DW OrderDepth\r
+\r
+\ ;;;;;;;;;;;;;;;\r
+\ Non-Standard words - Colon definitions\r
+\ ;;;;;;;;;;;;;;;\r
+\r
+\ (') ( "<spaces>name" -- xt 1 | xt -1 )\r
+\ Parse a name, find it and return execution token and\r
+\ -1 or 1 ( IMMEDIATE) if found\r
+\r
+: (') PARSE-WORD search-word ?DUP IF NIP EXIT THEN\r
+ errWord 2! \ if not found error\r
+ -13 THROW ; \ undefined word\r
+\r
+\ $COLON NameParenTick,ParenTick\r
+\ DW PARSE_WORD,Search_word,QuestionDUP,ZBranch,PTICK1\r
+\ DW NIP,EXIT\r
+\ PTICK1 DW DoLIT,AddrErrWord,TwoStore,DoLIT,-13,THROW\r
+\r
+\ (d.) ( d -- c-addr u )\r
+\ Convert a double number to a string.\r
+\r
+: (d.) SWAP OVER DUP 0< IF DNEGATE THEN\r
+ <# #S ROT SIGN #> ;\r
+\r
+\ $COLON NameParenDDot,ParenDDot\r
+\ DW SWAP,OVER,DUPP,ZeroLess,ZBranch,PARDD1\r
+\ DW DNEGATE\r
+\ PARDD1 DW LessNumberSign,NumberSignS,ROT\r
+\ DW SIGN,NumberSignGreater,EXIT\r
+\r
+\ .ok ( -- )\r
+\ Display 'ok'.\r
+\r
+: .ok ." okay" ;\r
+\r
+\ $COLON NameDotOK,DotOK\r
+\ DW DoLIT,DotOKStr\r
+\ DW COUNT,TYPEE,EXIT\r
+\r
+\ .prompt ( -- )\r
+\ Disply Forth prompt. This word is vectored.\r
+\r
+: .prompt 'prompt EXECUTE ;\r
+\r
+\ $COLON NameDotOK,DotPrompt\r
+\ DW TickPrompt,EXECUTE,EXIT\r
+\r
+\ 0 ( -- 0 )\r
+\ Return zero.\r
+\r
+\ $CONST NameZero,Zero,0\r
+\r
+\ 1 ( -- 1 )\r
+\ Return one.\r
+\r
+\ $CONST NameOne,One,1\r
+\r
+\ -1 ( -- -1 )\r
+\ Return -1.\r
+\r
+\ $CONST NameMinusOne,MinusOne,-1\r
+\r
+\ abort"msg ( -- a-addr )\r
+\ Abort" error message string address.\r
+\r
+\ $CONST NameAbortQMsg,AbortQMsg,AddrAbortQMsg\r
+\r
+\ bal+ ( -- )\r
+\ Increase bal by 1.\r
+\r
+: bal+ bal 1+ TO bal ;\r
+\r
+\ $COLON 4,'bal+',BalPlus,_SLINK\r
+\ DW Bal,OnePlus,DoTO,AddrBal,EXIT\r
+\r
+\ $CODE NameBalPlus,BalPlus\r
+\ INC AddrBal\r
+\ $NEXT\r
+\r
+\ bal- ( -- )\r
+\ Decrease bal by 1.\r
+\r
+: bal- bal 1- TO bal ;\r
+\r
+\ $COLON NameBalMinus,BalMinus\r
+\ DW Bal,OneMinus,DoTO,AddrBal,EXIT\r
+\r
+\ $CODE NameBalMinus,BalMinus\r
+\ DEC AddrBal\r
+\ $NEXT\r
+\r
+\ cell- ( a-addr1 -- a-addr2 )\r
+\ Return previous aligned cell address.\r
+\r
+: cell- [ cell-size NEGATE ] LITERAL + ;\r
+\r
+\ $COLON NameCellMinus,CellMinus\r
+\ DW DoLIT,0-CELLL,Plus,EXIT\r
+\r
+\ $CODE NameCellMinus,CellMinus\r
+\ SUB BX,CELLL\r
+\ $NEXT\r
+\r
+\ COMPILE-ONLY ( -- )\r
+\ Make the most recent definition an compile-only word.\r
+\r
+: COMPILE-ONLY lastName [ =compo ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+\ $COLON NameCOMPILE_ONLY,COMPILE_ONLY\r
+\ DW LastName,DoLIT,COMPO,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+\ doDO ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )\r
+\ Run-time funtion of DO.\r
+\r
+: doDO >R max-negative + R> OVER - SWAP R> SWAP >R SWAP >R >R ;\r
+\r
+\ $COLON NameDoDO,DoDO\r
+\ DW ToR,DoLIT,MaxNegative,Plus,RFrom\r
+\ DW OVER,Minus,SWAP,RFrom,SWAP,ToR,SWAP,ToR,ToR,EXIT\r
+\r
+\ $CODE NameDoDO,DoDO\r
+\ SUB BP,2*CELLL\r
+\ POP AX\r
+\ ADD AX,MaxNegative\r
+\ MOV [BP+CELLL],AX\r
+\ SUB BX,AX\r
+\ MOV [BP],BX\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ errWord ( -- a-addr )\r
+\ Last found word. To be used to display the word causing error.\r
+\r
+\ $CONST NameErrWord,ErrWord,AddrErrWord\r
+\r
+\ head, ( xt "<spaces>name" -- )\r
+\ Parse a word and build a dictionary entry.\r
+\r
+: head, >R PARSE-WORD DUP 0=\r
+ IF errWord 2! -16 THROW THEN\r
+ \ attempt to use zero-length string as a name\r
+ DUP =mask > IF -19 THROW THEN \ definition name too long\r
+ 2DUP GET-CURRENT SEARCH-WORDLIST \ name exist?\r
+ IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined\r
+ ALIGN R@ , \ align and store xt\r
+ GET-CURRENT @ , \ build wordlist link\r
+ HERE DUP >R pack" ALIGNED TO HERE \ pack the name in name space\r
+ R> DUP R> cell- code! \ store name addr in code space\r
+ TO lastName ;\r
+\r
+\ $COLON NameHeadComma,HeadComma\r
+\ DW ToR,PARSE_WORD,DUPP,ZBranch,HEADC1\r
+\ DW DUPP,DoLIT,MASKK,GreaterThan,ZBranch,HEADC3\r
+\ DW DoLIT,-19,THROW\r
+\ HEADC3 DW TwoDUP,GET_CURRENT,SEARCH_WORDLIST,ZBranch,HEADC2\r
+\ DW DROP\r
+\ DW DoLIT,HEADCstr\r
+\ DW COUNT,TYPEE,TwoDUP,TYPEE,SPACE\r
+\ HEADC2 DW ALIGNN,RFetch,Comma\r
+\ DW GET_CURRENT,Fetch,Comma\r
+\ DW HERE,DUPP,ToR,PackQuote,ALIGNED,DoTO,AddrHERE\r
+\ DW RFrom,DUPP,RFrom,CellMinus,CodeStore\r
+\ DW DoTO,AddrLastName,EXIT\r
+\ HEADC1 DW DoLIT,AddrErrWord,TwoStore,DoLIT,-16,THROW\r
+\r
+\ hld ( -- a-addr )\r
+\ Hold a pointer in building a numeric output string.\r
+\r
+\ $CONST NameHLD,HLD,AddrHLD\r
+\r
+\ interpret ( i*x -- j*x )\r
+\ Intrepret input string.\r
+\r
+: interpret BEGIN DEPTH 0< IF -4 THROW THEN \ stack underflow\r
+ PARSE-WORD DUP\r
+ WHILE 2DUP errWord 2!\r
+ search-word \ ca u 0 | xt f -1 | xt f 1\r
+ DUP IF\r
+ SWAP STATE @ OR 0= \ compile-only in interpretation\r
+ IF -14 THROW THEN \ interpreting a compile-only word\r
+ THEN\r
+ 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE\r
+ REPEAT 2DROP ;\r
+\r
+\ $COLON NameInterpret,Interpret\r
+\ INTERP1 DW DEPTH,ZeroLess,ZBranch,INTERP2\r
+\ DW DoLIT,-4,THROW\r
+\ INTERP2 DW PARSE_WORD,DUPP,ZBranch,INTERP3\r
+\ DW TwoDUP,DoLIT,AddrErrWord,TwoStore\r
+\ DW Search_word,DUPP,ZBranch,INTERP5\r
+\ DW SWAP,DoLIT,AddrSTATE,Fetch,ORR,ZBranch,INTERP4\r
+\ INTERP5 DW OnePlus,TwoStar,DoLIT,AddrSTATE,Fetch,OnePlus,Plus,CELLS\r
+\ DW DoLIT,AddrTickDoWord,Plus,Fetch,EXECUTE\r
+\ DW Branch,INTERP1\r
+\ INTERP3 DW TwoDROP,EXIT\r
+\ INTERP4 DW DoLIT,-14,THROW\r
+\r
+\ optiCOMPILE, ( xt -- )\r
+\ Optimized COMPILE, . Reduce doLIST ... EXIT sequence if\r
+\ xt is COLON definition which contains less than two words.\r
+\r
+: optiCOMPILE,\r
+ DUP ?call ['] doLIST = IF\r
+ DUP code@ ['] EXIT = IF \ if first word is EXIT\r
+ 2DROP EXIT THEN\r
+ DUP CELL+ code@ ['] EXIT = IF \ if second word is EXIT\r
+ code@ DUP ['] doLIT XOR \ make sure it is not literal\r
+ IF SWAP THEN THEN\r
+ THEN DROP COMPILE, ;\r
+\r
+\ $COLON NameOptiCOMPILEComma,OptiCOMPILEComma\r
+\ DW DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2\r
+\ DW DUPP,CodeFetch,DoLIT,EXIT,Equals,ZBranch,OPTC1\r
+\ DW TwoDROP,EXIT\r
+\ OPTC1 DW DUPP,CELLPlus,CodeFetch,DoLIT,EXIT,Equals\r
+\ DW ZBranch,OPTC2\r
+\ DW CodeFetch,DUPP,DoLIT,DoLIT,XORR,ZBranch,OPTC2\r
+\ DW SWAP\r
+\ OPTC2 DW DROP,COMPILEComma,EXIT\r
+\r
+\ $CODE NameOptiCOMPILEComma,OptiCOMPILEComma\r
+\ CMP WORD PTR CS:[BX],CALLL\r
+\ JNE OPTC1\r
+\ MOV AX,CS:[BX+CELLL]\r
+\ ADD AX,BX\r
+\ ADD AX,2*CELLL\r
+\ CMP AX,OFFSET DoLIST\r
+\ JNE OPTC1\r
+\ MOV DX,OFFSET EXIT\r
+\ MOV AX,CS:[BX+2*CELLL]\r
+\ CMP AX,DX\r
+\ JE OPTC2\r
+\ CMP DX,CS:[BX+3*CELLL]\r
+\ JNE OPTC1\r
+\ CMP AX,OFFSET DoLIT\r
+\ JE OPTC1\r
+\ MOV BX,AX\r
+\ OPTC1: JMP COMPILEComma\r
+\ OPTC2: POP BX\r
+\ $NEXT\r
+\r
+\ singleOnly ( c-addr u -- x )\r
+\ Handle the word not found in the search-order. If the string\r
+\ is legal, leave a single cell number in interpretation state.\r
+\r
+: singleOnly\r
+ 0 DUP 2SWAP OVER C@ [CHAR] -\r
+ = DUP >R IF 1 /STRING THEN\r
+ >NUMBER IF -13 THROW THEN \ undefined word\r
+ 2DROP R> IF NEGATE THEN ;\r
+\r
+\ $COLON NameSingleOnly,SingleOnly\r
+\ DW DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'\r
+\ DW Equals,DUPP,ToR,ZBranch,SINGLEO4\r
+\ DW DoLIT,1,SlashSTRING\r
+\ SINGLEO4 DW ToNUMBER,ZBranch,SINGLEO1\r
+\ DW DoLIT,-13,THROW\r
+\ SINGLEO1 DW TwoDROP,RFrom,ZBranch,SINGLEO2\r
+\ DW NEGATE\r
+\ SINGLEO2 DW EXIT \r
+\ singleOnly, ( c-addr u -- )\r
+\ Handle the word not found in the search-order. Compile a\r
+\ single cell number in compilation state.\r
+\r
+: singleOnly,\r
+ singleOnly POSTPONE LITERAL ;\r
+\r
+\ $COLON NameSingleOnlyComma,SingleOnlyComma\r
+\ DW SingleOnly,LITERAL,EXIT\r
+\r
+\ (doubleAlso) ( c-addr u -- x 1 | x x 2 )\r
+\ If the string is legal, leave a single or double cell number\r
+\ and size of the number.\r
+\r
+: (doubleAlso)\r
+ 0 DUP 2SWAP OVER C@ [CHAR] -\r
+ = DUP >R IF 1 /STRING THEN\r
+ >NUMBER ?DUP\r
+ IF 1- IF -13 THROW THEN \ more than one char is remained\r
+ DUP C@ [CHAR] . XOR \ last char is not '.'\r
+ IF -13 THROW THEN \ undefined word\r
+ R> IF DNEGATE THEN\r
+ 2 EXIT THEN\r
+ 2DROP R> IF NEGATE THEN \ single number\r
+ 1 ;\r
+\r
+\ $COLON NameParenDoubleAlso,ParenDoubleAlso\r
+\ DW DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'\r
+\ DW Equals,DUPP,ToR,ZBranch,DOUBLEA1\r
+\ DW DoLIT,1,SlashSTRING\r
+\ DOUBLEA1 DW ToNUMBER,QuestionDUP,ZBranch,DOUBLEA4\r
+\ DW OneMinus,ZBranch,DOUBLEA3\r
+\ DOUBLEA2 DW DoLIT,-13,THROW\r
+\ DOUBLEA3 DW CFetch,DoLIT,'.',Equals,ZBranch,DOUBLEA2\r
+\ DW RFrom,ZBranch,DOUBLEA5\r
+\ DW DNEGATE\r
+\ DOUBLEA5 DW DoLIT,2,EXIT\r
+\ DOUBLEA4 DW TwoDROP,RFrom,ZBranch,DOUBLEA6\r
+\ DW NEGATE\r
+\ DOUBLEA6 DW DoLIT,1,EXIT\r
+\r
+\ doubleAlso ( c-addr u -- x | x x )\r
+\ Handle the word not found in the search-order. If the string\r
+\ is legal, leave a single or double cell number in\r
+\ interpretation state.\r
+\r
+: doubleAlso\r
+ (doubleAlso) DROP ;\r
+\r
+\ $COLON NameDoubleAlso,DoubleAlso\r
+\ DW ParenDoubleAlso,DROP,EXIT\r
+\r
+\ doubleAlso, ( c-addr u -- )\r
+\ Handle the word not found in the search-order. If the string\r
+\ is legal, compile a single or double cell number in\r
+\ compilation state.\r
+\r
+: doubleAlso,\r
+ (doubleAlso) 1- IF SWAP POSTPONE LITERAL THEN POSTPONE LITERAL ;\r
+\r
+\ $COLON NameDoubleAlsoComma,DoubleAlsoComma\r
+\ DW ParenDoubleAlso,OneMinus,ZBranch,DOUBC1\r
+\ DW SWAP,LITERAL\r
+\ DOUBC1 DW LITERAL,EXIT\r
+\r
+\ -. ( -- )\r
+\ You don't need this word unless you care that '-.' returns\r
+\ double cell number 0. Catching illegal number '-.' in this way\r
+\ is easier than make 'interpret' catch this exception.\r
+\r
+: -. -13 THROW ; IMMEDIATE \ undefined word\r
+\r
+\ $COLON NameMinusDot,MinusDot\r
+\ DW DoLIT,-13,THROW\r
+\r
+\ lastName ( -- c-addr )\r
+\ Return the address of the last definition name.\r
+\r
+\ $VALUE NameLastName,LastName,AddrLastName\r
+\r
+\ linkLast ( -- )\r
+\ Link the word being defined to the current wordlist.\r
+\ Do nothing if the last definition is made by :NONAME .\r
+\r
+: linkLast lastName GET-CURRENT ! ;\r
+\r
+\ $COLON NameLinkLast,LinkLast\r
+\ DW LastName,GET_CURRENT,Store,EXIT\r
+\r
+\ $CODE NameLinkLast,LinkLast\r
+\ MOV AX,AddrLastName\r
+\ MOV DI,AddrCurrent\r
+\ MOV [DI],AX\r
+\ $NEXT\r
+\r
+\ name>xt ( c-addr -- xt )\r
+\ Return execution token using counted string at c-addr.\r
+\r
+: name>xt cell- cell- @ ;\r
+\r
+\ $COLON NameNameToXT,NameToXT\r
+\ DW CellMinus,CellMinus,Fetch,EXIT\r
+\r
+\ $CODE NameNameToXT,NameToXT\r
+\ MOV BX,[BX-2*CELLL]\r
+\ $NEXT\r
+\r
+\ pack" ( c-addr u a-addr -- a-addr2 )\r
+\ Place a string c-addr u at a-addr and gives the next\r
+\ cell-aligned address. Fill the rest of the last cell with\r
+\ null character.\r
+\r
+: pack" 2DUP SWAP CHARS + CHAR+ DUP >R \ ca u aa aa+u+1\r
+ ALIGNED cell- 0 SWAP ! \ fill 0 at the end of string\r
+ 2DUP C! CHAR+ SWAP \ c-addr a-addr+1 u\r
+ CHARS MOVE R> ALIGNED ; COMPILE-ONLY\r
+\r
+\ $COLON 5,'pack"',PackQuote,_SLINK\r
+\ DW TwoDUP,SWAP,CHARS,Plus,CHARPlus,DUPP,ToR\r
+\ DW ALIGNED,CellMinus,Zero,SWAP,Store\r
+\ DW TwoDUP,CStore,CHARPlus,SWAP\r
+\ DW CHARS,MOVE,RFrom,ALIGNED,EXIT\r
+\r
+\ $CODE NamePackQuote,PackQuote\r
+\ MOV DI,BX\r
+\ MOV DX,SI\r
+\ MOV AX,DS\r
+\ MOV ES,AX\r
+\ POP CX\r
+\ POP SI\r
+\ MOV BYTE PTR [DI],CL\r
+\ INC DI\r
+\ REP MOVSB\r
+\ TEST DI,1 ;odd address?\r
+\ JZ PACKQ2\r
+\ MOV BYTE PTR [DI],0\r
+\ INC DI\r
+\ PACKQ2: MOV BX,DI\r
+\ MOV SI,DX\r
+\ $NEXT\r
+\r
+\ PARSE-WORD ( "<spaces>ccc<space>" -- c-addr u )\r
+\ Skip leading spaces and parse a word. Return the name.\r
+\r
+: PARSE-WORD BL skipPARSE ;\r
+\r
+\ $COLON NamePARSE_WORD,PARSE_WORD\r
+\ DW DoLIT,' ',SkipPARSE,EXIT\r
+\r
+\ $CODE NamePARSE_WORD,PARSE_WORD\r
+\ PUSH BX\r
+\ MOV BX,' '\r
+\ JMP SkipPARSE\r
+\ $ALIGN\r
+\r
+\ pipe ( -- ) ( R: xt -- )\r
+\ Connect most recently defined word to code following DOES>.\r
+\ Structure of CREATEd word:\r
+\ |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |\r
+\r
+: pipe lastName name>xt ?call DUP IF \ code-addr xt2\r
+ ['] doCREATE = IF\r
+ R> SWAP code! \ change DOES> code of CREATEd word\r
+ EXIT\r
+ THEN THEN\r
+ -32 THROW \ invalid name argument, no-CREATEd last name\r
+ ; COMPILE-ONLY\r
+\r
+\ $COLON NamePipe,Pipe\r
+\ DW LastName,NameToXT,QCall,DUPP,ZBranch,PIPE1\r
+\ DW DoLIT,DoCREATE,Equals,ZBranch,PIPE1\r
+\ DW RFrom,SWAP,CodeStore,EXIT\r
+\ PIPE1 DW DoLIT,-32,THROW\r
+\r
+\ skipPARSE ( char "<chars>ccc<char>" -- c-addr u )\r
+\ Skip leading chars and parse a word using char as a\r
+\ delimeter. Return the name.\r
+\r
+: skipPARSE\r
+ >R SOURCE >IN @ /STRING \ c_addr u R: char\r
+ DUP IF\r
+ BEGIN OVER C@ R@ =\r
+ WHILE 1- SWAP CHAR+ SWAP DUP 0=\r
+ UNTIL R> DROP EXIT\r
+ ELSE THEN\r
+ DROP SOURCE DROP - 1chars/ >IN ! R> PARSE EXIT\r
+ THEN R> DROP ;\r
+\r
+\ $COLON NameSkipPARSE,SkipPARSE\r
+\ DW ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING\r
+\ DW DUPP,ZBranch,SKPAR1\r
+\ SKPAR2 DW OVER,CFetch,RFetch,Equals,ZBranch,SKPAR3\r
+\ DW OneMinus,SWAP,CHARPlus,SWAP\r
+\ DW DUPP,ZeroEquals,ZBranch,SKPAR2\r
+\ DW RFrom,DROP,EXIT\r
+\ SKPAR3 DW DROP,SOURCE,DROP,Minus,OneCharsSlash\r
+\ DW DoLIT,AddrToIN,Store,RFrom,PARSE,EXIT\r
+\ SKPAR1 DW RFrom,DROP,EXIT\r
+\r
+\ $CODE NameSkipPARSE,SkipPARSE\r
+\ MOV AH,BL\r
+\ MOV DX,SI\r
+\ MOV SI,AddrSourceVar+CELLL\r
+\ MOV BX,AddrSourceVar\r
+\ MOV CX,AddrToIN\r
+\ ADD SI,CX\r
+\ SUB BX,CX\r
+\ MOV CX,SI\r
+\ OR BX,BX\r
+\ JZ PARSW1\r
+\ PARSW5: LODSB\r
+\ CMP AL,AH\r
+\ JNE PARSW4\r
+\ DEC BX\r
+\ OR BX,BX\r
+\ JNZ PARSW5\r
+\ MOV AX,AddrSourceVar\r
+\ MOV AddrToIN,AX\r
+\ PARSW1: PUSH SI\r
+\ MOV SI,DX\r
+\ $NEXT\r
+\ PARSW4: DEC SI\r
+\ SUB SI,AddrSourceVar+CELLL\r
+\ MOV AddrToIN,SI\r
+\ XOR BX,BX\r
+\ MOV BL,AH\r
+\ MOV SI,DX\r
+\ JMP PARSE\r
+\ $ALIGN\r
+\r
+\ specialComp? ( -- xt|0 )\r
+\ Return xt for special compilation semantics of the last found\r
+\ word. Return 0 if there is no special compilation action.\r
+\r
+\ $VALUE NameSpecialCompQ,SpecialCompQ,AddrSpecialCompQ\r
+\r
+\ rake ( C: do-sys -- )\r
+\ Gathers LEAVEs.\r
+\r
+: rake DUP code, rakeVar @\r
+ BEGIN 2DUP U<\r
+ WHILE DUP code@ xhere ROT code!\r
+ REPEAT rakeVar ! DROP\r
+ ?DUP IF \ check for ?DO\r
+ 1 bal+ POSTPONE THEN \ orig type is 1\r
+ THEN bal- ; COMPILE-ONLY\r
+\r
+\ $COLON Namerake,rake\r
+\ DW DUPP,CodeComma,DoLIT,AddrRakeVar,Fetch\r
+\ RAKE1 DW TwoDUP,ULess,ZBranch,RAKE2\r
+\ DW DUPP,CodeFetch,XHere,ROT,CodeStore,Branch,RAKE1\r
+\ RAKE2 DW DoLIT,AddrRakeVar,Store,DROP\r
+\ DW QuestionDUP,ZBranch,RAKE3\r
+\ DW One,BalPlus,THENN\r
+\ RAKE3 DW BalMinus,EXIT\r
+\r
+\ rp0 ( -- a-addr )\r
+\ Pointer to bottom of the return stack.\r
+\r
+: rp0 userP @ CELL+ CELL+ @ ;\r
+\r
+\ $COLON NameRPZero,RPZero\r
+\ DW DoLIT,AddrUserP,Fetch,CELLPlus,CELLPlus,Fetch,EXIT\r
+\r
+\ search-word ( c-addr u -- c-addr u 0 | xt f 1 | xt f -1)\r
+\ Search dictionary for a match with the given name. Return\r
+\ execution token, not-compile-only flag and -1 or 1\r
+\ ( IMMEDIATE) if found; c-addr u 0 if not.\r
+\r
+: search-word\r
+ #order @ DUP \ not found if #order is 0\r
+ IF 0\r
+ DO 2DUP \ ca u ca u\r
+ I CELLS #order CELL+ + @ \ ca u ca u wid\r
+ (search-wordlist) \ ca u; 0 | w f 1 | w f -1\r
+ ?DUP IF \ ca u; 0 | w f 1 | w f -1\r
+ >R 2SWAP 2DROP R> UNLOOP EXIT \ xt f 1 | xt f -1\r
+ THEN \ ca u\r
+ LOOP 0 \ ca u 0\r
+ THEN ;\r
+\r
+\ $COLON NameSearch_word,Search_word\r
+\ DW NumberOrder,Fetch,DUPP,ZBranch,SEARCH1\r
+\ DW DoLIT,0,DoDO\r
+\ SEARCH2 DW TwoDUP,I,CELLS,NumberOrder,CELLPlus,Plus,Fetch\r
+\ DW ParenSearch_Wordlist,QuestionDUP,ZBranch,SEARCH3\r
+\ DW ToR,TwoSWAP,TwoDROP,RFrom,UNLOOP,EXIT\r
+\ SEARCH3 DW DoLOOP,SEARCH2\r
+\ DW DoLIT,0\r
+\ SEARCH1 DW EXIT\r
+\r
+\ sourceVar ( -- a-addr )\r
+\ Hold the current count and address of the terminal input buffer.\r
+\r
+\ $CONST NameSourceVar,SourceVar,AddrSourceVar\r
+\r
+\ sp0 ( -- a-addr )\r
+\ Pointer to bottom of the data stack.\r
+\r
+: sp0 userP @ CELL+ @ ;\r
+\r
+\ $COLON NameSPZero,SPZero\r
+\ DW DoLIT,AddrUserP,Fetch,CELLPlus,Fetch,EXIT\r
+\r
+\ ;;;;;;;;;;;;;;;\r
+\ Essential Standard words - Colon definitions\r
+\ ;;;;;;;;;;;;;;;\r
+\r
+\ # ( ud1 -- ud2 ) \ CORE\r
+\ Extract one digit from ud1 and append the digit to\r
+\ pictured numeric output string. ( ud2 = ud1 / BASE )\r
+\r
+: # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP\r
+ 9 OVER < [ CHAR A CHAR 9 1 + - ] LITERAL AND +\r
+ [ CHAR 0 ] LITERAL + HOLD R> ;\r
+\r
+\ $COLON NameNumberSign,NumberSign\r
+\ DW DoLIT,0,DoLITFetch,AddrBASE,UMSlashMOD,ToR\r
+\ DW DoLITFetch,AddrBASE,UMSlashMOD,SWAP\r
+\ DW DoLIT,9,OVER,LessThan,DoLIT,'A'-'9'-1,ANDD,Plus\r
+\ DW DoLIT,'0',Plus,HOLD,RFrom,EXIT\r
+\r
+\ $CODE NameNumberSign,NumberSign\r
+\ XOR DX,DX\r
+\ MOV AX,BX\r
+\ MOV CX,AddrBASE\r
+\ DIV CX ;0:TOS / BASE\r
+\ MOV BX,AX ;quotient\r
+\ POP AX\r
+\ DIV CX\r
+\ PUSH AX ;BX:AX = ud2\r
+\ MOV AL,DL\r
+\ CMP AL,9\r
+\ JBE NUMSN1\r
+\ ADD AL,'A'-'9'-1\r
+\ NUMSN1: ADD AL,'0'\r
+\ MOV DI,AddrHLD\r
+\ DEC DI\r
+\ MOV AddrHLD,DI\r
+\ MOV [DI],AL\r
+\ $NEXT\r
+\r
+\ #> ( xd -- c-addr u ) \ CORE\r
+\ Prepare the output string to be TYPE'd.\r
+\ ||HERE>WORD/#-work-area|\r
+\r
+: #> 2DROP hld @ HERE size-of-PAD + OVER - 1chars/ ;\r
+\r
+\ $COLON NameNumberSignGreater,NumberSignGreater\r
+\ DW TwoDROP,DoLIT,AddrHLD,Fetch,HERE,DoLIT,PADSize*CHARR,Plus\r
+\ DW OVER,Minus,OneCharsSlash,EXIT\r
+\r
+\ #S ( ud -- 0 0 ) \ CORE\r
+\ Convert ud until all digits are added to the output string.\r
+\r
+: #S BEGIN # 2DUP OR 0= UNTIL ;\r
+\r
+\ $COLON NameNumberSignS,NumberSignS\r
+\ NUMSS1 DW NumberSign,TwoDUP,ORR\r
+\ DW ZeroEquals,ZBranch,NUMSS1\r
+\ DW EXIT\r
+\r
+\ ' ( "<spaces>name" -- xt ) \ CORE\r
+\ Parse a name, find it and return xt.\r
+\r
+: ' (') DROP ;\r
+\r
+\ $COLON NameTick,Tick\r
+\ DW ParenTick,DROP,EXIT\r
+\r
+\ + ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+\ Add top two items and gives the sum.\r
+\r
+: + um+ DROP ;\r
+\r
+\ $COLON NamePlus,Plus\r
+\ DW UMPlus,DROP,EXIT\r
+\r
+\ $CODE NamePlus,Plus\r
+\ POP AX\r
+\ ADD BX,AX\r
+\ $NEXT\r
+\r
+\ +! ( n|u a-addr -- ) \ CORE\r
+\ Add n|u to the contents at a-addr.\r
+\r
+: +! SWAP OVER @ + SWAP ! ;\r
+\r
+\ $COLON NamePlusStore,PlusStore\r
+\ DW SWAP,OVER,Fetch,Plus\r
+\ DW SWAP,Store,EXIT\r
+\r
+\ $CODE NamePlusStore,PlusStore\r
+\ POP AX\r
+\ ADD [BX],AX\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ , ( x -- ) \ CORE\r
+\ Reserve one cell in data space and store x in it.\r
+\r
+: , HERE ! HERE CELL+ TO HERE ;\r
+\r
+\ $COLON NameComma,Comma\r
+\ DW HERE,Store,HERE,CELLPlus,DoTO,AddrHERE,EXIT\r
+\r
+\ $CODE NameComma,Comma\r
+\ MOV DI,AddrHERE\r
+\ MOV [DI],BX\r
+\ ADD DI,CELLL\r
+\ MOV AddrHERE,DI\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ - ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+\ Subtract n2|u2 from n1|u1, giving the difference n3|u3.\r
+\r
+: - NEGATE + ;\r
+\r
+\ $COLON NameMinus,Minus\r
+\ DW NEGATE,Plus,EXIT\r
+\\r
+\ $CODE NameMinus,Minus\r
+\ POP AX\r
+\ SUB AX,BX\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\r
+\ . ( n -- ) \ CORE\r
+\ Display a signed number followed by a space.\r
+\r
+: . S>D D. ;\r
+\r
+\ $COLON NameDot,Dot\r
+\ DW SToD,DDot,EXIT\r
+\r
+\ / ( n1 n2 -- n3 ) \ CORE\r
+\ Divide n1 by n2, giving single-cell quotient n3.\r
+\r
+: / /MOD NIP ;\r
+\r
+\ $COLON NameSlash,Slash\r
+\ DW SlashMOD,NIP,EXIT\r
+\r
+\ /MOD ( n1 n2 -- n3 n4 ) \ CORE\r
+\ Divide n1 by n2, giving single-cell remainder n3 and\r
+\ single-cell quotient n4.\r
+\r
+: /MOD >R S>D R> FM/MOD ;\r
+\r
+\ $COLON NameSlashMOD,SlashMOD\r
+\ DW ToR,SToD,RFrom,FMSlashMOD,EXIT\r
+\r
+\ $CODE NameSlashMOD,SlashMOD\r
+\ POP AX\r
+\ CWD\r
+\ PUSH AX\r
+\ PUSH DX\r
+\ JMP FMSlashMOD\r
+\ $ALIGN\r
+\r
+\ /STRING ( c-addr1 u1 n -- c-addr2 u2 ) \ STRING\r
+\ Adjust the char string at c-addr1 by n chars.\r
+\r
+: /STRING DUP >R - SWAP R> CHARS + SWAP ;\r
+\r
+\ $COLON NameSlashSTRING,SlashSTRING\r
+\ DW DUPP,ToR,Minus,SWAP,RFrom,CHARS,Plus,SWAP,EXIT\r
+\r
+\ $CODE NameSlashSTRING,SlashSTRING\r
+\ POP AX\r
+\ SUB AX,BX\r
+\ POP DX\r
+\ ADD DX,BX\r
+\ PUSH DX\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\r
+\ 1+ ( n1|u1 -- n2|u2 ) \ CORE\r
+\ Increase top of the stack item by 1.\r
+\r
+: 1+ 1 + ;\r
+\r
+\ $COLON NameOnePlus,OnePlus\r
+\ DW DoLIT,1,Plus,EXIT\r
+\r
+\ $CODE NameOnePlus,OnePlus\r
+\ INC BX\r
+\ $NEXT\r
+\r
+\ 1- ( n1|u1 -- n2|u2 ) \ CORE\r
+\ Decrease top of the stack item by 1.\r
+\r
+: 1- -1 + ;\r
+\r
+\ $COLON NameOneMinus,OneMinus\r
+\ DW DoLIT,-1,Plus,EXIT\r
+\r
+\ $CODE NameOneMinus,OneMinus\r
+\ DEC BX\r
+\ $NEXT\r
+\r
+\ 2! ( x1 x2 a-addr -- ) \ CORE\r
+\ Store the cell pare x1 x2 at a-addr, with x2 at a-addr and\r
+\ x1 at the next consecutive cell.\r
+\r
+: 2! SWAP OVER ! CELL+ ! ;\r
+\r
+\ $COLON NameTwoStore,TwoStore\r
+\ DW SWAP,OVER,Store,CELLPlus,Store,EXIT\r
+\\r
+\ $CODE NameTwoStore,TwoStore\r
+\ POP [BX]\r
+\ POP [BX+CELLL]\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ 2@ ( a-addr -- x1 x2 ) \ CORE\r
+\ Fetch the cell pair stored at a-addr. x2 is stored at a-addr\r
+\ and x1 at the next consecutive cell.\r
+\r
+: 2@ DUP CELL+ @ SWAP @ ;\r
+\r
+\ $COLON NameTwoFetch,TwoFetch\r
+\ DW DUPP,CELLPlus,Fetch,SWAP,Fetch,EXIT\r
+\r
+\ $CODE NameTwoFetch,TwoFetch\r
+\ PUSH [BX+CELLL]\r
+\ MOV BX,[BX]\r
+\ $NEXT\r
+\r
+\ 2DROP ( x1 x2 -- ) \ CORE\r
+\ Drop cell pair x1 x2 from the stack.\r
+\r
+: 2DROP DROP DROP ;\r
+\r
+\ $COLON NameTwoDROP,TwoDROP\r
+\ DW DROP,DROP,EXIT\r
+\r
+\ $CODE NameTwoDROP,TwoDROP\r
+\ POP BX\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ 2DUP ( x1 x2 -- x1 x2 x1 x2 ) \ CORE\r
+\ Duplicate cell pair x1 x2.\r
+\r
+: 2DUP OVER OVER ;\r
+\r
+\ $COLON NameTwoDUP,TwoDUP\r
+\ DW OVER,OVER,EXIT\r
+\r
+\ $CODE NameTwoDUP,TwoDUP\r
+\ MOV DI,SP\r
+\ PUSH BX\r
+\ PUSH [DI]\r
+\ $NEXT\r
+\r
+\ 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) \ CORE\r
+\ Exchange the top two cell pairs.\r
+\r
+: 2SWAP ROT >R ROT R> ;\r
+\r
+\ $COLON NameTwoSWAP,TwoSWAP\r
+\ DW ROT,ToR,ROT,RFrom,EXIT\r
+\r
+\ $CODE NameTwoSWAP,TwoSWAP\r
+\ POP AX\r
+\ POP CX\r
+\ POP DX\r
+\ PUSH AX\r
+\ PUSH BX\r
+\ PUSH DX\r
+\ MOV BX,CX\r
+\ $NEXT\r
+\r
+\ : ( "<spaces>name" -- colon-sys ) \ CORE\r
+\ Start a new colon definition using next word as its name.\r
+\r
+: : xhere ALIGNED CELL+ TO xhere \ reserve a cell for name pointer\r
+ :NONAME ROT head, -1 TO notNONAME? ;\r
+\r
+\ $COLON NameCOLON,COLON\r
+\ DW XHere,ALIGNED,CELLPlus,DoTO,AddrXHere\r
+\ DW ColonNONAME,ROT,HeadComma\r
+\ DW DoLIT,-1,DoTO,AddrNotNONAMEQ,EXIT\r
+\r
+\ :NONAME ( -- xt colon-sys ) \ CORE EXT\r
+\ Create an execution token xt, enter compilation state and\r
+\ start the current definition.\r
+\r
+: :NONAME bal IF -29 THROW THEN \ compiler nesting\r
+ ['] doLIST xt, DUP -1\r
+ 0 TO notNONAME? 1 TO bal ] ;\r
+\r
+\ $COLON NameColonNONAME,ColonNONAME\r
+\ DW Bal,ZBranch,NONAME1\r
+\ DW DoLIT,-29,THROW\r
+\ NONAME1 DW DoLIT,DoLIST,xtComma,DUPP,DoLIT,-1\r
+\ DW DoLIT,0,DoTO,AddrNotNONAMEQ\r
+\ DW One,DoTO,AddrBal,RightBracket,EXIT\r
+\r
+\ ; ( colon-sys -- ) \ CORE\r
+\ Terminate a colon definition.\r
+\r
+: ; bal 1- IF -22 THROW THEN \ control structure mismatch\r
+ NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+ notNONAME? IF \ if the last definition is not created by ':'\r
+ linkLast 0 TO notNONAME? \ link the word to wordlist\r
+ THEN POSTPONE EXIT \ add EXIT at the end of the definition\r
+ 0 TO bal POSTPONE [ ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameSemicolon,Semicolon\r
+\ DW Bal,OneMinus,ZBranch,SEMI1\r
+\ DW DoLIT,-22,THROW\r
+\ SEMI1 DW NIP,OnePlus,ZBranch,SEMI2\r
+\ DW DoLIT,-22,THROW\r
+\ SEMI2 DW NotNONAMEQ,ZBranch,SEMI3\r
+\ DW LinkLast,DoLIT,0,DoTO,AddrNotNONAMEQ\r
+\ SEMI3 DW DoLIT,EXIT,COMPILEComma\r
+\ DW DoLIT,0,DoTO,AddrBal,LeftBracket,EXIT\r
+\r
+\ < ( n1 n2 -- flag ) \ CORE\r
+\ Returns true if n1 is less than n2.\r
+\r
+: < 2DUP XOR 0< \ same sign?\r
+ IF DROP 0< EXIT THEN \ different signs, true if n1 <0\r
+ - 0< ; \ same signs, true if n1-n2 <0\r
+\r
+\ $COLON NameLessThan,LessThan\r
+\ DW TwoDUP,XORR,ZeroLess,ZBranch,LESS1\r
+\ DW DROP,ZeroLess,EXIT\r
+\ LESS1 DW Minus,ZeroLess,EXIT\r
+\r
+\ $CODE NameLessThan,LessThan\r
+\ POP AX\r
+\ SUB AX,BX\r
+\ MOV BX,-1\r
+\ JL LESS1\r
+\ INC BX\r
+\ LESS1: $NEXT\r
+\r
+\ <# ( -- ) \ CORE\r
+\ Initiate the numeric output conversion process.\r
+\ ||HERE>WORD/#-work-area|\r
+\r
+: <# HERE size-of-PAD + hld ! ;\r
+\r
+\ $COLON NameLessNumberSign,LessNumberSign\r
+\ DW HERE,DoLIT,PADSize*CHARR,Plus,DoLIT,AddrHLD,Store,EXIT\r
+\r
+\ = ( x1 x2 -- flag ) \ CORE\r
+\ Return true if top two are equal.\r
+\r
+: = XOR 0= ;\r
+\r
+\ $COLON NameEquals,Equals\r
+\ DW XORR,ZeroEquals,EXIT\r
+\r
+\ $CODE NameEquals,Equals\r
+\ POP AX\r
+\ CMP BX,AX\r
+\ MOV BX,-1\r
+\ JE EQUAL1\r
+\ INC BX\r
+\ EQUAL1: $NEXT\r
+\r
+\ > ( n1 n2 -- flag ) \ CORE\r
+\ Returns true if n1 is greater than n2.\r
+\r
+: > SWAP < ;\r
+\r
+\ $COLON NameGreaterThan,GreaterThan\r
+\ DW SWAP,LessThan,EXIT\r
+\r
+\ $CODE NameGreaterThan,GreaterThan\r
+\ POP AX\r
+\ SUB AX,BX\r
+\ MOV BX,-1\r
+\ JG GREAT1\r
+\ INC BX\r
+\ GREAT1: $NEXT\r
+\r
+\ >IN ( -- a-addr )\r
+\ Hold the character pointer while parsing input stream.\r
+\r
+\ $CONST NameToIN,ToIN,AddrToIN\r
+\r
+\ >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ CORE\r
+\ Add number string's value to ud1. Leaves string of any\r
+\ unconverted chars.\r
+\r
+: >NUMBER BEGIN DUP\r
+ WHILE >R DUP >R C@ \ ud char R: u c-addr\r
+ DUP [ CHAR 9 1+ ] LITERAL [CHAR] A WITHIN\r
+ IF DROP R> R> EXIT THEN\r
+ [ CHAR 0 ] LITERAL - 9 OVER <\r
+ [ CHAR A CHAR 9 1 + - ] LITERAL AND -\r
+ DUP 0 BASE @ WITHIN\r
+ WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> R> 1 /STRING\r
+ REPEAT DROP R> R>\r
+ THEN ;\r
+\r
+\ $COLON NameToNUMBER,ToNUMBER\r
+\ TONUM1 DW DUPP,ZBranch,TONUM3\r
+\ DW ToR,DUPP,ToR,CFetch,DUPP\r
+\ DW DoLIT,'9'+1,DoLIT,'A',WITHIN,ZeroEquals,ZBranch,TONUM2\r
+\ DW DoLIT,'0',Minus,DoLIT,9,OVER,LessThan\r
+\ DW DoLIT,'A'-'9'-1,ANDD,Minus,DUPP\r
+\ DW DoLIT,0,DoLIT,AddrBASE,Fetch,WITHIN,ZBranch,TONUM2\r
+\ DW SWAP,DoLIT,AddrBASE,Fetch,UMStar,DROP,ROT,DoLIT,AddrBASE,Fetch\r
+\ DW UMStar,DPlus,RFrom,RFrom,DoLIT,1,SlashSTRING\r
+\ DW Branch,TONUM1\r
+\ TONUM2 DW DROP,RFrom,RFrom\r
+\ TONUM3 DW EXIT\r
+\r
+\ $CODE NameToNUMBER,ToNUMBER\r
+\ POP DI\r
+\ TONUM4: OR BX,BX\r
+\ JZ TONUM2\r
+\ XOR CX,CX\r
+\ MOV CL,[DI]\r
+\ SUB CX,'0'\r
+\ JS TONUM2 ;not valid digit\r
+\ CMP CX,'9'-'0'\r
+\ JLE TONUM3\r
+\ CMP CX,'A'-'0'\r
+\ JL TONUM2 ;not valid digit\r
+\ SUB CX,'A'-'9'-1\r
+\ TONUM3: CMP CX,AddrBASE\r
+\ JGE TONUM2 ;not valid digit\r
+\ POP AX\r
+\ MUL AddrBASE\r
+\ POP DX\r
+\ PUSH AX\r
+\ MOV AX,DX\r
+\ MUL AddrBASE\r
+\ ADD AX,CX\r
+\ POP CX\r
+\ ADC DX,CX\r
+\ PUSH AX\r
+\ PUSH DX\r
+\ INC DI\r
+\ DEC BX\r
+\ JMP TONUM4\r
+\ TONUM2: PUSH DI\r
+\ $NEXT\r
+\r
+\ ?DUP ( x -- x x | 0 ) \ CORE\r
+\ Duplicate top of the stack if it is not zero.\r
+\r
+: ?DUP DUP IF DUP THEN ;\r
+\r
+\ $COLON NameQuestionDUP,QuestionDUP\r
+\ DW DUPP,ZBranch,QDUP1\r
+\ DW DUPP\r
+\ QDUP1 DW EXIT\r
+\r
+\ $CODE NameQuestionDUP,QuestionDUP\r
+\ OR BX,BX\r
+\ JZ QDUP1\r
+\ PUSH BX\r
+\ QDUP1: $NEXT\r
+\r
+\ ABORT ( i*x -- ) ( R: j*x -- ) \ EXCEPTION EXT\r
+\ Reset data stack and jump to QUIT.\r
+\r
+: ABORT -1 THROW ;\r
+\r
+\ $COLON NameABORT,ABORT\r
+\ DW DoLIT,-1,THROW\r
+\r
+\ ACCEPT ( c-addr +n1 -- +n2 ) \ CORE\r
+\ Accept a string of up to +n1 chars. Return with actual count.\r
+\ Implementation-defined editing. Stops at EOL# .\r
+\ Supports backspace and delete editing.\r
+\r
+: ACCEPT >R 0\r
+ BEGIN DUP R@ < \ ca n2 f R: n1\r
+ WHILE EKEY max-char AND\r
+ DUP BL <\r
+ IF DUP cr# = IF ROT 2DROP R> DROP EXIT THEN\r
+ DUP tab# =\r
+ IF DROP 2DUP + BL DUP EMIT SWAP C! 1+\r
+ ELSE DUP bsp# =\r
+ SWAP del# = OR\r
+ IF DROP DUP\r
+ \ discard the last char if not 1st char\r
+ IF 1- bsp# EMIT BL EMIT bsp# EMIT THEN THEN\r
+ THEN\r
+ ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+ \ Nick THEN\r
+ THEN\r
+ REPEAT SWAP R> 2DROP ;\r
+\r
+\ $COLON NameACCEPT,ACCEPT\r
+\ DW ToR,DoLIT,0\r
+\ ACCPT1 DW DUPP,RFetch,LessThan,ZBranch,ACCPT5\r
+\ DW EKEY,DoLIT,MaxChar,ANDD\r
+\ DW DUPP,DoLIT,' ',LessThan,ZBranch,ACCPT3\r
+\ DW DUPP,DoLIT,CRR,Equals,ZBranch,ACCPT4\r
+\ DW ROT,TwoDROP,RFrom,DROP,EXIT\r
+\ ACCPT4 DW DUPP,DoLIT,TABB,Equals,ZBranch,ACCPT6\r
+\ DW DROP,TwoDUP,Plus,DoLIT,' ',DUPP,EMIT,SWAP,CStore,OnePlus\r
+\ DW Branch,ACCPT1\r
+\ ACCPT6 DW DUPP,DoLIT,BKSPP,Equals\r
+\ DW SWAP,DoLIT,DEL,Equals,ORR,ZBranch,ACCPT1\r
+\ DW DUPP,ZBranch,ACCPT1\r
+\ DW OneMinus,DoLIT,BKSPP,EMIT,DoLIT,' ',EMIT,DoLIT,BKSPP,EMIT\r
+\ DW Branch,ACCPT1\r
+\ ACCPT3 DW ToR,TwoDUP,CHARS,Plus,RFrom,DUPP,EMIT,SWAP,CStore\r
+\ DW OnePlus,Branch,ACCPT1\r
+\ ACCPT5 DW SWAP,RFrom,TwoDROP,EXIT\r
+\r
+\ AGAIN ( C: dest -- ) \ CORE EXT\r
+\ Resolve backward reference dest. Typically used as\r
+\ BEGIN ... AGAIN . Move control to the location specified by\r
+\ dest on execution.\r
+\r
+: AGAIN IF -22 THROW THEN \ control structure mismatch; dest type is 0\r
+ POSTPONE branch code, bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameAGAIN,AGAIN\r
+\ DW ZBranch,AGAIN1\r
+\ DW DoLIT,-22,THROW\r
+\ AGAIN1 DW DoLIT,Branch,COMPILEComma,CodeComma,BalMinus,EXIT\r
+\r
+\ AHEAD ( C: -- orig ) \ TOOLS EXT\r
+\ Put the location of a new unresolved forward reference onto\r
+\ control-flow stack.\r
+\r
+: AHEAD POSTPONE branch xhere 0 code,\r
+ 1 bal+ \ orig type is 1\r
+ ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameAHEAD,AHEAD\r
+\ DW DoLIT,Branch,COMPILEComma,XHere,DoLIT,0,CodeComma\r
+\ DW One,BalPlus,EXIT\r
+\r
+\ BL ( -- char ) \ CORE\r
+\ Return the value of the blank character.\r
+\r
+: BL blank-char-value EXIT ;\r
+\r
+\ $CONST NameBLank,BLank,' '\r
+\r
+\ CATCH ( i*x xt -- j*x 0 | i*x n ) \ EXCEPTION\r
+\ Push an exception frame on the exception stack and then execute\r
+\ the execution token xt in such a way that control can be\r
+\ transferred to a point just after CATCH if THROW is executed\r
+\ during the execution of xt.\r
+\r
+: CATCH sp@ >R throwFrame @ >R \ save error frame\r
+ rp@ throwFrame ! EXECUTE \ execute\r
+ R> throwFrame ! \ restore error frame\r
+ R> DROP 0 ; \ no error\r
+\r
+\ $COLON NameCATCH,CATCH\r
+\ DW SPFetch,ToR,ThrowFrame,Fetch,ToR\r
+\ DW RPFetch,ThrowFrame,Store,EXECUTE\r
+\ DW RFrom,ThrowFrame,Store\r
+\ DW RFrom,DROP,DoLIT,0,EXIT\r
+\r
+\ CELL+ ( a-addr1 -- a-addr2 ) \ CORE\r
+\ Return next aligned cell address.\r
+\r
+: CELL+ cell-size + ;\r
+\r
+\ $COLON NameCELLPlus,CELLPlus\r
+\ DW DoLIT,CELLL,Plus,EXIT\r
+\r
+\ $CODE NameCELLPlus,CELLPlus\r
+\ ADD BX,CELLL\r
+\ $NEXT\r
+\r
+\ CHAR+ ( c-addr1 -- c-addr2 ) \ CORE\r
+\ Returns next character-aligned address.\r
+\r
+: CHAR+ char-size + ;\r
+\r
+\ $COLON NameCHARPlus,CHARPlus\r
+\ DW DoLIT,CHARR,Plus,EXIT\r
+\r
+\ $CODE NameCHARPlus,CHARPlus\r
+\ INC BX\r
+\ $NEXT\r
+\r
+\ COMPILE, ( xt -- ) \ CORE EXT\r
+\ Compile the execution token on data stack into current\r
+\ colon definition.\r
+\ Structure of words with special compilation action\r
+\ for default compilation behavior\r
+\ |compile_xt|name_ptr| execution_code |\r
+\r
+: COMPILE, DUP specialComp? = IF DUP cell- cell- code@ EXECUTE EXIT THEN\r
+ code, ;\r
+\r
+\ $COLON NameCOMPILEComma,COMPILEComma\r
+\ DW DUPP,SpecialCompQ,Equals,ZBranch,COMPILEC1\r
+\ DW DUPP,CellMinus,CellMinus,CodeFetch,EXECUTE,EXIT\r
+\ COMPILEC1 DW CodeComma,EXIT\r
+\r
+\ $CODE NameCOMPILEComma,COMPILEComma\r
+\ CMP BX,AddrSpecialCompQ\r
+\ JE COMPILEC1\r
+\ MOV DI,AddrXHere\r
+\ MOV CS:[DI],BX\r
+\ ADD DI,CELLL\r
+\ POP BX\r
+\ MOV AddrXHere,DI\r
+\ $NEXT\r
+\ COMPILEC1: MOV AX,CS:[BX-2*CELLL]\r
+\ JMP AX\r
+\ $ALIGN\r
+\r
+\ compileCONST ( xt -- )\r
+\ Compile a CONSTANT word of which xt is given.\r
+\ Structure of CONSTANT word:\r
+\ |compile_xt|name_ptr| call-doCONST | x |\r
+\r
+: compileCONST\r
+ CELL+ CELL+ code@ POSTPONE LITERAL ;\r
+\r
+\ $COLON NameCompileCONST,CompileCONST\r
+\ DW CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT\r
+\r
+\ $CODE NameCompileCONST,CompileCONST\r
+\ MOV CX,CS:[BX+2*CELLL]\r
+\ MOV DI,AddrXHere\r
+\ MOV AX,OFFSET DoLIT\r
+\ MOV CS:[DI],AX\r
+\ MOV CS:[DI+CELLL],CX\r
+\ ADD DI,2*CELLL\r
+\ POP BX\r
+\ MOV AddrXHere,DI\r
+\ $NEXT\r
+\r
+\ CONSTANT ( x "<spaces>name" -- ) \ CORE\r
+\ name Execution: ( -- x )\r
+\ Create a definition for name which pushes x on the stack on\r
+\ execution.\r
+\r
+: CONSTANT bal IF -29 THROW THEN \ compiler nesting\r
+ xhere ALIGNED TO xhere\r
+ ['] compileCONST code,\r
+ xhere CELL+ TO xhere\r
+ ['] doCONST xt, head,\r
+ code, linkLast\r
+ lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+\ $COLON NameCONSTANT,CONSTANT\r
+\ DW Bal,ZBranch,CONST1\r
+\ DW DoLIT,-29,THROW\r
+\ CONST1 DW XHere,ALIGNED,DoTO,AddrXHere\r
+\ DW DoLIT,CompileCONST,CodeComma\r
+\ DW XHere,CELLPlus,DoTO,AddrXHere\r
+\ DW DoLIT,DoCONST,xtComma,HeadComma\r
+\ DW CodeComma,LinkLast\r
+\ DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+\ COUNT ( c-addr1 -- c-addr2 u ) \ CORE\r
+\ Convert counted string to string specification. c-addr2 is\r
+\ the next char-aligned address after c-addr1 and u is the\r
+\ contents at c-addr1.\r
+\r
+: COUNT DUP CHAR+ SWAP C@ ;\r
+\r
+\ $COLON NameCOUNT,COUNT\r
+\ DW DUPP,CHARPlus,SWAP,CFetch,EXIT\r
+\r
+\ $CODE NameCOUNT,COUNT\r
+\ MOV AX,BX\r
+\ INC AX\r
+\ MOV BL,[BX]\r
+\ XOR BH,BH\r
+\ PUSH AX\r
+\ $NEXT\r
+\r
+\ compileCREATE ( xt -- )\r
+\ Compile a CREATEd word of which xt is given.\r
+\ Structure of CREATEd word:\r
+\ |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |\r
+\r
+: compileCREATE\r
+ DUP CELL+ CELL+ code@ \ 0 or DOES>_xt\r
+ IF code, EXIT THEN\r
+ CELL+ CELL+ CELL+ code@ POSTPONE LITERAL ;\r
+\r
+\ $COLON NameCompileCREATE,CompileCREATE\r
+\ DW DUPP,CELLPlus,CELLPlus,CodeFetch,ZBranch,COMPCREAT1\r
+\ DW CodeComma,EXIT\r
+\ COMPCREAT1 DW CELLPlus,CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT\r
+\r
+\ CREATE ( "<spaces>name" -- ) \ CORE\r
+\ name Execution: ( -- a-addr )\r
+\ Create a data object in RAM/ROM data space, which return\r
+\ data object address on execution\r
+\r
+: CREATE bal IF -29 THROW THEN \ compiler nesting\r
+ xhere ALIGNED TO xhere\r
+ ['] compileCREATE code,\r
+ xhere CELL+ TO xhere \ reserve space for nfa\r
+ ['] doCREATE xt, head,\r
+ 0 code, \ no DOES> code yet\r
+ ALIGN HERE code, \ >BODY returns this address\r
+ linkLast \ link CREATEd word to current wordlist\r
+ lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+\ $COLON NameCREATE,CREATE\r
+\ DW Bal,ZBranch,CREAT1\r
+\ DW DoLIT,-29,THROW\r
+\ CREAT1 DW XHere,ALIGNED,DoTO,AddrXHere\r
+\ DW DoLIT,CompileCREATE,CodeComma\r
+\ DW XHere,CELLPlus,DoTO,AddrXHere\r
+\ DW DoLIT,DoCREATE,xtComma,HeadComma,DoLIT,0,CodeComma\r
+\ DW ALIGNN,HERE,CodeComma,LinkLast\r
+\ DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+\ D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE\r
+\ Add double-cell numbers.\r
+\r
+: D+ >R SWAP >R um+ R> R> + + ;\r
+\r
+\ $COLON NameDPlus,DPlus\r
+\ DW ToR,SWAP,ToR,UMPlus\r
+\ DW RFrom,RFrom,Plus,Plus,EXIT\r
+\r
+\ $CODE NameDPlus,DPlus\r
+\ POP CX\r
+\ POP DX\r
+\ POP AX\r
+\ ADD CX,AX\r
+\ ADC BX,DX\r
+\ PUSH CX\r
+\ $NEXT\r
+\r
+\ D. ( d -- ) \ DOUBLE\r
+\ Display d in free field format followed by a space.\r
+\r
+: D. (d.) TYPE SPACE ;\r
+\r
+\ $COLON NameDDot,DDot\r
+\ DW ParenDDot,TYPEE,SPACE,EXIT\r
+\r
+\ DECIMAL ( -- ) \ CORE\r
+\ Set the numeric conversion radix to decimal 10.\r
+\r
+: DECIMAL 10 BASE ! ;\r
+\r
+\ $COLON NameDECIMAL,DECIMAL\r
+\ DW DoLIT,10,DoLIT,AddrBASE,Store,EXIT\r
+\r
+\ DEPTH ( -- +n ) \ CORE\r
+\ Return the depth of the data stack.\r
+\r
+: DEPTH sp@ sp0 SWAP - cell-size / ;\r
+\r
+\ $COLON NameDEPTH,DEPTH\r
+\ DW SPFetch,SPZero,SWAP,Minus\r
+\ DW DoLIT,CELLL,Slash,EXIT\r
+\r
+\ $CODE NameDEPTH,DEPTH\r
+\ PUSH BX\r
+\ MOV BX,AddrUserP\r
+\ MOV BX,[BX+CELLL]\r
+\ SUB BX,SP\r
+\ SAR BX,1\r
+\ $NEXT\r
+\r
+\ DNEGATE ( d1 -- d2 ) \ DOUBLE\r
+\ Two's complement of double-cell number.\r
+\r
+: DNEGATE INVERT >R INVERT 1 um+ R> + ;\r
+\r
+\ $COLON NameDNEGATE,DNEGATE\r
+\ DW INVERT,ToR,INVERT\r
+\ DW DoLIT,1,UMPlus\r
+\ DW RFrom,Plus,EXIT\r
+\r
+\ $CODE NameDNEGATE,DNEGATE\r
+\ POP AX\r
+\ NEG AX\r
+\ PUSH AX\r
+\ ADC BX,0\r
+\ NEG BX\r
+\ $NEXT\r
+\r
+\ EKEY ( -- u ) \ FACILITY EXT\r
+\ Receive one keyboard event u.\r
+\r
+: EKEY BEGIN PAUSE EKEY? UNTIL 'ekey EXECUTE ;\r
+\r
+\ $COLON NameEKEY,EKEY\r
+\ EKEY1 DW PAUSE,EKEYQuestion,ZBranch,EKEY1\r
+\ DW TickEKEY,EXECUTE,EXIT\r
+\r
+\ EMIT ( x -- ) \ CORE\r
+\ Send a character to the output device.\r
+\r
+: EMIT 'emit EXECUTE ;\r
+\r
+\ $COLON NameEMIT,EMIT\r
+\ DW TickEMIT,EXECUTE,EXIT\r
+\r
+\ $CODE NameEMIT,EMIT\r
+\ MOV AX,AddrTickEMIT\r
+\ JMP AX\r
+\ $ALIGN\r
+\r
+\ FM/MOD ( d n1 -- n2 n3 ) \ CORE\r
+\ Signed floored divide of double by single. Return mod n2\r
+\ and quotient n3.\r
+\r
+: FM/MOD DUP >R 2DUP XOR >R >R DUP 0< IF DNEGATE THEN\r
+ R@ ABS UM/MOD DUP 0<\r
+ IF DUP [ 16 BASE ! ] 8000 [ DECIMAL ] XOR IF -11 THROW THEN THEN \ result out of range\r
+ SWAP R> 0< IF NEGATE THEN\r
+ SWAP R> 0< IF NEGATE OVER IF R@ ROT - SWAP 1- THEN THEN\r
+ R> DROP ;\r
+\r
+\ $COLON 6,'FM/MOD',FMSlashMOD,_FLINK\r
+\ DW DUPP,ToR,TwoDUP,XORR,ToR,ToR,DUPP,ZeroLess\r
+\ DW ZBranch,FMMOD1\r
+\ DW DNEGATE\r
+\ FMMOD1 DW RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,FMMOD2\r
+\ DW DUPP,DoLIT,08000h,XORR,ZBranch,FMMOD2\r
+\ DW DoLIT,-11,THROW\r
+\ FMMOD2 DW SWAP,RFrom,ZeroLess,ZBranch,FMMOD3\r
+\ DW NEGATE\r
+\ FMMOD3 DW SWAP,RFrom,ZeroLess,ZBranch,FMMOD4\r
+\ DW NEGATE,OVER,ZBranch,FMMOD4\r
+\ DW RFetch,ROT,Minus,SWAP,OneMinus\r
+\ FMMOD4 DW RFrom,DROP,EXIT\r
+\r
+\ $CODE NameFMSlashMOD,FMSlashMOD\r
+\ POP DX\r
+\ POP AX\r
+\ OR DX,DX\r
+\ JS FMMOD2\r
+\ OR BX,BX\r
+\ JZ FMMOD1\r
+\ JS FMMOD3\r
+\ CMP DX,BX\r
+\ JAE FMMOD6\r
+\ DIV BX ;positive dividend, positive divisor\r
+\ CMP AX,08000h\r
+\ JA FMMOD6\r
+\ PUSH DX\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\ FMMOD3: NEG BX ;positive dividend, negative divisor\r
+\ CMP DX,BX\r
+\ JAE FMMOD6\r
+\ DIV BX\r
+\ CMP AX,08000h\r
+\ JA FMMOD6\r
+\ OR DX,DX\r
+\ JZ FMMOD7 ;modulo = 0\r
+\ SUB DX,BX\r
+\ NOT AX ;AX=-AX-1\r
+\ PUSH DX\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\ FMMOD2: NEG AX ;DNEGATE\r
+\ ADC DX,0\r
+\ NEG DX\r
+\ OR BX,BX\r
+\ JZ FMMOD1\r
+\ JS FMMOD4\r
+\ CMP DX,BX ;negative dividend, positive divisor\r
+\ JAE FMMOD6\r
+\ DIV BX\r
+\ CMP AX,08000h\r
+\ JA FMMOD6\r
+\ OR DX,DX\r
+\ JZ FMMOD7\r
+\ SUB BX,DX\r
+\ NOT AX ;AX=-AX-1\r
+\ PUSH BX\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\ FMMOD7: NEG AX\r
+\ PUSH DX\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\ FMMOD4: NEG BX ;negative dividend, negative divisor\r
+\ CMP DX,BX\r
+\ JAE FMMOD6\r
+\ DIV BX\r
+\ CMP AX,08000h\r
+\ JA FMMOD6\r
+\ NEG DX\r
+\ MOV BX,AX\r
+\ PUSH DX\r
+\ $NEXT\r
+\ FMMOD6: MOV BX,-11 ;result out of range\r
+\ JMP THROW\r
+\ FMMOD1: MOV BX,-10 ;divide by zero\r
+\ JMP THROW\r
+\ $ALIGN\r
+\r
+\ GET-CURRENT ( -- wid ) \ SEARCH\r
+\ Return the indentifier of the compilation wordlist.\r
+\r
+: GET-CURRENT current @ ;\r
+\r
+\ $COLON NameGET_CURRENT,GET_CURRENT\r
+\ DW DoLIT,AddrCurrent,Fetch,EXIT\r
+\r
+\ HOLD ( char -- ) \ CORE\r
+\ Add char to the beginning of pictured numeric output string.\r
+\r
+: HOLD hld @ 1 CHARS - DUP hld ! C! ;\r
+\r
+\ $COLON NameHOLD,HOLD\r
+\ DW DoLIT,AddrHLD,Fetch,DoLIT,0-CHARR,Plus\r
+\ DW DUPP,DoLIT,AddrHLD,Store,CStore,EXIT\r
+\r
+\ $CODE NameHOLD,HOLD\r
+\ MOV DI,AddrHLD\r
+\ DEC DI\r
+\ MOV AddrHLD,DI\r
+\ MOV [DI],BL\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ I ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE\r
+\ Push the innermost loop index.\r
+\r
+: I rp@ [ 1 CELLS ] LITERAL + @\r
+ rp@ [ 2 CELLS ] LITERAL + @ + ; COMPILE-ONLY\r
+\r
+\ $COLON NameI,I\r
+\ DW RPFetch,DoLIT,CELLL,Plus,Fetch\r
+\ DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT\r
+\r
+\ $CODE NameI,I\r
+\ PUSH BX\r
+\ MOV BX,[BP]\r
+\ ADD BX,[BP+2]\r
+\ $NEXT\r
+\r
+\ IF Compilation: ( C: -- orig ) \ CORE\r
+\ Run-time: ( x -- )\r
+\ Put the location of a new unresolved forward reference orig\r
+\ onto the control flow stack. On execution jump to location\r
+\ specified by the resolution of orig if x is zero.\r
+\r
+: IF POSTPONE 0branch xhere 0 code,\r
+ 1 bal+ ; \ orig type is 1\r
+\r
+\ $COLON NameIFF,IFF\r
+\ DW DoLIT,ZBranch,COMPILEComma,XHere,DoLIT,0,CodeComma\r
+\ DW One,BalPlus,EXIT\r
+\r
+\ INVERT ( x1 -- x2 ) \ CORE\r
+\ Return one's complement of x1.\r
+\r
+: INVERT -1 XOR ;\r
+\r
+\ $COLON NameINVERT,INVERT\r
+\ DW DoLIT,-1,XORR,EXIT\r
+\r
+\ $CODE NameINVERT,INVERT\r
+\ NOT BX\r
+\ $NEXT\r
+\r
+\ KEY ( -- char ) \ CORE\r
+\ Receive a character. Do not display char.\r
+\r
+: KEY EKEY max-char AND ;\r
+\r
+\ $COLON NameKEY,KEY\r
+\ DW EKEY,DoLIT,MaxChar,ANDD,EXIT\r
+\r
+\ LITERAL Compilation: ( x -- ) \ CORE\r
+\ Run-time: ( -- x )\r
+\ Append following run-time semantics. Put x on the stack on\r
+\ execution\r
+\r
+: LITERAL POSTPONE doLIT code, ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameLITERAL,LITERAL\r
+\ DW DoLIT,DoLIT,COMPILEComma,CodeComma,EXIT\r
+\r
+\ NEGATE ( n1 -- n2 ) \ CORE\r
+\ Return two's complement of n1.\r
+\r
+: NEGATE INVERT 1+ ;\r
+\r
+\ $COLON NameNEGATE,NEGATE\r
+\ DW INVERT,OnePlus,EXIT\r
+\r
+\ $CODE NameNEGATE,NEGATE\r
+\ NEG BX\r
+\ $NEXT\r
+\r
+\ NIP ( n1 n2 -- n2 ) \ CORE EXT\r
+\ Discard the second stack item.\r
+\r
+: NIP SWAP DROP ;\r
+\r
+\ $COLON NameNIP,NIP\r
+\ DW SWAP,DROP,EXIT\r
+\r
+\ $CODE NameNIP,NIP\r
+\ POP AX\r
+\ $NEXT\r
+\r
+\ PARSE ( char "ccc<char>"-- c-addr u ) \ CORE EXT\r
+\ Scan input stream and return counted string delimited by char.\r
+\r
+: PARSE >R SOURCE >IN @ /STRING \ c-addr u R: char\r
+ DUP IF\r
+ OVER CHARS + OVER \ c-addr c-addr+u c-addr R: char\r
+ BEGIN DUP C@ R@ XOR\r
+ WHILE CHAR+ 2DUP =\r
+ UNTIL DROP OVER - 1chars/ DUP\r
+ ELSE NIP OVER - 1chars/ DUP CHAR+\r
+ THEN >IN +!\r
+ THEN R> DROP EXIT ;\r
+\r
+\ $COLON 5,'PARSE',PARSE,_FLINK\r
+\ DW ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING\r
+\ DW DUPP,ZBranch,PARSE4\r
+\ DW OVER,CHARS,Plus,OVER\r
+\ PARSE1 DW DUPP,CFetch,RFetch,XORR,ZBranch,PARSE3\r
+\ DW CHARPlus,TwoDUP,Equals,ZBranch,PARSE1\r
+\ PARSE2 DW DROP,OVER,Minus,DUPP,OneCharsSlash,Branch,PARSE5\r
+\ PARSE3 DW NIP,OVER,Minus,DUPP,OneCharsSlash,CHARPlus\r
+\ PARSE5 DW DoLIT,AddrToIN,PlusStore\r
+\ PARSE4 DW RFrom,DROP,EXIT\r
+\r
+\ $CODE NamePARSE,PARSE\r
+\ MOV AH,BL\r
+\ MOV DX,SI\r
+\ MOV SI,AddrSourceVar+CELLL\r
+\ MOV BX,AddrSourceVar\r
+\ MOV CX,AddrToIN\r
+\ ADD SI,CX\r
+\ SUB BX,CX\r
+\ MOV CX,SI\r
+\ PUSH SI\r
+\ OR BX,BX\r
+\ JZ PARSE1\r
+\ PARSE5: LODSB\r
+\ CMP AL,AH\r
+\ JE PARSE4\r
+\ DEC BX\r
+\ OR BX,BX\r
+\ JNZ PARSE5\r
+\ MOV BX,SI\r
+\ SUB SI,AddrSourceVar+CELLL\r
+\ SUB BX,CX\r
+\ MOV AddrToIN,SI\r
+\ PARSE1: MOV SI,DX\r
+\ $NEXT\r
+\ PARSE4: MOV BX,SI\r
+\ SUB SI,AddrSourceVar+CELLL\r
+\ SUB BX,CX\r
+\ DEC BX\r
+\ MOV AddrToIN,SI\r
+\ MOV SI,DX\r
+\ $NEXT\r
+\r
+\ QUIT ( -- ) ( R: i*x -- ) \ CORE\r
+\ Empty the return stack, store zero in SOURCE-ID, make the user\r
+\ input device the input source, and start text interpreter.\r
+\r
+: QUIT BEGIN\r
+ rp0 rp! 0 TO SOURCE-ID 0 TO bal POSTPONE [\r
+ BEGIN CR REFILL DROP SPACE \ REFILL returns always true\r
+ ['] interpret CATCH ?DUP 0=\r
+ WHILE STATE @ 0= IF .prompt THEN\r
+ REPEAT\r
+ DUP -1 XOR IF \ ABORT\r
+ DUP -2 = IF SPACE abort"msg 2@ TYPE ELSE \ ABORT"\r
+ SPACE errWord 2@ TYPE\r
+ SPACE [CHAR] ? EMIT SPACE\r
+ DUP -1 -58 WITHIN IF ." Exception # " . ELSE \ undefined exception\r
+ CELLS THROWMsgTbl + @ COUNT TYPE THEN THEN THEN\r
+ sp0 sp!\r
+ AGAIN ;\r
+\r
+\ $COLON NameQUIT,QUIT\r
+\ QUIT1 DW RPZero,RPStore,DoLIT,0,DoTO,AddrSOURCE_ID\r
+\ DW DoLIT,0,DoTO,AddrBal,LeftBracket\r
+\ QUIT2 DW CR,REFILL,DROP,SPACE\r
+\ DW DoLIT,Interpret,CATCH,QuestionDUP,ZeroEquals\r
+\ DW ZBranch,QUIT3\r
+\ DW DoLIT,AddrSTATE,Fetch,ZeroEquals,ZBranch,QUIT2\r
+\ DW DotPrompt,Branch,QUIT2\r
+\ QUIT3 DW DUPP,DoLIT,-1,XORR,ZBranch,QUIT5\r
+\ DW DUPP,DoLIT,-2,Equals,ZBranch,QUIT4\r
+\ DW SPACE,DoLIT,AddrAbortQMsg,TwoFetch,TYPEE,Branch,QUIT5\r
+\ QUIT4 DW SPACE,DoLIT,AddrErrWord,TwoFetch,TYPEE\r
+\ DW SPACE,DoLIT,'?',EMIT,SPACE\r
+\ DW DUPP,DoLIT,-1,DoLIT,-58,WITHIN,ZBranch,QUIT7\r
+\ DW DoLIT,QUITstr\r
+\ DW COUNT,TYPEE,Dot,Branch,QUIT5\r
+\ QUIT7 DW CELLS,DoLIT,AddrTHROWMsgTbl,Plus,Fetch,COUNT,TYPEE\r
+\ QUIT5 DW SPZero,SPStore,Branch,QUIT1\r
+\r
+\ REFILL ( -- flag ) \ CORE EXT\r
+\ Attempt to fill the input buffer from the input source. Make\r
+\ the result the input buffer, set >IN to zero, and return true\r
+\ if successful. Return false if the input source is a string\r
+\ from EVALUATE.\r
+\r
+\ Nick, possible problem here\r
+\ : REFILL SOURCE-ID IF 0 EXIT THEN\r
+\ memTop [ size-of-PAD CHARS ] LITERAL - DUP\r
+\ size-of-PAD ACCEPT sourceVar 2!\r
+\ 0 >IN ! -1 ;\r
+\r
+\ $COLON NameREFILL,REFILL\r
+\ DW SOURCE_ID,ZBranch,REFIL1\r
+\ DW DoLIT,0,EXIT\r
+\ REFIL1 DW MemTop,DoLIT,0-PADSize*CHARR,Plus,DUPP\r
+\ DW DoLIT,PADSize*CHARR,ACCEPT,DoLIT,AddrSourceVar,TwoStore\r
+\ DW DoLIT,0,DoLIT,AddrToIN,Store,DoLIT,-1,EXIT\r
+\r
+\ ROT ( x1 x2 x3 -- x2 x3 x1 ) \ CORE\r
+\ Rotate the top three data stack items.\r
+\r
+: ROT >R SWAP R> SWAP ;\r
+\r
+\ $COLON NameROT,ROT\r
+\ DW ToR,SWAP,RFrom,SWAP,EXIT\r
+\r
+\ $CODE NameROT,ROT\r
+\ POP AX\r
+\ POP CX\r
+\ PUSH AX\r
+\ PUSH BX\r
+\ MOV BX,CX\r
+\ $NEXT\r
+\r
+\ S>D ( n -- d ) \ CORE\r
+\ Convert a single-cell number n to double-cell number.\r
+\r
+: S>D DUP 0< ;\r
+\r
+\ $COLON NameSToD,SToD\r
+\ DW DUPP,ZeroLess,EXIT\r
+\r
+\ $CODE NameSToD,SToD\r
+\ PUSH BX\r
+\ MOV AX,BX\r
+\ CWD\r
+\ MOV BX,DX\r
+\ $NEXT\r
+\r
+\ SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1) \ SEARCH\r
+\ Search word list for a match with the given name.\r
+\ Return execution token and -1 or 1 ( IMMEDIATE) if found.\r
+\ Return 0 if not found.\r
+\r
+: SEARCH-WORDLIST\r
+ (search-wordlist) DUP IF NIP THEN ;\r
+\r
+\ $COLON NameSEARCH_WORDLIST,SEARCH_WORDLIST\r
+\ DW ParenSearch_Wordlist,DUPP,ZBranch,SRCHW1\r
+\ DW NIP\r
+\ SRCHW1 DW EXIT\r
+\r
+\ SIGN ( n -- ) \ CORE\r
+\ Add a minus sign to the numeric output string if n is negative.\r
+\r
+: SIGN 0< IF [CHAR] - HOLD THEN ;\r
+\r
+\ $COLON NameSIGN,SIGN\r
+\ DW ZeroLess,ZBranch,SIGN1\r
+\ DW DoLIT,'-',HOLD\r
+\ SIGN1 DW EXIT\r
+\r
+\ $CODE NameSIGN,SIGN\r
+\ OR BX,BX\r
+\ JNS SIGN1\r
+\ MOV AL,'-'\r
+\ MOV DI,AddrHLD\r
+\ DEC DI\r
+\ MOV AddrHLD,DI\r
+\ MOV [DI],AL\r
+\ SIGN1: POP BX\r
+\ $NEXT\r
+\r
+\ SOURCE ( -- c-addr u ) \ CORE\r
+\ Return input buffer string.\r
+\r
+: SOURCE sourceVar 2@ ;\r
+\r
+\ $COLON NameSOURCE,SOURCE\r
+\ DW DoLIT,AddrSourceVar,TwoFetch,EXIT\r
+\r
+\ SPACE ( -- ) \ CORE\r
+\ Send the blank character to the output device.\r
+\r
+: SPACE 32 EMIT ;\r
+\r
+\ $COLON NameSPACE,SPACE\r
+\ DW DoLIT,' ',EMIT,EXIT\r
+\r
+\ $CODE NameSPACE,SPACE\r
+\ PUSH BX\r
+\ MOV BX,' '\r
+\ MOV AX,AddrTickEMIT\r
+\ JMP AX\r
+\ $ALIGN\r
+\r
+\ STATE ( -- a-addr ) \ CORE\r
+\ Return the address of a cell containing compilation-state flag\r
+\ which is true in compilation state or false otherwise.\r
+\r
+\ $CONST NameSTATE,STATE,AddrSTATE\r
+\r
+\ THEN Compilation: ( C: orig -- ) \ CORE\r
+\ Run-time: ( -- )\r
+\ Resolve the forward reference orig.\r
+\r
+: THEN 1- IF -22 THROW THEN \ control structure mismatch\r
+ \ orig type is 1\r
+ xhere SWAP code! bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameTHENN,THENN\r
+\ DW OneMinus,ZBranch,THEN1\r
+\ DW DoLIT,-22,THROW\r
+\ THEN1 DW XHere,SWAP,CodeStore,BalMinus,EXIT\r
+\r
+\ THROW ( k*x n -- k*x | i*x n ) \ EXCEPTION\r
+\ If n is not zero, pop the topmost exception frame from the\r
+\ exception stack, along with everything on the return stack\r
+\ above the frame. Then restore the condition before CATCH and\r
+\ transfer control just after the CATCH that pushed that\r
+\ exception frame.\r
+\r
+: THROW ?DUP\r
+ IF throwFrame @ rp! \ restore return stack\r
+ R> throwFrame ! \ restore THROW frame\r
+ R> SWAP >R sp! \ restore data stack\r
+ DROP R>\r
+ 'init-i/o EXECUTE\r
+ THEN ;\r
+\r
+\ $COLON NameTHROW,THROW\r
+\ DW QuestionDUP,ZBranch,THROW1\r
+\ DW ThrowFrame,Fetch,RPStore,RFrom,ThrowFrame,Store\r
+\ DW RFrom,SWAP,ToR,SPStore,DROP,RFrom\r
+\ DW TickINIT_IO,EXECUTE\r
+\ THROW1 DW EXIT\r
+\r
+\ TYPE ( c-addr u -- ) \ CORE\r
+\ Display the character string if u is greater than zero.\r
+\r
+: TYPE ?DUP IF 0 DO DUP C@ EMIT CHAR+ LOOP THEN DROP ;\r
+\r
+\ $COLON NameTYPEE,TYPEE\r
+\ DW QuestionDUP,ZBranch,TYPE2\r
+\ DW DoLIT,0,DoDO\r
+\ TYPE1 DW DUPP,CFetch,EMIT,CHARPlus,DoLOOP,TYPE1\r
+\ TYPE2 DW DROP,EXIT\r
+\r
+\ $CODE NameTYPEE,TYPEE\r
+\ POP DI\r
+\ OR BX,BX\r
+\ JZ TYPE2\r
+\ PUSH SI\r
+\ SUB BP,CELLL\r
+\ MOV [BP],BX\r
+\ MOV BX,DI\r
+\ TYPE4: MOV DI,BX\r
+\ XOR BX,BX\r
+\ MOV BL,[DI]\r
+\ INC DI\r
+\ PUSH DI\r
+\ MOV SI,OFFSET TYPE3\r
+\ MOV AX,AddrTickEMIT\r
+\ JMP AX\r
+\ TYPE1: DEC WORD PTR [BP]\r
+\ JNZ TYPE4\r
+\ POP SI\r
+\ ADD BP,CELLL\r
+\ TYPE2: POP BX\r
+\ $NEXT\r
+\ TYPE3 DW TYPE1\r
+\r
+\ U< ( u1 u2 -- flag ) \ CORE\r
+\ Unsigned compare of top two items. True if u1 < u2.\r
+\r
+: U< 2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;\r
+\r
+\ $COLON NameULess,ULess\r
+\ DW TwoDUP,XORR,ZeroLess\r
+\ DW ZBranch,ULES1\r
+\ DW NIP,ZeroLess,EXIT\r
+\ ULES1 DW Minus,ZeroLess,EXIT\r
+\r
+\ $CODE NameULess,ULess\r
+\ POP AX\r
+\ SUB AX,BX\r
+\ MOV BX,-1\r
+\ JB ULES1\r
+\ INC BX\r
+\ ULES1: $NEXT\r
+\r
+\ UM* ( u1 u2 -- ud ) \ CORE\r
+\ Unsigned multiply. Return double-cell product.\r
+\r
+: UM* 0 SWAP cell-size-in-bits 0 DO\r
+ DUP um+ >R >R DUP um+ R> +\r
+ R> IF >R OVER um+ R> + THEN \ if carry\r
+ LOOP ROT DROP ;\r
+\r
+\ $COLON NameUMStar,UMStar\r
+\ DW DoLIT,0,SWAP,DoLIT,CELLL*8,DoLIT,0,DoDO\r
+\ UMST1 DW DUPP,UMPlus,ToR,ToR\r
+\ DW DUPP,UMPlus,RFrom,Plus,RFrom\r
+\ DW ZBranch,UMST2\r
+\ DW ToR,OVER,UMPlus,RFrom,Plus\r
+\ UMST2 DW DoLOOP,UMST1\r
+\ DW ROT,DROP,EXIT\r
+\r
+\ $CODE NameUMStar,UMStar\r
+\ POP AX\r
+\ MUL BX\r
+\ PUSH AX\r
+\ MOV BX,DX\r
+\ $NEXT\r
+\r
+\ UM/MOD ( ud u1 -- u2 u3 ) \ CORE\r
+\ Unsigned division of a double-cell number ud by a single-cell\r
+\ number u1. Return remainder u2 and quotient u3.\r
+\r
+: UM/MOD DUP 0= IF -10 THROW THEN \ divide by zero\r
+ 2DUP U< IF\r
+ NEGATE cell-size-in-bits 0\r
+ DO >R DUP um+ >R >R DUP um+ R> + DUP\r
+ R> R@ SWAP >R um+ R> OR\r
+ IF >R DROP 1+ R> THEN\r
+ ELSE DROP THEN\r
+ R>\r
+ LOOP DROP SWAP EXIT\r
+ ELSE -11 THROW \ result out of range\r
+ THEN ;\r
+\r
+\ $COLON NameUMSlashMOD,UMSlashMOD\r
+\ DW DUPP,ZBranch,UMM5\r
+\ DW TwoDUP,ULess,ZBranch,UMM4\r
+\ DW NEGATE,DoLIT,CELLL*8,DoLIT,0,DoDO\r
+\ UMM1 DW ToR,DUPP,UMPlus,ToR,ToR,DUPP,UMPlus,RFrom,Plus,DUPP\r
+\ DW RFrom,RFetch,SWAP,ToR,UMPlus,RFrom,ORR,ZBranch,UMM2\r
+\ DW ToR,DROP,OnePlus,RFrom,Branch,UMM3\r
+\ UMM2 DW DROP\r
+\ UMM3 DW RFrom,DoLOOP,UMM1\r
+\ DW DROP,SWAP,EXIT\r
+\ UMM5 DW DoLIT,-10,THROW\r
+\ UMM4 DW DoLIT,-11,THROW\r
+\r
+\ $CODE NameUMSlashMOD,UMSlashMOD\r
+\ OR BX,BX\r
+\ JZ UMM1\r
+\ POP DX\r
+\ CMP DX,BX\r
+\ JAE UMM2\r
+\ POP AX\r
+\ DIV BX\r
+\ PUSH DX\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\ UMM1: MOV BX,-10 ;divide by zero\r
+\ JMP THROW\r
+\ UMM2: MOV BX,-11 ;result out of range\r
+\ JMP THROW\r
+\ $ALIGN\r
+\r
+\ UNLOOP ( -- ) ( R: loop-sys -- ) \ CORE\r
+\ Discard loop-control parameters for the current nesting level.\r
+\ An UNLOOP is required for each nesting level before the\r
+\ definition may be EXITed.\r
+\r
+: UNLOOP R> R> R> 2DROP >R ;\r
+\r
+\ $COLON NameUNLOOP,UNLOOP\r
+\ DW RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT\r
+\r
+\ $CODE NameUNLOOP,UNLOOP\r
+\ ADD BP,2*CELLL\r
+\ $NEXT\r
+\r
+\ WITHIN ( n1|u1 n2|n2 n3|u3 -- flag ) \ CORE EXT\r
+\ Return true if (n2|u2<=n1|u1 and n1|u1<n3|u3) or\r
+\ (n2|u2>n3|u3 and (n2|u2<=n1|u1 or n1|u1<n3|u3)).\r
+\r
+: WITHIN OVER - >R - R> U< ;\r
+\r
+\ $COLON NameWITHIN,WITHIN\r
+\ DW OVER,Minus,ToR ;ul <= u < uh\r
+\ DW Minus,RFrom,ULess,EXIT\r
+\r
+\ $CODE NameWITHIN,WITHIN\r
+\ POP AX\r
+\ SUB BX,AX\r
+\ POP DX\r
+\ SUB DX,AX\r
+\ CMP DX,BX\r
+\ MOV BX,-1\r
+\ JB WITHIN1\r
+\ INC BX\r
+\ WITHIN1: $NEXT\r
+\r
+\ [ ( -- ) \ CORE\r
+\ Enter interpretation state.\r
+\r
+: [ 0 STATE ! ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameLeftBracket,LeftBracket\r
+\ DW DoLIT,0,DoLIT,AddrSTATE,Store,EXIT\r
+\r
+\ ] ( -- ) \ CORE\r
+\ Enter compilation state.\r
+\r
+: ] -1 STATE ! ;\r
+\r
+\ $COLON NameRightBracket,RightBracket\r
+\ DW DoLIT,-1,DoLIT,AddrSTATE,Store,EXIT\r
+\r
+\ ;;;;;;;;;;;;;;;\r
+\ Rest of CORE words and two facility words, EKEY? and EMIT?\r
+\ ;;;;;;;;;;;;;;;\r
+\ Following definitions can be removed from assembler source and\r
+\ can be colon-defined later.\r
+\r
+\ ( ( "ccc<)>" -- ) \ CORE\r
+\ Ignore following string up to next ) . A comment.\r
+\r
+: ( [CHAR] ) PARSE 2DROP ;\r
+\r
+\ $COLON NameParen,Paren\r
+\ DW DoLIT,')',PARSE,TwoDROP,EXIT\r
+\r
+\ * ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+\ Multiply n1|u1 by n2|u2 giving a single product.\r
+\r
+: * UM* DROP ;\r
+\r
+\ $COLON NameStar,Star\r
+\ DW UMStar,DROP,EXIT\r
+\r
+\ $CODE NameStar,Star\r
+\ POP AX\r
+\ IMUL BX\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\r
+\ */ ( n1 n2 n3 -- n4 ) \ CORE\r
+\ Multiply n1 by n2 producing double-cell intermediate,\r
+\ then divide it by n3. Return single-cell quotient.\r
+\r
+: */ */MOD NIP ;\r
+\r
+\ $COLON NameStarSlash,StarSlash\r
+\ DW StarSlashMOD,NIP,EXIT\r
+\r
+\ */MOD ( n1 n2 n3 -- n4 n5 ) \ CORE\r
+\ Multiply n1 by n2 producing double-cell intermediate,\r
+\ then divide it by n3. Return single-cell remainder and\r
+\ single-cell quotient.\r
+\r
+: */MOD >R M* R> FM/MOD ;\r
+\r
+\ $COLON NameStarSlashMOD,StarSlashMOD\r
+\ DW ToR,MStar,RFrom,FMSlashMOD,EXIT\r
+\r
+\ $CODE NameStarSlashMOD,StarSlashMOD\r
+\ POP AX\r
+\ POP CX\r
+\ IMUL CX\r
+\ PUSH AX\r
+\ PUSH DX\r
+\ JMP FMSlashMOD\r
+\ $ALIGN\r
+\r
+\ +LOOP Compilation: ( C: do-sys -- ) \ CORE\r
+\ Run-time: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+\ Terminate a DO-+LOOP structure. Resolve the destination of all\r
+\ unresolved occurences of LEAVE.\r
+\ On execution add n to the loop index. If loop index did not\r
+\ cross the boundary between loop_limit-1 and loop_limit,\r
+\ continue execution at the beginning of the loop. Otherwise,\r
+\ finish the loop.\r
+\r
+: +LOOP POSTPONE do+LOOP rake ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NamePlusLOOP,PlusLOOP\r
+\ DW DoLIT,DoPLOOP,COMPILEComma,rake,EXIT\r
+\r
+\ ." ( "ccc<">" -- ) \ CORE\r
+\ Run-time ( -- )\r
+\ Compile an inline string literal to be typed out at run time.\r
+\r
+: ." POSTPONE S" POSTPONE TYPE ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameDotQuote,DotQuote\r
+\ DW SQuote,DoLIT,TYPEE,COMPILEComma,EXIT\r
+\r
+\ 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) \ CORE\r
+\ Copy cell pair x1 x2 to the top of the stack.\r
+\r
+: 2OVER >R >R 2DUP R> R> 2SWAP ;\r
+\r
+\ $COLON NameTwoOVER,TwoOVER\r
+\ DW ToR,ToR,TwoDUP,RFrom,RFrom,TwoSWAP,EXIT\r
+\r
+\ $CODE NameTwoOVER,TwoOVER\r
+\ MOV DI,SP\r
+\ PUSH BX\r
+\ PUSH [DI+2*CELLL]\r
+\ MOV BX,[DI+CELLL]\r
+\ $NEXT\r
+\r
+\ >BODY ( xt -- a-addr ) \ CORE\r
+\ Push data field address of CREATEd word.\r
+\r
+: >BODY ?call DUP IF \ code-addr xt2\r
+ ['] doCREATE = IF \ should be call-doCREATE\r
+ CELL+ code@ EXIT\r
+ THEN THEN\r
+ -31 THROW ; \ >BODY used on non-CREATEd definition\r
+\r
+\ $COLON NameToBODY,ToBODY\r
+\ DW QCall,DUPP,ZBranch,TBODY1\r
+\ DW DoLIT,DoCREATE,Equals,ZBranch,TBODY1\r
+\ DW CELLPlus,CodeFetch,EXIT\r
+\ TBODY1 DW DoLIT,-31,THROW\r
+\r
+\ ABORT" ( "ccc<">" -- ) \ EXCEPTION EXT\r
+\ Run-time ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )\r
+\ Conditional abort with an error message.\r
+\r
+: ABORT" S" POSTPONE ROT\r
+ POSTPONE IF POSTPONE abort"msg POSTPONE 2!\r
+ -2 POSTPONE LITERAL POSTPONE THROW\r
+ POSTPONE ELSE POSTPONE 2DROP POSTPONE THEN\r
+ ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameABORTQuote,ABORTQuote\r
+\ DW SQuote,DoLIT,ROT,COMPILEComma\r
+\ DW IFF,DoLIT,AbortQMsg,COMPILEComma ; IF is immediate\r
+\ DW DoLIT,TwoStore,COMPILEComma\r
+\ DW DoLIT,-2,LITERAL ; LITERAL is immediate\r
+\ DW DoLIT,THROW,COMPILEComma\r
+\ DW ELSEE,DoLIT,TwoDROP,COMPILEComma ; ELSE and THEN are\r
+\ DW THENN,EXIT ; immediate\r
+\r
+\ ABS ( n -- u ) \ CORE\r
+\ Return the absolute value of n.\r
+\r
+: ABS DUP 0< IF NEGATE THEN ;\r
+\r
+\ $COLON NameABSS,ABSS\r
+\ DW DUPP,ZeroLess,ZBranch,ABS1\r
+\ DW NEGATE\r
+\ ABS1 DW EXIT\r
+\r
+\ $CODE NameABSS,ABSS\r
+\ OR BX,BX\r
+\ JNS ABS1\r
+\ NEG BX\r
+\ ABS1: $NEXT\r
+\r
+\ ALLOT ( n -- ) \ CORE\r
+\ Allocate n bytes in data space.\r
+\r
+: ALLOT HERE + TO HERE ;\r
+\r
+\ $COLON NameALLOT,ALLOT\r
+\ DW HERE,Plus,DoTO,AddrHERE,EXIT\r
+\r
+\ BEGIN ( C: -- dest ) \ CORE\r
+\ Start an infinite or indefinite loop structure. Put the next\r
+\ location for a transfer of control, dest, onto the data\r
+\ control stack.\r
+\r
+: BEGIN xhere 0 bal+ \ dest type is 0\r
+ ; COMPILE-ONLY IMMDEDIATE\r
+\r
+\ $COLON NameBEGIN,BEGIN\r
+\ DW XHere,DoLIT,0,BalPlus,EXIT\r
+\r
+\ C, ( char -- ) \ CORE\r
+\ Compile a character into data space.\r
+\r
+: C, HERE C! HERE CHAR+ TO HERE ;\r
+\r
+\ $COLON NameCComma,CComma\r
+\ DW HERE,CStore,HERE,CHARPlus,DoTO,AddrHERE,EXIT\r
+\r
+\ $CODE NameCComma,CComma\r
+\ MOV DI,AddrHERE\r
+\ MOV [DI],BL\r
+\ INC DI\r
+\ MOV AddrHERE,DI\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ CHAR ( "<spaces>ccc" -- char ) \ CORE\r
+\ Parse next word and return the value of first character.\r
+\r
+: CHAR PARSE-WORD DROP C@ ;\r
+\r
+\ $COLON NameCHAR,CHAR\r
+\ DW PARSE_WORD,DROP,CFetch,EXIT\r
+\r
+\ DO Compilation: ( C: -- do-sys ) \ CORE\r
+\ Run-time: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )\r
+\ Start a DO-LOOP structure in a colon definition. Place do-sys\r
+\ on control-flow stack, which will be resolved by LOOP or +LOOP.\r
+\r
+: DO 0 rakeVar ! 0 \ ?DO-orig is 0 for DO\r
+\ POSTPONE doDO xhere bal+ \ DO-dest\r
+\r
+\ $COLON NameDO,DO\r
+\ DW DoLIT,0,RakeVar,Store,DoLIT,0\r
+\ DW DoLIT,DoDO,COMPILEComma,XHere,BalPlus,EXIT\r
+\r
+\ DOES> ( C: colon-sys1 -- colon-sys2 ) \ CORE\r
+\ Build run time code of the data object CREATEd.\r
+\r
+: DOES> bal 1- IF -22 THROW THEN \ control structure mismatch\r
+ NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+ POSTPONE pipe ['] doLIST xt, -1 ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameDOESGreater,DOESGreater\r
+\ DW Bal,OneMinus,ZBranch,DOES1\r
+\ DW DoLIT,-22,THROW\r
+\ DOES1 DW NIP,OnePlus,ZBranch,DOES2\r
+\ DW DoLIT,-22,THROW\r
+\ DOES2 DW DoLIT,Pipe,COMPILEComma\r
+\ DW DoLIT,DoLIST,xtComma,DoLIT,-1,EXIT\r
+\r
+\ ELSE Compilation: ( C: orig1 -- orig2 ) \ CORE\r
+\ Run-time: ( -- )\r
+\ Start the false clause in an IF-ELSE-THEN structure.\r
+\ Put the location of new unresolved forward reference orig2\r
+\ onto control-flow stack.\r
+\r
+: ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMDEDIATE\r
+\r
+\ $COLON NameELSEE,ELSEE\r
+\ DW AHEAD,TwoSWAP,THENN,EXIT\r
+\r
+\ ENVIRONMENT? ( c-addr u -- false | i*x true ) \ CORE\r
+\ Environment query.\r
+\r
+: ENVIRONMENT?\r
+ envQList SEARCH-WORDLIST\r
+ DUP >R IF EXECUTE THEN R> ;\r
+\r
+\ $COLON NameENVIRONMENTQuery,ENVIRONMENTQuery\r
+\ DW DoLIT,AddrEnvQList,SEARCH_WORDLIST\r
+\ DW DUPP,ToR,ZBranch,ENVRN1\r
+\ DW EXECUTE\r
+\ ENVRN1 DW RFrom,EXIT\r
+\r
+\ EVALUATE ( i*x c-addr u -- j*x ) \ CORE\r
+\ Evaluate the string. Save the input source specification.\r
+\ Store -1 in SOURCE-ID.\r
+\r
+: EVALUATE SOURCE >R >R >IN @ >R SOURCE-ID >R\r
+ -1 TO SOURCE-ID\r
+ sourceVar 2! 0 >IN ! interpret\r
+ R> TO SOURCE-ID\r
+ R> >IN ! R> R> sourceVar 2! ;\r
+\r
+\ $COLON NameEVALUATE,EVALUATE\r
+\ DW SOURCE,ToR,ToR,DoLIT,AddrToIN,Fetch,ToR,SOURCE_ID,ToR\r
+\ DW DoLIT,-1,DoTO,AddrSOURCE_ID\r
+\ DW DoLIT,AddrSourceVar,TwoStore,DoLIT,0,DoLIT,AddrToIN,Store,Interpret\r
+\ DW RFrom,DoTO,AddrSOURCE_ID\r
+\ DW RFrom,DoLIT,AddrToIN,Store,RFrom,RFrom,DoLIT,AddrSourceVar,TwoStore,EXIT\r
+\r
+\ FILL ( c-addr u char -- ) \ CORE\r
+\ Store char in each of u consecutive characters of memory\r
+\ beginning at c-addr.\r
+\r
+: FILL ROT ROT ?DUP IF 0 DO 2DUP C! CHAR+ LOOP THEN 2DROP ;\r
+\r
+\ $COLON NameFILL,FILL\r
+\ DW ROT,ROT,QuestionDUP,ZBranch,FILL2\r
+\ DW DoLIT,0,DoDO\r
+\ FILL1 DW TwoDUP,CStore,CHARPlus,DoLOOP,FILL1\r
+\ FILL2 DW TwoDROP,EXIT\r
+\r
+\ $CODE NameFILL,FILL\r
+\ POP CX\r
+\ MOV DX,SI\r
+\ POP SI\r
+\ OR CX,CX\r
+\ JZ FILL1\r
+\ MOV [SI],BL\r
+\ MOV AX,DS\r
+\ MOV ES,AX\r
+\ MOV DI,SI\r
+\ DEC CX\r
+\ INC DI\r
+\ REP MOVSB\r
+\ FILL1: MOV SI,DX\r
+\ POP BX\r
+\ $NEXT\r
+\r
+\ FIND ( c-addr -- c-addr 0 | xt 1 | xt -1) \ SEARCH\r
+\ Search dictionary for a match with the given counted name.\r
+\ Return execution token and -1 or 1 ( IMMEDIATE) if found;\r
+\ c-addr 0 if not found.\r
+\r
+: FIND DUP COUNT search-word ?DUP IF NIP ROT DROP EXIT THEN\r
+ 2DROP 0 ;\r
+\r
+\ $COLON NameFIND,FIND\r
+\ DW DUPP,COUNT,Search_word,QuestionDUP,ZBranch,FIND1\r
+\ DW NIP,ROT,DROP,EXIT\r
+\ FIND1 DW TwoDROP,DoLIT,0,EXIT\r
+\r
+\ IMMEDIATE ( -- ) \ CORE\r
+\ Make the most recent definition an immediate word.\r
+\r
+: IMMEDIATE lastName [ =immed ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+\ $COLON NameIMMEDIATE,IMMEDIATE\r
+\ DW LastName,DoLIT,IMMED,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+\ J ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE\r
+\ Push the index of next outer loop.\r
+\r
+: J rp@ [ 3 CELLS ] LITERAL + @\r
+ rp@ [ 4 CELLS ] LITERAL + @ + ; COMPILE-ONLY\r
+\r
+\ $COLON NameJ,J\r
+\ DW RPFetch,DoLIT,3*CELLL,Plus,Fetch\r
+\ DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT\r
+\r
+\ $CODE NameJ,J\r
+\ PUSH BX\r
+\ MOV BX,[BP+2*CELLL]\r
+\ ADD BX,[BP+3*CELLL]\r
+\ $NEXT\r
+\r
+\ LEAVE ( -- ) ( R: loop-sys -- ) \ CORE\r
+\ Terminate definite loop, DO|?DO ... LOOP|+LOOP, immediately.\r
+\r
+: LEAVE POSTPONE UNLOOP POSTPONE branch\r
+ xhere rakeVar DUP @ code, ! ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameLEAVEE,LEAVEE\r
+\ DW DoLIT,UNLOOP,COMPILEComma,DoLIT,Branch,COMPILEComma\r
+\ DW XHere,DoLIT,AddrRakeVar,DUPP,Fetch,CodeComma,Store,EXIT\r
+\r
+\ LOOP Compilation: ( C: do-sys -- ) \ CORE\r
+\ Run-time: ( -- ) ( R: loop-sys1 -- loop-sys2 )\r
+\ Terminate a DO|?DO ... LOOP structure. Resolve the destination\r
+\ of all unresolved occurences of LEAVE.\r
+\r
+: LOOP POSTPONE doLOOP rake ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameLOOPP,LOOPP\r
+\ DW DoLIT,DoLOOP,COMPILEComma,rake,EXIT\r
+\r
+\ LSHIFT ( x1 u -- x2 ) \ CORE\r
+\ Perform a logical left shift of u bit-places on x1, giving x2.\r
+\ Put 0 into the least significant bits vacated by the shift.\r
+\r
+: LSHIFT ?DUP IF 0 DO 2* LOOP THEN ;\r
+\r
+\ $COLON NameLSHIFT,LSHIFT\r
+\ DW QuestionDUP,ZBranch,LSHIFT2\r
+\ DW DoLIT,0,DoDO\r
+\ LSHIFT1 DW TwoStar,DoLOOP,LSHIFT1\r
+\ LSHIFT2 DW EXIT\r
+\r
+\ $CODE NameLSHIFT,LSHIFT\r
+\ MOV CX,BX\r
+\ POP BX\r
+\ OR CX,CX\r
+\ JZ LSHIFT2\r
+\ SHL BX,CL\r
+\ LSHIFT2: $NEXT\r
+\r
+\ M* ( n1 n2 -- d ) \ CORE\r
+\ Signed multiply. Return double product.\r
+\r
+: M* 2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;\r
+\r
+\ $COLON NameMStar,MStar\r
+\ DW TwoDUP,XORR,ZeroLess,ToR,ABSS,SWAP,ABSS\r
+\ DW UMStar,RFrom,ZBranch,MSTAR1\r
+\ DW DNEGATE\r
+\ MSTAR1 DW EXIT\r
+\r
+\ $CODE NameMStar,MStar\r
+\ POP AX\r
+\ IMUL BX\r
+\ PUSH AX\r
+\ MOV BX,DX\r
+\ $NEXT\r
+\r
+\ MAX ( n1 n2 -- n3 ) \ CORE\r
+\ Return the greater of two top stack items.\r
+\r
+: MAX 2DUP < IF SWAP THEN DROP ;\r
+\r
+\ $COLON NameMAX,MAX\r
+\ DW TwoDUP,LessThan,ZBranch,MAX1\r
+\ DW SWAP\r
+\ MAX1 DW DROP,EXIT\r
+\r
+\ $CODE NameMAX,MAX\r
+\ POP AX\r
+\ CMP AX,BX\r
+\ JLE MAX1\r
+\ MOV BX,AX\r
+\ MAX1: $NEXT\r
+\r
+\ MIN ( n1 n2 -- n3 ) \ CORE\r
+\ Return the smaller of top two stack items.\r
+\r
+: MIN 2DUP > IF SWAP THEN DROP ;\r
+\r
+\ $COLON NameMIN,MIN\r
+\ DW TwoDUP,GreaterThan,ZBranch,MIN1\r
+\ DW SWAP\r
+\ MIN1 DW DROP,EXIT\r
+\r
+\ $CODE NameMIN,MIN\r
+\ POP AX\r
+\ CMP AX,BX\r
+\ JGE MIN1\r
+\ MOV BX,AX\r
+\ MIN1: $NEXT\r
+\r
+\ MOD ( n1 n2 -- n3 ) \ CORE\r
+\ Divide n1 by n2, giving the single cell remainder n3.\r
+\ Returns modulo of floored division in this implementation.\r
+\r
+: MOD /MOD DROP ;\r
+\r
+\ $COLON NameMODD,MODD\r
+\ DW SlashMOD,DROP,EXIT\r
+\r
+\ PICK ( x_u ... x1 x0 u -- x_u ... x1 x0 x_u ) \ CORE EXT\r
+\ Remove u and copy the uth stack item to top of the stack. An\r
+\ ambiguous condition exists if there are less than u+2 items\r
+\ on the stack before PICK is executed.\r
+\r
+: PICK DEPTH DUP 2 < IF -4 THROW THEN \ stack underflow\r
+ 2 - OVER U< IF -4 THROW THEN\r
+ 1+ CELLS sp@ + @ ;\r
+\r
+\ $COLON NamePICK,PICK\r
+\ DW DEPTH,DUPP,DoLIT,2,LessThan,ZBranch,PICK1\r
+\ DW DoLIT,-4,THROW\r
+\ PICK1 DW DoLIT,2,Minus,OVER,ULess,ZBranch,PICK2\r
+\ DW DoLIT,-4,THROW\r
+\ PICK2 DW OnePlus,CELLS,SPFetch,Plus,Fetch,EXIT\r
+\r
+\ $CODE NamePICK,PICK\r
+\ MOV DI,AddrUserP\r
+\ MOV DI,[DI+CELLL] ; sp0\r
+\ SUB DI,SP\r
+\ SAR DI,1 ; depth-1 in DI\r
+\ DEC DI\r
+\ JS PICK1\r
+\ CMP DI,BX\r
+\ JB PICK1\r
+\ SHL BX,1\r
+\ ADD BX,SP\r
+\ MOV BX,[BX]\r
+\ $NEXT\r
+\ PICK1: MOV BX,-4\r
+\ JMP THROW\r
+\ $ALIGN\r
+\r
+\ POSTPONE ( "<spaces>name" -- ) \ CORE\r
+\ Parse name and find it. Append compilation semantics of name\r
+\ to current definition.\r
+\ Structure of words with special compilation action\r
+\ for default compilation behavior\r
+\ |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |\r
+\r
+: POSTPONE (') 0< IF\r
+ specialComp? OVER = IF \ special compilation action\r
+ DUP POSTPONE LITERAL\r
+ cell- cell- code@\r
+ POSTPONE LITERAL\r
+ POSTPONE EXECUTE EXIT THEN\r
+ POSTPONE LITERAL \ non-IMMEDIATE\r
+ POSTPONE code, EXIT THEN\r
+ code, ; COMPILE-ONLY IMMEDIATE \ IMMEDIATE\r
+\r
+\ $COLON NamePOSTPONE,POSTPONE\r
+\ DW ParenTick,ZeroLess,ZBranch,POSTP1\r
+\ DW SpecialCompQ,OVER,Equals,ZBranch,POSTP2\r
+\ DW DUPP,LITERAL,CellMinus,CellMinus,CodeFetch\r
+\ DW LITERAL,DoLIT,EXECUTE,CodeComma,EXIT\r
+\ POSTP2 DW LITERAL,DoLIT,CodeComma\r
+\ POSTP1 DW CodeComma,EXIT\r
+\r
+\ RECURSE ( -- ) \ CORE\r
+\ Append the execution semactics of the current definition to\r
+\ the current definition.\r
+\r
+: RECURSE bal 1- 2* PICK 1+ IF -22 THROW THEN\r
+ \ control structure mismatch; colon-sys type is -1\r
+ bal 1- 2* 1+ PICK \ xt of current definition\r
+ COMPILE, ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameRECURSE,RECURSE\r
+\ DW Bal,OneMinus,TwoStar,PICK,OnePlus,ZBranch,RECUR1\r
+\ DW DoLIT,-22,THROW\r
+\ RECUR1 DW Bal,OneMinus,TwoStar,OnePlus,PICK\r
+\ DW COMPILEComma,EXIT\r
+\r
+\ REPEAT ( C: orig dest -- ) \ CORE\r
+\ Terminate a BEGIN-WHILE-REPEAT indefinite loop. Resolve\r
+\ backward reference dest and forward reference orig.\r
+\r
+: REPEAT AGAIN THEN ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameREPEAT,REPEATT\r
+\ DW AGAIN,THENN,EXIT\r
+\r
+\ RSHIFT ( x1 u -- x2 ) \ CORE\r
+\ Perform a logical right shift of u bit-places on x1, giving x2.\r
+\ Put 0 into the most significant bits vacated by the shift.\r
+\r
+: RSHIFT ?DUP IF\r
+ 0 SWAP cell-size-in-bits SWAP -\r
+ 0 DO 2DUP D+ LOOP\r
+ NIP\r
+ THEN ;\r
+\r
+\ $COLON NameRSHIFT,RSHIFT\r
+\ DW QuestionDUP,ZBranch,RSHIFT2\r
+\ DW DoLIT,0,SWAP,DoLIT,CELLL*8,SWAP,Minus,DoLIT,0,DoDO\r
+\ RSHIFT1 DW TwoDUP,DPlus,DoLOOP,RSHIFT1\r
+\ DW NIP\r
+\ RSHIFT2 DW EXIT\r
+\r
+\ $CODE NameRSHIFT,RSHIFT\r
+\ MOV CX,BX\r
+\ POP BX\r
+\ OR CX,CX\r
+\ JZ RSHIFT2\r
+\ SHR BX,CL\r
+\ LSHIFT2: $NEXT\r
+\r
+\ SLITERAL ( c-addr1 u -- ) \ STRING\r
+\ Run-time ( -- c-addr2 u )\r
+\ Compile a string literal. Return the string on execution.\r
+\r
+: SLITERAL ALIGN HERE POSTPONE LITERAL DUP POSTPONE LITERAL\r
+ CHARS HERE 2DUP + ALIGNED TO HERE\r
+ SWAP MOVE ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameSLITERAL,SLITERAL\r
+\ DW ALIGNN,HERE,LITERAL,DUPP,LITERAL\r
+\ DW CHARS,HERE,TwoDUP,Plus,ALIGNED,DoTO,AddrHERE\r
+\ DW SWAP,MOVE,EXIT\r
+\r
+\ S" Compilation: ( "ccc<">" -- ) \ CORE\r
+\ Run-time: ( -- c-addr u )\r
+\ Parse ccc delimetered by " . Return the string specification\r
+\ c-addr u on execution.\r
+\r
+: S" [CHAR] " PARSE POSTPONE SLITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameSQuote,SQuote\r
+\ DW DoLIT,'"',PARSE,SLITERAL,EXIT\r
+\r
+\ SM/REM ( d n1 -- n2 n3 ) \ CORE\r
+\ Symmetric divide of double by single. Return remainder n2\r
+\ and quotient n3.\r
+\r
+: SM/REM OVER >R >R DUP 0< IF DNEGATE THEN\r
+ R@ ABS UM/MOD DUP 0<\r
+ IF DUP [ 16 BASE ! ] 8000 [ DECIMAL ] XOR IF -11 THROW THEN THEN \ result out of range\r
+ R> R@ XOR 0< IF NEGATE THEN\r
+ R> 0< IF SWAP NEGATE SWAP THEN ;\r
+\r
+\ $COLON 6,'SM/REM',SMSlashREM,_FLINK\r
+\ DW OVER,ToR,ToR,DUPP,ZeroLess,ZBranch,SMREM1\r
+\ DW DNEGATE\r
+\ SMREM1 DW RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,SMREM4\r
+\ DW DUPP,DoLIT,08000h,XORR,ZBranch,SMREM4\r
+\ DW DoLIT,-11,THROW\r
+\ SMREM4 DW RFrom,RFetch,XORR,ZeroLess,ZBranch,SMREM2\r
+\ DW NEGATE\r
+\ SMREM2 DW RFrom,ZeroLess,ZBranch,SMREM3\r
+\ DW SWAP,NEGATE,SWAP\r
+\ SMREM3 DW EXIT\r
+\r
+\ $CODE NameSMSlashREM,SMSlashREM\r
+\ POP DX\r
+\ POP AX\r
+\ OR DX,DX\r
+\ JS SMREM2\r
+\ OR BX,BX\r
+\ JZ SMREM1\r
+\ JS SMREM3\r
+\ CMP DX,BX\r
+\ JAE SMREM6\r
+\ DIV BX ;positive dividend, positive divisor\r
+\ CMP AX,08000h\r
+\ JA SMREM6\r
+\ PUSH DX\r
+\ MOV BX,AX\r
+\ $NEXT\r
+\ SMREM3: NEG BX ;positive dividend, negative divisor\r
+\ CMP DX,BX\r
+\ JAE SMREM6\r
+\ DIV BX\r
+\ CMP AX,08000h\r
+\ JA SMREM6\r
+\ MOV BX,AX\r
+\ PUSH DX\r
+\ NEG BX\r
+\ $NEXT\r
+\ SMREM2: NEG AX ;DNEGATE\r
+\ ADC DX,0\r
+\ NEG DX\r
+\ OR BX,BX\r
+\ JZ SMREM1\r
+\ JS SMREM4\r
+\ CMP DX,BX ;negative dividend, positive divisor\r
+\ JAE SMREM6\r
+\ DIV BX\r
+\ CMP AX,08000h\r
+\ JA SMREM6\r
+\ NEG DX\r
+\ MOV BX,AX\r
+\ PUSH DX\r
+\ NEG BX\r
+\ $NEXT\r
+\ SMREM4: NEG BX ;negative dividend, negative divisor\r
+\ CMP DX,BX\r
+\ JAE SMREM6\r
+\ DIV BX\r
+\ CMP AX,08000h\r
+\ JA SMREM6\r
+\ NEG DX\r
+\ MOV BX,AX\r
+\ PUSH DX\r
+\ $NEXT\r
+\ SMREM6: MOV BX,-11 ;result out of range\r
+\ JMP THROW\r
+\ SMREM1: MOV BX,-10 ;divide by zero\r
+\ JMP THROW\r
+\ $ALIGN\r
+\r
+\ SPACES ( n -- ) \ CORE\r
+\ Send n spaces to the output device if n is greater than zero.\r
+\r
+: SPACES DUP 0 > IF 0 DO SPACE LOOP EXIT THEN DROP;\r
+\r
+\ $COLON 6,'SPACES',SPACES,_FLINK\r
+\ DW DUPP,Zero,GreaterThan,ZBranch,SPACES1\r
+\ DW Zero,DoDO\r
+\ SPACES2 DW SPACE,DoLOOP,SPACES2\r
+\ DW EXIT\r
+\ SPACES1 DW DROP,EXIT\r
+\r
+\ $CODE NameSPACES,SPACES\r
+\ OR BX,BX\r
+\ JLE SPACES2\r
+\ PUSH SI\r
+\ SUB BP,CELLL\r
+\ MOV [BP],BX\r
+\ MOV BX,' '\r
+\ SPACES4: PUSH BX\r
+\ MOV SI,OFFSET SPACES3\r
+\ MOV AX,AddrTickEMIT\r
+\ JMP AX\r
+\ SPACES1: DEC WORD PTR [BP]\r
+\ JNZ SPACES4\r
+\ POP SI\r
+\ ADD BP,CELLL\r
+\ SPACES2: POP BX\r
+\ $NEXT\r
+\ SPACES3 DW SPACES1\r
+\r
+\ TO Interpretation: ( x "<spaces>name" -- ) \ CORE EXT\r
+\ Compilation: ( "<spaces>name" -- )\r
+\ Run-time: ( x -- )\r
+\ Store x in name.\r
+\r
+: TO ' ?call ?DUP IF \ should be CALL\r
+ ['] doVALUE = \ verify VALUE marker\r
+ IF code@ STATE @\r
+ IF POSTPONE doTO code, EXIT THEN\r
+ ! EXIT\r
+ THEN THEN\r
+ -32 THROW ; IMMEDIATE \ invalid name argument (e.g. TO xxx)\r
+\r
+\ $COLON NameTO,TO\r
+\ DW Tick,QCall,QuestionDUP,ZBranch,TO1\r
+\ DW DoLIT,DoVALUE,Equals,ZBranch,TO1\r
+\ DW CodeFetch,DoLIT,AddrSTATE,Fetch,ZBranch,TO2\r
+\ DW DoLIT,DoTO,COMPILEComma,CodeComma,EXIT\r
+\ TO2 DW Store,EXIT\r
+\ TO1 DW DoLIT,-32,THROW\r
+\r
+\ U. ( u -- ) \ CORE\r
+\ Display u in free field format followed by space.\r
+\r
+: U. 0 D. ;\r
+\r
+\ $COLON NameUDot,UDot\r
+\ DW DoLIT,0,DDot,EXIT\r
+\r
+\ UNTIL ( C: dest -- ) \ CORE\r
+\ Terminate a BEGIN-UNTIL indefinite loop structure.\r
+\r
+: UNTIL IF -22 THROW THEN \ control structure mismatch; dest type is 0\r
+ POSTPONE 0branch code, bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameUNTIL,UNTIL\r
+\ DW ZBranch,UNTIL1\r
+\ DW DoLIT,-22,THROW\r
+\ UNTIL1 DW DoLIT,ZBranch,COMPILEComma,CodeComma,BalMinus,EXIT\r
+\r
+\ VALUE ( x "<spaces>name" -- ) \ CORE EXT\r
+\ name Execution: ( -- x )\r
+\ Create a value object with initial value x.\r
+\r
+: VALUE bal IF -29 THROW THEN \ compiler nesting\r
+ xhere ALIGNED CELL+ TO xhere\r
+ ['] doVALUE xt, head,\r
+ ALIGN HERE code,\r
+ , linkLast ; \ store x and link CREATEd word to current wordlist\r
+\r
+\ $COLON NameVALUE,VALUE\r
+\ DW Bal,ZBranch,VALUE1\r
+\ DW DoLIT,-29,THROW\r
+\ VALUE1 DW XHere,ALIGNED,CELLPlus,DoTO,AddrXHere\r
+\ DW DoLIT,DoVALUE,xtComma,HeadComma\r
+\ DW ALIGNN,HERE,CodeComma\r
+\ DW Comma,LinkLast,EXIT\r
+\r
+\ VARIABLE ( "<spaces>name" -- ) \ CORE\r
+\ name Execution: ( -- a-addr )\r
+\ Parse a name and create a variable with the name.\r
+\ Resolve one cell of data space at an aligned address.\r
+\ Return the address on execution.\r
+\r
+: VARIABLE bal IF -29 THROW THEN \ compiler nesting\r
+ xhere ALIGNED TO xhere\r
+ ['] compileCONST code,\r
+ xhere CELL+ TO xhere\r
+ ['] doCONST xt, head,\r
+ ALIGN HERE\r
+ 1 CELLS ALLOT \ allocate one cell in data space\r
+ code, linkLast\r
+ lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+\ $COLON NameVARIABLE,VARIABLE\r
+\ DW Bal,ZBranch,VARIA1\r
+\ DW DoLIT,-29,THROW\r
+\ VARIA1 DW XHere,ALIGNED,DoTO,AddrXHere\r
+\ DW DoLIT,CompileCONST,CodeComma\r
+\ DW XHere,CELLPlus,DoTO,AddrXHere\r
+\ DW DoLIT,DoCONST,xtComma,HeadComma\r
+\ DW ALIGNN,HERE,DoLIT,1*CELLL,ALLOT\r
+\ DW CodeComma,LinkLast\r
+\ DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+\ WHILE ( C: dest -- orig dest ) \ CORE\r
+\ Put the location of a new unresolved forward reference orig\r
+\ onto the control flow stack under the existing dest. Typically\r
+\ used in BEGIN ... WHILE ... REPEAT structure.\r
+\r
+: WHILE POSTPONE IF 2SWAP ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameWHILE,WHILEE\r
+\ DW IFF,TwoSWAP,EXIT\r
+\r
+\ WORD ( char "<chars>ccc<char>" -- c-addr ) \ CORE\r
+\ Skip leading delimeters and parse a word. Return the address\r
+\ of a transient region containing the word as counted string.\r
+\r
+: WORD skipPARSE HERE pack" DROP HERE ;\r
+\r
+\ $COLON NameWORDD,WORDD\r
+\ DW SkipPARSE,HERE,PackQuote,DROP,HERE,EXIT\r
+\r
+\ ['] Compilation: ( "<spaces>name" -- ) \ CORE\r
+\ Run-time: ( -- xt )\r
+\ Parse name. Return the execution token of name on execution.\r
+\r
+: ['] ' POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameBracketTick,BracketTick\r
+\ DW Tick,LITERAL,EXIT\r
+\r
+\ [CHAR] Compilation: ( "<spaces>name" -- ) \ CORE\r
+\ Run-time: ( -- char )\r
+\ Parse name. Return the value of the first character of name\r
+\ on execution.\r
+\r
+: [CHAR] CHAR POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ $COLON NameBracketCHAR,BracketCHAR\r
+\ DW CHAR,LITERAL,EXIT\r
+\r
+\ \ ( "ccc<eol>" -- ) \ CORE EXT\r
+\ Parse and discard the remainder of the parse area.\r
+\r
+: \ SOURCE >IN ! DROP ; IMMEDIATE\r
+\r
+\ $COLON NameBackslash,Backslash\r
+\ DW SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT\r
+\r
+\ Optional Facility words\r
+\r
+\ EKEY? ( -- flag ) \ FACILITY EXT\r
+\ If a keyboard event is available, return true.\r
+\r
+: EKEY? 'ekey? EXECUTE ;\r
+\r
+\ $COLON NameEKEYQuestion,EKEYQuestion\r
+\ DW TickEKEYQ,EXECUTE,EXIT\r
+\r
+\ $CODE NameEKEYQuestion,EKEYQuestion\r
+\ MOV AX,AddrTickEKEYQ\r
+\ JMP AX\r
+\ $ALIGN\r
+\r
+\ EMIT? ( -- flag ) \ FACILITY EXT\r
+\ flag is true if the user output device is ready to accept data\r
+\ and the execution of EMIT in place of EMIT? would not have\r
+\ suffered an indefinite delay. If device state is indeterminate,\r
+\ flag is true.\r
+\r
+: EMIT? 'emit? EXECUTE ;\r
+\r
+\ $COLON NameEMITQuestion,EMITQuestion\r
+\ DW TickEMITQ,EXECUTE,EXIT\r
+\r
+\ $CODE NameEMITQuestion,EMITQuestion\r
+\ MOV AX,AddrTickEMITQ\r
+\ JMP AX\r
+\ $ALIGN\r
+\r
+\ Nick\r
+\ ' RX? TO 'ekey?\r
+\ ' RX@ TO 'ekey\r
+\ ' TX? TO 'emit?\r
+\ ' TX! TO 'emit\r
+' set-i/o TO 'init-i/o\r
+' .ok TO 'prompt\r
+' hi TO 'boot\r
+' optiCOMPILE, 'doWord !\r
+\ ' EXECUTE 'doWord 2 + !\r
+' doubleAlso, 'doWord 4 + !\r
+' doubleAlso 'doWord 6 + !\r
+\ ' EXECUTE 'doWord 8 + !\r
+\ ' EXECUTE 'doWord 10 + !\r
+\r
+<< CON\r
public / hf86v099.git / commitdiff