1 TITLE hForth 8086 RAM Model
\r
3 PAGE 62,132 ;62 lines per page, 132 characters per line
\r
5 ;===============================================================
\r
7 ; hForth 8086 RAM model v0.9.9 by Wonyong Koh, 1997
\r
11 ; Fix SPACES. Thank Benjamin Hoyt.
\r
15 ; Split environmental variable systemID into CPU and Model.
\r
17 ; Add Neal Crook's microdebugger and comments on assembly definitions.
\r
19 ; Add $THROWMSG macro and revise accordingly.
\r
21 ; Remove 'NullString' from assembly source.
\r
25 ; Revise PICK to catch stack underflow.
\r
27 ; Port from ROM Model v0.9.9.
\r
29 ; Changes from 0.9.7
\r
31 ;; hForth RAM ¡¡
\95I·e RAM e·i ³a
\93e ¯¡¯aÉQµA xÂ
\81´á hForth ROM ¡¡
\95I·i
\r
32 ;;
\89¡Áa¬á e
\97i´ö¯s
\93¡
\94a.
\r
34 ;; hForth ROM ¡¡
\95I
\89Á
\94a
\9fe ¸ñ
\97i·i ´a
\9c\81µA ¸â´ö¯s
\93¡
\94a. ¡A¡¡
\9f¡
\9fi
\r
35 ;; ¸é´¢Ða
\89¡ ¢
\95¡
\9fi ¨a
\9fa
\89A Ða
\9da
\89¡
\8b¡
\89\81´á ¸÷·
\81\9fi ¡y
\88\81 \94áÐa
\89¡
\r
36 ;;
\89¡Áv¯s
\93¡
\94a. ´áQ§i
\9f¡ ¤aÈw¥¥µA¬á aÇa
\9d¡µÁ °w¸ñ ¸÷·
\81\9fi ¡y
\88\81\r
37 ;; ¤a
\8e\81´ö¯s
\93¡
\94a.
\r
39 ;; 1. ¬a¸å·
\81 \8a\81¹¡
\9fi ¤a
\8e\81´ö¯s
\93¡
\94a. hForth ROM ¡¡
\95IµA¬á
\93e Å¡
\97aµÁ ·¡
\9fq
\r
40 ;; ¸a
\9f¡
\88a ´a
\9c\81Àá
\9cñ
\90a
\92á´á ·¶´ö»¡ e
\r
42 ;; ||Å¡
\97a> ... <¯¡Ç±Îa|·µ
\8b¡|·¡
\9fq||
\r
44 ;; hForth RAM ¡¡
\95IµA¬á
\93e Å¡
\97a, ·¡
\9fq, ¸a
\9ea ¸a
\9f¡
\88a ´a
\9c\81Àá
\9cñ ¡¡
\96\81\r
45 ;; ¬ãµa ·¶¯s
\93¡
\94a.
\r
47 ;; ||·µ
\8b¡|·¡
\9fq|·¡
\9fq
\88a
\9f¡Ç±|Å¡
\97a>
\r
49 ;; µa
\8b¡¬á '¯¡Ç±Îa(xt)'
\93e Å¡
\97a·
\81 ¯¡¸b º
\81¡·³
\93¡
\94a. $STRµÁ $CODEµÁ
\r
50 ;; $ENVIRµÁ $VALUE aÇa
\9d¡
\9fi ¤a
\8e\81´ö¯s
\93¡
\94a.
\r
52 ;; 2. xt>name
\89Á name>xt
\9fi ¤a
\8e\81´ö¯s
\93¡
\94a. hForth ROM ¡¡
\95IµA¬á
\93e ·¡
\9fq
\r
53 ;; ¸a
\9f¡µA xt
\9fi
\88i¢
\81\9f¡Ð
\81 \96\81´á¬á name>xt
\88a ·¡
\88t·i
\94ᣡµA
\r
54 ;; µ©
\9dv¯s
\93¡
\94a.
\8ba
\9cá
\90a Å¡
\97a ¸a
\9f¡
\9fi ¸b¹A Ða
\9da
\89¡ Å¡
\97a ¸a
\9f¡µA
\93e ·¡
\9fq
\r
55 ;; ¸a
\9f¡
\88a
\9f¡Ç±
\88t·i
\90q
\89a
\91½»¡ ´g´a¬á xt>name·¡ ·©Ã¡Ða
\93e xt
\9fi Àx·i
\r
56 ;;
\98\81\8ca»¡ ·¡
\9fq ¸a
\9f¡
\9fi
\94á
\97q·i ®
\81¤cµA ´ô´ö¯s
\93¡
\94a. hForth RAM
\r
57 ;; ¡¡
\95IµA
\93e ·¡
\9fq·
\81 \8f{µA¬á Å¡
\97a
\88a ¯¡¸bÐa
\8b¡
\98\81¢
\85µA 'name>xt'
\9fi
\r
58 ;; ¶áÐ
\81 \98a
\9d¡
\88a
\9f¡Ç±
\88t·i
\90q
\89a
\91½·i Ï©¶a
\88a ´ô¯s
\93¡
\94a. Ða»¡ e
\r
59 ;; xt>name
\9fi ¶áÐ
\81¬á xt ¤a
\9d¡ ´|µA ·¡
\9fq º
\81¡
\9fi
\88a
\9f¡Ç¡
\93e
\88t·i
\90q
\8b©
\r
60 ;; 쩦a
\88a ·¶¯s
\93¡
\94a. name>xt
\88a ¤a
\8eá´ö
\8b¡
\98\81¢
\85µA
\r
61 ;; (search-wordlist)·
\81 \8b¡
\89\81´á ¸÷·
\81\9fi ¤a
\8e\81´ö¯s
\93¡
\94a (°w¸ñ ¸÷·
\81\93e
\r
62 ;; ¤a
\8e\89 쩦a
\88a ´ô¯s
\93¡
\94a).
\r
64 ;; 3. Å¡
\97a, ·¡
\9fq, ¸a
\9ea ¸a
\9f¡·
\81 §¥ ¸a
\9f¡
\9fi
\90aÈa
\90\81\93e
\88t
\97i·¡ hForth RAM
\r
65 ;; ¡¡
\95IµA¬á
\93e ROM
\89Á RAM ¸a
\9f¡
\9fi
\88a
\9f¡Ç¡
\93e
\88a
\9f¡Ç±
\88t
\97i´á´¡ Ði Ï©¶a
\88a
\r
66 ;; ´ô¯s
\93¡
\94a. ROMB, ROMT, RAMB, RAMT
\9fi ¨
\96¯s
\93¡
\94a. xhere
\9fi ¡¡
\96\81\r
67 ; HERE
\9d¡ ¤a
\8e\81´ö¯s
\93¡
\94a. 'code,'
\9fi ¡¡
\96\81 ','
\9d¡ ¤a
\8e\81´ö¯s
\93¡
\94a.
\r
69 ;; 4. head,
\88a ¤a
\8eá´ö
\8b¡
\98\81¢
\85µA :µÁ CONSTANTµÁ CREATEµÁ VARIABLEµÁ
\r
70 ;; VALUE
\9fi
\89¡Áv¯s
\93¡
\94a. hForth ROM ¡¡
\95IµA¬á
\93e ·¡
\9fq ¸a
\9f¡
\88a Å¡
\97a
\r
71 ;; ¸a
\9f¡µÁ
\98é´á¹a ·¶´ö
\8b¡
\98\81¢
\85µA
\90{ i·
\81 ·¡
\9fq·i ·¡
\9fq ¸a
\9f¡µA °á
\r
72 ;;
\90ý
\8b¡ ¸åµA head,
\88a xt
\9fi ´i ®
\81 ·¶´ö¯s
\93¡
\94a.
\8ba
\9cá
\90a hForth RAM
\r
73 ;; ¡¡
\95IµA¬á
\93e Å¡
\97a ¸a
\9f¡µÁ ·¡
\9fq ¸a
\9f¡
\88a ÐsÁa¹v
\8b¡
\98\81¢
\85µA ·¡
\9fq·i
\r
74 ;; °á
\90ý
\8b¡ ¸åµA head,
\88a xt
\9fi £¡
\9f¡ ´i ®
\81 ´ô¯s
\93¡
\94a.
\r
76 ;; 5. Á¡
\8b¡
\88t·¡ Ï©¶aÐe ¯¡¯aÉQ ¢
\81\9fe
\88t
\97i
\89Á
\94e®
\85Ðe ¯¡¯aÉQ ¢
\81\9fe
\88t·i
\r
77 ;;
\8a\81¦
\85Ð
\96¯s
\93¡
\94a. Á¡
\8b¡
\88t·¡ Ï©¶aÐe ¢
\81\9fe
\88t
\97i·e doCONST
\9fi °á¬á
\r
78 ;;
\94ᣡµA
\88t·
\81 º
\81¡
\9fi µ©
\9f¡
\89A Ða
\89¡ Á¡
\8b¡
\88t·¡ Ï©¶a´ô
\93e ¢
\81\9fe
\88t
\97i·e
\r
79 ;; $VAR aÇa
\9d¡
\9d¡ ¸÷·
\81Ð
\81‡ doVAR
\9d¡
\88t·
\81 º
\81¡
\9fi
\94ᣡµA µ©
\9f¡
\89A
\r
80 ;; Ð
\96¯s
\93¡
\94a. VARIABLE·¡ ³a
\93e
\8b¡
\89\81´á ¸÷·
\81 doVAR
\9fi
\94áÐ
\96¯s
\93¡
\94a.
\r
82 ;; 6. CREATEµÁ doCREATEµÁ >BODY·
\81 ¸÷·
\81\9fi ¤a
\8e\81´ö¯s
\93¡
\94a.
\r
84 ;; 7. RESET-SYSTEM·i ´ô´
\96¯s
\93¡
\94a. COLDµÁ set-i/o
\9fi
\89¡Áv¯s
\93¡
\94a.
\r
86 ;; 8. PADSize
\9fi
\96\81 ¤
\81\9d¡
\93i
\9dv¯s
\93¡
\94a.
\r
88 ;; 9. ¡A¡¡
\9f¡ e
\90â
\90âÐa
\94a¡e wordlist·
\81 ®
\81µA ¹AÐe·¡ ´ô¯s
\93¡
\94a.
\r
90 ;; 10. ¬a¶w
\88a
\93wÐe ¡A¡¡
\9f¡·
\81 \85 ¶á
\9fi
\88a
\9f¡Ç¡
\93e ¢
\81\9fe
\88t memTop·i
\r
91 ;;
\94áÐ
\96¯s
\93¡
\94a.
\r
94 ; hForth RAM model is derived from hForth ROM model and adapted
\r
95 ; to RAM only system.
\r
97 ; Differences from hForth ROM model are described below. One low
\r
98 ; level CODE definition is changed and only one is added for
\r
99 ; efficiency. Some macros in the assembler source and high level
\r
100 ; colon definitions are redefined.
\r
102 ; 1. The structure of the dictionary is changed. Code and name
\r
103 ; spaces are intermingled in hForth RAM model as below
\r
105 ; ||link|name|pointer_to_name|code>
\r
107 ; while they are separated in hForth ROM model as below.
\r
109 ; ||code> ... <xt|link|name||
\r
111 ; where xt is the starting address of code. $STR, $CODE, $ENVIR,
\r
112 ; and $VALUE macros are redefined in assembly source.
\r
114 ; 2. 'xt>name' and 'name>xt' are redefined. In hForth ROM model the
\r
115 ; xt of a definition is stored in name space which is used by
\r
116 ; 'name>xt', however, the pointer to the name of a definition is
\r
117 ; not stored in code space to keep the code space as tight as
\r
118 ; possible. So 'xt>name' of hForth ROM model need to search the
\r
119 ; whole name space until it finds the matched xt. In hForth RAM
\r
120 ; model no pointer for 'name>xt' is necessary since code space
\r
121 ; starts at the end of the name, however, a pointer to the name
\r
122 ; of a definition is stored before the code of a definition for
\r
123 ; 'xt>name'. CODE definition of '(search-wordlist)' is changed
\r
124 ; since 'name>xt' is redefined (although colon definition need
\r
125 ; not be changed at all).
\r
127 ; 3. Code, name and data pointers need not be vectored since the
\r
128 ; memory space is not split into separated ROM and RAM spaces.
\r
129 ; 'ROMB', 'ROMT', 'RAMB' and 'RAMT' are deleted. Every 'xhere'
\r
130 ; was replaced with HERE. Every 'code,' was replaced with ','.
\r
132 ; 4. ':', 'CONSTANT', 'CREATE', 'VARIABLE', and 'VALUE' are
\r
133 ; redefined since 'head,' is redefined. In hForth ROM model
\r
134 ; name spaces are separated from code space and xt is given to
\r
135 ; 'head,' before the name of a definition is compiled into the
\r
136 ; name space. However, in hForth RAM model code and name spaces
\r
137 ; are combined and xt can not be known to 'head,' until the
\r
138 ; name of a definition is compiled into the name space.
\r
140 ; 5. System variables are devided into initializable variables
\r
141 ; defined by $CONST which use doCONST to put a-addr on the
\r
142 ; stack and non-initialized ones defined by $VAR which use
\r
143 ; doVAR. CODE definition 'doVAR' is added and used by VARIABLE.
\r
145 ; 6. 'CREATE', 'doCREATE', and '>BODY' are redefined.
\r
147 ; 7. RESET-SYSTEM is deleted. COLD and 'set-i/o' are revised.
\r
149 ; 8. Increase PADSize twice.
\r
151 ; 9. Number of wordlists are only limited by available memory.
\r
153 ; 10. Variable 'memTop' is added, which points top of available
\r
156 ;===============================================================
\r
158 ; 8086/8 register usages
\r
159 ; Single segment model. CS, DS and SS must be same.
\r
160 ; The direction bit must be cleared before returning to Forth
\r
161 ; interpreter(CLD).
\r
162 ; SP: data stack pointer
\r
163 ; BP: return stack pointer
\r
164 ; SI: Forth virtual machine instruction pointer
\r
165 ; BX: top of data stack item
\r
166 ; All other registers are free.
\r
168 ; Structure of a task
\r
169 ; userP points follower.
\r
170 ; //userP//<return_stack//<data_stack//
\r
171 ; //user_area/user1/taskName/throwFrame/stackTop/status/follower/sp0/rp0
\r
173 ;===============================================================
\r
176 ; Assembly Constants
\r
182 CHARR EQU 1 ;byte size of a character
\r
183 CELLL EQU 2 ;byte size of a cell
\r
184 MaxChar EQU 0FFh ;Extended character set
\r
185 ; Use 07Fh for ASCII only
\r
186 MaxSigned EQU 07FFFh ;max value of signed integer
\r
187 MaxUnsigned EQU 0FFFFh ;max value of unsigned integer
\r
188 MaxNegative EQU 8000h ;max value of negative integer
\r
191 PADSize EQU 258 ;PAD area size
\r
192 RTCells EQU 64 ;return stack size
\r
193 DTCells EQU 256 ;data stack size
\r
195 BASEE EQU 10 ;default radix
\r
196 OrderDepth EQU 10 ;depth of search order stack
\r
198 COMPO EQU 020h ;lexicon compile only bit
\r
199 IMMED EQU 040h ;lexicon immediate bit
\r
200 MASKK EQU 1Fh ;lexicon bit mask
\r
201 ;extended character set
\r
202 ;maximum name length = 1Fh
\r
204 BKSPP EQU 8 ;backspace
\r
206 LFF EQU 10 ;line feed
\r
207 CRR EQU 13 ;carriage return
\r
208 DEL EQU 127 ;delete
\r
210 CALLL EQU 0E890h ;NOP CALL opcodes
\r
212 ; Memory allocation
\r
213 ; RAMbottom||code/name/data>WORDworkarea|--//--|PAD|TIB||MemTop
\r
215 COLDD EQU 00100h ;cold start vector
\r
217 ; Initialize assembly variables
\r
219 _SLINK = 0 ;force a null link
\r
220 _FLINK = 0 ;force a null link
\r
221 _ENVLINK = 0 ;farce a null link
\r
222 _THROW = 0 ;current throw str addr offset
\r
228 ; Adjust an address to the next cell boundary.
\r
231 EVEN ;for 16 bit systems
\r
234 ; Add a name to name space of dictionary.
\r
236 $STR MACRO LABEL,STRING
\r
247 ; Add a THROW message in name space. THROW messages won't be
\r
248 ; needed if target system do not need names of Forth words.
\r
250 $THROWMSG MACRO STRING
\r
256 _THROW = _THROW + CELLL
\r
257 ORG AddrTHROWMsgTbl - _THROW
\r
262 ; Compile a code definition header.
\r
264 $CODE MACRO LEX,NAME,LABEL,LINK
\r
265 $ALIGN ;force to cell boundary
\r
268 LINK = $ ;link points to a name string
\r
269 DB LEX,NAME ;name string
\r
272 LABEL: ;assembly label
\r
275 ; Compile a colon definition header.
\r
277 $COLON MACRO LEX,NAME,LABEL,LINK
\r
278 $CODE LEX,NAME,LABEL,LINK
\r
279 NOP ;align to cell boundary
\r
280 CALL DoLIST ;include CALL doLIST
\r
283 ; Compile a system CONSTANT header.
\r
285 $CONST MACRO LEX,NAME,LABEL,VALUE,LINK
\r
286 $CODE LEX,NAME,LABEL,LINK
\r
292 ; Compile a system VALUE header.
\r
294 $VALUE MACRO LEX,NAME,LABEL,VALUE,LINK
\r
295 $CODE LEX,NAME,LABEL,LINK
\r
301 ; Compile a non-initialized system VARIABLE header.
\r
303 $VAR MACRO LEX,NAME,LABEL,N_CELLS,LINK
\r
304 $CODE LEX,NAME,LABEL,LINK
\r
310 ; Compile a system USER header.
\r
312 $USER MACRO LEX,NAME,LABEL,OFFSET,LINK
\r
313 $CODE LEX,NAME,LABEL,LINK
\r
319 ; Compile an inline string.
\r
323 _LEN = $ ;save address of count
\r
326 DB STRNG ;store string
\r
327 _CODE = $ ;save code pointer
\r
328 ORG _LEN ;point to count byte
\r
329 DW _CODE-_LEN-2*CELLL ;set count
\r
330 ORG _CODE ;restore code pointer
\r
334 ; Compile a environment query string header.
\r
336 $ENVIR MACRO LEX,NAME
\r
337 $ALIGN ;force to cell boundary
\r
339 _ENVLINK = $ ;link points to a name string
\r
340 DB LEX,NAME ;name string
\r
347 ; Assemble inline direct threaded code ending.
\r
350 ; JMP uDebug ;activate to use microdebugger
\r
351 LODSW ;next code address into AX
\r
352 JMP AX ;jump directly to code address
\r
356 ;===============================================================
\r
359 ; Main entry points and COLD start data
\r
363 ASSUME CS:MAIN,DS:MAIN,SS:MAIN
\r
365 ORG COLDD ;beginning of cold boot
\r
367 ORIG: CLD ;direction flag, increment
\r
368 MOV WORD PTR AddrMemTop,SP ;top of memory at 'memTop'
\r
370 MOV DS,AX ;DS is same as CS
\r
371 CLI ;disable interrupts, old 808x CPU bug
\r
372 MOV SS,AX ;SS is same as CS
\r
373 MOV SP,offset SPP ;initialize SP
\r
374 STI ;enable interrupts
\r
375 MOV BP,offset RPP ;initialize RP
\r
377 XOR AX,AX ;MS-DOS only
\r
378 MOV Redirect1stQ,AX ;MS-DOS only
\r
380 JMP COLD ;to high level cold start
\r
384 $STR ModelStr,'RAM Model'
\r
385 $STR VersionStr,'0.9.9'
\r
387 ; system variables.
\r
389 $ALIGN ;align to cell boundary
\r
390 ValueTickEKEYQ EQU RXQ ;'ekey?
\r
391 ValueTickEKEY EQU RXFetch ;'ekey
\r
392 ValueTickEMITQ EQU TXQ ;'emit?
\r
393 ValueTickEMIT EQU TXStore ;'emit
\r
394 ValueTickINIT_IO EQU Set_IO ;'init-i/o
\r
395 ValueTickPrompt EQU DotOK ;'prompt
\r
396 ValueTickBoot EQU HI ;'boot
\r
397 ValueSOURCE_ID EQU 0 ;SOURCE-ID
\r
398 ValueHERE EQU CTOP ;data space pointer
\r
399 AddrTickDoWord DW OptiCOMPILEComma ;nonimmediate word - compilation
\r
400 DW EXECUTE ;nonimmediate word - interpretation
\r
401 DW DoubleAlsoComma ;not found word - compilateion
\r
402 DW DoubleAlso ;not found word - interpretation
\r
403 DW EXECUTE ;immediate word - compilation
\r
404 DW EXECUTE ;immediate word - interpretation
\r
405 AddrBASE DW 10 ;BASE
\r
406 AddrRakeVar DW 0 ;rakeVar
\r
407 AddrNumberOrder DW 2 ;#order
\r
408 DW AddrFORTH_WORDLIST ;search order stack
\r
409 DW AddrNONSTANDARD_WORDLIST
\r
410 DW (OrderDepth-2) DUP (0)
\r
411 AddrCurrent DW AddrFORTH_WORDLIST ;current pointer
\r
412 AddrFORTH_WORDLIST DW LASTFORTH ;FORTH-WORDLIST
\r
413 DW AddrNONSTANDARD_WORDLIST;wordlist link
\r
414 DW FORTH_WORDLISTName ;name of the WORDLIST
\r
415 AddrNONSTANDARD_WORDLIST DW LASTSYSTEM ;NONSTANDARD-WORDLIST
\r
416 DW 0 ;wordlist link
\r
417 DW NONSTANDARD_WORDLISTName;name of the WORDLIST
\r
418 AddrEnvQList DW LASTENV ;envQList
\r
419 AddrUserP DW SysUserP ;user pointer
\r
420 SysTask DW SysUserP ;system task's tid
\r
421 SysUser1 DW ? ;user1
\r
422 SysTaskName DW SystemTaskName ;taskName
\r
423 SysThrowFrame DW ? ;throwFrame
\r
424 SysStackTop DW ? ;stackTop
\r
425 SysStatus DW Wake ;status
\r
427 SysFollower DW SysStatus ;follower
\r
428 DW SPP ;system task's sp0
\r
429 DW RPP ;system task's rp0
\r
431 AddrNumberOrder0 DW 2 ;#order
\r
432 DW AddrFORTH_WORDLIST ;search order stack
\r
433 DW AddrNONSTANDARD_WORDLIST
\r
434 DW (OrderDepth-2) DUP (0)
\r
436 RStack DW RTCells DUP (0AAAAh) ;to see how deep stack grows
\r
438 DStack DW DTCells DUP (05555h) ;to see how deep stack grows
\r
441 ; THROW code messages
\r
443 DW 58 DUP (?) ;number of throw messages = 58
\r
446 $THROWMSG 'ABORT' ;-01
\r
447 $THROWMSG 'ABORT"' ;-02
\r
448 $THROWMSG 'stack overflow' ;-03
\r
449 $THROWMSG 'stack underflow' ;-04
\r
450 $THROWMSG 'return stack overflow' ;-05
\r
451 $THROWMSG 'return stack underflow' ;-06
\r
452 $THROWMSG 'do-loops nested too deeply during execution' ;-07
\r
453 $THROWMSG 'dictionary overflow' ;-08
\r
454 $THROWMSG 'invalid memory address' ;-09
\r
455 $THROWMSG 'division by zero' ;-10
\r
456 $THROWMSG 'result out of range' ;-11
\r
457 $THROWMSG 'argument type mismatch' ;-12
\r
458 $THROWMSG 'undefined word' ;-13
\r
459 $THROWMSG 'interpreting a compile-only word' ;-14
\r
460 $THROWMSG 'invalid FORGET' ;-15
\r
461 $THROWMSG 'attempt to use zero-length string as a name' ;-16
\r
462 $THROWMSG 'pictured numeric output string overflow' ;-17
\r
463 $THROWMSG 'parsed string overflow' ;-18
\r
464 $THROWMSG 'definition name too long' ;-19
\r
465 $THROWMSG 'write to a read-only location' ;-20
\r
466 $THROWMSG 'unsupported operation (e.g., AT-XY on a too-dumb terminal)' ;-21
\r
467 $THROWMSG 'control structure mismatch' ;-22
\r
468 $THROWMSG 'address alignment exception' ;-23
\r
469 $THROWMSG 'invalid numeric argument' ;-24
\r
470 $THROWMSG 'return stack imbalance' ;-25
\r
471 $THROWMSG 'loop parameters unavailable' ;-26
\r
472 $THROWMSG 'invalid recursion' ;-27
\r
473 $THROWMSG 'user interrupt' ;-28
\r
474 $THROWMSG 'compiler nesting' ;-29
\r
475 $THROWMSG 'obsolescent feature' ;-30
\r
476 $THROWMSG '>BODY used on non-CREATEd definition' ;-31
\r
477 $THROWMSG 'invalid name argument (e.g., TO xxx)' ;-32
\r
478 $THROWMSG 'block read exception' ;-33
\r
479 $THROWMSG 'block write exception' ;-34
\r
480 $THROWMSG 'invalid block number' ;-35
\r
481 $THROWMSG 'invalid file position' ;-36
\r
482 $THROWMSG 'file I/O exception' ;-37
\r
483 $THROWMSG 'non-existent file' ;-38
\r
484 $THROWMSG 'unexpected end of file' ;-39
\r
485 $THROWMSG 'invalid BASE for floating point conversion' ;-40
\r
486 $THROWMSG 'loss of precision' ;-41
\r
487 $THROWMSG 'floating-point divide by zero' ;-42
\r
488 $THROWMSG 'floating-point result out of range' ;-43
\r
489 $THROWMSG 'floating-point stack overflow' ;-44
\r
490 $THROWMSG 'floating-point stack underflow' ;-45
\r
491 $THROWMSG 'floating-point invalid argument' ;-46
\r
492 $THROWMSG 'compilation word list deleted' ;-47
\r
493 $THROWMSG 'invalid POSTPONE' ;-48
\r
494 $THROWMSG 'search-order overflow' ;-49
\r
495 $THROWMSG 'search-order underflow' ;-50
\r
496 $THROWMSG 'compilation word list changed' ;-51
\r
497 $THROWMSG 'control-flow stack overflow' ;-52
\r
498 $THROWMSG 'exception stack overflow' ;-53
\r
499 $THROWMSG 'floating-point underflow' ;-54
\r
500 $THROWMSG 'floating-point unidentified fault' ;-55
\r
501 $THROWMSG 'QUIT' ;-56
\r
502 $THROWMSG 'exception in sending or receiving a character' ;-57
\r
503 $THROWMSG '[IF], [ELSE], or [THEN] exception' ;-58
\r
506 ; System dependent words -- Must be re-definded for each system.
\r
508 ; I/O words must be redefined if serial communication is used instead of
\r
509 ; keyboard. Following words are for MS-DOS system.
\r
512 ; Return true if key is pressed.
\r
514 $CODE 3,'RX?',RXQ,_SLINK
\r
516 MOV AH,0Bh ;get input status of STDIN
\r
523 ; Receive one keyboard event u.
\r
525 $CODE 3,'RX@',RXFetch,_SLINK
\r
528 MOV AH,08h ;MS-DOS Read Keyboard
\r
530 ADD BL,AL ;MOV BL,AL and OR AL,AL
\r
531 JNZ RXFET1 ;extended character code?
\r
537 ; Return true if output device is ready or device state is
\r
540 $CONST 3,'TX?',TXQ,TRUEE,_SLINK ;always true for MS-DOS
\r
543 ; Send char to the output device.
\r
545 $CODE 3,'TX!',TXStore,_SLINK
\r
546 MOV DX,BX ;char in DL
\r
547 MOV AH,02h ;MS-DOS Display output
\r
548 INT 021H ;display character
\r
553 ; Carriage return and linefeed.
\r
555 ; : CR carriage-return-char EMIT linefeed-char EMIT ;
\r
557 $COLON 2,'CR',CR,_FLINK
\r
558 DW DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT
\r
560 ; BYE ( -- ) \ TOOLS EXT
\r
561 ; Return control to the host operation system, if any.
\r
563 $CODE 3,'BYE',BYE,_FLINK
\r
564 MOV AX,04C00h ;close all files and
\r
565 INT 021h ; return to MS-DOS
\r
570 ; : hi CR ." hForth "
\r
571 ; S" CPU" ENVIRONMENT? DROP TYPE SPACE
\r
572 ; S" model" ENVIRONMENT? DROP TYPE SPACE [CHAR] v EMIT
\r
573 ; S" version" ENVIRONMENT? DROP TYPE
\r
574 ; ." by Wonyong Koh, 1997" CR
\r
575 ; ." ALL noncommercial and commercial uses are granted." CR
\r
576 ; ." Please send comment, bug report and suggestions to:" CR
\r
577 ; ." wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr" CR ;
\r
579 $COLON 2,'hi',HI,_SLINK
\r
584 DW ENVIRONMENTQuery,DROP,TYPEE,SPACE
\r
586 DW ENVIRONMENTQuery,DROP,TYPEE,SPACE,DoLIT,'v',EMIT
\r
588 DW ENVIRONMENTQuery,DROP,TYPEE
\r
589 $INSTR ' by Wonyong Koh, 1997'
\r
591 $INSTR 'All noncommercial and commercial uses are granted.'
\r
593 $INSTR 'Please send comment, bug report and suggestions to:'
\r
595 $INSTR ' wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr'
\r
599 ; The cold start sequence execution word.
\r
601 ; : COLD sp0 sp! rp0 rp! \ initialize stack
\r
602 ; 'init-i/o EXECUTE
\r
604 ; QUIT ; \ start interpretation
\r
606 $COLON 4,'COLD',COLD,_SLINK
\r
607 DW SPZero,SPStore,RPZero,RPStore
\r
608 DW TickINIT_IO,EXECUTE,TickBoot,EXECUTE
\r
612 ; Set input/output device.
\r
614 ; : set-i/o S" CON" stdin ; \ MS-DOS only
\r
616 $COLON 7,'set-i/o',Set_IO,_SLINK
\r
617 $INSTR 'CON' ;MS-DOS only
\r
618 DW STDIN ;MS-DOS only
\r
622 ; MS-DOS only words -- not necessary for other systems.
\r
624 ; File input using MS-DOS redirection function without using FILE words.
\r
626 ; redirect ( c-addr -- flag )
\r
627 ; Redirect standard input from the device identified by ASCIIZ
\r
628 ; string stored at c-addr. Return error code.
\r
630 $CODE 8,'redirect',Redirect,_SLINK
\r
632 MOV AX,Redirect1stQ
\r
637 INT 021h ; close previously opend file
\r
638 REDIRECT2: MOV AX,03D00h ; open file read-only
\r
639 MOV Redirect1stQ,AX ; set Redirect1stQ true
\r
641 JC REDIRECT1 ; if error
\r
649 REDIRECT1: MOV BX,AX
\r
651 Redirect1stQ DW 0 ; true after the first redirection
\r
652 RedirHandle DW ? ; redirect file handle
\r
654 ; asciiz ( ca1 u -- ca2 )
\r
655 ; Return ASCIIZ string.
\r
657 ; : asciiz HERE SWAP 2DUP + 0 SWAP C! CHARS MOVE HERE ;
\r
659 $COLON 6,'asciiz',ASCIIZ,_SLINK
\r
660 DW HERE,SWAP,TwoDUP,Plus,Zero
\r
661 DW SWAP,CStore,CHARS,MOVE,HERE,EXIT
\r
663 ; stdin ( ca u -- )
\r
665 ; : stdin asciiz redirect ?DUP
\r
666 ; IF -38 THROW THEN ; COMPILE-ONLY
\r
668 $COLON 5,'stdin',STDIN,_SLINK
\r
669 DW ASCIIZ,Redirect,QuestionDUP,ZBranch,STDIN1
\r
673 ; << ( "<spaces>ccc" -- )
\r
674 ; Redirect input from the file 'ccc'. Should be used only in
\r
675 ; interpretation state.
\r
677 ; : << STATE @ IF ." Do not use '<<' in a definition." ABORT THEN
\r
678 ; PARSE-WORD stdin SOURCE >IN ! DROP ; IMMEDIATE
\r
680 $COLON IMMED+2,'<<',FROM,_SLINK
\r
681 DW STATE,Fetch,ZBranch,FROM1
\r
683 $INSTR 'Do not use << in a definition.'
\r
685 FROM1 DW PARSE_WORD,STDIN,SOURCE,ToIN,Store,DROP,EXIT
\r
688 ; Non-Standard words - Processor-dependent definitions
\r
689 ; 16 bit Forth for 8086/8
\r
692 ; microdebugger for debugging new hForth ports by NAC.
\r
694 ; The major problem with debugging Forth code at the assembler level is that
\r
695 ; most of the definitions are lists of execution tokens that get interpreted
\r
696 ; (using doLIST) rather than executed directly. As far as the native processor
\r
697 ; is concerned, these xt are data, and a debugger cannot be set to trap on
\r
700 ; The solution to that problem would seem to be to trap on the native-machine
\r
701 ; 'call' instruction at the start of each definition. However, the threaded
\r
702 ; nature of the code makes it very difficult to follow a particular definition
\r
703 ; through: many definitions are used repeatedly through the code. Simply
\r
704 ; trapping on the 'call' leads to multiple unwanted traps.
\r
706 ; Consider, for example, the code for doS" --
\r
708 ; DW RFrom,SWAP,TwoDUP,Plus,ALIGNED,ToR,EXIT
\r
710 ; It would be useful to run each word in turn; at the end of each word the
\r
711 ; effect upon the stacks could be checked until the faulty word is found.
\r
713 ; This technique allows you to do exactly that.
\r
715 ; All definitions end with $NEXT -- either directly (code definitions) or
\r
716 ; indirectly (colon definitions terminating in EXIT, which is itself a code
\r
717 ; definition). The action of $NEXT is to use the fpc for the next word to
\r
718 ; fetch the xt and jumps to it.
\r
720 ; To use the udebug routine, replace the $NEXT expansion with a jump (not a
\r
721 ; call) to the routine udebug (this requires you to reassemble the code)
\r
723 ; When you want to debug a word, trap at the CALL doLIST at the start of the
\r
724 ; word and then load the location trapfpc with the address of the first xt
\r
725 ; of the word. Make your debugger trap when you execute the final instruction
\r
726 ; in the udebug routine. Now execute your code and your debugger will trap
\r
727 ; after the completion of the first xt in the definition. To stop debugging,
\r
728 ; simply set trapfpc to 0.
\r
730 ; This technique has a number of limitations:
\r
731 ; - It is an assumption that an xt of 0 is illegal
\r
732 ; - You cannot automatically debug a code stream that includes inline string
\r
733 ; definitions, or any other kind of inline literal. You must step into the
\r
734 ; word that includes the definition then hand-edit the appropriate new value
\r
736 ; Clearly, you could overcome these limitations by making udebug more
\r
737 ; complex -- but then you run the risk of introducing bugs in that code.
\r
739 uDebug: MOV AX,trapfpc
\r
740 CMP AX,SI ; compare the stored address with
\r
741 ; the address we're about to get the
\r
743 JNE uDebug1 ; not the trap address, so we're done
\r
744 ADD AX,CELLL ; next time trap on the next xt
\r
746 NOP ; make debugger TRAP at this address
\r
753 ; same? ( c-addr1 c-addr2 u -- -1|0|1 )
\r
754 ; Return 0 if two strings, ca1 u and ca2 u, are same; -1 if
\r
755 ; string, ca1 u is smaller than ca2 u; 1 otherwise. Used by
\r
756 ; '(search-wordlist)'. Code definition is preferred to speed up
\r
757 ; interpretation. Colon definition is shown below.
\r
759 ; : same? ?DUP IF \ null strings are always same
\r
760 ; 0 DO OVER C@ OVER C@ XOR
\r
761 ; IF UNLOOP C@ SWAP C@ > 2* 1+ EXIT THEN
\r
762 ; CHAR+ SWAP CHAR+ SWAP
\r
766 ; $COLON 5,'same?',SameQ,_SLINK
\r
767 ; DW QuestionDUP,ZBranch,SAMEQ4
\r
769 ; SAMEQ3 DW OVER,CFetch,OVER,CFetch,XORR,ZBranch,SAMEQ2
\r
770 ; DW UNLOOP,CFetch,SWAP,CFetch,GreaterThan
\r
771 ; DW TwoStar,OnePlus,EXIT
\r
772 ; SAMEQ2 DW CHARPlus,SWAP,CHARPlus
\r
774 ; SAMEQ4 DW TwoDROP,Zero,EXIT
\r
776 $CODE 5,'same?',SameQ,_SLINK
\r
794 ; (search-wordlist) ( c-addr u wid -- 0 | xt f 1 | xt f -1)
\r
795 ; Search word list for a match with the given name.
\r
796 ; Return execution token and not-compile-only flag and
\r
797 ; -1 or 1 ( IMMEDIATE) if found. Return 0 if not found.
\r
799 ; format is: wid---->[ a ]
\r
803 ; [ a' ][ccbbaann][ggffeedd]...
\r
807 ; [ a'' ][ccbbaann][ggffeedd]...
\r
809 ; a, a' etc. point to the cell that contains the name of the
\r
810 ; word. The length is in the low byte of the cell (little byte
\r
811 ; for little-endian, big byte for big-endian).
\r
812 ; Eventually, a''' contains 0 to indicate the end of the wordlist
\r
813 ; (oldest entry). a=0 indicates an empty wordlist.
\r
814 ; xt is the xt of the word. aabbccddeedd etc. is the name of
\r
815 ; the word, packed into cells.
\r
817 ; : (search-wordlist)
\r
818 ; ROT >R SWAP DUP 0= IF -16 THROW THEN
\r
819 ; \ attempt to use zero-length string as a name
\r
820 ; >R \ wid R: ca1 u
\r
821 ; BEGIN @ \ ca2 R: ca1 u
\r
822 ; DUP 0= IF R> R> 2DROP EXIT THEN \ not found
\r
823 ; DUP COUNT [ =MASK ] LITERAL AND R@ = \ ca2 ca2+char f
\r
824 ; IF R> R@ SWAP DUP >R \ ca2 ca2+char ca1 u
\r
826 ; \ ELSE DROP -1 \ unnecessary since ca2+char is not 0.
\r
828 ; WHILE cell- \ pointer to next word in wordlist
\r
830 ; R> R> 2DROP DUP name>xt SWAP \ xt ca2
\r
831 ; C@ DUP [ =COMP ] LITERAL AND 0= SWAP
\r
832 ; [ =IMED ] LITERAL AND 0= 2* 1+ ;
\r
834 ; $COLON 17,'(search-wordlist)',ParenSearch_Wordlist,_SLINK
\r
835 ; DW ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6
\r
838 ; DW DUPP,ZBranch,PSRCH9
\r
839 ; DW DUPP,COUNT,DoLIT,MASKK,ANDD,RFetch,Equals
\r
840 ; DW ZBranch,PSRCH5
\r
841 ; DW RFrom,RFetch,SWAP,DUPP,ToR,SameQ
\r
842 ; PSRCH5 DW ZBranch,PSRCH3
\r
843 ; DW CellMinus,Branch,PSRCH1
\r
844 ; PSRCH3 DW RFrom,RFrom,TwoDROP,DUPP,NameToXT,SWAP
\r
845 ; DW CFetch,DUPP,DoLIT,COMPO,ANDD,ZeroEquals,SWAP
\r
846 ; DW DoLIT,IMMED,ANDD,ZeroEquals,TwoStar,OnePlus,EXIT
\r
847 ; PSRCH9 DW RFrom,RFrom,TwoDROP,EXIT
\r
848 ; PSRCH6 DW DoLIT,-16,THROW
\r
850 $CODE 17,'(search-wordlist)',ParenSearch_Wordlist,_SLINK
\r
859 PSRCH2: MOV BX,[BX]
\r
861 JZ PSRCH4 ; end of wordlist?
\r
863 SUB BX,CELLL ;pointer to nextword
\r
864 AND CL,MASKK ;max name length = MASKK
\r
873 ADD DI,3 ;add 1 CELLS + 1
\r
874 AND DI,0FFFEh ;align
\r
887 PSRCH1: MOV BX,-16 ;attempt to use zero-length string as a name
\r
892 ; ?call ( xt1 -- xt1 0 | a-addr xt2 )
\r
893 ; Return xt of the CALLed run-time word if xt starts with machine
\r
894 ; CALL instruction and leaves the next cell address after the
\r
895 ; CALL instruction. Otherwise leaves the original xt1 and zero.
\r
897 ; : ?call DUP @ call-code =
\r
898 ; IF CELL+ DUP @ SWAP CELL+ DUP ROT + EXIT THEN
\r
899 ; \ Direct Threaded Code 8086 relative call
\r
902 $COLON 5,'?call',QCall,_SLINK
\r
903 DW DUPP,Fetch,DoLIT,CALLL,Equals,ZBranch,QCALL1
\r
904 DW CELLPlus,DUPP,Fetch,SWAP,CELLPlus,DUPP,ROT,Plus,EXIT
\r
905 QCALL1 DW Zero,EXIT
\r
907 ; xt, ( xt1 -- xt2 )
\r
908 ; Take a run-time word xt1 for :NONAME , CONSTANT , VARIABLE and
\r
909 ; CREATE . Return xt2 of current definition.
\r
911 ; : xt, HERE ALIGNED DUP TO HERE SWAP
\r
912 ; call-code , \ Direct Threaded Code
\r
913 ; HERE CELL+ - , ; \ 8086 relative call
\r
915 $COLON 3,'xt,',xtComma,_SLINK
\r
916 DW HERE,ALIGNED,DUPP,DoTO,AddrHERE,SWAP
\r
917 DW DoLIT,CALLL,Comma,HERE,CELLPlus,Minus,Comma,EXIT
\r
920 ; Push an inline literal. The inline literal is at the current
\r
921 ; value of the fpc, so put it onto the stack and point past it.
\r
923 $CODE COMPO+5,'doLIT',DoLIT,_SLINK
\r
930 ; Run-time routine of CONSTANT. When you quote a constant you
\r
931 ; execute its code, which consists of a call to here, followed
\r
932 ; by an inline literal. Although you come here as the result of
\r
933 ; a native machine call, you never go back to the return address
\r
934 ; -- you jump back up a level by continuing at the new fpc
\r
935 ; value. For 8086, Z80 the inline literal is at the return
\r
936 ; address stored on the top of the hardware stack.
\r
938 $CODE COMPO+7,'doCONST',DoCONST,_SLINK
\r
945 ; Run-time routine of VALUE. Same as doCONSTANT. Used as a
\r
948 $CODE COMPO+7,'doVALUE',DoVALUE,_SLINK
\r
955 ; Run-time routine of VARIABLE. When you quote a variable you
\r
956 ; execute its code, which consists of a call to here, followed
\r
957 ; by an inline literal. The literal is the address at which a
\r
958 ; VARIABLE's value is stored. Although you come here as the
\r
959 ; result of a native machine call, you never go back to the
\r
960 ; return address -- you jump back up a level by continuing at
\r
961 ; the new fpc value. For 8086, Z80 the inline literal is at
\r
962 ; the return address stored on the top of the hardware stack.
\r
964 $CODE COMPO+5,'doVAR',DoVAR,_SLINK
\r
969 ; doCREATE ( -- a-addr )
\r
970 ; Run-time routine of CREATE. For CREATEd words with an
\r
971 ; associated DOES>, get the address of the CREATEd word's data
\r
972 ; space and execute the DOES> actions. For CREATEd word without
\r
973 ; an associated DOES>, return the address of the CREATE'd word's
\r
974 ; data space. A CREATEd word starts its execution through this
\r
975 ; routine in exactly the same way as a colon definition uses
\r
976 ; doLIST. In other words, we come here through a native machine
\r
979 ; Structure of CREATEd word:
\r
980 ; | call-doCREATE | 0 or DOES> code addr | >BODY points here
\r
982 ; The DOES> address holds a native call to doLIST. This routine
\r
983 ; doesn't alter the fpc. We never come back *here* so we never
\r
984 ; need to preserve an address that would bring us back *here*.
\r
986 ; Example : myVARIABLE CREATE , DOES> ;
\r
987 ; 56 myVARIABLE JIM
\r
988 ; JIM \ stacks the address of the data cell that contains 56
\r
990 ; : doCREATE SWAP \ switch BX and top of 8086 stack item
\r
991 ; DUP CELL+ SWAP @ ?DUP IF EXECUTE THEN ; COMPILE-ONLY
\r
993 ; $COLON COMPO+8,'doCREATE',DoCREATE,_SLINK
\r
994 ; DW SWAP,DUPP,CELLPlus,SWAP,Fetch,QuestionDUP
\r
995 ; DW ZBranch,DOCREAT1
\r
999 $CODE COMPO+8,'doCREATE',DoCREATE,_SLINK
\r
1011 ; Run-time routine of TO. Store x at the address in the
\r
1012 ; following cell. The inline literal holds the address
\r
1015 $CODE COMPO+4,'doTO',DoTO,_SLINK
\r
1022 ; doUSER ( -- a-addr )
\r
1023 ; Run-time routine of USER. Return address of data space.
\r
1024 ; This is like doCONST but a variable offset is added to the
\r
1025 ; result. By changing the value at AddrUserP (which happens
\r
1026 ; on a taskswap) the whole set of user variables is switched
\r
1027 ; to the set for the new task.
\r
1029 $CODE COMPO+6,'doUSER',DoUSER,_SLINK
\r
1036 ; doLIST ( -- ) ( R: -- nest-sys )
\r
1037 ; Process colon list.
\r
1038 ; The first word of a definition (the xt for the word) is a
\r
1039 ; native machine-code instruction for the target machine. For
\r
1040 ; high-level definitions, that code is emitted by xt, and
\r
1041 ; performs a call to doLIST. doLIST executes the list of xt that
\r
1042 ; make up the definition. The final xt in the definition is EXIT.
\r
1043 ; The address of the first xt to be executed is passed to doLIST
\r
1044 ; in a target-specific way. Two examples:
\r
1045 ; Z80, 8086: native machine call, leaves the return address on
\r
1046 ; the hardware stack pointer, which is used for the data stack.
\r
1048 $CODE COMPO+6,'doLIST',DoLIST,_SLINK
\r
1050 MOV [BP],SI ;push return stack
\r
1051 POP SI ;new list address
\r
1054 ; doLOOP ( -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
1055 ; Run time routine for LOOP.
\r
1057 $CODE COMPO+6,'doLOOP',DoLOOP,_SLINK
\r
1058 INC WORD PTR [BP] ;increase loop count
\r
1059 JO DoLOOP1 ;?loop end
\r
1060 MOV SI,[SI] ;no, go back
\r
1062 DoLOOP1: ADD SI,CELLL ;yes, continue past the branch offset
\r
1063 ADD BP,2*CELLL ;clear return stack
\r
1066 ; do+LOOP ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
1067 ; Run time routine for +LOOP.
\r
1069 $CODE COMPO+7,'do+LOOP',DoPLOOP,_SLINK
\r
1070 ADD WORD PTR [BP],BX ;increase loop count
\r
1071 JO DoPLOOP1 ;?loop end
\r
1072 MOV SI,[SI] ;no, go back
\r
1075 DoPLOOP1: ADD SI,CELLL ;yes, continue past the branch offset
\r
1076 ADD BP,2*CELLL ;clear return stack
\r
1080 ; 0branch ( flag -- )
\r
1081 ; Branch if flag is zero.
\r
1083 $CODE COMPO+7,'0branch',ZBranch,_SLINK
\r
1085 JZ ZBRAN1 ;yes, so branch
\r
1086 ADD SI,CELLL ;point IP to next cell
\r
1089 ZBRAN1: MOV SI,[SI] ;IP:=(IP)
\r
1094 ; Branch to an inline address.
\r
1096 $CODE COMPO+6,'branch',Branch,_SLINK
\r
1097 MOV SI,[SI] ;IP:=(IP)
\r
1100 ; rp@ ( -- a-addr )
\r
1101 ; Push the current RP to the data stack.
\r
1103 $CODE COMPO+3,'rp@',RPFetch,_SLINK
\r
1108 ; rp! ( a-addr -- )
\r
1109 ; Set the return stack pointer.
\r
1111 $CODE COMPO+3,'rp!',RPStore,_SLINK
\r
1116 ; sp@ ( -- a-addr )
\r
1117 ; Push the current data stack pointer.
\r
1119 $CODE 3,'sp@',SPFetch,_SLINK
\r
1124 ; sp! ( a-addr -- )
\r
1125 ; Set the data stack pointer.
\r
1127 $CODE 3,'sp!',SPStore,_SLINK
\r
1132 ; um+ ( u1 u2 -- u3 1|0 )
\r
1133 ; Add two unsigned numbers, return the sum and carry.
\r
1135 $CODE 3,'um+',UMPlus,_SLINK
\r
1140 RCL CX,1 ;get carry
\r
1144 ; 1chars/ ( n1 -- n2 )
\r
1145 ; Calculate number of chars for n1 address units.
\r
1147 ; : 1chars/ 1 CHARS / ; \ slow, very portable
\r
1148 ; : 1chars/ ; \ fast, must be redefined for each system
\r
1150 $COLON 7,'1chars/',OneCharsSlash,_SLINK
\r
1154 ; Standard words - Processor-dependent definitions
\r
1155 ; 16 bit Forth for 8086/8
\r
1158 ; ALIGN ( -- ) \ CORE
\r
1159 ; Align the data space pointer.
\r
1161 ; : ALIGN HERE ALIGNED TO HERE ;
\r
1163 $COLON 5,'ALIGN',ALIGNN,_FLINK
\r
1164 DW HERE,ALIGNED,DoTO,AddrHERE,EXIT
\r
1166 ; ALIGNED ( addr -- a-addr ) \ CORE
\r
1167 ; Align address to the cell boundary.
\r
1169 ; : ALIGNED DUP 0 cell-size UM/MOD DROP DUP
\r
1170 ; IF cell-size SWAP - THEN + ; \ slow, very portable
\r
1172 ; $COLON 7,'ALIGNED',ALIGNED,_FLINK
\r
1173 ; DW DUPP,Zero,DoLIT,CELLL
\r
1174 ; DW UMSlashMOD,DROP,DUPP
\r
1175 ; DW ZBranch,ALGN1
\r
1176 ; DW DoLIT,CELLL,SWAP,Minus
\r
1177 ; ALGN1 DW Plus,EXIT
\r
1179 $CODE 7,'ALIGNED',ALIGNED,_FLINK
\r
1184 ; CELLS ( n1 -- n2 ) \ CORE
\r
1185 ; Calculate number of address units for n1 cells.
\r
1187 ; : CELLS cell-size * ; \ slow, very portable
\r
1188 ; : CELLS 2* ; \ fast, must be redefined for each system
\r
1190 $COLON 5,'CELLS',CELLS,_FLINK
\r
1193 ; CHARS ( n1 -- n2 ) \ CORE
\r
1194 ; Calculate number of address units for n1 characters.
\r
1196 ; : CHARS char-size * ; \ slow, very portable
\r
1197 ; : CHARS ; \ fast, must be redefined for each system
\r
1199 $COLON 5,'CHARS',CHARS,_FLINK
\r
1202 ; ! ( x a-addr -- ) \ CORE
\r
1203 ; Store x at a aligned address.
\r
1205 $CODE 1,'!',Store,_FLINK
\r
1210 ; 0< ( n -- flag ) \ CORE
\r
1211 ; Return true if n is negative.
\r
1213 $CODE 2,'0<',ZeroLess,_FLINK
\r
1219 ; 0= ( x -- flag ) \ CORE
\r
1220 ; Return true if x is zero.
\r
1222 $CODE 2,'0=',ZeroEquals,_FLINK
\r
1229 ; 2* ( x1 -- x2 ) \ CORE
\r
1230 ; Bit-shift left, filling the least significant bit with 0.
\r
1232 $CODE 2,'2*',TwoStar,_FLINK
\r
1236 ; 2/ ( x1 -- x2 ) \ CORE
\r
1237 ; Bit-shift right, leaving the most significant bit unchanged.
\r
1239 $CODE 2,'2/',TwoSlash,_FLINK
\r
1243 ; >R ( x -- ) ( R: -- x ) \ CORE
\r
1244 ; Move top of the data stack item to the return stack.
\r
1246 $CODE COMPO+2,'>R',ToR,_FLINK
\r
1247 SUB BP,CELLL ;adjust RP
\r
1252 ; @ ( a-addr -- x ) \ CORE
\r
1253 ; Push the contents at a-addr to the data stack.
\r
1255 $CODE 1,'@',Fetch,_FLINK
\r
1259 ; AND ( x1 x2 -- x3 ) \ CORE
\r
1262 $CODE 3,'AND',ANDD,_FLINK
\r
1267 ; C! ( char c-addr -- ) \ CORE
\r
1268 ; Store char at c-addr.
\r
1270 $CODE 2,'C!',CStore,_FLINK
\r
1276 ; C@ ( c-addr -- char ) \ CORE
\r
1277 ; Fetch the character stored at c-addr.
\r
1279 $CODE 2,'C@',CFetch,_FLINK
\r
1284 ; DROP ( x -- ) \ CORE
\r
1285 ; Discard top stack item.
\r
1287 $CODE 4,'DROP',DROP,_FLINK
\r
1291 ; DUP ( x -- x x ) \ CORE
\r
1292 ; Duplicate the top stack item.
\r
1294 $CODE 3,'DUP',DUPP,_FLINK
\r
1298 ; EXECUTE ( i*x xt -- j*x ) \ CORE
\r
1299 ; Perform the semantics indentified by execution token, xt.
\r
1301 $CODE 7,'EXECUTE',EXECUTE,_FLINK
\r
1304 JMP AX ;jump to the code address
\r
1307 ; EXIT ( -- ) ( R: nest-sys -- ) \ CORE
\r
1308 ; Return control to the calling definition.
\r
1310 $CODE COMPO+4,'EXIT',EXIT,_FLINK
\r
1311 XCHG BP,SP ;exchange pointers
\r
1312 POP SI ;pop return stack
\r
1313 XCHG BP,SP ;restore the pointers
\r
1316 ; MOVE ( addr1 addr2 u -- ) \ CORE
\r
1317 ; Copy u address units from addr1 to addr2 if u is greater
\r
1318 ; than zero. This word is CODE defined since no other Standard
\r
1319 ; words can handle address unit directly.
\r
1321 $CODE 4,'MOVE',MOVE,_FLINK
\r
1327 XCHG DX,SI ;save SI
\r
1329 MOV ES,AX ;set ES same as DS
\r
1347 ; OR ( x1 x2 -- x3 ) \ CORE
\r
1348 ; Return bitwise inclusive-or of x1 with x2.
\r
1350 $CODE 2,'OR',ORR,_FLINK
\r
1355 ; OVER ( x1 x2 -- x1 x2 x1 ) \ CORE
\r
1356 ; Copy second stack item to top of the stack.
\r
1358 $CODE 4,'OVER',OVER,_FLINK
\r
1364 ; R> ( -- x ) ( R: x -- ) \ CORE
\r
1365 ; Move x from the return stack to the data stack.
\r
1367 $CODE COMPO+2,'R>',RFrom,_FLINK
\r
1370 ADD BP,CELLL ;adjust RP
\r
1373 ; R@ ( -- x ) ( R: x -- x ) \ CORE
\r
1374 ; Copy top of return stack to the data stack.
\r
1376 $CODE COMPO+2,'R@',RFetch,_FLINK
\r
1381 ; SWAP ( x1 x2 -- x2 x1 ) \ CORE
\r
1382 ; Exchange top two stack items.
\r
1384 $CODE 4,'SWAP',SWAP,_FLINK
\r
1389 ; XOR ( x1 x2 -- x3 ) \ CORE
\r
1390 ; Bitwise exclusive OR.
\r
1392 $CODE 3,'XOR',XORR,_FLINK
\r
1398 ; System constants and variables
\r
1401 ; #order0 ( -- a-addr )
\r
1402 ; Start address of default search order.
\r
1404 $CONST 7,'#order0',NumberOrder0,AddrNumberOrder0,_SLINK
\r
1406 ; 'ekey? ( -- a-addr )
\r
1407 ; Execution vector of EKEY?.
\r
1409 $VALUE 6,"'ekey?",TickEKEYQ,ValueTickEKEYQ,_SLINK
\r
1411 ; 'ekey ( -- a-addr )
\r
1412 ; Execution vector of EKEY.
\r
1414 $VALUE 5,"'ekey",TickEKEY,ValueTickEKEY,_SLINK
\r
1416 ; 'emit? ( -- a-addr )
\r
1417 ; Execution vector of EMIT?.
\r
1419 $VALUE 6,"'emit?",TickEMITQ,ValueTickEMITQ,_SLINK
\r
1421 ; 'emit ( -- a-addr )
\r
1422 ; Execution vector of EMIT.
\r
1424 $VALUE 5,"'emit",TickEMIT,ValueTickEMIT,_SLINK
\r
1426 ; 'init-i/o ( -- a-addr )
\r
1427 ; Execution vector to initialize input/output devices.
\r
1429 $VALUE 9,"'init-i/o",TickINIT_IO,ValueTickINIT_IO,_SLINK
\r
1431 ; 'prompt ( -- a-addr )
\r
1432 ; Execution vector of '.prompt'.
\r
1434 $VALUE 7,"'prompt",TickPrompt,ValueTickPrompt,_SLINK
\r
1436 ; 'boot ( -- a-addr )
\r
1437 ; Execution vector of COLD.
\r
1439 $VALUE 5,"'boot",TickBoot,ValueTickBoot,_SLINK
\r
1441 ; SOURCE-ID ( -- 0 | -1 ) \ CORE EXT
\r
1442 ; Identify the input source. -1 for string (via EVALUATE) and
\r
1443 ; 0 for user input device.
\r
1445 $VALUE 9,'SOURCE-ID',SOURCE_ID,ValueSOURCE_ID,_FLINK
\r
1446 AddrSOURCE_ID EQU $-CELLL
\r
1448 ; HERE ( -- addr ) \ CORE
\r
1449 ; Return data space pointer.
\r
1451 $VALUE 4,'HERE',HERE,ValueHERE,_FLINK
\r
1452 AddrHERE EQU $-CELLL
\r
1454 ; 'doWord ( -- a-addr )
\r
1455 ; Execution vectors for 'interpret'.
\r
1457 $CONST 7,"'doWord",TickDoWord,AddrTickDoWord,_SLINK
\r
1459 ; BASE ( -- a-addr ) \ CORE
\r
1460 ; Return the address of the radix base for numeric I/O.
\r
1462 $CONST 4,'BASE',BASE,AddrBASE,_FLINK
\r
1464 ; THROWMsgTbl ( -- a-addr ) \ CORE
\r
1465 ; Return the address of the THROW message table.
\r
1467 $CONST 11,'THROWMsgTbl',THROWMsgTbl,AddrTHROWMsgTbl,_SLINK
\r
1469 ; memTop ( -- a-addr )
\r
1470 ; Top of free RAM area.
\r
1472 $VALUE 6,'memTop',MemTop,?,_SLINK
\r
1473 AddrMemTop EQU $-CELLL
\r
1476 ; Return the depth of control-flow stack.
\r
1478 $VALUE 3,'bal',Bal,?,_SLINK
\r
1479 AddrBal EQU $-CELLL
\r
1481 ; notNONAME? ( -- f )
\r
1482 ; Used by ';' whether to do 'linkLast' or not
\r
1484 $VALUE 10,'notNONAME?',NotNONAMEQ,?,_SLINK
\r
1485 AddrNotNONAMEQ EQU $-CELLL
\r
1487 ; rakeVar ( -- a-addr )
\r
1488 ; Used by 'rake' to gather LEAVE.
\r
1490 $CONST 7,'rakeVar',RakeVar,AddrRakeVar,_SLINK
\r
1492 ; #order ( -- a-addr )
\r
1493 ; Hold the search order stack depth.
\r
1495 $CONST 6,'#order',NumberOrder,AddrNumberOrder,_SLINK
\r
1497 ; current ( -- a-addr )
\r
1498 ; Point to the wordlist to be extended.
\r
1500 $CONST 7,'current',Current,AddrCurrent,_SLINK
\r
1502 ; FORTH-WORDLIST ( -- wid ) \ SEARCH
\r
1503 ; Return wid of Forth wordlist.
\r
1505 $CONST 14,'FORTH-WORDLIST',FORTH_WORDLIST,AddrFORTH_WORDLIST,_FLINK
\r
1506 FORTH_WORDLISTName EQU _NAME-0
\r
1508 ; NONSTANDARD-WORDLIST ( -- wid )
\r
1509 ; Return wid of non-standard wordlist.
\r
1511 $CONST 20,'NONSTANDARD-WORDLIST',NONSTANDARD_WORDLIST,AddrNONSTANDARD_WORDLIST,_FLINK
\r
1512 NONSTANDARD_WORDLISTName EQU _NAME-0
\r
1514 ; envQList ( -- wid )
\r
1515 ; Return wid of ENVIRONMENT? string list. Never put this wid in
\r
1516 ; search-order. It should be used only by SET-CURRENT to add new
\r
1517 ; environment query string after addition of a complete wordset.
\r
1519 $CONST 8,'envQList',EnvQList,AddrEnvQList,_SLINK
\r
1521 ; userP ( -- a-addr )
\r
1522 ; Return address of USER variable area of current task.
\r
1524 $CONST 5,'userP',UserP,AddrUserP,_SLINK
\r
1526 ; SystemTask ( -- a-addr )
\r
1527 ; Return system task's tid.
\r
1529 $CONST 10,'SystemTask',SystemTask,SysTask,_SLINK
\r
1530 SystemTaskName EQU _NAME-0
\r
1532 ; follower ( -- a-addr )
\r
1533 ; Point next task's 'status' USER variable.
\r
1535 $USER 8,'follower',Follower,SysFollower-SysUserP,_SLINK
\r
1537 ; status ( -- a-addr )
\r
1538 ; Status of current task. Point 'pass' or 'wake'.
\r
1540 $USER 6,'status',Status,SysStatus-SysUserP,_SLINK
\r
1542 ; stackTop ( -- a-addr )
\r
1543 ; Store current task's top of stack position.
\r
1545 $USER 8,'stackTop',StackTop,SysStackTop-SysUserP,_SLINK
\r
1547 ; throwFrame ( -- a-addr )
\r
1548 ; THROW frame for CATCH and THROW need to be saved for eack task.
\r
1550 $USER 10,'throwFrame',ThrowFrame,SysThrowFrame-SysUserP,_SLINK
\r
1552 ; taskName ( -- a-addr )
\r
1553 ; Current task's task ID.
\r
1555 $USER 8,'taskName',TaskName,SysTaskName-SysUserP,_SLINK
\r
1557 ; user1 ( -- a-addr )
\r
1558 ; One free USER variable for each task.
\r
1560 $USER 5,'user1',User1,SysUser1-SysUserP,_SLINK
\r
1562 ; ENVIRONMENT? strings can be searched using SEARCH-WORDLIST and can be
\r
1563 ; EXECUTEd. This wordlist is completely hidden to Forth system except
\r
1567 DW DoLIT,CPUStr,COUNT,EXIT
\r
1570 DW DoLIT,ModelStr,COUNT,EXIT
\r
1572 $ENVIR 7,'version'
\r
1573 DW DoLIT,VersionStr,COUNT,EXIT
\r
1575 $ENVIR 15,'/COUNTED-STRING'
\r
1576 DW DoLIT,MaxChar,EXIT
\r
1579 DW DoLIT,PADSize,EXIT
\r
1582 DW DoLIT,PADSize,EXIT
\r
1584 $ENVIR 17,'ADDRESS-UNIT-BITS'
\r
1588 DW DoLIT,TRUEE,EXIT
\r
1590 $ENVIR 7,'FLOORED'
\r
1591 DW DoLIT,TRUEE,EXIT
\r
1593 $ENVIR 8,'MAX-CHAR'
\r
1594 DW DoLIT,MaxChar,EXIT ;max value of character set
\r
1597 DW DoLIT,MaxUnsigned,DoLIT,MaxSigned,EXIT
\r
1600 DW DoLIT,MaxSigned,EXIT
\r
1603 DW DoLIT,MaxUnsigned,EXIT
\r
1606 DW DoLIT,MaxUnsigned,DoLIT,MaxUnsigned,EXIT
\r
1608 $ENVIR 18,'RETURN-STACK-CELLS'
\r
1609 DW DoLIT,RTCells,EXIT
\r
1611 $ENVIR 11,'STACK-CELLS'
\r
1612 DW DoLIT,DTCells,EXIT
\r
1614 $ENVIR 9,'EXCEPTION'
\r
1615 DW DoLIT,TRUEE,EXIT
\r
1617 $ENVIR 13,'EXCEPTION-EXT'
\r
1618 DW DoLIT,TRUEE,EXIT
\r
1620 $ENVIR 9,'WORDLISTS'
\r
1621 DW DoLIT,OrderDepth,EXIT
\r
1624 ; Non-Standard words - Colon definitions
\r
1627 ; (') ( "<spaces>name" -- xt 1 | xt -1 )
\r
1628 ; Parse a name, find it and return execution token and
\r
1629 ; -1 or 1 ( IMMEDIATE) if found
\r
1631 ; : (') PARSE-WORD search-word ?DUP IF NIP EXIT THEN
\r
1632 ; errWord 2! \ if not found error
\r
1633 ; -13 THROW ; \ undefined word
\r
1635 $COLON 3,"(')",ParenTick,_SLINK
\r
1636 DW PARSE_WORD,Search_word,QuestionDUP,ZBranch,PTICK1
\r
1638 PTICK1 DW ErrWord,TwoStore,DoLIT,-13,THROW
\r
1640 ; (d.) ( d -- c-addr u )
\r
1641 ; Convert a double number to a string.
\r
1643 ; : (d.) SWAP OVER DUP 0< IF DNEGATE THEN
\r
1644 ; <# #S ROT SIGN #> ;
\r
1646 $COLON 4,'(d.)',ParenDDot,_SLINK
\r
1647 DW SWAP,OVER,DUPP,ZeroLess,ZBranch,PARDD1
\r
1649 PARDD1 DW LessNumberSign,NumberSignS,ROT
\r
1650 DW SIGN,NumberSignGreater,EXIT
\r
1657 $COLON 3,'.ok',DotOK,_SLINK
\r
1662 ; Disply Forth prompt. This word is vectored.
\r
1664 ; : .prompt 'prompt EXECUTE ;
\r
1666 $COLON 7,'.prompt',DotPrompt,_SLINK
\r
1667 DW TickPrompt,EXECUTE,EXIT
\r
1672 $CONST 1,'0',Zero,0,_SLINK
\r
1677 $CONST 1,'1',One,1,_SLINK
\r
1682 $CONST 2,'-1',MinusOne,-1,_SLINK
\r
1684 ; abort"msg ( -- a-addr )
\r
1685 ; Abort" error message string address.
\r
1687 $VAR 9,'abort"msg',AbortQMsg,2,_SLINK
\r
1690 ; Increase bal by 1.
\r
1692 ; : bal+ bal 1+ TO bal ;
\r
1694 $COLON 4,'bal+',BalPlus,_SLINK
\r
1695 DW Bal,OnePlus,DoTO,AddrBal,EXIT
\r
1698 ; Decrease bal by 1.
\r
1700 ; : bal- bal 1- TO bal ;
\r
1702 $COLON 4,'bal-',BalMinus,_SLINK
\r
1703 DW Bal,OneMinus,DoTO,AddrBal,EXIT
\r
1705 ; cell- ( a-addr1 -- a-addr2 )
\r
1706 ; Return previous aligned cell address.
\r
1708 ; : cell- -(cell-size) + ;
\r
1710 $COLON 5,'cell-',CellMinus,_SLINK
\r
1711 DW DoLIT,0-CELLL,Plus,EXIT
\r
1713 ; COMPILE-ONLY ( -- )
\r
1714 ; Make the most recent definition an compile-only word.
\r
1716 ; : COMPILE-ONLY lastName [ =comp ] LITERAL OVER @ OR SWAP ! ;
\r
1718 $COLON 12,'COMPILE-ONLY',COMPILE_ONLY,_SLINK
\r
1719 DW LastName,DoLIT,COMPO,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
1721 ; doS" ( u -- c-addr u )
\r
1722 ; Run-time function of S" .
\r
1724 ; : doS" R> SWAP 2DUP + ALIGNED >R ; COMPILE-ONLY
\r
1726 $COLON COMPO+4,'doS"',DoSQuote,_SLINK
\r
1727 DW RFrom,SWAP,TwoDUP,Plus,ALIGNED,ToR,EXIT
\r
1729 ; doDO ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )
\r
1730 ; Run-time funtion of DO.
\r
1732 ; : doDO >R max-negative + R> OVER - SWAP R> SWAP >R SWAP >R >R ;
\r
1734 $COLON COMPO+4,'doDO',DoDO,_SLINK
\r
1735 DW ToR,DoLIT,MaxNegative,Plus,RFrom
\r
1736 DW OVER,Minus,SWAP,RFrom,SWAP,ToR,SWAP,ToR,ToR,EXIT
\r
1738 ; errWord ( -- a-addr )
\r
1739 ; Last found word. To be used to display the word causing error.
\r
1741 $VAR 7,'errWord',ErrWord,2,_SLINK
\r
1743 ; head, ( "<spaces>name" -- )
\r
1744 ; Parse a word and build a dictionary entry using a name.
\r
1746 ; : head, PARSE-WORD DUP 0=
\r
1747 ; IF errWord 2! -16 THROW THEN
\r
1748 ; \ attempt to use zero-length string as a name
\r
1749 ; DUP =mask > IF -19 THROW THEN \ definition name too long
\r
1750 ; 2DUP GET-CURRENT SEARCH-WORDLIST \ name exist?
\r
1751 ; IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined
\r
1752 ; HERE ALIGNED TO HERE \ align
\r
1753 ; GET-CURRENT @ , \ build wordlist link
\r
1754 ; HERE DUP >R pack" TO HERE R> \ pack the name in dictionary
\r
1755 ; DUP , TO lastName ;
\r
1757 $COLON 5,'head,',HeadComma,_SLINK
\r
1758 DW PARSE_WORD,DUPP,ZBranch,HEADC1
\r
1759 DW DUPP,DoLIT,MASKK,GreaterThan,ZBranch,HEADC3
\r
1760 DW DoLIT,-19,THROW
\r
1761 HEADC3 DW TwoDUP,GET_CURRENT,SEARCH_WORDLIST,ZBranch,HEADC2
\r
1763 $INSTR 'redefine '
\r
1764 DW TYPEE,TwoDUP,TYPEE,SPACE
\r
1765 HEADC2 DW HERE,ALIGNED,DoTO,AddrHERE
\r
1766 DW GET_CURRENT,Fetch,Comma
\r
1767 DW HERE,DUPP,ToR,PackQuote,DoTO,AddrHERE,RFrom
\r
1768 DW DUPP,Comma,DoTO,AddrLastName,EXIT
\r
1769 HEADC1 DW ErrWord,TwoStore,DoLIT,-16,THROW
\r
1771 ; hld ( -- a-addr )
\r
1772 ; Hold a pointer in building a numeric output string.
\r
1774 $VAR 3,'hld',HLD,1,_SLINK
\r
1776 ; interpret ( i*x -- j*x )
\r
1777 ; Intrepret input string.
\r
1779 ; : interpret BEGIN DEPTH 0< IF -4 THROW THEN \ stack underflow
\r
1781 ; WHILE 2DUP errWord 2!
\r
1782 ; search-word \ ca u 0 | xt f -1 | xt f 1
\r
1784 ; SWAP STATE @ OR 0= \ compile-only in interpretation
\r
1785 ; IF -14 THROW THEN \ interpreting a compile-only word
\r
1787 ; 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE
\r
1790 $COLON 9,'interpret',Interpret,_SLINK
\r
1791 INTERP1 DW DEPTH,ZeroLess,ZBranch,INTERP2
\r
1793 INTERP2 DW PARSE_WORD,DUPP,ZBranch,INTERP3
\r
1794 DW TwoDUP,ErrWord,TwoStore
\r
1795 DW Search_word,DUPP,ZBranch,INTERP5
\r
1796 DW SWAP,STATE,Fetch,ORR,ZBranch,INTERP4
\r
1797 INTERP5 DW OnePlus,TwoStar,STATE,Fetch,OnePlus,Plus,CELLS
\r
1798 DW TickDoWord,Plus,Fetch,EXECUTE
\r
1800 INTERP3 DW TwoDROP,EXIT
\r
1801 INTERP4 DW DoLIT,-14,THROW
\r
1803 ; optiCOMPILE, ( xt -- )
\r
1804 ; Optimized COMPILE, . Reduce doLIST ... EXIT sequence if
\r
1805 ; xt is COLON definition which contains less than two words.
\r
1808 ; DUP ?call ['] doLIST = IF
\r
1809 ; DUP @ ['] EXIT = IF \ if first word is EXIT
\r
1811 ; DUP CELL+ @ ['] EXIT = IF \ if second word is EXIT
\r
1812 ; @ DUP ['] doLIT XOR \ make sure it is not literal value
\r
1813 ; IF SWAP THEN THEN
\r
1814 ; THEN THEN DROP COMPILE, ;
\r
1816 $COLON 12,'optiCOMPILE,',OptiCOMPILEComma,_SLINK
\r
1817 DW DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2
\r
1818 DW DUPP,Fetch,DoLIT,EXIT,Equals,ZBranch,OPTC1
\r
1820 OPTC1 DW DUPP,CELLPlus,Fetch,DoLIT,EXIT,Equals,ZBranch,OPTC2
\r
1821 DW Fetch,DUPP,DoLIT,DoLIT,XORR,ZBranch,OPTC2
\r
1823 OPTC2 DW DROP,COMPILEComma,EXIT
\r
1825 ; singleOnly ( c-addr u -- x )
\r
1826 ; Handle the word not found in the search-order. If the string
\r
1827 ; is legal, leave a single cell number in interpretation state.
\r
1830 ; 0 DUP 2SWAP OVER C@ [CHAR] -
\r
1831 ; = DUP >R IF 1 /STRING THEN
\r
1832 ; >NUMBER IF -13 THROW THEN \ undefined word
\r
1833 ; 2DROP R> IF NEGATE THEN ;
\r
1835 $COLON 10,'singleOnly',SingleOnly,_SLINK
\r
1836 DW Zero,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\r
1837 DW Equals,DUPP,ToR,ZBranch,SINGLEO4
\r
1838 DW One,SlashSTRING
\r
1839 SINGLEO4 DW ToNUMBER,ZBranch,SINGLEO1
\r
1840 DW DoLIT,-13,THROW
\r
1841 SINGLEO1 DW TwoDROP,RFrom,ZBranch,SINGLEO2
\r
1845 ; singleOnly, ( c-addr u -- )
\r
1846 ; Handle the word not found in the search-order. Compile a
\r
1847 ; single cell number in compilation state.
\r
1850 ; singleOnly LITERAL ;
\r
1852 $COLON 11,'singleOnly,',SingleOnlyComma,_SLINK
\r
1853 DW SingleOnly,LITERAL,EXIT
\r
1855 ; (doubleAlso) ( c-addr u -- x 1 | x x 2 )
\r
1856 ; If the string is legal, leave a single or double cell number
\r
1857 ; and size of the number.
\r
1860 ; 0 DUP 2SWAP OVER C@ [CHAR] -
\r
1861 ; = DUP >R IF 1 /STRING THEN
\r
1863 ; IF 1- IF -13 THROW THEN \ more than one char is remained
\r
1864 ; DUP C@ [CHAR] . XOR \ last char is not '.'
\r
1865 ; IF -13 THROW THEN \ undefined word
\r
1866 ; R> IF DNEGATE THEN
\r
1868 ; 2DROP R> IF NEGATE THEN \ single number
\r
1871 $COLON 12,'(doubleAlso)',ParenDoubleAlso,_SLINK
\r
1872 DW Zero,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\r
1873 DW Equals,DUPP,ToR,ZBranch,DOUBLEA1
\r
1874 DW One,SlashSTRING
\r
1875 DOUBLEA1 DW ToNUMBER,QuestionDUP,ZBranch,DOUBLEA4
\r
1876 DW OneMinus,ZBranch,DOUBLEA3
\r
1877 DOUBLEA2 DW DoLIT,-13,THROW
\r
1878 DOUBLEA3 DW CFetch,DoLIT,'.',Equals,ZBranch,DOUBLEA2
\r
1879 DW RFrom,ZBranch,DOUBLEA5
\r
1881 DOUBLEA5 DW DoLIT,2,EXIT
\r
1882 DOUBLEA4 DW TwoDROP,RFrom,ZBranch,DOUBLEA6
\r
1884 DOUBLEA6 DW One,EXIT
\r
1886 ; doubleAlso ( c-addr u -- x | x x )
\r
1887 ; Handle the word not found in the search-order. If the string
\r
1888 ; is legal, leave a single or double cell number in
\r
1889 ; interpretation state.
\r
1892 ; (doubleAlso) DROP ;
\r
1894 $COLON 10,'doubleAlso',DoubleAlso,_SLINK
\r
1895 DW ParenDoubleAlso,DROP,EXIT
\r
1897 ; doubleAlso, ( c-addr u -- )
\r
1898 ; Handle the word not found in the search-order. If the string
\r
1899 ; is legal, compile a single or double cell number in
\r
1900 ; compilation state.
\r
1903 ; (doubleAlso) 1- IF SWAP LITERAL THEN LITERAL ;
\r
1905 $COLON 11,'doubleAlso,',DoubleAlsoComma,_SLINK
\r
1906 DW ParenDoubleAlso,OneMinus,ZBranch,DOUBC1
\r
1908 DOUBC1 DW LITERAL,EXIT
\r
1911 ; You don't need this word unless you care that '-.' returns
\r
1912 ; double cell number 0. Catching illegal number '-.' in this way
\r
1913 ; is easier than make 'interpret' catch this exception.
\r
1915 ; : -. -13 THROW ; IMMEDIATE \ undefined word
\r
1917 $COLON IMMED+2,'-.',MinusDot,_SLINK
\r
1918 DW DoLIT,-13,THROW
\r
1920 ; lastName ( -- c-addr )
\r
1921 ; Return the address of the last definition name.
\r
1923 $VALUE 8,'lastName',LastName,?,_SLINK
\r
1924 AddrLastName EQU $-CELLL
\r
1927 ; Link the word being defined to the current wordlist.
\r
1928 ; Do nothing if the last definition is made by :NONAME .
\r
1930 ; : linkLast lastName GET-CURRENT ! ;
\r
1932 $COLON 8,'linkLast',LinkLast,_SLINK
\r
1933 DW LastName,GET_CURRENT,Store,EXIT
\r
1935 ; name>xt ( c-addr -- xt )
\r
1936 ; Return execution token using counted string at c-addr.
\r
1938 ; : name>xt COUNT [ =MASK ] LITERAL AND + ALIGNED CELL+ ;
\r
1940 $COLON 7,'name>xt',NameToXT,_SLINK
\r
1941 DW COUNT,DoLIT,MASKK,ANDD,Plus,ALIGNED,CELLPlus,EXIT
\r
1943 ; pack" ( c-addr u a-addr -- a-addr2 )
\r
1944 ; Place a string c-addr u at a-addr and gives the next
\r
1945 ; cell-aligned address. Fill the rest of the last cell with
\r
1948 ; : pack" 2DUP SWAP CHARS + CHAR+ DUP >R \ ca u aa aa+u+1
\r
1949 ; ALIGNED cell- 0 SWAP ! \ fill 0 at the end of string
\r
1950 ; 2DUP C! CHAR+ SWAP \ c-addr a-addr+1 u
\r
1951 ; CHARS MOVE R> ALIGNED ; COMPILE-ONLY
\r
1953 $COLON 5,'pack"',PackQuote,_SLINK
\r
1954 DW TwoDUP,SWAP,CHARS,Plus,CHARPlus,DUPP,ToR
\r
1955 DW ALIGNED,CellMinus,Zero,SWAP,Store
\r
1956 DW TwoDUP,CStore,CHARPlus,SWAP
\r
1957 DW CHARS,MOVE,RFrom,ALIGNED,EXIT
\r
1959 ; PARSE-WORD ( "<spaces>ccc<space>" -- c-addr u )
\r
1960 ; Skip leading spaces and parse a word. Return the name.
\r
1962 ; : PARSE-WORD BL skipPARSE ;
\r
1964 $COLON 10,'PARSE-WORD',PARSE_WORD,_SLINK
\r
1965 DW BLank,SkipPARSE,EXIT
\r
1967 ; pipe ( -- ) ( R: xt -- )
\r
1968 ; Connect most recently defined word to code following DOES>.
\r
1969 ; Structure of CREATEd word:
\r
1970 ; | call-doCREATE | 0 or DOES> code addr | >BODY points here
\r
1972 ; : pipe lastName name>xt ?call DUP IF \ code-addr xt2
\r
1973 ; ['] doCREATE = IF
\r
1974 ; R> SWAP ! \ change DOES> code of CREATEd word
\r
1977 ; -32 THROW \ invalid name argument, no-CREATEd last name
\r
1980 $COLON COMPO+4,'pipe',Pipe,_SLINK
\r
1981 DW LastName,NameToXT,QCall,DUPP,ZBranch,PIPE1
\r
1982 DW DoLIT,DoCREATE,Equals,ZBranch,PIPE1
\r
1983 DW RFrom,SWAP,Store,EXIT
\r
1984 PIPE1 DW DoLIT,-32,THROW
\r
1986 ; skipPARSE ( char "<chars>ccc<char>" -- c-addr u )
\r
1987 ; Skip leading chars and parse a word using char as a
\r
1988 ; delimeter. Return the name.
\r
1991 ; >R SOURCE >IN @ /STRING \ c_addr u R: char
\r
1993 ; BEGIN OVER C@ R@ =
\r
1994 ; WHILE 1- SWAP CHAR+ SWAP DUP 0=
\r
1995 ; UNTIL R> DROP EXIT
\r
1997 ; DROP SOURCE DROP - 1chars/ >IN ! R> PARSE EXIT
\r
2000 $COLON 9,'skipPARSE',SkipPARSE,_SLINK
\r
2001 DW ToR,SOURCE,ToIN,Fetch,SlashSTRING
\r
2002 DW DUPP,ZBranch,SKPAR1
\r
2003 SKPAR2 DW OVER,CFetch,RFetch,Equals,ZBranch,SKPAR3
\r
2004 DW OneMinus,SWAP,CHARPlus,SWAP
\r
2005 DW DUPP,ZeroEquals,ZBranch,SKPAR2
\r
2006 DW RFrom,DROP,EXIT
\r
2007 SKPAR3 DW DROP,SOURCE,DROP,Minus,OneCharsSlash
\r
2008 DW ToIN,Store,RFrom,PARSE,EXIT
\r
2009 SKPAR1 DW RFrom,DROP,EXIT
\r
2011 ; rake ( C: do-sys -- )
\r
2014 ; : rake DUP , rakeVar @
\r
2016 ; WHILE DUP @ HERE ROT !
\r
2017 ; REPEAT rakeVar ! DROP
\r
2018 ; ?DUP IF \ check for ?DO
\r
2019 ; 1 bal+ POSTPONE THEN \ orig type is 1
\r
2020 ; THEN bal- ; COMPILE-ONLY
\r
2022 $COLON COMPO+4,'rake',rake,_SLINK
\r
2023 DW DUPP,Comma,RakeVar,Fetch
\r
2024 RAKE1 DW TwoDUP,ULess,ZBranch,RAKE2
\r
2025 DW DUPP,Fetch,HERE,ROT,Store,Branch,RAKE1
\r
2026 RAKE2 DW RakeVar,Store,DROP
\r
2027 DW QuestionDUP,ZBranch,RAKE3
\r
2028 DW One,BalPlus,THENN
\r
2029 RAKE3 DW BalMinus,EXIT
\r
2031 ; rp0 ( -- a-addr )
\r
2032 ; Pointer to bottom of the return stack.
\r
2034 ; : rp0 userP @ CELL+ CELL+ @ ;
\r
2036 $COLON 3,'rp0',RPZero,_SLINK
\r
2037 DW UserP,Fetch,CELLPlus,CELLPlus,Fetch,EXIT
\r
2039 ; search-word ( c-addr u -- c-addr u 0 | xt f 1 | xt f -1)
\r
2040 ; Search dictionary for a match with the given name. Return
\r
2041 ; execution token, not-compile-only flag and -1 or 1
\r
2042 ; ( IMMEDIATE) if found; c-addr u 0 if not.
\r
2045 ; #order @ DUP \ not found if #order is 0
\r
2047 ; DO 2DUP \ ca u ca u
\r
2048 ; I CELLS #order CELL+ + @ \ ca u ca u wid
\r
2049 ; (search-wordlist) \ ca u; 0 | w f 1 | w f -1
\r
2050 ; ?DUP IF \ ca u; 0 | w f 1 | w f -1
\r
2051 ; >R 2SWAP 2DROP R> UNLOOP EXIT \ xt f 1 | xt f -1
\r
2056 $COLON 11,'search-word',Search_word,_SLINK
\r
2057 DW NumberOrder,Fetch,DUPP,ZBranch,SEARCH1
\r
2059 SEARCH2 DW TwoDUP,I,CELLS,NumberOrder,CELLPlus,Plus,Fetch
\r
2060 DW ParenSearch_Wordlist,QuestionDUP,ZBranch,SEARCH3
\r
2061 DW ToR,TwoSWAP,TwoDROP,RFrom,UNLOOP,EXIT
\r
2062 SEARCH3 DW DoLOOP,SEARCH2
\r
2066 ; sourceVar ( -- a-addr )
\r
2067 ; Hold the current count and address of the terminal input buffer.
\r
2069 $VAR 9,'sourceVar',SourceVar,2,_SLINK
\r
2071 ; sp0 ( -- a-addr )
\r
2072 ; Pointer to bottom of the data stack.
\r
2074 ; : sp0 userP @ CELL+ @ ;
\r
2076 $COLON 3,'sp0',SPZero,_SLINK
\r
2077 DW UserP,Fetch,CELLPlus,Fetch,EXIT
\r
2080 ; Words for multitasking
\r
2084 ; Stop current task and transfer control to the task of which
\r
2085 ; 'status' USER variable is stored in 'follower' USER variable
\r
2086 ; of current task.
\r
2088 ; : PAUSE rp@ sp@ stackTop ! follower @ >R ; COMPILE-ONLY
\r
2090 $COLON COMPO+5,'PAUSE',PAUSE,_SLINK
\r
2091 DW RPFetch,SPFetch,StackTop,Store,Follower,Fetch,ToR,EXIT
\r
2094 ; Wake current task.
\r
2096 ; : wake R> userP ! \ userP points 'follower' of current task
\r
2097 ; stackTop @ sp! \ set data stack
\r
2098 ; rp! ; COMPILE-ONLY \ set return stack
\r
2100 $COLON COMPO+4,'wake',Wake,_SLINK
\r
2101 DW RFrom,UserP,Store,StackTop,Fetch,SPStore,RPStore,EXIT
\r
2104 ; Essential Standard words - Colon definitions
\r
2107 ; # ( ud1 -- ud2 ) \ CORE
\r
2108 ; Extract one digit from ud1 and append the digit to
\r
2109 ; pictured numeric output string. ( ud2 = ud1 / BASE )
\r
2111 ; : # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP
\r
2112 ; 9 OVER < [ CHAR A CHAR 9 1 + - ] LITERAL AND +
\r
2113 ; [ CHAR 0 ] LITERAL + HOLD R> ;
\r
2115 $COLON 1,'#',NumberSign,_FLINK
\r
2116 DW Zero,BASE,Fetch,UMSlashMOD,ToR,BASE,Fetch,UMSlashMOD
\r
2117 DW SWAP,DoLIT,9,OVER,LessThan,DoLIT,'A'-'9'-1,ANDD,Plus
\r
2118 DW DoLIT,'0',Plus,HOLD,RFrom,EXIT
\r
2120 ; #> ( xd -- c-addr u ) \ CORE
\r
2121 ; Prepare the output string to be TYPE'd.
\r
2122 ; ||HERE>WORD/#-work-area|
\r
2124 ; : #> 2DROP hld @ HERE size-of-PAD + OVER - 1chars/ ;
\r
2126 $COLON 2,'#>',NumberSignGreater,_FLINK
\r
2127 DW TwoDROP,HLD,Fetch,HERE,DoLIT,PADSize*CHARR,Plus
\r
2128 DW OVER,Minus,OneCharsSlash,EXIT
\r
2130 ; #S ( ud -- 0 0 ) \ CORE
\r
2131 ; Convert ud until all digits are added to the output string.
\r
2133 ; : #S BEGIN # 2DUP OR 0= UNTIL ;
\r
2135 $COLON 2,'#S',NumberSignS,_FLINK
\r
2136 NUMSS1 DW NumberSign,TwoDUP,ORR
\r
2137 DW ZeroEquals,ZBranch,NUMSS1
\r
2140 ; ' ( "<spaces>name" -- xt ) \ CORE
\r
2141 ; Parse a name, find it and return xt.
\r
2145 $COLON 1,"'",Tick,_FLINK
\r
2146 DW ParenTick,DROP,EXIT
\r
2148 ; + ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
2149 ; Add top two items and gives the sum.
\r
2153 $COLON 1,'+',Plus,_FLINK
\r
2154 DW UMPlus,DROP,EXIT
\r
2156 ; +! ( n|u a-addr -- ) \ CORE
\r
2157 ; Add n|u to the contents at a-addr.
\r
2159 ; : +! SWAP OVER @ + SWAP ! ;
\r
2161 $COLON 2,'+!',PlusStore,_FLINK
\r
2162 DW SWAP,OVER,Fetch,Plus
\r
2163 DW SWAP,Store,EXIT
\r
2165 ; , ( x -- ) \ CORE
\r
2166 ; Reserve one cell in data space and store x in it.
\r
2168 ; : , HERE DUP CELL+ TO HERE ! ;
\r
2170 $COLON 1,',',Comma,_FLINK
\r
2171 DW HERE,DUPP,CELLPlus,DoTO,AddrHERE,Store,EXIT
\r
2173 ; - ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
2174 ; Subtract n2|u2 from n1|u1, giving the difference n3|u3.
\r
2178 $COLON 1,'-',Minus,_FLINK
\r
2179 DW NEGATE,Plus,EXIT
\r
2181 ; . ( n -- ) \ CORE
\r
2182 ; Display a signed number followed by a space.
\r
2186 $COLON 1,'.',Dot,_FLINK
\r
2189 ; / ( n1 n2 -- n3 ) \ CORE
\r
2190 ; Divide n1 by n2, giving single-cell quotient n3.
\r
2194 $COLON 1,'/',Slash,_FLINK
\r
2195 DW SlashMOD,NIP,EXIT
\r
2197 ; /MOD ( n1 n2 -- n3 n4 ) \ CORE
\r
2198 ; Divide n1 by n2, giving single-cell remainder n3 and
\r
2199 ; single-cell quotient n4.
\r
2201 ; : /MOD >R S>D R> FM/MOD ;
\r
2203 $COLON 4,'/MOD',SlashMOD,_FLINK
\r
2204 DW ToR,SToD,RFrom,FMSlashMOD,EXIT
\r
2206 ; /STRING ( c-addr1 u1 n -- c-addr2 u2 ) \ STRING
\r
2207 ; Adjust the char string at c-addr1 by n chars.
\r
2209 ; : /STRING DUP >R - SWAP R> CHARS + SWAP ;
\r
2211 $COLON 7,'/STRING',SlashSTRING,_FLINK
\r
2212 DW DUPP,ToR,Minus,SWAP,RFrom,CHARS,Plus,SWAP,EXIT
\r
2214 ; 1+ ( n1|u1 -- n2|u2 ) \ CORE
\r
2215 ; Increase top of the stack item by 1.
\r
2219 $COLON 2,'1+',OnePlus,_FLINK
\r
2222 ; 1- ( n1|u1 -- n2|u2 ) \ CORE
\r
2223 ; Decrease top of the stack item by 1.
\r
2227 $COLON 2,'1-',OneMinus,_FLINK
\r
2228 DW MinusOne,Plus,EXIT
\r
2230 ; 2! ( x1 x2 a-addr -- ) \ CORE
\r
2231 ; Store the cell pare x1 x2 at a-addr, with x2 at a-addr and
\r
2232 ; x1 at the next consecutive cell.
\r
2234 ; : 2! SWAP OVER ! CELL+ ! ;
\r
2236 $COLON 2,'2!',TwoStore,_FLINK
\r
2237 DW SWAP,OVER,Store,CELLPlus,Store,EXIT
\r
2239 ; 2@ ( a-addr -- x1 x2 ) \ CORE
\r
2240 ; Fetch the cell pair stored at a-addr. x2 is stored at a-addr
\r
2241 ; and x1 at the next consecutive cell.
\r
2243 ; : 2@ DUP CELL+ @ SWAP @ ;
\r
2245 $COLON 2,'2@',TwoFetch,_FLINK
\r
2246 DW DUPP,CELLPlus,Fetch,SWAP,Fetch,EXIT
\r
2248 ; 2DROP ( x1 x2 -- ) \ CORE
\r
2249 ; Drop cell pair x1 x2 from the stack.
\r
2251 $COLON 5,'2DROP',TwoDROP,_FLINK
\r
2254 ; 2DUP ( x1 x2 -- x1 x2 x1 x2 ) \ CORE
\r
2255 ; Duplicate cell pair x1 x2.
\r
2257 $COLON 4,'2DUP',TwoDUP,_FLINK
\r
2260 ; 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) \ CORE
\r
2261 ; Exchange the top two cell pairs.
\r
2263 ; : 2SWAP ROT >R ROT R> ;
\r
2265 $COLON 5,'2SWAP',TwoSWAP,_FLINK
\r
2266 DW ROT,ToR,ROT,RFrom,EXIT
\r
2268 ; : ( "<spaces>name" -- colon-sys ) \ CORE
\r
2269 ; Start a new colon definition using next word as its name.
\r
2271 ; : : head, :NONAME ROT DROP -1 TO notNONAME? ;
\r
2273 $COLON 1,':',COLON,_FLINK
\r
2274 DW HeadComma,ColonNONAME,ROT,DROP
\r
2275 DW DoLIT,-1,DoTO,AddrNotNONAMEQ,EXIT
\r
2277 ; :NONAME ( -- xt colon-sys ) \ CORE EXT
\r
2278 ; Create an execution token xt, enter compilation state and
\r
2279 ; start the current definition.
\r
2281 ; : :NONAME bal IF -29 THROW THEN \ compiler nesting
\r
2282 ; ['] doLIST xt, DUP -1
\r
2283 ; 0 TO notNONAME? 1 TO bal ] ;
\r
2285 $COLON 7,':NONAME',ColonNONAME,_FLINK
\r
2286 DW Bal,ZBranch,NONAME1
\r
2287 DW DoLIT,-29,THROW
\r
2288 NONAME1 DW DoLIT,DoLIST,xtComma,DUPP,DoLIT,-1
\r
2289 DW Zero,DoTO,AddrNotNONAMEQ
\r
2290 DW One,DoTO,AddrBal,RightBracket,EXIT
\r
2292 ; ; ( colon-sys -- ) \ CORE
\r
2293 ; Terminate a colon definition.
\r
2295 ; : ; bal 1- IF -22 THROW THEN \ control structure mismatch
\r
2296 ; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1
\r
2297 ; notNONAME? IF \ if the last definition is not created by ':'
\r
2298 ; linkLast 0 TO notNONAME? \ link the word to wordlist
\r
2299 ; THEN POSTPONE EXIT \ add EXIT at the end of the definition
\r
2300 ; 0 TO bal POSTPONE [ ; COMPILE-ONLY IMMEDIATE
\r
2302 $COLON IMMED+COMPO+1,';',Semicolon,_FLINK
\r
2303 DW Bal,OneMinus,ZBranch,SEMI1
\r
2304 DW DoLIT,-22,THROW
\r
2305 SEMI1 DW NIP,OnePlus,ZBranch,SEMI2
\r
2306 DW DoLIT,-22,THROW
\r
2307 SEMI2 DW NotNONAMEQ,ZBranch,SEMI3
\r
2308 DW LinkLast,Zero,DoTO,AddrNotNONAMEQ
\r
2309 SEMI3 DW DoLIT,EXIT,COMPILEComma
\r
2310 DW Zero,DoTO,AddrBal,LeftBracket,EXIT
\r
2312 ; < ( n1 n2 -- flag ) \ CORE
\r
2313 ; Returns true if n1 is less than n2.
\r
2315 ; : < 2DUP XOR 0< \ same sign?
\r
2316 ; IF DROP 0< EXIT THEN \ different signs, true if n1 <0
\r
2317 ; - 0< ; \ same signs, true if n1-n2 <0
\r
2319 $COLON 1,'<',LessThan,_FLINK
\r
2320 DW TwoDUP,XORR,ZeroLess,ZBranch,LESS1
\r
2321 DW DROP,ZeroLess,EXIT
\r
2322 LESS1 DW Minus,ZeroLess,EXIT
\r
2324 ; <# ( -- ) \ CORE
\r
2325 ; Initiate the numeric output conversion process.
\r
2326 ; ||HERE>WORD/#-work-area|
\r
2328 ; : <# HERE size-of-PAD + hld ! ;
\r
2330 $COLON 2,'<#',LessNumberSign,_FLINK
\r
2331 DW HERE,DoLIT,PADSize*CHARR,Plus,HLD,Store,EXIT
\r
2333 ; = ( x1 x2 -- flag ) \ CORE
\r
2334 ; Return true if top two are equal.
\r
2338 $COLON 1,'=',Equals,_FLINK
\r
2339 DW XORR,ZeroEquals,EXIT
\r
2341 ; > ( n1 n2 -- flag ) \ CORE
\r
2342 ; Returns true if n1 is greater than n2.
\r
2346 $COLON 1,'>',GreaterThan,_FLINK
\r
2347 DW SWAP,LessThan,EXIT
\r
2349 ; >IN ( -- a-addr )
\r
2350 ; Hold the character pointer while parsing input stream.
\r
2352 $VAR 3,'>IN',ToIN,1,_FLINK
\r
2354 ; >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ CORE
\r
2355 ; Add number string's value to ud1. Leaves string of any
\r
2356 ; unconverted chars.
\r
2358 ; : >NUMBER BEGIN DUP
\r
2359 ; WHILE >R DUP >R C@ \ ud char R: u c-addr
\r
2360 ; DUP [ CHAR 9 1+ ] LITERAL [CHAR] A WITHIN
\r
2361 ; IF DROP R> R> EXIT THEN
\r
2362 ; [ CHAR 0 ] LITERAL - 9 OVER <
\r
2363 ; [ CHAR A CHAR 9 1 + - ] LITERAL AND -
\r
2364 ; DUP 0 BASE @ WITHIN
\r
2365 ; WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> R> 1 /STRING
\r
2366 ; REPEAT DROP R> R>
\r
2369 $COLON 7,'>NUMBER',ToNUMBER,_FLINK
\r
2370 TONUM1 DW DUPP,ZBranch,TONUM3
\r
2371 DW ToR,DUPP,ToR,CFetch,DUPP
\r
2372 DW DoLIT,'9'+1,DoLIT,'A',WITHIN,ZeroEquals,ZBranch,TONUM2
\r
2373 DW DoLIT,'0',Minus,DoLIT,9,OVER,LessThan
\r
2374 DW DoLIT,'A'-'9'-1,ANDD,Minus,DUPP
\r
2375 DW Zero,BASE,Fetch,WITHIN,ZBranch,TONUM2
\r
2376 DW SWAP,BASE,Fetch,UMStar,DROP,ROT,BASE,Fetch
\r
2377 DW UMStar,DPlus,RFrom,RFrom,One,SlashSTRING
\r
2379 TONUM2 DW DROP,RFrom,RFrom
\r
2382 ; ?DUP ( x -- x x | 0 ) \ CORE
\r
2383 ; Duplicate top of the stack if it is not zero.
\r
2385 ; : ?DUP DUP IF DUP THEN ;
\r
2387 $COLON 4,'?DUP',QuestionDUP,_FLINK
\r
2388 DW DUPP,ZBranch,QDUP1
\r
2392 ; ABORT ( i*x -- ) ( R: j*x -- ) \ EXCEPTION EXT
\r
2393 ; Reset data stack and jump to QUIT.
\r
2395 ; : ABORT -1 THROW ;
\r
2397 $COLON 5,'ABORT',ABORT,_FLINK
\r
2400 ; ACCEPT ( c-addr +n1 -- +n2 ) \ CORE
\r
2401 ; Accept a string of up to +n1 chars. Return with actual count.
\r
2402 ; Implementation-defined editing. Stops at EOL# .
\r
2403 ; Supports backspace and delete editing.
\r
2406 ; BEGIN DUP R@ < \ ca n2 f R: n1
\r
2407 ; WHILE EKEY max-char AND
\r
2409 ; IF DUP cr# = IF ROT 2DROP R> DROP EXIT THEN
\r
2411 ; IF DROP 2DUP + BL DUP EMIT SWAP C! 1+
\r
2415 ; \ discard the last char if not 1st char
\r
2416 ; IF 1- bsp# EMIT BL EMIT bsp# EMIT THEN THEN
\r
2418 ; ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+ THEN
\r
2420 ; REPEAT SWAP R> 2DROP ;
\r
2422 $COLON 6,'ACCEPT',ACCEPT,_FLINK
\r
2424 ACCPT1 DW DUPP,RFetch,LessThan,ZBranch,ACCPT5
\r
2425 DW EKEY,DoLIT,MaxChar,ANDD
\r
2426 DW DUPP,BLank,LessThan,ZBranch,ACCPT3
\r
2427 DW DUPP,DoLIT,CRR,Equals,ZBranch,ACCPT4
\r
2428 DW ROT,TwoDROP,RFrom,DROP,EXIT
\r
2429 ACCPT4 DW DUPP,DoLIT,TABB,Equals,ZBranch,ACCPT6
\r
2430 DW DROP,TwoDUP,Plus,BLank,DUPP,EMIT,SWAP,CStore,OnePlus
\r
2432 ACCPT6 DW DUPP,DoLIT,BKSPP,Equals
\r
2433 DW SWAP,DoLIT,DEL,Equals,ORR,ZBranch,ACCPT1
\r
2434 DW DUPP,ZBranch,ACCPT1
\r
2435 DW OneMinus,DoLIT,BKSPP,EMIT,BLank,EMIT,DoLIT,BKSPP,EMIT
\r
2437 ACCPT3 DW ToR,TwoDUP,CHARS,Plus,RFrom,DUPP,EMIT,SWAP,CStore
\r
2438 DW OnePlus,Branch,ACCPT1
\r
2439 ACCPT5 DW SWAP,RFrom,TwoDROP,EXIT
\r
2441 ; AGAIN ( C: dest -- ) \ CORE EXT
\r
2442 ; Resolve backward reference dest. Typically used as
\r
2443 ; BEGIN ... AGAIN . Move control to the location specified by
\r
2444 ; dest on execution.
\r
2446 ; : AGAIN IF -22 THROW THEN \ control structure mismatch; dest type is 0
\r
2447 ; POSTPONE branch , bal- ; COMPILE-ONLY IMMEDIATE
\r
2449 $COLON IMMED+COMPO+5,'AGAIN',AGAIN,_FLINK
\r
2451 DW DoLIT,-22,THROW
\r
2452 AGAIN1 DW DoLIT,Branch,COMPILEComma,Comma,BalMinus,EXIT
\r
2454 ; AHEAD ( C: -- orig ) \ TOOLS EXT
\r
2455 ; Put the location of a new unresolved forward reference onto
\r
2456 ; control-flow stack.
\r
2458 ; : AHEAD POSTPONE branch HERE 0 ,
\r
2459 ; 1 bal+ \ orig type is 1
\r
2460 ; ; COMPILE-ONLY IMMEDIATE
\r
2462 $COLON IMMED+COMPO+5,'AHEAD',AHEAD,_FLINK
\r
2463 DW DoLIT,Branch,COMPILEComma,HERE,Zero,Comma
\r
2464 DW One,BalPlus,EXIT
\r
2466 ; BL ( -- char ) \ CORE
\r
2467 ; Return the value of the blank character.
\r
2469 ; : BL blank-char-value EXIT ;
\r
2471 $CONST 2,'BL',BLank,' ',_FLINK
\r
2473 ; CATCH ( i*x xt -- j*x 0 | i*x n ) \ EXCEPTION
\r
2474 ; Push an exception frame on the exception stack and then execute
\r
2475 ; the execution token xt in such a way that control can be
\r
2476 ; transferred to a point just after CATCH if THROW is executed
\r
2477 ; during the execution of xt.
\r
2479 ; : CATCH sp@ >R throwFrame @ >R \ save error frame
\r
2480 ; rp@ throwFrame ! EXECUTE \ execute
\r
2481 ; R> throwFrame ! \ restore error frame
\r
2482 ; R> DROP 0 ; \ no error
\r
2484 $COLON 5,'CATCH',CATCH,_FLINK
\r
2485 DW SPFetch,ToR,ThrowFrame,Fetch,ToR
\r
2486 DW RPFetch,ThrowFrame,Store,EXECUTE
\r
2487 DW RFrom,ThrowFrame,Store
\r
2488 DW RFrom,DROP,Zero,EXIT
\r
2490 ; CELL+ ( a-addr1 -- a-addr2 ) \ CORE
\r
2491 ; Return next aligned cell address.
\r
2493 ; : CELL+ cell-size + ;
\r
2495 $COLON 5,'CELL+',CELLPlus,_FLINK
\r
2496 DW DoLIT,CELLL,Plus,EXIT
\r
2498 ; CHAR+ ( c-addr1 -- c-addr2 ) \ CORE
\r
2499 ; Returns next character-aligned address.
\r
2501 ; : CHAR+ char-size + ;
\r
2503 $COLON 5,'CHAR+',CHARPlus,_FLINK
\r
2504 DW DoLIT,CHARR,Plus,EXIT
\r
2506 ; COMPILE, ( xt -- ) \ CORE EXT
\r
2507 ; Compile the execution token on data stack into current
\r
2508 ; colon definition.
\r
2510 ; : COMPILE, , ; COMPILE-ONLY
\r
2512 $COLON COMPO+8,'COMPILE,',COMPILEComma,_FLINK
\r
2515 ; CONSTANT ( x "<spaces>name" -- ) \ CORE
\r
2516 ; name Execution: ( -- x )
\r
2517 ; Create a definition for name which pushes x on the stack on
\r
2520 ; : CONSTANT bal IF -29 THROW THEN \ compiler nesting
\r
2521 ; head, ['] doCONST xt, DROP , linkLast ;
\r
2523 $COLON 8,'CONSTANT',CONSTANT,_FLINK
\r
2524 DW Bal,ZBranch,CONST1
\r
2525 DW DoLIT,-29,THROW
\r
2526 CONST1 DW HeadComma,DoLIT,DoCONST,xtComma,DROP,Comma
\r
2529 ; COUNT ( c-addr1 -- c-addr2 u ) \ CORE
\r
2530 ; Convert counted string to string specification. c-addr2 is
\r
2531 ; the next char-aligned address after c-addr1 and u is the
\r
2532 ; contents at c-addr1.
\r
2534 ; : COUNT DUP CHAR+ SWAP C@ ;
\r
2536 $COLON 5,'COUNT',COUNT,_FLINK
\r
2537 DW DUPP,CHARPlus,SWAP,CFetch,EXIT
\r
2539 ; CREATE ( "<spaces>name" -- ) \ CORE
\r
2540 ; name Execution: ( -- a-addr )
\r
2541 ; Create a data object in data space, which return data
\r
2542 ; object address on execution
\r
2543 ; Structure of CREATEd word:
\r
2544 ; | call-doCREATE | 0 or DOES> code addr | >BODY points here
\r
2546 ; : CREATE bal IF -29 THROW THEN \ compiler nesting
\r
2547 ; head, ['] doCREATE xt, DROP
\r
2548 ; HERE DUP CELL+ TO HERE \ reserve a cell
\r
2549 ; 0 SWAP ! \ no DOES> code yet
\r
2550 ; linkLast ; \ link CREATEd word to current wordlist
\r
2552 $COLON 6,'CREATE',CREATE,_FLINK
\r
2553 DW Bal,ZBranch,CREAT1
\r
2554 DW DoLIT,-29,THROW
\r
2555 CREAT1 DW HeadComma,DoLIT,DoCREATE,xtComma,DROP
\r
2556 DW HERE,DUPP,CELLPlus,DoTO,AddrHERE
\r
2557 DW Zero,SWAP,Store,LinkLast,EXIT
\r
2559 ; D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE
\r
2560 ; Add double-cell numbers.
\r
2562 ; : D+ >R SWAP >R um+ R> R> + + ;
\r
2564 $COLON 2,'D+',DPlus,_FLINK
\r
2565 DW ToR,SWAP,ToR,UMPlus
\r
2566 DW RFrom,RFrom,Plus,Plus,EXIT
\r
2568 ; D. ( d -- ) \ DOUBLE
\r
2569 ; Display d in free field format followed by a space.
\r
2571 ; : D. (d.) TYPE SPACE ;
\r
2573 $COLON 2,'D.',DDot,_FLINK
\r
2574 DW ParenDDot,TYPEE,SPACE,EXIT
\r
2576 ; DECIMAL ( -- ) \ CORE
\r
2577 ; Set the numeric conversion radix to decimal 10.
\r
2579 ; : DECIMAL 10 BASE ! ;
\r
2581 $COLON 7,'DECIMAL',DECIMAL,_FLINK
\r
2582 DW DoLIT,10,BASE,Store,EXIT
\r
2584 ; DEPTH ( -- +n ) \ CORE
\r
2585 ; Return the depth of the data stack.
\r
2587 ; : DEPTH sp@ sp0 SWAP - cell-size / ;
\r
2589 $COLON 5,'DEPTH',DEPTH,_FLINK
\r
2590 DW SPFetch,SPZero,SWAP,Minus
\r
2591 DW DoLIT,CELLL,Slash,EXIT
\r
2593 ; DNEGATE ( d1 -- d2 ) \ DOUBLE
\r
2594 ; Two's complement of double-cell number.
\r
2596 ; : DNEGATE INVERT >R INVERT 1 um+ R> + ;
\r
2598 $COLON 7,'DNEGATE',DNEGATE,_FLINK
\r
2599 DW INVERT,ToR,INVERT
\r
2601 DW RFrom,Plus,EXIT
\r
2603 ; EKEY ( -- u ) \ FACILITY EXT
\r
2604 ; Receive one keyboard event u.
\r
2606 ; : EKEY BEGIN PAUSE EKEY? UNTIL 'ekey EXECUTE ;
\r
2608 $COLON 4,'EKEY',EKEY,_FLINK
\r
2609 EKEY1 DW PAUSE,EKEYQuestion,ZBranch,EKEY1
\r
2610 DW TickEKEY,EXECUTE,EXIT
\r
2612 ; EMIT ( x -- ) \ CORE
\r
2613 ; Send a character to the output device.
\r
2615 ; : EMIT 'emit EXECUTE ;
\r
2617 $COLON 4,'EMIT',EMIT,_FLINK
\r
2618 DW TickEMIT,EXECUTE,EXIT
\r
2620 ; FM/MOD ( d n1 -- n2 n3 ) \ CORE
\r
2621 ; Signed floored divide of double by single. Return mod n2
\r
2622 ; and quotient n3.
\r
2624 ; : FM/MOD DUP >R 2DUP XOR >R >R DUP 0< IF DNEGATE THEN
\r
2626 ; R> 0< IF SWAP NEGATE SWAP THEN
\r
2627 ; R> 0< IF NEGATE \ negative quotient
\r
2628 ; OVER IF R@ ROT - SWAP 1- THEN
\r
2630 ; 0 OVER < IF -11 THROW THEN \ result out of range
\r
2632 ; R> DROP DUP 0< IF -11 THROW THEN ; \ result out of range
\r
2634 $COLON 6,'FM/MOD',FMSlashMOD,_FLINK
\r
2635 DW DUPP,ToR,TwoDUP,XORR,ToR,ToR,DUPP,ZeroLess
\r
2638 FMMOD1 DW RFetch,ABSS,UMSlashMOD
\r
2639 DW RFrom,ZeroLess,ZBranch,FMMOD2
\r
2640 DW SWAP,NEGATE,SWAP
\r
2641 FMMOD2 DW RFrom,ZeroLess,ZBranch,FMMOD3
\r
2642 DW NEGATE,OVER,ZBranch,FMMOD4
\r
2643 DW RFetch,ROT,Minus,SWAP,OneMinus
\r
2644 FMMOD4 DW RFrom,DROP
\r
2645 DW DoLIT,0,OVER,LessThan,ZBranch,FMMOD6
\r
2646 DW DoLIT,-11,THROW
\r
2648 FMMOD3 DW RFrom,DROP,DUPP,ZeroLess,ZBranch,FMMOD6
\r
2649 DW DoLIT,-11,THROW
\r
2651 ; GET-CURRENT ( -- wid ) \ SEARCH
\r
2652 ; Return the indentifier of the compilation wordlist.
\r
2654 ; : GET-CURRENT current @ ;
\r
2656 $COLON 11,'GET-CURRENT',GET_CURRENT,_FLINK
\r
2657 DW Current,Fetch,EXIT
\r
2659 ; HOLD ( char -- ) \ CORE
\r
2660 ; Add char to the beginning of pictured numeric output string.
\r
2662 ; : HOLD hld @ 1 CHARS - DUP hld ! C! ;
\r
2664 $COLON 4,'HOLD',HOLD,_FLINK
\r
2665 DW HLD,Fetch,DoLIT,0-CHARR,Plus
\r
2666 DW DUPP,HLD,Store,CStore,EXIT
\r
2668 ; I ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE
\r
2669 ; Push the innermost loop index.
\r
2671 ; : I rp@ [ 1 CELLS ] LITERAL + @
\r
2672 ; rp@ [ 2 CELLS ] LITERAL + @ + ; COMPILE-ONLY
\r
2674 $COLON COMPO+1,'I',I,_FLINK
\r
2675 DW RPFetch,DoLIT,CELLL,Plus,Fetch
\r
2676 DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT
\r
2678 ; IF Compilation: ( C: -- orig ) \ CORE
\r
2679 ; Run-time: ( x -- )
\r
2680 ; Put the location of a new unresolved forward reference orig
\r
2681 ; onto the control flow stack. On execution jump to location
\r
2682 ; specified by the resolution of orig if x is zero.
\r
2684 ; : IF POSTPONE 0branch HERE 0 ,
\r
2685 ; 1 bal+ \ orig type is 1
\r
2686 ; ; COMPILE-ONLY IMMEDIATE
\r
2688 $COLON IMMED+COMPO+2,'IF',IFF,_FLINK
\r
2689 DW DoLIT,ZBranch,COMPILEComma,HERE,Zero,Comma
\r
2690 DW One,BalPlus,EXIT
\r
2692 ; INVERT ( x1 -- x2 ) \ CORE
\r
2693 ; Return one's complement of x1.
\r
2695 ; : INVERT -1 XOR ;
\r
2697 $COLON 6,'INVERT',INVERT,_FLINK
\r
2698 DW MinusOne,XORR,EXIT
\r
2700 ; KEY ( -- char ) \ CORE
\r
2701 ; Receive a character. Do not display char.
\r
2703 ; : KEY EKEY max-char AND ;
\r
2705 $COLON 3,'KEY',KEY,_FLINK
\r
2706 DW EKEY,DoLIT,MaxChar,ANDD,EXIT
\r
2708 ; LITERAL Compilation: ( x -- ) \ CORE
\r
2709 ; Run-time: ( -- x )
\r
2710 ; Append following run-time semantics. Put x on the stack on
\r
2713 ; : LITERAL POSTPONE doLIT , ; COMPILE-ONLY IMMEDIATE
\r
2715 $COLON IMMED+COMPO+7,'LITERAL',LITERAL,_FLINK
\r
2716 DW DoLIT,DoLIT,COMPILEComma,Comma,EXIT
\r
2718 ; NEGATE ( n1 -- n2 ) \ CORE
\r
2719 ; Return two's complement of n1.
\r
2721 ; : NEGATE INVERT 1+ ;
\r
2723 $COLON 6,'NEGATE',NEGATE,_FLINK
\r
2724 DW INVERT,OnePlus,EXIT
\r
2726 ; NIP ( n1 n2 -- n2 ) \ CORE EXT
\r
2727 ; Discard the second stack item.
\r
2729 ; : NIP SWAP DROP ;
\r
2731 $COLON 3,'NIP',NIP,_FLINK
\r
2734 ; PARSE ( char "ccc<char>"-- c-addr u ) \ CORE EXT
\r
2735 ; Scan input stream and return counted string delimited by char.
\r
2737 ; : PARSE >R SOURCE >IN @ /STRING \ c-addr u R: char
\r
2739 ; OVER CHARS + OVER \ c-addr c-addr+u c-addr R: char
\r
2740 ; BEGIN DUP C@ R@ XOR
\r
2741 ; WHILE CHAR+ 2DUP =
\r
2742 ; UNTIL DROP OVER - 1chars/ DUP
\r
2743 ; ELSE NIP OVER - 1chars/ DUP CHAR+
\r
2745 ; THEN R> DROP EXIT ;
\r
2747 $COLON 5,'PARSE',PARSE,_FLINK
\r
2748 DW ToR,SOURCE,ToIN,Fetch,SlashSTRING
\r
2749 DW DUPP,ZBranch,PARSE4
\r
2750 DW OVER,CHARS,Plus,OVER
\r
2751 PARSE1 DW DUPP,CFetch,RFetch,XORR,ZBranch,PARSE3
\r
2752 DW CHARPlus,TwoDUP,Equals,ZBranch,PARSE1
\r
2753 PARSE2 DW DROP,OVER,Minus,DUPP,OneCharsSlash,Branch,PARSE5
\r
2754 PARSE3 DW NIP,OVER,Minus,DUPP,OneCharsSlash,CHARPlus
\r
2755 PARSE5 DW ToIN,PlusStore
\r
2756 PARSE4 DW RFrom,DROP,EXIT
\r
2758 ; QUIT ( -- ) ( R: i*x -- ) \ CORE
\r
2759 ; Empty the return stack, store zero in SOURCE-ID, make the user
\r
2760 ; input device the input source, and start text interpreter.
\r
2763 ; rp0 rp! 0 TO SOURCE-ID 0 TO bal POSTPONE [
\r
2764 ; BEGIN CR REFILL DROP SPACE \ REFILL returns always true
\r
2765 ; ['] interpret CATCH ?DUP 0=
\r
2766 ; WHILE STATE @ 0= IF .prompt THEN
\r
2768 ; DUP -1 XOR IF \ ABORT
\r
2769 ; DUP -2 = IF SPACE abort"msg 2@ TYPE ELSE \ ABORT"
\r
2770 ; SPACE errWord 2@ TYPE
\r
2771 ; SPACE [CHAR] ? EMIT SPACE
\r
2772 ; DUP -1 -58 WITHIN IF ." Exception # " . ELSE \ undefined exception
\r
2773 ; CELLS THROWMsgTbl + @ COUNT TYPE THEN THEN THEN
\r
2777 $COLON 4,'QUIT',QUIT,_FLINK
\r
2778 QUIT1 DW RPZero,RPStore,Zero,DoTO,AddrSOURCE_ID
\r
2779 DW Zero,DoTO,AddrBal,LeftBracket
\r
2780 QUIT2 DW CR,REFILL,DROP,SPACE
\r
2781 DW DoLIT,Interpret,CATCH,QuestionDUP,ZeroEquals
\r
2783 DW STATE,Fetch,ZeroEquals,ZBranch,QUIT2
\r
2784 DW DotPrompt,Branch,QUIT2
\r
2785 QUIT3 DW DUPP,MinusOne,XORR,ZBranch,QUIT5
\r
2786 DW DUPP,DoLIT,-2,Equals,ZBranch,QUIT4
\r
2787 DW SPACE,AbortQMsg,TwoFetch,TYPEE,Branch,QUIT5
\r
2788 QUIT4 DW SPACE,ErrWord,TwoFetch,TYPEE
\r
2789 DW SPACE,DoLIT,'?',EMIT,SPACE
\r
2790 DW DUPP,MinusOne,DoLIT,-58,WITHIN,ZBranch,QUIT7
\r
2791 $INSTR ' Exception # '
\r
2792 DW TYPEE,Dot,Branch,QUIT5
\r
2793 QUIT7 DW CELLS,THROWMsgTbl,Plus,Fetch,COUNT,TYPEE
\r
2794 QUIT5 DW SPZero,SPStore,Branch,QUIT1
\r
2796 ; REFILL ( -- flag ) \ CORE EXT
\r
2797 ; Attempt to fill the input buffer from the input source. Make
\r
2798 ; the result the input buffer, set >IN to zero, and return true
\r
2799 ; if successful. Return false if the input source is a string
\r
2802 ; : REFILL SOURCE-ID IF 0 EXIT THEN
\r
2803 ; memTop [ size-of-PAD CHARS ] LITERAL - DUP
\r
2804 ; size-of-PAD ACCEPT sourceVar 2!
\r
2807 $COLON 6,'REFILL',REFILL,_FLINK
\r
2808 DW SOURCE_ID,ZBranch,REFIL1
\r
2810 REFIL1 DW MemTop,DoLIT,0-PADSize*CHARR,Plus,DUPP
\r
2811 DW DoLIT,PADSize*CHARR,ACCEPT,SourceVar,TwoStore
\r
2812 DW Zero,ToIN,Store,MinusOne,EXIT
\r
2814 ; ROT ( x1 x2 x3 -- x2 x3 x1 ) \ CORE
\r
2815 ; Rotate the top three data stack items.
\r
2817 ; : ROT >R SWAP R> SWAP ;
\r
2819 $COLON 3,'ROT',ROT,_FLINK
\r
2820 DW ToR,SWAP,RFrom,SWAP,EXIT
\r
2822 ; S>D ( n -- d ) \ CORE
\r
2823 ; Convert a single-cell number n to double-cell number.
\r
2827 $COLON 3,'S>D',SToD,_FLINK
\r
2828 DW DUPP,ZeroLess,EXIT
\r
2830 ; SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1) \ SEARCH
\r
2831 ; Search word list for a match with the given name.
\r
2832 ; Return execution token and -1 or 1 ( IMMEDIATE) if found.
\r
2833 ; Return 0 if not found.
\r
2835 ; : SEARCH-WORDLIST
\r
2836 ; (search-wordlist) DUP IF NIP THEN ;
\r
2838 $COLON 15,'SEARCH-WORDLIST',SEARCH_WORDLIST,_FLINK
\r
2839 DW ParenSearch_Wordlist,DUPP,ZBranch,SRCHW1
\r
2843 ; SIGN ( n -- ) \ CORE
\r
2844 ; Add a minus sign to the numeric output string if n is negative.
\r
2846 ; : SIGN 0< IF [CHAR] - HOLD THEN ;
\r
2848 $COLON 4,'SIGN',SIGN,_FLINK
\r
2849 DW ZeroLess,ZBranch,SIGN1
\r
2853 ; SOURCE ( -- c-addr u ) \ CORE
\r
2854 ; Return input buffer string.
\r
2856 ; : SOURCE sourceVar 2@ ;
\r
2858 $COLON 6,'SOURCE',SOURCE,_FLINK
\r
2859 DW SourceVar,TwoFetch,EXIT
\r
2861 ; SPACE ( -- ) \ CORE
\r
2862 ; Send the blank character to the output device.
\r
2864 ; : SPACE 32 EMIT ;
\r
2866 $COLON 5,'SPACE',SPACE,_FLINK
\r
2867 DW BLank,EMIT,EXIT
\r
2869 ; STATE ( -- a-addr ) \ CORE
\r
2870 ; Return the address of a cell containing compilation-state flag
\r
2871 ; which is true in compilation state or false otherwise.
\r
2873 $VAR 5,'STATE',STATE,1,_FLINK
\r
2875 ; THEN Compilation: ( C: orig -- ) \ CORE
\r
2876 ; Run-time: ( -- )
\r
2877 ; Resolve the forward reference orig.
\r
2879 ; : THEN 1- IF -22 THROW THEN \ control structure mismatch
\r
2880 ; \ orig type is 1
\r
2881 ; HERE SWAP ! bal- ; COMPILE-ONLY IMMEDIATE
\r
2883 $COLON IMMED+COMPO+4,'THEN',THENN,_FLINK
\r
2884 DW OneMinus,ZBranch,THEN1
\r
2885 DW DoLIT,-22,THROW
\r
2886 THEN1 DW HERE,SWAP,Store,BalMinus,EXIT
\r
2888 ; THROW ( k*x n -- k*x | i*x n ) \ EXCEPTION
\r
2889 ; If n is not zero, pop the topmost exception frame from the
\r
2890 ; exception stack, along with everything on the return stack
\r
2891 ; above the frame. Then restore the condition before CATCH and
\r
2892 ; transfer control just after the CATCH that pushed that
\r
2893 ; exception frame.
\r
2896 ; IF throwFrame @ rp! \ restore return stack
\r
2897 ; R> throwFrame ! \ restore THROW frame
\r
2898 ; R> SWAP >R sp! \ restore data stack
\r
2900 ; 'init-i/o EXECUTE
\r
2903 $COLON 5,'THROW',THROW,_FLINK
\r
2904 DW QuestionDUP,ZBranch,THROW1
\r
2905 DW ThrowFrame,Fetch,RPStore,RFrom,ThrowFrame,Store
\r
2906 DW RFrom,SWAP,ToR,SPStore,DROP,RFrom
\r
2907 DW TickINIT_IO,EXECUTE
\r
2910 ; TYPE ( c-addr u -- ) \ CORE
\r
2911 ; Display the character string if u is greater than zero.
\r
2913 ; : TYPE ?DUP IF 0 DO DUP C@ EMIT CHAR+ LOOP THEN DROP ;
\r
2915 $COLON 4,'TYPE',TYPEE,_FLINK
\r
2916 DW QuestionDUP,ZBranch,TYPE2
\r
2918 TYPE1 DW DUPP,CFetch,EMIT,CHARPlus,DoLOOP,TYPE1
\r
2919 TYPE2 DW DROP,EXIT
\r
2921 ; U< ( u1 u2 -- flag ) \ CORE
\r
2922 ; Unsigned compare of top two items. True if u1 < u2.
\r
2924 ; : U< 2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;
\r
2926 $COLON 2,'U<',ULess,_FLINK
\r
2927 DW TwoDUP,XORR,ZeroLess
\r
2929 DW NIP,ZeroLess,EXIT
\r
2930 ULES1 DW Minus,ZeroLess,EXIT
\r
2932 ; UM* ( u1 u2 -- ud ) \ CORE
\r
2933 ; Unsigned multiply. Return double-cell product.
\r
2935 ; : UM* 0 SWAP cell-size-in-bits 0 DO
\r
2936 ; DUP um+ >R >R DUP um+ R> +
\r
2937 ; R> IF >R OVER um+ R> + THEN \ if carry
\r
2940 $COLON 3,'UM*',UMStar,_FLINK
\r
2941 DW Zero,SWAP,DoLIT,CELLL*8,Zero,DoDO
\r
2942 UMST1 DW DUPP,UMPlus,ToR,ToR
\r
2943 DW DUPP,UMPlus,RFrom,Plus,RFrom
\r
2945 DW ToR,OVER,UMPlus,RFrom,Plus
\r
2946 UMST2 DW DoLOOP,UMST1
\r
2949 ; UM/MOD ( ud u1 -- u2 u3 ) \ CORE
\r
2950 ; Unsigned division of a double-cell number ud by a single-cell
\r
2951 ; number u1. Return remainder u2 and quotient u3.
\r
2953 ; : UM/MOD DUP 0= IF -10 THROW THEN \ divide by zero
\r
2955 ; NEGATE cell-size-in-bits 0
\r
2956 ; DO >R DUP um+ >R >R DUP um+ R> + DUP
\r
2957 ; R> R@ SWAP >R um+ R> OR
\r
2958 ; IF >R DROP 1+ R> THEN
\r
2961 ; LOOP DROP SWAP EXIT
\r
2962 ; ELSE -11 THROW \ result out of range
\r
2965 $COLON 6,'UM/MOD',UMSlashMOD,_FLINK
\r
2966 DW DUPP,ZBranch,UMM5
\r
2967 DW TwoDUP,ULess,ZBranch,UMM4
\r
2968 DW NEGATE,DoLIT,CELLL*8,Zero,DoDO
\r
2969 UMM1 DW ToR,DUPP,UMPlus,ToR,ToR,DUPP,UMPlus,RFrom,Plus,DUPP
\r
2970 DW RFrom,RFetch,SWAP,ToR,UMPlus,RFrom,ORR,ZBranch,UMM2
\r
2971 DW ToR,DROP,OnePlus,RFrom,Branch,UMM3
\r
2973 UMM3 DW RFrom,DoLOOP,UMM1
\r
2975 UMM5 DW DoLIT,-10,THROW
\r
2976 UMM4 DW DoLIT,-11,THROW
\r
2978 ; UNLOOP ( -- ) ( R: loop-sys -- ) \ CORE
\r
2979 ; Discard loop-control parameters for the current nesting level.
\r
2980 ; An UNLOOP is required for each nesting level before the
\r
2981 ; definition may be EXITed.
\r
2983 ; : UNLOOP R> R> R> 2DROP >R ;
\r
2985 $COLON COMPO+6,'UNLOOP',UNLOOP,_FLINK
\r
2986 DW RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT
\r
2988 ; WITHIN ( n1|u1 n2|n2 n3|u3 -- flag ) \ CORE EXT
\r
2989 ; Return true if (n2|u2<=n1|u1 and n1|u1<n3|u3) or
\r
2990 ; (n2|u2>n3|u3 and (n2|u2<=n1|u1 or n1|u1<n3|u3)).
\r
2992 ; : WITHIN OVER - >R - R> U< ;
\r
2994 $COLON 6,'WITHIN',WITHIN,_FLINK
\r
2995 DW OVER,Minus,ToR ;ul <= u < uh
\r
2996 DW Minus,RFrom,ULess,EXIT
\r
2999 ; Enter interpretation state.
\r
3001 ; : [ 0 STATE ! ; COMPILE-ONLY IMMEDIATE
\r
3003 $COLON IMMED+COMPO+1,'[',LeftBracket,_FLINK
\r
3004 DW Zero,STATE,Store,EXIT
\r
3007 ; Enter compilation state.
\r
3009 ; : ] -1 STATE ! ;
\r
3011 $COLON 1,']',RightBracket,_FLINK
\r
3012 DW MinusOne,STATE,Store,EXIT
\r
3015 ; Rest of CORE words and two facility words, EKEY? and EMIT?
\r
3017 ; Following definitions can be removed from assembler source and
\r
3018 ; can be colon-defined later.
\r
3020 ; ( ( "ccc<)>" -- ) \ CORE
\r
3021 ; Ignore following string up to next ) . A comment.
\r
3023 ; : ( [CHAR] ) PARSE 2DROP ;
\r
3025 $COLON IMMED+1,'(',Paren,_FLINK
\r
3026 DW DoLIT,')',PARSE,TwoDROP,EXIT
\r
3028 ; * ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
3029 ; Multiply n1|u1 by n2|u2 giving a single product.
\r
3033 $COLON 1,'*',Star,_FLINK
\r
3034 DW UMStar,DROP,EXIT
\r
3036 ; */ ( n1 n2 n3 -- n4 ) \ CORE
\r
3037 ; Multiply n1 by n2 producing double-cell intermediate,
\r
3038 ; then divide it by n3. Return single-cell quotient.
\r
3040 ; : */ */MOD NIP ;
\r
3042 $COLON 2,'*/',StarSlash,_FLINK
\r
3043 DW StarSlashMOD,NIP,EXIT
\r
3045 ; */MOD ( n1 n2 n3 -- n4 n5 ) \ CORE
\r
3046 ; Multiply n1 by n2 producing double-cell intermediate,
\r
3047 ; then divide it by n3. Return single-cell remainder and
\r
3048 ; single-cell quotient.
\r
3050 ; : */MOD >R M* R> FM/MOD ;
\r
3052 $COLON 5,'*/MOD',StarSlashMOD,_FLINK
\r
3053 DW ToR,MStar,RFrom,FMSlashMOD,EXIT
\r
3055 ; +LOOP Compilation: ( C: do-sys -- ) \ CORE
\r
3056 ; Run-time: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
3057 ; Terminate a DO-+LOOP structure. Resolve the destination of all
\r
3058 ; unresolved occurences of LEAVE.
\r
3059 ; On execution add n to the loop index. If loop index did not
\r
3060 ; cross the boundary between loop_limit-1 and loop_limit,
\r
3061 ; continue execution at the beginning of the loop. Otherwise,
\r
3062 ; finish the loop.
\r
3064 ; : +LOOP POSTPONE do+LOOP rake ; COMPILE-ONLY IMMEDIATE
\r
3066 $COLON IMMED+COMPO+5,'+LOOP',PlusLOOP,_FLINK
\r
3067 DW DoLIT,DoPLOOP,COMPILEComma,rake,EXIT
\r
3069 ; ." ( "ccc<">" -- ) \ CORE
\r
3071 ; Compile an inline string literal to be typed out at run time.
\r
3073 ; : ." POSTPONE S" POSTPONE TYPE ; COMPILE-ONLY IMMEDIATE
\r
3075 $COLON IMMED+COMPO+2,'."',DotQuote,_FLINK
\r
3076 DW SQuote,DoLIT,TYPEE,COMPILEComma,EXIT
\r
3078 ; 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) \ CORE
\r
3079 ; Copy cell pair x1 x2 to the top of the stack.
\r
3081 ; : 2OVER >R >R 2DUP R> R> 2SWAP ;
\r
3083 $COLON 5,'2OVER',TwoOVER,_FLINK
\r
3084 DW ToR,ToR,TwoDUP,RFrom,RFrom,TwoSWAP,EXIT
\r
3086 ; >BODY ( xt -- a-addr ) \ CORE
\r
3087 ; Push data field address of CREATEd word.
\r
3088 ; Structure of CREATEd word:
\r
3089 ; | call-doCREATE | 0 or DOES> code addr | >BODY points here
\r
3091 ; : >BODY ?call DUP IF \ code-addr xt2
\r
3092 ; ['] doCREATE = IF \ should be call-doCREATE
\r
3095 ; -31 THROW ; \ >BODY used on non-CREATEd definition
\r
3097 $COLON 5,'>BODY',ToBODY,_FLINK
\r
3098 DW QCall,DUPP,ZBranch,TBODY1
\r
3099 DW DoLIT,DoCREATE,Equals,ZBranch,TBODY1
\r
3101 TBODY1 DW DoLIT,-31,THROW
\r
3103 ; ABORT" ( "ccc<">" -- ) \ EXCEPTION EXT
\r
3104 ; Run-time ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )
\r
3105 ; Conditional abort with an error message.
\r
3107 ; : ABORT" S" POSTPONE ROT
\r
3108 ; POSTPONE IF POSTPONE abort"msg POSTPONE 2!
\r
3109 ; -2 POSTPONE LITERAL POSTPONE THROW
\r
3110 ; POSTPONE ELSE POSTPONE 2DROP POSTPONE THEN
\r
3111 ; ; COMPILE-ONLY IMMEDIATE
\r
3113 $COLON IMMED+COMPO+6,'ABORT"',ABORTQuote,_FLINK
\r
3114 DW SQuote,DoLIT,ROT,COMPILEComma
\r
3115 DW IFF,DoLIT,AbortQMsg,COMPILEComma ; IF is immediate
\r
3116 DW DoLIT,TwoStore,COMPILEComma
\r
3117 DW DoLIT,-2,LITERAL ; LITERAL is immediate
\r
3118 DW DoLIT,THROW,COMPILEComma
\r
3119 DW ELSEE,DoLIT,TwoDROP,COMPILEComma ; ELSE and THEN are
\r
3120 DW THENN,EXIT ; immediate
\r
3122 ; ABS ( n -- u ) \ CORE
\r
3123 ; Return the absolute value of n.
\r
3125 ; : ABS DUP 0< IF NEGATE THEN ;
\r
3127 $COLON 3,'ABS',ABSS,_FLINK
\r
3128 DW DUPP,ZeroLess,ZBranch,ABS1
\r
3132 ; ALLOT ( n -- ) \ CORE
\r
3133 ; Allocate n address units in data space.
\r
3135 ; : ALLOT HERE + TO HERE ;
\r
3137 $COLON 5,'ALLOT',ALLOT,_FLINK
\r
3138 DW HERE,Plus,DoTO,AddrHERE,EXIT
\r
3140 ; BEGIN ( C: -- dest ) \ CORE
\r
3141 ; Start an infinite or indefinite loop structure. Put the next
\r
3142 ; location for a transfer of control, dest, onto the data
\r
3145 ; : BEGIN HERE 0 bal+ \ dest type is 0
\r
3146 ; ; COMPILE-ONLY IMMDEDIATE
\r
3148 $COLON IMMED+COMPO+5,'BEGIN',BEGIN,_FLINK
\r
3149 DW HERE,Zero,BalPlus,EXIT
\r
3151 ; C, ( char -- ) \ CORE
\r
3152 ; Compile a character into data space.
\r
3154 ; : C, HERE C! HERE CHAR+ TO HERE ;
\r
3156 $COLON 2,'C,',CComma,_FLINK
\r
3157 DW HERE,CStore,HERE,CHARPlus,DoTO,AddrHERE,EXIT
\r
3159 ; CHAR ( "<spaces>ccc" -- char ) \ CORE
\r
3160 ; Parse next word and return the value of first character.
\r
3162 ; : CHAR PARSE-WORD DROP C@ ;
\r
3164 $COLON 4,'CHAR',CHAR,_FLINK
\r
3165 DW PARSE_WORD,DROP,CFetch,EXIT
\r
3167 ; DO Compilation: ( C: -- do-sys ) \ CORE
\r
3168 ; Run-time: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )
\r
3169 ; Start a DO-LOOP structure in a colon definition. Place do-sys
\r
3170 ; on control-flow stack, which will be resolved by LOOP or +LOOP.
\r
3172 ; : DO 0 rakeVar ! 0 \ ?DO-orig is 0 for DO
\r
3173 ; POSTPONE doDO HERE bal+ \ DO-dest
\r
3174 ; ; COMPILE-ONLY IMMEDIATE
\r
3176 $COLON IMMED+COMPO+2,'DO',DO,_FLINK
\r
3177 DW Zero,RakeVar,Store,Zero
\r
3178 DW DoLIT,DoDO,COMPILEComma,HERE,BalPlus,EXIT
\r
3180 ; DOES> ( C: colon-sys1 -- colon-sys2 ) \ CORE
\r
3181 ; Build run time code of the data object CREATEd.
\r
3183 ; : DOES> bal 1- IF -22 THROW THEN \ control structure mismatch
\r
3184 ; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1
\r
3185 ; POSTPONE pipe ['] doLIST xt, -1 ; COMPILE-ONLY IMMEDIATE
\r
3187 $COLON IMMED+COMPO+5,'DOES>',DOESGreater,_FLINK
\r
3188 DW Bal,OneMinus,ZBranch,DOES1
\r
3189 DW DoLIT,-22,THROW
\r
3190 DOES1 DW NIP,OnePlus,ZBranch,DOES2
\r
3191 DW DoLIT,-22,THROW
\r
3192 DOES2 DW DoLIT,Pipe,COMPILEComma
\r
3193 DW DoLIT,DoLIST,xtComma,DoLIT,-1,EXIT
\r
3195 ; ELSE Compilation: ( C: orig1 -- orig2 ) \ CORE
\r
3196 ; Run-time: ( -- )
\r
3197 ; Start the false clause in an IF-ELSE-THEN structure.
\r
3198 ; Put the location of new unresolved forward reference orig2
\r
3199 ; onto control-flow stack.
\r
3201 ; : ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMDEDIATE
\r
3203 $COLON IMMED+COMPO+4,'ELSE',ELSEE,_FLINK
\r
3204 DW AHEAD,TwoSWAP,THENN,EXIT
\r
3206 ; ENVIRONMENT? ( c-addr u -- false | i*x true ) \ CORE
\r
3207 ; Environment query.
\r
3210 ; envQList SEARCH-WORDLIST
\r
3211 ; DUP >R IF EXECUTE THEN R> ;
\r
3213 $COLON 12,'ENVIRONMENT?',ENVIRONMENTQuery,_FLINK
\r
3214 DW EnvQList,SEARCH_WORDLIST
\r
3215 DW DUPP,ToR,ZBranch,ENVRN1
\r
3217 ENVRN1 DW RFrom,EXIT
\r
3219 ; EVALUATE ( i*x c-addr u -- j*x ) \ CORE
\r
3220 ; Evaluate the string. Save the input source specification.
\r
3221 ; Store -1 in SOURCE-ID.
\r
3223 ; : EVALUATE SOURCE >R >R >IN @ >R SOURCE-ID >R
\r
3225 ; sourceVar 2! 0 >IN ! interpret
\r
3227 ; R> >IN ! R> R> sourceVar 2! ;
\r
3229 $COLON 8,'EVALUATE',EVALUATE,_FLINK
\r
3230 DW SOURCE,ToR,ToR,ToIN,Fetch,ToR,SOURCE_ID,ToR
\r
3231 DW MinusOne,DoTO,AddrSOURCE_ID
\r
3232 DW SourceVar,TwoStore,Zero,ToIN,Store,Interpret
\r
3233 DW RFrom,DoTO,AddrSOURCE_ID
\r
3234 DW RFrom,ToIN,Store,RFrom,RFrom,SourceVar,TwoStore,EXIT
\r
3236 ; FILL ( c-addr u char -- ) \ CORE
\r
3237 ; Store char in each of u consecutive characters of memory
\r
3238 ; beginning at c-addr.
\r
3240 ; : FILL ROT ROT ?DUP IF 0 DO 2DUP C! CHAR+ LOOP THEN 2DROP ;
\r
3242 $COLON 4,'FILL',FILL,_FLINK
\r
3243 DW ROT,ROT,QuestionDUP,ZBranch,FILL2
\r
3245 FILL1 DW TwoDUP,CStore,CHARPlus,DoLOOP,FILL1
\r
3246 FILL2 DW TwoDROP,EXIT
\r
3248 ; FIND ( c-addr -- c-addr 0 | xt 1 | xt -1) \ SEARCH
\r
3249 ; Search dictionary for a match with the given counted name.
\r
3250 ; Return execution token and -1 or 1 ( IMMEDIATE) if found;
\r
3251 ; c-addr 0 if not found.
\r
3253 ; : FIND DUP COUNT search-word ?DUP IF NIP ROT DROP EXIT THEN
\r
3256 $COLON 4,'FIND',FIND,_FLINK
\r
3257 DW DUPP,COUNT,Search_word,QuestionDUP,ZBranch,FIND1
\r
3258 DW NIP,ROT,DROP,EXIT
\r
3259 FIND1 DW TwoDROP,Zero,EXIT
\r
3261 ; IMMEDIATE ( -- ) \ CORE
\r
3262 ; Make the most recent definition an immediate word.
\r
3264 ; : IMMEDIATE lastName [ =imed ] LITERAL OVER @ OR SWAP ! ;
\r
3266 $COLON 9,'IMMEDIATE',IMMEDIATE,_FLINK
\r
3267 DW LastName,DoLIT,IMMED,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
3269 ; J ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE
\r
3270 ; Push the index of next outer loop.
\r
3272 ; : J rp@ [ 3 CELLS ] LITERAL + @
\r
3273 ; rp@ [ 4 CELLS ] LITERAL + @ + ; COMPILE-ONLY
\r
3275 $COLON COMPO+1,'J',J,_FLINK
\r
3276 DW RPFetch,DoLIT,3*CELLL,Plus,Fetch
\r
3277 DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT
\r
3279 ; LEAVE ( -- ) ( R: loop-sys -- ) \ CORE
\r
3280 ; Terminate definite loop, DO|?DO ... LOOP|+LOOP, immediately.
\r
3282 ; : LEAVE POSTPONE UNLOOP POSTPONE branch
\r
3283 ; HERE rakeVar DUP @ , ! ; COMPILE-ONLY IMMEDIATE
\r
3285 $COLON IMMED+COMPO+5,'LEAVE',LEAVEE,_FLINK
\r
3286 DW DoLIT,UNLOOP,COMPILEComma,DoLIT,Branch,COMPILEComma
\r
3287 DW HERE,RakeVar,DUPP,Fetch,Comma,Store,EXIT
\r
3289 ; LOOP Compilation: ( C: do-sys -- ) \ CORE
\r
3290 ; Run-time: ( -- ) ( R: loop-sys1 -- loop-sys2 )
\r
3291 ; Terminate a DO|?DO ... LOOP structure. Resolve the destination
\r
3292 ; of all unresolved occurences of LEAVE.
\r
3294 ; : LOOP POSTPONE doLOOP rake ; COMPILE-ONLY IMMEDIATE
\r
3296 $COLON IMMED+COMPO+4,'LOOP',LOOPP,_FLINK
\r
3297 DW DoLIT,DoLOOP,COMPILEComma,rake,EXIT
\r
3299 ; LSHIFT ( x1 u -- x2 ) \ CORE
\r
3300 ; Perform a logical left shift of u bit-places on x1, giving x2.
\r
3301 ; Put 0 into the least significant bits vacated by the shift.
\r
3303 ; : LSHIFT ?DUP IF 0 DO 2* LOOP THEN ;
\r
3305 $COLON 6,'LSHIFT',LSHIFT,_FLINK
\r
3306 DW QuestionDUP,ZBranch,LSHIFT2
\r
3308 LSHIFT1 DW TwoStar,DoLOOP,LSHIFT1
\r
3311 ; M* ( n1 n2 -- d ) \ CORE
\r
3312 ; Signed multiply. Return double product.
\r
3314 ; : M* 2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;
\r
3316 $COLON 2,'M*',MStar,_FLINK
\r
3317 DW TwoDUP,XORR,ZeroLess,ToR,ABSS,SWAP,ABSS
\r
3318 DW UMStar,RFrom,ZBranch,MSTAR1
\r
3322 ; MAX ( n1 n2 -- n3 ) \ CORE
\r
3323 ; Return the greater of two top stack items.
\r
3325 ; : MAX 2DUP < IF SWAP THEN DROP ;
\r
3327 $COLON 3,'MAX',MAX,_FLINK
\r
3328 DW TwoDUP,LessThan,ZBranch,MAX1
\r
3332 ; MIN ( n1 n2 -- n3 ) \ CORE
\r
3333 ; Return the smaller of top two stack items.
\r
3335 ; : MIN 2DUP > IF SWAP THEN DROP ;
\r
3337 $COLON 3,'MIN',MIN,_FLINK
\r
3338 DW TwoDUP,GreaterThan,ZBranch,MIN1
\r
3342 ; MOD ( n1 n2 -- n3 ) \ CORE
\r
3343 ; Divide n1 by n2, giving the single cell remainder n3.
\r
3344 ; Returns modulo of floored division in this implementation.
\r
3346 ; : MOD /MOD DROP ;
\r
3348 $COLON 3,'MOD',MODD,_FLINK
\r
3349 DW SlashMOD,DROP,EXIT
\r
3351 ; PICK ( x_u ... x1 x0 u -- x_u ... x1 x0 x_u ) \ CORE EXT
\r
3352 ; Remove u and copy the uth stack item to top of the stack. An
\r
3353 ; ambiguous condition exists if there are less than u+2 items
\r
3354 ; on the stack before PICK is executed.
\r
3356 ; : PICK DEPTH DUP 2 < IF -4 THROW THEN \ stack underflow
\r
3357 ; 2 - OVER U< IF -4 THROW THEN
\r
3358 ; 1+ CELLS sp@ + @ ;
\r
3360 $COLON 4,'PICK',PICK,_FLINK
\r
3361 DW DEPTH,DUPP,DoLIT,2,LessThan,ZBranch,PICK1
\r
3363 PICK1 DW DoLIT,2,Minus,OVER,ULess,ZBranch,PICK2
\r
3365 PICK2 DW OnePlus,CELLS,SPFetch,Plus,Fetch,EXIT
\r
3367 ; POSTPONE ( "<spaces>name" -- ) \ CORE
\r
3368 ; Parse name and find it. Append compilation semantics of name
\r
3369 ; to current definition.
\r
3371 ; : POSTPONE (') 0< IF POSTPONE LITERAL
\r
3372 ; POSTPONE COMPILE, EXIT THEN \ non-IMMEDIATE
\r
3373 ; COMPILE, ; COMPILE-ONLY IMMEDIATE \ IMMEDIATE
\r
3375 $COLON IMMED+COMPO+8,'POSTPONE',POSTPONE,_FLINK
\r
3376 DW ParenTick,ZeroLess,ZBranch,POSTP1
\r
3377 DW LITERAL,DoLIT,COMPILEComma
\r
3378 POSTP1 DW COMPILEComma,EXIT
\r
3380 ; RECURSE ( -- ) \ CORE
\r
3381 ; Append the execution semactics of the current definition to
\r
3382 ; the current definition.
\r
3384 ; : RECURSE bal 1- 2* PICK 1+ IF -22 THROW THEN
\r
3385 ; \ control structure mismatch; colon-sys type is -1
\r
3386 ; bal 1- 2* 1+ PICK \ xt of current definition
\r
3387 ; COMPILE, ; COMPILE-ONLY IMMEDIATE
\r
3389 $COLON IMMED+COMPO+7,'RECURSE',RECURSE,_FLINK
\r
3390 DW Bal,OneMinus,TwoStar,PICK,OnePlus,ZBranch,RECUR1
\r
3391 DW DoLIT,-22,THROW
\r
3392 RECUR1 DW Bal,OneMinus,TwoStar,OnePlus,PICK
\r
3393 DW COMPILEComma,EXIT
\r
3395 ; REPEAT ( C: orig dest -- ) \ CORE
\r
3396 ; Terminate a BEGIN-WHILE-REPEAT indefinite loop. Resolve
\r
3397 ; backward reference dest and forward reference orig.
\r
3399 ; : REPEAT AGAIN THEN ; COMPILE-ONLY IMMEDIATE
\r
3401 $COLON IMMED+COMPO+6,'REPEAT',REPEATT,_FLINK
\r
3402 DW AGAIN,THENN,EXIT
\r
3404 ; RSHIFT ( x1 u -- x2 ) \ CORE
\r
3405 ; Perform a logical right shift of u bit-places on x1, giving x2.
\r
3406 ; Put 0 into the most significant bits vacated by the shift.
\r
3408 ; : RSHIFT ?DUP IF
\r
3409 ; 0 SWAP cell-size-in-bits SWAP -
\r
3410 ; 0 DO 2DUP D+ LOOP
\r
3414 $COLON 6,'RSHIFT',RSHIFT,_FLINK
\r
3415 DW QuestionDUP,ZBranch,RSHIFT2
\r
3416 DW Zero,SWAP,DoLIT,CELLL*8,SWAP,Minus,Zero,DoDO
\r
3417 RSHIFT1 DW TwoDUP,DPlus,DoLOOP,RSHIFT1
\r
3421 ; SLITERAL ( c-addr1 u -- ) \ STRING
\r
3422 ; Run-time ( -- c-addr2 u )
\r
3423 ; Compile a string literal. Return the string on execution.
\r
3425 ; : SLITERAL DUP LITERAL POSTPONE doS"
\r
3426 ; CHARS HERE 2DUP + ALIGNED TO HERE
\r
3427 ; SWAP MOVE ; COMPILE-ONLY IMMEDIATE
\r
3429 $COLON IMMED+COMPO+8,'SLITERAL',SLITERAL,_FLINK
\r
3430 DW DUPP,LITERAL,DoLIT,DoSQuote,COMPILEComma
\r
3431 DW CHARS,HERE,TwoDUP,Plus,ALIGNED,DoTO,AddrHERE
\r
3434 ; S" Compilation: ( "ccc<">" -- ) \ CORE
\r
3435 ; Run-time: ( -- c-addr u )
\r
3436 ; Parse ccc delimetered by " . Return the string specification
\r
3437 ; c-addr u on execution.
\r
3439 ; : S" [CHAR] " PARSE POSTPONE SLITERAL ; COMPILE-ONLY IMMEDIATE
\r
3441 $COLON IMMED+COMPO+2,'S"',SQuote,_FLINK
\r
3442 DW DoLIT,'"',PARSE,SLITERAL,EXIT
\r
3444 ; SM/REM ( d n1 -- n2 n3 ) \ CORE
\r
3445 ; Symmetric divide of double by single. Return remainder n2
\r
3446 ; and quotient n3.
\r
3448 ; : SM/REM 2DUP XOR >R OVER >R >R DUP 0< IF DNEGATE THEN
\r
3450 ; R> 0< IF SWAP NEGATE SWAP THEN
\r
3451 ; R> 0< IF \ negative quotient
\r
3452 ; NEGATE 0 OVER < 0= IF EXIT THEN
\r
3453 ; -11 THROW THEN \ result out of range
\r
3454 ; DUP 0< IF -11 THROW THEN ; \ result out of range
\r
3456 $COLON 6,'SM/REM',SMSlashREM,_FLINK
\r
3457 DW TwoDUP,XORR,ToR,OVER,ToR,ToR,DUPP,ZeroLess
\r
3460 SMREM1 DW RFrom,ABSS,UMSlashMOD
\r
3461 DW RFrom,ZeroLess,ZBranch,SMREM2
\r
3462 DW SWAP,NEGATE,SWAP
\r
3463 SMREM2 DW RFrom,ZeroLess,ZBranch,SMREM3
\r
3464 DW NEGATE,DoLIT,0,OVER,LessThan,ZeroEquals,ZBranch,SMREM4
\r
3466 SMREM3 DW DUPP,ZeroLess,ZBranch,SMREM5
\r
3467 SMREM4 DW DoLIT,-11,THROW
\r
3469 ; SPACES ( n -- ) \ CORE
\r
3470 ; Send n spaces to the output device if n is greater than zero.
\r
3472 ; : SPACES DUP 0 > IF 0 DO SPACE LOOP EXIT THEN DROP;
\r
3474 $COLON 6,'SPACES',SPACES,_FLINK
\r
3475 DW DUPP,Zero,GreaterThan,ZBranch,SPACES1
\r
3477 SPACES2 DW SPACE,DoLOOP,SPACES2
\r
3479 SPACES1 DW DROP,EXIT
\r
3481 ; TO Interpretation: ( x "<spaces>name" -- ) \ CORE EXT
\r
3482 ; Compilation: ( "<spaces>name" -- )
\r
3483 ; Run-time: ( x -- )
\r
3484 ; Store x in name.
\r
3486 ; : TO ' ?call DUP IF \ should be call-doCONST
\r
3487 ; ['] doVALUE = \ verify VALUE marker
\r
3489 ; IF POSTPONE doTO , EXIT THEN
\r
3492 ; -32 THROW ; IMMEDIATE \ invalid name argument (e.g. TO xxx)
\r
3494 $COLON IMMED+2,'TO',TO,_FLINK
\r
3495 DW Tick,QCall,DUPP,ZBranch,TO1
\r
3496 DW DoLIT,DoVALUE,Equals,ZBranch,TO1
\r
3497 DW STATE,Fetch,ZBranch,TO2
\r
3498 DW DoLIT,DoTO,COMPILEComma,Comma,EXIT
\r
3500 TO1 DW DoLIT,-32,THROW
\r
3502 ; U. ( u -- ) \ CORE
\r
3503 ; Display u in free field format followed by space.
\r
3507 $COLON 2,'U.',UDot,_FLINK
\r
3510 ; UNTIL ( C: dest -- ) \ CORE
\r
3511 ; Terminate a BEGIN-UNTIL indefinite loop structure.
\r
3513 ; : UNTIL IF -22 THROW THEN \ control structure mismatch; dest type is 0
\r
3514 ; POSTPONE 0branch , bal- ; COMPILE-ONLY IMMEDIATE
\r
3516 $COLON IMMED+COMPO+5,'UNTIL',UNTIL,_FLINK
\r
3518 DW DoLIT,-22,THROW
\r
3519 UNTIL1 DW DoLIT,ZBranch,COMPILEComma,Comma,BalMinus,EXIT
\r
3521 ; VALUE ( x "<spaces>name" -- ) \ CORE EXT
\r
3522 ; name Execution: ( -- x )
\r
3523 ; Create a value object with initial value x.
\r
3525 ; : VALUE bal IF -29 THROW THEN \ compiler nesting
\r
3526 ; head, ['] doVALUE xt, DROP
\r
3527 ; , linkLast ; \ store x and link VALUE word to current wordlist
\r
3529 $COLON 5,'VALUE',VALUE,_FLINK
\r
3530 DW Bal,ZBranch,VALUE1
\r
3531 DW DoLIT,-29,THROW
\r
3532 VALUE1 DW HeadComma,DoLIT,DoVALUE,xtComma,DROP
\r
3533 DW Comma,LinkLast,EXIT
\r
3535 ; VARIABLE ( "<spaces>name" -- ) \ CORE
\r
3536 ; name Execution: ( -- a-addr )
\r
3537 ; Parse a name and create a variable with the name.
\r
3538 ; Resolve one cell of data space at an aligned address.
\r
3539 ; Return the address on execution.
\r
3541 ; : VARIABLE bal IF -29 THROW THEN \ compiler nesting
\r
3542 ; head, ['] doVAR xt, DROP
\r
3543 ; HERE CELL+ TO HERE linkLast ;
\r
3545 $COLON 8,'VARIABLE',VARIABLE,_FLINK
\r
3546 DW Bal,ZBranch,VARIA1
\r
3547 DW DoLIT,-29,THROW
\r
3548 VARIA1 DW HeadComma,DoLIT,DoVAR,xtComma,DROP
\r
3549 DW HERE,CELLPlus,DoTO,AddrHERE,LinkLast,EXIT
\r
3551 ; WHILE ( C: dest -- orig dest ) \ CORE
\r
3552 ; Put the location of a new unresolved forward reference orig
\r
3553 ; onto the control flow stack under the existing dest. Typically
\r
3554 ; used in BEGIN ... WHILE ... REPEAT structure.
\r
3556 ; : WHILE POSTPONE IF 2SWAP ; COMPILE-ONLY IMMEDIATE
\r
3558 $COLON IMMED+COMPO+5,'WHILE',WHILEE,_FLINK
\r
3559 DW IFF,TwoSWAP,EXIT
\r
3561 ; WORD ( char "<chars>ccc<char>" -- c-addr ) \ CORE
\r
3562 ; Skip leading delimeters and parse a word. Return the address
\r
3563 ; of a transient region containing the word as counted string.
\r
3565 ; : WORD skipPARSE HERE pack" DROP HERE ;
\r
3567 $COLON 4,'WORD',WORDD,_FLINK
\r
3568 DW SkipPARSE,HERE,PackQuote,DROP,HERE,EXIT
\r
3570 ; ['] Compilation: ( "<spaces>name" -- ) \ CORE
\r
3571 ; Run-time: ( -- xt )
\r
3572 ; Parse name. Return the execution token of name on execution.
\r
3574 ; : ['] ' POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE
\r
3576 $COLON IMMED+COMPO+3,"[']",BracketTick,_FLINK
\r
3577 DW Tick,LITERAL,EXIT
\r
3579 ; [CHAR] Compilation: ( "<spaces>name" -- ) \ CORE
\r
3580 ; Run-time: ( -- char )
\r
3581 ; Parse name. Return the value of the first character of name
\r
3584 ; : [CHAR] CHAR POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE
\r
3586 $COLON IMMED+COMPO+6,'[CHAR]',BracketCHAR,_FLINK
\r
3587 DW CHAR,LITERAL,EXIT
\r
3589 ; \ ( "ccc<eol>" -- ) \ CORE EXT
\r
3590 ; Parse and discard the remainder of the parse area.
\r
3592 ; : \ SOURCE >IN ! DROP ; IMMEDIATE
\r
3594 $COLON IMMED+1,'\',Backslash,_FLINK
\r
3595 DW SOURCE,ToIN,Store,DROP,EXIT
\r
3597 ; Optional Facility words
\r
3599 ; EKEY? ( -- flag ) \ FACILITY EXT
\r
3600 ; If a keyboard event is available, return true.
\r
3602 ; : EKEY? 'ekey? EXECUTE ;
\r
3604 $COLON 5,'EKEY?',EKEYQuestion,_FLINK
\r
3605 DW TickEKEYQ,EXECUTE,EXIT
\r
3607 ; EMIT? ( -- flag ) \ FACILITY EXT
\r
3608 ; flag is true if the user output device is ready to accept data
\r
3609 ; and the execution of EMIT in place of EMIT? would not have
\r
3610 ; suffered an indefinite delay. If device state is indeterminate,
\r
3613 ; : EMIT? 'emit? EXECUTE ;
\r
3615 $COLON 5,'EMIT?',EMITQuestion,_FLINK
\r
3616 DW TickEMITQ,EXECUTE,EXIT
\r
3618 ;===============================================================
\r
3620 LASTENV EQU _ENVLINK-0
\r
3621 LASTSYSTEM EQU _SLINK-0 ;last SYSTEM word name address
\r
3622 LASTFORTH EQU _FLINK-0 ;last FORTH word name address
\r
3624 CTOP EQU $-0 ;next available memory in dictionary
\r
3629 ;===============================================================
\r
public / hf86v099.git / blob