; hForth 8086 ROM model v0.9.9 by Wonyong Koh, 1997\r
;\r
;\r
+; 1999. 3. 5.\r
+; Fix bugs reported by Mr. Neal Crook. Thank Neal Crook.\r
+; Fix Forth definition of ACCEPT. \r
+; Add high-level definition of 2DROP and 2DUP.\r
+; Remove superfluous THEN in optiCOMPILE,ACCEPT, and UM/MOD.\r
+; LITERAL in the high-level definitions of doubleAlso, singleOnly,\r
+; and SLITERAL should have been 'POSTPONE LITERAL'.\r
+; S" in the high-level definitions of ABORT" should have been \r
+; 'POSTPONE S"'.\r
+; The hith-level definition of REPEAT should have been \r
+; 'POSTPONE AGAIN POSTPONE THEN'.\r
+; Add COMSTANT word 'sysVar00'.\r
+; 1998. 1. 5.\r
+; Mr. Kwon Hyuk Kun reported several bugs. Thank Mr. Kwon.\r
+; Fix REFILL . 'Fetch' was missing in DW statement. Thank Kwon Hyuk Kun.\r
+; Fix PARSE . It should have been 'CHARS OVER +' to calculate\r
+; c_addr+u*chars from 'c_addr u'.\r
+; Add CHARS in the definition of 'head,'.\r
+; It is more convenient to use up-growing stack for some \r
+; microprocessors such as 8051 family. I, J, and DEPTH\r
+; are now processor-dependent words.\r
+; 1997. 8. 26.\r
+; Introduce MaxCountedString.\r
+; 1997. 8. 16.\r
+; Replace 'EKEY max-char AND' with KEY in ACCEPT.\r
+; 1997. 7. 11.\r
+; Fix SPACES. Thank Benjamin Hoyt.\r
+; 1997. 6. 23.\r
+; Fix pack".\r
; 1997. 2. 19.\r
; Split environmental variable systemID into CPU and Model.\r
; 1997. 2. 6.\r
\r
CHARR EQU 1 ;byte size of a character\r
CELLL EQU 2 ;byte size of a cell\r
+MaxCountedString EQU 0FFh ;max char length of counted string\r
MaxChar EQU 0FFh ;Extended character set\r
; Use 07Fh for ASCII only\r
MaxSigned EQU 07FFFh ;max value of signed integer\r
ROM0 EQU 0 ;bottom of ROM memory ******\r
ROMEnd EQU 08000h ;end of ROM memory ******\r
;ROM size = 32KB\r
-COLDD EQU ROM0+00100h ;cold start vector ******\r
+COLDD EQU 00100h ;cold start vector ******\r
\r
Trapfpc EQU RAMEnd ;reserve a cell for microdebugger\r
RPP EQU RAMEnd-CELLL ;start of return stack (RP0)\r
DW 0 ;bal\r
DW 0 ;notNONAME?\r
DW 0 ;rakeVar\r
-NOrder0 DW 2 ;#order\r
+ DW 2 ;#order\r
DW FORTH_WORDLISTAddr ;search order stack\r
DW NONSTANDARD_WORDLISTAddr\r
DW (OrderDepth-2) DUP (0)\r
$THROWMSG '[IF], [ELSE], or [THEN] exception' ;-58\r
\r
;;;;;;;;;;;;;;;;\r
-; System dependent words -- Must be re-definded for each system.\r
+; System dependent words -- Must be re-defined 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
; CR ( -- ) \ CORE\r
; Carriage return and linefeed.\r
;\r
-; : CR carriage-return-char EMIT linefeed-char EMIT ;\r
+; : CR [ carriage-return-char ] LITERAL EMIT [ linefeed-char ] LITERAL EMIT ;\r
\r
$COLON 2,'CR',CR,_FLINK\r
DW DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT\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
+; ." wykoh@pado.krict.re.kr or wykoh@free.xtel.com" CR ;\r
\r
$COLON 2,'hi',HI,_SLINK\r
DW CR\r
DW TYPEE,CR\r
$INSTR 'Please send comment, bug report and suggestions to:'\r
DW TYPEE,CR\r
- $INSTR ' wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr'\r
+ $INSTR ' wykoh@pado.krict.re.kr or wykoh@free.xtel.com'\r
DW TYPEE,CR,EXIT\r
\r
; COLD ( -- )\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
+; 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
; WHILE cell- \ pointer to next word in wordlist\r
; REPEAT\r
; R> R> 2DROP DUP name>xt SWAP \ xt ca2\r
-; C@ DUP [ =COMP ] LITERAL AND 0= SWAP\r
-; [ =IMED ] LITERAL AND 0= 2* 1+ ;\r
+; C@ DUP [ =comp ] LITERAL AND 0= SWAP\r
+; [ =immed ] LITERAL AND 0= 2* 1+ ;\r
;\r
; $COLON 17,'(search-wordlist)',ParenSearch_Wordlist,_SLINK\r
; DW ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6\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 @ call-code =\r
+; : ?call DUP @ [ call-code ] LITERAL =\r
; IF CELL+ DUP @ SWAP CELL+ DUP ROT + EXIT THEN\r
; \ Direct Threaded Code 8086 relative call\r
; 0 ;\r
; CREATE . Return xt2 of current definition.\r
;\r
; : xt, xhere ALIGNED DUP TOxhere SWAP\r
-; call-code code, \ Direct Threaded Code\r
-; xhere CELL+ - code, ; \ 8086 relative call\r
+; [ call-code ] LITERAL code, \ Direct Threaded Code\r
+; xhere CELL+ - code, ; \ 8086 relative call\r
\r
$COLON 3,'xt,',xtComma,_SLINK\r
DW XHere,ALIGNED,DUPP,TOXHere,SWAP\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 + ; \ slow, very portable\r
+; : ALIGNED DUP 0 [ cell-size ] LITERAL UM/MOD DROP DUP\r
+; IF [ cell-size ] LITERAL SWAP - THEN + ; \ slow, very portable\r
;\r
; $COLON 7,'ALIGNED',ALIGNED,_FLINK\r
; DW DUPP,Zero,DoLIT,CELLL\r
AND BX,0FFFEh\r
$NEXT\r
\r
-; pack" is dependent of cell alignment.\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
-; 1 CHARS - 0 SWAP ! \ fill 0 at the end of string\r
-; 2DUP C! CHAR+ SWAP \ c-addr a-addr+1 u\r
-; CHARS MOVE R> ; COMPILE-ONLY\r
-\r
- $COLON 5,'pack"',PackQuote,_SLINK\r
- DW TwoDUP,SWAP,CHARS,Plus,CHARPlus,DUPP,ToR\r
- DW DoLIT,CHARR,Minus,Zero,SWAP,Store\r
- DW TwoDUP,CStore,CHARPlus,SWAP\r
- DW CHARS,MOVE,RFrom,EXIT\r
-\r
-; CELLS ( n1 -- n2 ) \ CORE\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
+; : CELLS [ cell-size ] LITERAL * ; \ slow, very portable\r
+; : CELLS 2* ; \ fast, must be redefined for each system\r
\r
$COLON 5,'CELLS',CELLS,_FLINK\r
DW TwoStar,EXIT\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
+; : CHARS [ char-size ] LITERAL * ; \ slow, very portable\r
+; : CHARS ; \ fast, must be redefined for each system\r
\r
$COLON 5,'CHARS',CHARS,_FLINK\r
DW EXIT\r
\r
+; It is more convenient to use up-growing stack for some microprocessors such as 8051 family.\r
+; In those cases I, J, and DEPTH should be redefined.\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 COMPO+1,'I',I,_FLINK\r
+ DW RPFetch,DoLIT,CELLL,Plus,Fetch\r
+ DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,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 COMPO+1,'J',J,_FLINK\r
+ DW RPFetch,DoLIT,3*CELLL,Plus,Fetch\r
+ DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT\r
+\r
+; DEPTH ( -- +n ) \ CORE\r
+; Return the depth of the data stack.\r
+;\r
+; : DEPTH sp@ sp0 SWAP - [ cell-size ] LITERAL / ;\r
+\r
+ $COLON 5,'DEPTH',DEPTH,_FLINK\r
+ DW SPFetch,SPZero,SWAP,Minus\r
+ DW DoLIT,CELLL,Slash,EXIT\r
+\r
; ! ( x a-addr -- ) \ CORE\r
; Store x at a aligned address.\r
\r
\r
$CONST 7,'sysVar0',SysVar0,UZERO,_SLINK\r
\r
+; sysVar00 ( -- a-addr )\r
+; Start of backup copy of original value table of system variables.\r
+\r
+ $CONST 8,'sysVar00',SysVar00,UZERO0,_SLINK\r
+\r
; sysVar0End ( -- a-addr )\r
; End of initial value table of system variables.\r
\r
$CONST 10,'sysVar0End',SysVar0End,ULAST,_SLINK\r
\r
+; THROWMsgTbl ( -- a-addr ) \ CORE\r
+; Return the address of the THROW message table.\r
+\r
+ $CONST 11,'THROWMsgTbl',THROWMsgTbl,AddrTHROWMsgTbl,_SLINK\r
+\r
; 'ekey? ( -- a-addr )\r
; Execution vector of EKEY?.\r
\r
\r
$VAR 4,'BASE',BASE,_FLINK\r
\r
-; THROWMsgTbl ( -- a-addr ) \ CORE\r
-; Return the address of the THROW message table.\r
-\r
- $CONST 11,'THROWMsgTbl',THROWMsgTbl,AddrTHROWMsgTbl,_SLINK\r
-\r
; ROMB ( -- a-addr )\r
; Bottom of free ROM area.\r
\r
DW DoLIT,VersionStr,COUNT,EXIT\r
\r
$ENVIR 15,'/COUNTED-STRING'\r
- DW DoLIT,MaxChar,EXIT\r
+ DW DoLIT,MaxCountedString,EXIT\r
\r
$ENVIR 5,'/HOLD'\r
DW DoLIT,PADSize,EXIT\r
DW TYPEE,EXIT\r
\r
; .prompt ( -- )\r
-; Disply Forth prompt. This word is vectored.\r
+; Display Forth prompt. This word is vectored.\r
;\r
; : .prompt 'prompt EXECUTE ;\r
\r
; cell- ( a-addr1 -- a-addr2 )\r
; Return previous aligned cell address.\r
;\r
-; : cell- -(cell-size) + ;\r
+; : cell- [ cell-size NEGATE ] LITERAL + ;\r
\r
$COLON 5,'cell-',CellMinus,_SLINK\r
DW DoLIT,0-CELLL,Plus,EXIT\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
+; : doDO >R [ max-negative ] LITERAL + R> OVER - SWAP R> SWAP >R SWAP >R >R ;\r
\r
$COLON COMPO+4,'doDO',DoDO,_SLINK\r
DW ToR,DoLIT,MaxNegative,Plus,RFrom\r
; : head, 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
+; DUP [ =mask ] LITERAL > IF -19 THROW THEN\r
+; \ definition name too long\r
; 2DUP GET-CURRENT SEARCH-WORDLIST \ name exist?\r
; IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined\r
-; npVar @ OVER CELL+ - ALIGNED\r
+; npVar @ OVER CHARS CHAR+ - \r
+; DUP ALIGNED SWAP OVER XOR IF CELL- THEN \ aligned to lower addr\r
; DUP >R pack" DROP R> \ pack the name in dictionary\r
; cell- GET-CURRENT @ OVER ! \ build wordlist link\r
; cell- DUP npVar ! ! ; \ adjust name space pointer\r
DW DROP\r
$INSTR 'redefine '\r
DW TYPEE,TwoDUP,TYPEE,SPACE\r
-HEADC2 DW NPVar,Fetch,OVER,CELLPlus,Minus,ALIGNED\r
- DW DUPP,ToR,PackQuote,DROP,RFrom\r
+HEADC2 DW NPVar,Fetch,OVER,CHARS,CHARPlus,Minus\r
+ DW DUPP,ALIGNED,SWAP,OVER,XORR,ZBranch,HEADC4\r
+ DW CellMinus\r
+HEADC4 DW DUPP,ToR,PackQuote,DROP,RFrom\r
DW CellMinus,GET_CURRENT,Fetch,OVER,Store\r
DW CellMinus,DUPP,NPVar,Store,Store,EXIT\r
HEADC1 DW ErrWord,TwoStore,DoLIT,-16,THROW\r
; 2DROP EXIT THEN\r
; DUP CELL+ @ ['] EXIT = IF \ if second word is EXIT\r
; @ DUP ['] doLIT XOR \ make sure it is not literal value\r
-; IF SWAP THEN THEN\r
-; THEN THEN DROP COMPILE, ;\r
+; IF SWAP THEN THEN\r
+; THEN DROP COMPILE, ;\r
\r
$COLON 12,'optiCOMPILE,',OptiCOMPILEComma,_SLINK\r
DW DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2\r
; single cell number in compilation state.\r
;\r
; : singleOnly,\r
-; singleOnly LITERAL ;\r
+; singleOnly POSTPONE LITERAL ;\r
\r
$COLON 11,'singleOnly,',SingleOnlyComma,_SLINK\r
DW SingleOnly,LITERAL,EXIT\r
; compilation state.\r
;\r
; : doubleAlso,\r
-; (doubleAlso) 1- IF SWAP LITERAL THEN LITERAL ;\r
+; (doubleAlso) 1- IF SWAP POSTPONE LITERAL THEN POSTPONE LITERAL ;\r
\r
$COLON 11,'doubleAlso,',DoubleAlsoComma,_SLINK\r
DW ParenDoubleAlso,OneMinus,ZBranch,DOUBC1\r
$COLON 7,'name>xt',NameToXT,_SLINK\r
DW CellMinus,CellMinus,Fetch,EXIT\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" OVER max-counted-string SWAP U< \r
+; IF -18 THROW THEN \ parsed string overflow\r
+; 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 COMPO+5,'pack"',PackQuote,_SLINK\r
+ DW OVER,DoLIT,MaxCountedString,SWAP,ULess,ZBranch,PACKQ1\r
+ DW DoLIT,-18,THROW\r
+PACKQ1 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
; PARSE-WORD ( "<spaces>ccc<space>" -- c-addr u )\r
; Skip leading spaces and parse a word. Return the name.\r
;\r
; Prepare the output string to be TYPE'd.\r
; ||xhere>WORD/#-work-area|\r
;\r
-; : #> 2DROP hld @ xhere size-of-PAD + OVER - 1chars/ ;\r
+; : #> 2DROP hld @ xhere [ size-of-PAD ] LITERAL + OVER - 1chars/ ;\r
\r
$COLON 2,'#>',NumberSignGreater,_FLINK\r
DW TwoDROP,HLD,Fetch,XHere,DoLIT,PADSize*CHARR,Plus\r
; , ( x -- ) \ CORE\r
; Reserve one cell in RAM or ROM data space and store x in it.\r
;\r
-; : , HERE ! cell-size hereVar +! ;\r
+; : , HERE ! [ cell-size ] LITERAL hereVar +! ;\r
\r
$COLON 1,',',Comma,_FLINK\r
DW HERE,Store\r
\r
; 2DROP ( x1 x2 -- ) \ CORE\r
; Drop cell pair x1 x2 from the stack.\r
+;\r
+; : 2DROP DROP DROP ;\r
\r
$COLON 5,'2DROP',TwoDROP,_FLINK\r
DW DROP,DROP,EXIT\r
\r
; 2DUP ( x1 x2 -- x1 x2 x1 x2 ) \ CORE\r
; Duplicate cell pair x1 x2.\r
+;\r
+; : 2DUP DUP DUP ;\r
\r
$COLON 4,'2DUP',TwoDUP,_FLINK\r
DW OVER,OVER,EXIT\r
; Initiate the numeric output conversion process.\r
; ||xhere>WORD/#-work-area|\r
;\r
-; : <# xhere size-of-PAD + hld ! ;\r
+; : <# xhere [ size-of-PAD ] LITERAL + hld ! ;\r
\r
$COLON 2,'<#',LessNumberSign,_FLINK\r
DW XHere,DoLIT,PADSize*CHARR,Plus,HLD,Store,EXIT\r
; = ( x1 x2 -- flag ) \ CORE\r
; Return true if top two are equal.\r
;\r
-; : = XORR 0= ;\r
+; : = XOR 0= ;\r
\r
$COLON 1,'=',Equals,_FLINK\r
DW XORR,ZeroEquals,EXIT\r
$COLON 1,'>',GreaterThan,_FLINK\r
DW SWAP,LessThan,EXIT\r
\r
-; >IN ( -- a-addr )\r
+; >IN ( -- a-addr ) \ CORE\r
; Hold the character pointer while parsing input stream.\r
\r
$VAR 3,'>IN',ToIN,_FLINK\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
+; WHILE KEY DUP BL <\r
+; IF DUP [ cr# ] LITERAL = IF ROT 2DROP R> DROP EXIT THEN\r
+; DUP [ tab# ] LITERAL =\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
+; ELSE DUP [ bsp# ] LITERAL =\r
+; SWAP [ del# ] LITERAL = OR\r
+; IF DUP \ discard the last char if not 1st char\r
+; IF 1- [ bsp# ] LITERAL EMIT \r
+; BL EMIT [ bsp# ] LITERAL EMIT THEN \r
+; THEN\r
; THEN\r
-; ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+ THEN\r
+; ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+\r
; THEN\r
; REPEAT SWAP R> 2DROP ;\r
\r
$COLON 6,'ACCEPT',ACCEPT,_FLINK\r
DW ToR,Zero\r
ACCPT1 DW DUPP,RFetch,LessThan,ZBranch,ACCPT5\r
- DW EKEY,DoLIT,MaxChar,ANDD\r
- DW DUPP,BLank,LessThan,ZBranch,ACCPT3\r
+ DW KEY,DUPP,BLank,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
; CELL+ ( a-addr1 -- a-addr2 ) \ CORE\r
; Return next aligned cell address.\r
;\r
-; : CELL+ cell-size + ;\r
+; : CELL+ [ cell-size ] LITERAL + ;\r
\r
$COLON 5,'CELL+',CELLPlus,_FLINK\r
DW DoLIT,CELLL,Plus,EXIT\r
; CHAR+ ( c-addr1 -- c-addr2 ) \ CORE\r
; Returns next character-aligned address.\r
;\r
-; : CHAR+ char-size + ;\r
+; : CHAR+ [ char-size ] LITERAL + ;\r
\r
$COLON 5,'CHAR+',CHARPlus,_FLINK\r
DW DoLIT,CHARR,Plus,EXIT\r
$COLON 7,'DECIMAL',DECIMAL,_FLINK\r
DW DoLIT,10,BASE,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 5,'DEPTH',DEPTH,_FLINK\r
- DW SPFetch,SPZero,SWAP,Minus\r
- DW DoLIT,CELLL,Slash,EXIT\r
-\r
; DNEGATE ( d1 -- d2 ) \ DOUBLE\r
; Two's complement of double-cell number.\r
;\r
DW HLD,Fetch,DoLIT,0-CHARR,Plus\r
DW DUPP,HLD,Store,CStore,EXIT\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 COMPO+1,'I',I,_FLINK\r
- DW RPFetch,DoLIT,CELLL,Plus,Fetch\r
- DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT\r
-\r
; IF Compilation: ( C: -- orig ) \ CORE\r
; Run-time: ( x -- )\r
; Put the location of a new unresolved forward reference orig\r
; KEY ( -- char ) \ CORE\r
; Receive a character. Do not display char.\r
;\r
-; : KEY EKEY max-char AND ;\r
+; : KEY EKEY [ max-char ] LITERAL AND ;\r
\r
$COLON 3,'KEY',KEY,_FLINK\r
DW EKEY,DoLIT,MaxChar,ANDD,EXIT\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
+; CHARS OVER + 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
$COLON 5,'PARSE',PARSE,_FLINK\r
DW ToR,SOURCE,ToIN,Fetch,SlashSTRING\r
DW DUPP,ZBranch,PARSE4\r
- DW OVER,CHARS,Plus,OVER\r
+ DW CHARS,OVER,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
;\r
; : REFILL SOURCE-ID IF 0 EXIT THEN\r
; npVar @ [ size-of-PAD CHARS 2* ] LITERAL - DUP\r
-; size-of-PAD ACCEPT sourceVar 2!\r
+; [ size-of-PAD ] LITERAL ACCEPT sourceVar 2!\r
; 0 >IN ! -1 ;\r
\r
$COLON 6,'REFILL',REFILL,_FLINK\r
DW SOURCE_ID,ZBranch,REFIL1\r
DW Zero,EXIT\r
-REFIL1 DW NPVar,DoLIT,0-PADSize*CHARR*2,Plus,DUPP\r
+REFIL1 DW NPVar,Fetch,DoLIT,PADSize*CHARR*2,Minus,DUPP\r
DW DoLIT,PADSize*CHARR,ACCEPT,SourceVar,TwoStore\r
DW Zero,ToIN,Store,MinusOne,EXIT\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
+; : UM* 0 SWAP [ cell-size-in-bits ] LITERAL 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
; : UM/MOD DUP 0= IF -10 THROW THEN \ divide by zero\r
; 2DUP U< IF\r
-; NEGATE cell-size-in-bits 0\r
+; NEGATE [ cell-size-in-bits ] LITERAL 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
+; IF >R DROP 1+ R> ELSE DROP THEN\r
; LOOP DROP SWAP EXIT\r
; ELSE -11 THROW \ result out of range\r
; THEN ;\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
+; : UNLOOP R> R> R> 2DROP >R ; COMPILE-ONLY\r
\r
$COLON COMPO+6,'UNLOOP',UNLOOP,_FLINK\r
DW RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT\r
; ( ( "ccc<)>" -- ) \ CORE\r
; Ignore following string up to next ) . A comment.\r
;\r
-; : ( [CHAR] ) PARSE 2DROP ;\r
+; : ( [CHAR] ) PARSE 2DROP ; IMMEDIATE\r
\r
$COLON IMMED+1,'(',Paren,_FLINK\r
DW DoLIT,')',PARSE,TwoDROP,EXIT\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
+; : ABORT" POSTPONE 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
; control stack.\r
;\r
; : BEGIN xhere 0 bal+ \ dest type is 0\r
-; ; COMPILE-ONLY IMMDEDIATE\r
+; ; COMPILE-ONLY IMMEDIATE\r
\r
$COLON IMMED+COMPO+5,'BEGIN',BEGIN,_FLINK\r
DW XHere,Zero,BalPlus,EXIT\r
; C, ( char -- ) \ CORE\r
; Compile a character into data space.\r
;\r
-; : C, HERE C! char-size hereVar +! ;\r
+; : C, HERE C! [ char-size ] LITERAL hereVar +! ;\r
\r
$COLON 2,'C,',CComma,_FLINK\r
DW HERE,CStore,DoLIT,CHARR,HereVar,PlusStore,EXIT\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
+; : ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMEDIATE\r
\r
$COLON IMMED+COMPO+4,'ELSE',ELSEE,_FLINK\r
DW AHEAD,TwoSWAP,THENN,EXIT\r
; IMMEDIATE ( -- ) \ CORE\r
; Make the most recent definition an immediate word.\r
;\r
-; : IMMEDIATE lastName [ =imed ] LITERAL OVER @ OR SWAP ! ;\r
+; : IMMEDIATE lastName [ =immed ] LITERAL OVER @ OR SWAP ! ;\r
\r
$COLON 9,'IMMEDIATE',IMMEDIATE,_FLINK\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 COMPO+1,'J',J,_FLINK\r
- DW RPFetch,DoLIT,3*CELLL,Plus,Fetch\r
- DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT\r
-\r
; LEAVE ( -- ) ( R: loop-sys -- ) \ CORE\r
; Terminate definite loop, DO|?DO ... LOOP|+LOOP, immediately.\r
;\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
+; : REPEAT POSTPONE AGAIN POSTPONE THEN ; COMPILE-ONLY IMMEDIATE\r
\r
$COLON IMMED+COMPO+6,'REPEAT',REPEATT,_FLINK\r
DW AGAIN,THENN,EXIT\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 SWAP [ cell-size-in-bits ] LITERAL SWAP -\r
; 0 DO 2DUP D+ LOOP\r
; NIP\r
; THEN ;\r
; Run-time ( -- c-addr2 u )\r
; Compile a string literal. Return the string on execution.\r
;\r
-; : SLITERAL DUP LITERAL POSTPONE doS"\r
+; : SLITERAL DUP POSTPONE LITERAL POSTPONE doS"\r
; CHARS xhere 2DUP + ALIGNED TOxhere\r
; SWAP MOVE ; COMPILE-ONLY IMMEDIATE\r
\r
; SPACES ( n -- ) \ CORE\r
; Send n spaces to the output device if n is greater than zero.\r
;\r
-; : SPACES ?DUP IF 0 DO SPACE LOOP THEN ;\r
+; : SPACES DUP 0 > IF 0 DO SPACE LOOP EXIT THEN DROP;\r
\r
$COLON 6,'SPACES',SPACES,_FLINK\r
- DW QuestionDUP,ZBranch,SPACES2\r
+ DW DUPP,Zero,GreaterThan,ZBranch,SPACES1\r
DW Zero,DoDO\r
-SPACES1 DW SPACE,DoLOOP,SPACES1\r
-SPACES2 DW EXIT\r
+SPACES2 DW SPACE,DoLOOP,SPACES2\r
+ DW EXIT\r
+SPACES1 DW DROP,EXIT\r
\r
; TO Interpretation: ( x "<spaces>name" -- ) \ CORE EXT\r
; Compilation: ( "<spaces>name" -- )\r
public / hf86v099.git / blobdiff