1 TITLE hForth 8086 ROM Model
\r
3 PAGE 62,132 ;62 lines per page, 132 characters per line
\r
5 ;===============================================================
\r
7 ; hForth 8086 ROM model v0.9.9 by Wonyong Koh, 1997
\r
11 ; Fix bugs reported by Mr. Neal Crook. Thank Neal Crook.
\r
12 ; Fix Forth definition of ACCEPT.
\r
13 ; Add high-level definition of 2DROP and 2DUP.
\r
14 ; Remove superfluous THEN in optiCOMPILE,ACCEPT, and UM/MOD.
\r
15 ; LITERAL in the high-level definitions of doubleAlso, singleOnly,
\r
16 ; and SLITERAL should have been 'POSTPONE LITERAL'.
\r
17 ; S" in the high-level definitions of ABORT" should have been
\r
19 ; The hith-level definition of REPEAT should have been
\r
20 ; 'POSTPONE AGAIN POSTPONE THEN'.
\r
21 ; Add COMSTANT word 'sysVar00'.
\r
23 ; Mr. Kwon Hyuk Kun reported several bugs. Thank Mr. Kwon.
\r
24 ; Fix REFILL . 'Fetch' was missing in DW statement. Thank Kwon Hyuk Kun.
\r
25 ; Fix PARSE . It should have been 'CHARS OVER +' to calculate
\r
26 ; c_addr+u*chars from 'c_addr u'.
\r
27 ; Add CHARS in the definition of 'head,'.
\r
28 ; It is more convenient to use up-growing stack for some
\r
29 ; microprocessors such as 8051 family. I, J, and DEPTH
\r
30 ; are now processor-dependent words.
\r
32 ; Introduce MaxCountedString.
\r
34 ; Replace 'EKEY max-char AND' with KEY in ACCEPT.
\r
36 ; Fix SPACES. Thank Benjamin Hoyt.
\r
40 ; Split environmental variable systemID into CPU and Model.
\r
42 ; Add Neal Crook's microdebugger and comments on assembly definitions.
\r
44 ; Add $THROWMSG macro and revise accordingly.
\r
46 ; Remove 'NullString' from assembly source.
\r
50 ; Revise PICK to catch stack underflow.
\r
52 ; Implement control-flow stack on data stack. Control-flow stack
\r
53 ; item consists of two data stack items, one for value
\r
54 ; and one for the type of control-flow stack item.
\r
56 ; control-flow stack item data stack representation
\r
57 ; dest control-flow_destination 0
\r
58 ; orig control-flow_origin 1
\r
59 ; of-sys OF_origin 2
\r
60 ; case-sys x (any value) 3
\r
61 ; do-sys ?DO_origin DO_destination
\r
62 ; colon-sys xt_of_current_definition -1
\r
65 ; 'bal' is now the depth of control-flow stack.
\r
67 ; Introduce 'notNONAME?'
\r
68 ; Add 'bal+' and 'bal-'. Drop 'orig+', 'orig-', 'dest+', 'dest-',
\r
69 ; 'dosys+', and 'dosys-'.
\r
70 ; Revise ':NONAME', ':', ';', 'linkLast', 'head,', RECURSE, 'DOES>',
\r
71 ; CONSTANT, CREATE, VALUE, VARIABLE, and QUIT.
\r
72 ; This change makes RECURSE work properly in ':NONAME ... ;'
\r
73 ; and '... DOES> ... ;'.
\r
74 ; Revise 'rake', AGAIN, AHEAD, IF, THEN, +LOOP, BEGIN, DO, ELSE, LOOP,
\r
78 ; Revise SLITERAL, '."', 'doS"' to allow a string larger than
\r
80 ; Revise $INSTR and remove 'do."'.
\r
85 ; Changes from 0.9.7
\r
88 ; Revise FM/MOD and SM/REM to catch result-out-of-range error in
\r
89 ; '80000. 2 FM/MOD'.
\r
91 ; Rename 'x,' to 'code,'.
\r
93 ; Rename non-Standard 'parse-word' to PARSE-WORD.
\r
95 ; Drop '?doLIST' and revise 'optiCOMPILE,'.
\r
97 ; Changes from 0.9.6
\r
100 ; Make 'lastXT' VALUE word.
\r
102 ; Revise doCREATE, CREATE, pipe, DOES>, and >BODY.
\r
103 ; 'pipe' is no longer processor-dependent.
\r
105 ; Move ERASE to ASM8086.F.
\r
107 ; Changes from 0.9.5
\r
110 ; Fix MOVE to check whether 'u' is 0.
\r
113 ; Revise 'orig+', 'dosys+', etc to catch 'DO IF LOOP' mismatch.
\r
115 ; Changes from 0.9.2
\r
118 ; Move terminal input buffer (TIB) below the name space to
\r
119 ; prevent accidental overwriting it. It was too close
\r
120 ; to HERE and might be overwritten by ALLOT or , .
\r
121 ; TIB address is only known to REFILL . Revise REFILL .
\r
122 ; Move PAD also with TIB.
\r
124 ; Revise EVALUATE for FILE words.
\r
126 ; Chris Jakeman kindly report several bugs and made suggestions.
\r
127 ; CHARS is added in the definition of /STRING .
\r
128 ; '1chars/' is introduced to convert # address units to # chars.
\r
129 ; 'skipPARSE' is introduced. 'parse-word' and 'WORD' are
\r
130 ; redefined using it.
\r
132 ; Changes from 0.9.0
\r
135 ; Make 'cpVar', 'npVar' and 'hereVar' VALUE type.
\r
136 ; Make SOURCE-ID VALUE type, replace TOsource-id with
\r
137 ; "TO SOURCE-ID" and remove TOsource-id .
\r
139 ; Make 'ekey? , 'ekey , 'emit? , 'emit , 'init-i/o , 'prompt
\r
140 ; and 'boot VALUE type and replace "'emit @ EXECUTE"
\r
141 ; with "'emit EXECUTE".
\r
143 ; Add doVALUE , doTO , VALUE and TO .
\r
144 ; Replace 'DUP' with '?DUP' in the definition of "(')".
\r
145 ; Replace 'CREATEd' with 'doCREATE' and remove CREATEd .
\r
147 ; Move "'init-i/o @ EXECUTE" from QUIT to THROW according
\r
148 ; to the suggestion from Chris Jakeman.
\r
150 ; Revise $ENVIR for portability.
\r
151 ; 'CR' is a system dependent definition.
\r
153 ; Rename '.ok' and '.OKay' as '.prompt' and '.ok' respectively.
\r
157 ;; hForth ROM ¡¡
\95I·e ¸b·e
\90\81¸w ¯¡¯aÉQµA xÂ
\81´á ¬é
\89\81\96A´ö¯s
\93¡
\94a. ËbÓ¡
\r
158 ;; ·¡
\88õ·e ROM
\94\81¯¥
\90i´a
\88a»¡ ´g
\93e RAM(non-volatile RAM, NVRAM)·¡
\90a
\r
159 ;; ROM µA£I
\9dA·¡Èá
\9fi ³a
\93e ÂA¡Ðe·
\81 \88\81¤i ¯¡¯aÉQµA x
\89A
\r
160 ;; Ž
\89\81\96A´ö¯s
\93¡
\94a.
\88\81¤iÐa
\93e
\95·´eµA
\93e "ROM"·
\81 \90\81¶w·i
\89¡Ã© ®
\81 ·¶
\89¡
\r
161 ;;
\88\81¤i·¡
\8f{
\90a¡e ·¡ "ROM"·
\81 \90\81¶w·i ¯©¹A ¬a¶w
\96I ¯¡¯aÉQ·
\81 »¥¼a ROMµA
\r
162 ;; µ«
\8b© ®
\81 ·¶¯s
\93¡
\94a. µÅ¬÷
\96E ¯¡¯aÉQµA Í¡¯a ÉB¯aËa É·µb
\8b¡
\88a
\r
163 ;; Ï©¶a´ô
\94a¡e ·¡
\9fq ¸a
\9f¡
\93e µÅ¬÷
\96E ¯¡¯aÉQµA Í¡Ðq
\96I 쩦a
\88a ´ô¯s
\93¡
\94a.
\r
164 ;; ANS Í¡¯a Îaº
\85·
\81 ³¡´u
\90{ i(Core wordset)·i ¡¡
\96\81 Í¡ÐqÐe Å¡
\97a
\r
165 ;; ¸a
\9f¡·
\81 Ça
\8b¡
\93e 6 K¤a·¡Ëa·¡
\89¡ µa
\8b¡µA OPTIONAL.FµA
\97i´á ·¶
\93e
\r
166 ;; WORDSµÁ HEXµÁ SEE
\97w·
\81 \90{ i(Optional wordset)·i
\94áÐa¡e Å¡
\97a
\r
167 ;; ¸a
\9f¡
\93e 8 K¤a·¡Ëa·³
\93¡
\94a. hForth RAM ¡¡
\95IµA
\93e ÂA¡ 1 KB·
\81 RAM·¡
\r
170 ;; ANS Í¡¯a Îaº
\85·e Í¡¯a ¬a¸å·i Å¡
\97a ¸a
\9f¡µÁ ·¡
\9fq ¸a
\9f¡µÁ ¸a
\9ea ¸a
\9f¡
\9d¡
\r
171 ;;
\90a
\92\81´ö¯s
\93¡
\94a. hForth ROM ¡¡
\95I·¡ ¯¡¸bÐa¡e Å¡
\97a ¸a
\9f¡
\93e ROM·
\81 ´a
\9c\81\r
172 ;; ¦
\81¦
\85µA, ·¡
\9fq ¸a
\9f¡
\93e ROM·
\81 ¶á ¦
\81¦
\85µA, ¸a
\9ea ¸a
\9f¡
\93e RAMµA ¸a
\9f¡¸s
\89¡
\r
173 ;; ·¶¯s
\93¡
\94a. "ROM"µA ³i ®
\81 ·¶
\94a¡e ¬
\81 \90{ i
\97i·
\81 Å¡
\97aµÁ ·¡
\9fq·e ROM·
\81\r
174 ;; ´a
\9c\81µÁ ¶áµA
\98a
\9d¡
\98a
\9d¡
\97i´á
\88s
\93¡
\94a. "ROM"µA ³i ®
\81 ´ô
\94a¡e ¬
\81 \90{ i·
\81\r
175 ;; Å¡
\97aµÁ ¸a
\9ea
\93e RAM·
\81 ´a
\9c\81 ¦
\81¦
\85µA ·¡
\9fq·e RAM·
\81 ¶á ¦
\81¦
\85·i Àa»¡Ða
\89A
\r
178 ;; RAM
\89Á ROM
\90{ i·i °á¬á ¸a
\9ea
\89·
\88e·¡ RAMµA ·¶
\89A Ða
\88á
\90a ROMµA ·¶
\89A
\r
179 ;; Ði ®
\81 ·¶¯s
\93¡
\94a.
\r
181 ;; ROM CREATE TTABLE 1 , 2 , 3 ,
\r
183 ;; ·e ROM ¸a
\9f¡µA £¡
\9f¡
\88t·¡ ¸÷Ð
\81»¥ Îa TTABLE·i e
\97i
\89¡
\r
185 ;; RAM CREATE AARRAY 10 CELLS ALLOT
\r
187 ;; ·e RAM ¸a
\9f¡µA
\88t·i °á
\90ý·i ®
\81 ·¶
\93e 10 Äe ¤
\81µi·i e
\97s
\93¡
\94a.
\r
189 ;; hForth
\93e 1990
\91eµA Bill MuenchµÁ Dr. C. H. Ting·¡ ¤iÎaÐe eForth
\9fi
\r
190 ;; ¤aÈw·a
\9d¡ e
\97i´á¬á ¥¥
\9c\81·
\81 eForth·
\81 Ëb»·
\97i·i
\8ba
\94\81\9d¡ ¬i
\9dv¯s
\93¡
\94a.
\r
191 ;; ´a
\9c\81\93e 8086 eForth ¤aÈw¥¥µA¬á
\98a µ¥
\88õ·³
\93¡
\94a.
\r
193 ;; >
\88b
\88b·
\81 a·¡Ça
\9d¡Ïa
\9d¡A¬áµA xÂ
\85 ¡y ´e
\96A
\93e CODE
\90{ i
\97i
\89Á ¡¡
\97e
\r
194 ;; > a·¡Ça
\9d¡Ïa
\9d¡A¬áµA
\89·É··¥
\89¡
\8bs (high level)
\90{ i
\97i
\9d¡
\r
195 ;; > ·¡
\9e\81´á¹a ·¶¯s
\93¡
\94a.
\r
196 ;; > ¶¥¯¡Å¡
\97a
\93e MASM ´áQ§i
\9cá¶w·³
\93¡
\94a.
\r
197 ;; > »¢¸ó
\8eÅ (direct threaded) ¤w¤ó·i ³s
\93¡
\94a.
\r
198 ;; > ¬a¸å·
\81 Å¡
\97aµÁ ·¡
\9fq·¡ ¡A¡¡
\9f¡µA
\98a
\9d¡ ¸a
\9f¡Ðs
\93¡
\94a.
\r
199 ;; > ·³Â
\89\9db·e
\88a
\9f¡Ç±
\90{ i·i É·Ða
\89¡ º
\81 ÄñÏAÈá(host computer)
\9fi
\r
200 ;; >
\94e i
\8b¡µÁ Ìa·© ·³Â
\89\9dbµA ·¡¶wÐs
\93¡
\94a.
\r
201 ;; > ¹A´e
\96E £¡
\8a\82 Îaº
\85 Í¡¯a(ANS Forth)·
\81 ¤wз·i
\98a
\9cv¯s
\93¡
\94a.
\r
202 ;; > Ëb¸÷Ðe a·¡Ça
\9d¡Ïa
\9d¡A¬áµA xÂ
\81´á ÂA¸âÑÁÐa
\8b¡
\88a ®ó¯s
\93¡
\94a.
\r
204 ;; ·¡
\88õ
\97i·e
\8ba
\94\81\9d¡ hForth·
\81 ¬÷»©·³
\93¡
\94a.
\8ba
\9f¡
\89¡ hForth
\93e ANS Forth
\r
205 ;; Îaº
\85·
\81 ¤wз e·i
\98a
\9fa
\93e
\88õ·¡ ´a
\93¡
\9ca ANS Í¡¯a Îaº
\85·
\81 ¶a
\8a\81\r
206 ;; ¹¡
\88å·i ¡¡
\96\81 e¹¢Ða
\93e ANS Îaº
\85 Í¡¯a ¯¡¯aÉQ·³
\93¡
\94a.
\r
209 ; hForth ROM model is designed for small embedded system.
\r
210 ; Especially it is designed for a minimal development system which
\r
211 ; uses non-volatile RAM(NVRAM) or ROM emulator in place of ROM so
\r
212 ; that the content of ROM can be changed during development phase
\r
213 ; and can be copied to real ROM later for production system. Name
\r
214 ; space does not need to be included in final system if the system
\r
215 ; does not require Forth text interpreter. hForth occupies little
\r
216 ; more than 6 KB of code space for CORE words only and about 8 KB
\r
217 ; with additional words in OPTIONAL.F such as WORDS, HEX, SEE,
\r
218 ; etc. hForth ROM model requires at lease 1 KB of RAM.
\r
220 ; ANS Forth Standard divide Forth dictionary into code, name, and
\r
221 ; data space. When hForth ROM model starts, the code space resides
\r
222 ; at bottom of ROM, name space at top of ROM, and data space in
\r
223 ; RAM address space. Code and name parts of new definitions will
\r
224 ; split into proper spaces if "ROM" is writable. If "ROM" is not
\r
225 ; writable, code and data part of new definitions goes into bottom
\r
226 ; of RAM and name part of new definitions goes into top of RAM.
\r
228 ; You can use the words 'RAM' and 'ROM' to switch data space
\r
229 ; between RAM and ROM address space.
\r
231 ; ROM CREATE TTABLE 1 , 2 , 3 ,
\r
233 ; will make a preset table in ROM address space while
\r
235 ; RAM CREATE AARRAY 10 CELLS ALLOT
\r
237 ; will make an array of 10 cells where you write values into.
\r
239 ; hForth is based on eForth model published by Mr. Bill Muench and
\r
240 ; Dr. C. H. Ting in 1990. The key features of the original eForth
\r
241 ; model is preserved. Following is quoted from the orginal 8086
\r
244 ; > small machine dependent kernel and portable high level code
\r
245 ; > source code in the MASM format
\r
246 ; > direct threaded code
\r
247 ; > separated code and name dictionaries
\r
248 ; > simple vectored terminal and file interface to host computer
\r
249 ; > aligned with the proposed ANS Forth Standard
\r
250 ; > easy upgrade path to optimize for specific CPU
\r
252 ; These are also the characteristics of hForth. For better, hForth
\r
253 ; is ANS Forth system which complies the Standard, not just
\r
254 ; alignes with the Standard. Colon definitions for all high level
\r
255 ; words are also given as comments in TASM source code. The source
\r
256 ; code would be a working example for a Forth student.
\r
258 ;===============================================================
\r
260 ; 8086/8 register usages
\r
261 ; Single segment model. CS, DS and SS must be same.
\r
262 ; The direction bit must be cleared before returning to Forth
\r
263 ; interpreter(CLD).
\r
264 ; SP: data stack pointer
\r
265 ; BP: return stack pointer
\r
266 ; SI: Forth virtual machine instruction pointer
\r
267 ; BX: top of data stack item
\r
268 ; All other registers are free.
\r
270 ; Structure of a task
\r
271 ; userP points follower.
\r
272 ; //userP//<return_stack//<data_stack//
\r
273 ; //user_area/user1/taskName/throwFrame/stackTop/status/follower/sp0/rp0
\r
275 ;===============================================================
\r
278 ; Assembly Constants
\r
284 CHARR EQU 1 ;byte size of a character
\r
285 CELLL EQU 2 ;byte size of a cell
\r
286 MaxCountedString EQU 0FFh ;max char length of counted string
\r
287 MaxChar EQU 0FFh ;Extended character set
\r
288 ; Use 07Fh for ASCII only
\r
289 MaxSigned EQU 07FFFh ;max value of signed integer
\r
290 MaxUnsigned EQU 0FFFFh ;max value of unsigned integer
\r
291 MaxNegative EQU 8000h ;max value of negative integer
\r
294 PADSize EQU 134 ;PAD area size
\r
295 RTCells EQU 64 ;return stack size
\r
296 DTCells EQU 256 ;data stack size
\r
298 BASEE EQU 10 ;default radix
\r
299 OrderDepth EQU 10 ;depth of search order stack
\r
300 MaxWLISTS EQU 20 ;maximum number of wordlists
\r
301 ; 2 is used by the system
\r
302 ; 18 is available to Forth programs
\r
304 COMPO EQU 020h ;lexicon compile only bit
\r
305 IMMED EQU 040h ;lexicon immediate bit
\r
306 MASKK EQU 1Fh ;lexicon bit mask
\r
307 ;extended character set
\r
308 ;maximum name length = 1Fh
\r
310 BKSPP EQU 8 ;backspace
\r
312 LFF EQU 10 ;line feed
\r
313 CRR EQU 13 ;carriage return
\r
314 DEL EQU 127 ;delete
\r
316 CALLL EQU 0E890h ;NOP CALL opcodes
\r
318 ; Memory allocation for writable ROM
\r
319 ; ROMbottom||code>WORDworkarea|--//--|PAD|TIB|reserved<name||ROMtop
\r
320 ; RAMbottom||variable>--//--<sp|rp||RAMtop
\r
321 ; Memory allocation for unwritable ROM
\r
322 ; ROMbottom||initial-code>--//--<initial-name||ROMtop
\r
323 ; RAMbottom||code/data>WORDworkarea|--//--|PAD|TIB|reserved<name|sp|rp||RAMtop
\r
325 RAM0 EQU 0C000h ;bottom of RAM memory ******
\r
326 RAMEnd EQU 0FFFEh ;top of RAM memory ******
\r
328 ROM0 EQU 0 ;bottom of ROM memory ******
\r
329 ROMEnd EQU 08000h ;end of ROM memory ******
\r
331 COLDD EQU 00100h ;cold start vector ******
\r
333 Trapfpc EQU RAMEnd ;reserve a cell for microdebugger
\r
334 RPP EQU RAMEnd-CELLL ;start of return stack (RP0)
\r
335 SPP EQU RPP-RTCells*CELLL ;start of data stack (SP0)
\r
336 RAMT0 EQU SPP-DTCells*CELLL ;top of free RAM area
\r
338 ; Initialize assembly variables
\r
340 _SLINK = 0 ;force a null link
\r
341 _FLINK = 0 ;force a null link
\r
342 _ENVLINK = 0 ;farce a null link
\r
343 _NAME = ROMEnd ;initialize name pointer
\r
344 _VAR = RAM0 ;variable space pointer
\r
345 _THROW = 0 ;current throw str addr offset
\r
351 ; Adjust an address to the next cell boundary.
\r
354 EVEN ;for 16 bit systems
\r
357 ; Add a name to name space of dictionary.
\r
359 $STR MACRO LABEL,STRING
\r
363 _NAME = _NAME-(_LEN/CELLL+1)*CELLL
\r
367 ORG _CODE ;restore code pointer
\r
370 ; Add a THROW message in name space. THROW messages won't be
\r
371 ; needed if target system do not need names of Forth words.
\r
373 $THROWMSG MACRO STRING
\r
377 _NAME = _NAME-(_LEN/CELLL+1)*CELLL
\r
380 _THROW = _THROW + CELLL
\r
381 ORG AddrTHROWMsgTbl - _THROW
\r
386 ; Compile a code definition header.
\r
388 $CODE MACRO LEX,NAME,LABEL,LINK
\r
389 $ALIGN ;force to cell boundary
\r
390 LABEL: ;assembly label
\r
391 _CODE = $ ;save code pointer
\r
392 _LEN = (LEX AND MASKK)/CELLL ;string cell count, round down
\r
393 _NAME = _NAME-((_LEN+3)*CELLL) ;new header on cell boundary
\r
394 ORG _NAME ;set name pointer
\r
395 DW _CODE,LINK ;token pointer and link
\r
396 LINK = $ ;link points to a name string
\r
397 DB LEX,NAME ;name string
\r
398 ORG _CODE ;restore code pointer
\r
401 ; Compile a colon definition header.
\r
403 $COLON MACRO LEX,NAME,LABEL,LINK
\r
404 $CODE LEX,NAME,LABEL,LINK
\r
405 NOP ;align to cell boundary
\r
406 CALL DoLIST ;include CALL doLIST
\r
409 ; Compile a system CONSTANT header.
\r
411 $CONST MACRO LEX,NAME,LABEL,VALUE,LINK
\r
412 $CODE LEX,NAME,LABEL,LINK
\r
418 ; Compile a system VALUE header.
\r
420 $VALUE MACRO LEX,NAME,LABEL,LINK
\r
421 $CODE LEX,NAME,LABEL,LINK
\r
428 ; Compile a system VARIABLE header.
\r
430 $VAR MACRO LEX,NAME,LABEL,LINK
\r
431 $CODE LEX,NAME,LABEL,LINK
\r
435 _VAR = _VAR +CELLL ;update variable area offset
\r
438 ; Compile a system USER header.
\r
440 $USER MACRO LEX,NAME,LABEL,OFFSET,LINK
\r
441 $CODE LEX,NAME,LABEL,LINK
\r
447 ; Compile an inline string.
\r
451 _LEN = $ ;save address of count
\r
454 DB STRNG ;store string
\r
455 _CODE = $ ;save code pointer
\r
456 ORG _LEN ;point to count byte
\r
457 DW _CODE-_LEN-2*CELLL ;set count
\r
458 ORG _CODE ;restore code pointer
\r
462 ; Compile a environment query string header.
\r
464 $ENVIR MACRO LEX,NAME
\r
465 $ALIGN ;force to cell boundary
\r
466 _CODE = $ ;save code pointer
\r
467 _LEN = (LEX AND MASKK)/CELLL ;string cell count, round down
\r
468 _NAME = _NAME-((_LEN+3)*CELLL) ;new header on cell boundary
\r
469 ORG _NAME ;set name pointer
\r
470 DW _CODE,_ENVLINK ;token pointer and link
\r
471 _ENVLINK = $ ;link points to a name string
\r
472 DB LEX,NAME ;name string
\r
478 ; Assemble inline direct threaded code ending.
\r
481 ; JMP uDebug ;activate to use microdebugger
\r
482 LODSW ;next code address into AX
\r
483 JMP AX ;jump directly to code address
\r
487 ;===============================================================
\r
490 ; Main entry points and COLD start data
\r
494 ASSUME CS:MAIN,DS:MAIN,SS:MAIN
\r
496 ORG COLDD ;beginning of cold boot
\r
498 ORIG: CLD ;direction flag, increment
\r
500 MOV DS,AX ;DS is same as CS
\r
501 CLI ;disable interrupts, old 808x CPU bug
\r
502 MOV SS,AX ;SS is same as CS
\r
503 MOV SP,SPP ;initialize SP
\r
504 STI ;enable interrupts
\r
505 MOV BP,RPP ;initialize RP
\r
508 MOV [DI],AX ;initialize for microdebugger
\r
510 MOV Redirect1stQ,AX ;MS-DOS only
\r
512 JMP COLD ;to high level cold start
\r
516 $STR ModelStr,'ROM Model'
\r
517 $STR VersionStr,'0.9.9'
\r
519 ; COLD start moves the following to system variables.
\r
520 ; MUST BE IN SAME ORDER AS SYSTEM VARIABLES.
\r
522 $ALIGN ;align to cell boundary
\r
523 UZERO DW RXQ ;'ekey?
\r
527 DW Set_IO ;'init-i/o
\r
533 DW AddrRAMB ;HereVar points RAM space.
\r
534 DW OptiCOMPILEComma ;'doWord nonimmediate word - compilation
\r
535 DW EXECUTE ;nonimmediate word - interpretation
\r
536 DW DoubleAlsoComma ;not found word - compilateion
\r
537 DW DoubleAlso ;not found word - interpretation
\r
538 DW EXECUTE ;immediate word - compilation
\r
539 DW EXECUTE ;immediate word - interpretation
\r
549 DW FORTH_WORDLISTAddr ;search order stack
\r
550 DW NONSTANDARD_WORDLISTAddr
\r
551 DW (OrderDepth-2) DUP (0)
\r
552 DW FORTH_WORDLISTAddr ;current pointer
\r
553 DW LASTFORTH ;FORTH-WORDLIST
\r
554 DW NONSTANDARD_WORDLISTAddr ;wordlist link
\r
555 DW FORTH_WORDLISTName ;name of the WORDLIST
\r
556 DW LASTSYSTEM ;NONSTANDARD-WORDLIST
\r
557 DW 0 ;wordlist link
\r
558 DW NONSTANDARD_WORDLISTName ;name of the WORDLIST
\r
559 DW 3*(MaxWLISTS-2) DUP (0) ;wordlist area
\r
560 DW LASTENV ;envQList
\r
561 DW SysUserP ;user pointer
\r
562 DW SysUserP ;system task's tid
\r
564 DW SystemTaskName ;taskName
\r
568 DW SysStatus ;follower
\r
569 DW SPP ;system task's sp0
\r
570 DW RPP ;system task's rp0
\r
573 ; THROW code messages resides in top of name space. Messages must be
\r
574 ; placed before any Forth words were defined.
\r
579 _NAME = _NAME - 58*CELLL ;number of throw messages = 58
\r
582 $THROWMSG 'ABORT' ;-01
\r
583 $THROWMSG 'ABORT"' ;-02
\r
584 $THROWMSG 'stack overflow' ;-03
\r
585 $THROWMSG 'stack underflow' ;-04
\r
586 $THROWMSG 'return stack overflow' ;-05
\r
587 $THROWMSG 'return stack underflow' ;-06
\r
588 $THROWMSG 'do-loops nested too deeply during execution' ;-07
\r
589 $THROWMSG 'dictionary overflow' ;-08
\r
590 $THROWMSG 'invalid memory address' ;-09
\r
591 $THROWMSG 'division by zero' ;-10
\r
592 $THROWMSG 'result out of range' ;-11
\r
593 $THROWMSG 'argument type mismatch' ;-12
\r
594 $THROWMSG 'undefined word' ;-13
\r
595 $THROWMSG 'interpreting a compile-only word' ;-14
\r
596 $THROWMSG 'invalid FORGET' ;-15
\r
597 $THROWMSG 'attempt to use zero-length string as a name' ;-16
\r
598 $THROWMSG 'pictured numeric output string overflow' ;-17
\r
599 $THROWMSG 'parsed string overflow' ;-18
\r
600 $THROWMSG 'definition name too long' ;-19
\r
601 $THROWMSG 'write to a read-only location' ;-20
\r
602 $THROWMSG 'unsupported operation (e.g., AT-XY on a too-dumb terminal)' ;-21
\r
603 $THROWMSG 'control structure mismatch' ;-22
\r
604 $THROWMSG 'address alignment exception' ;-23
\r
605 $THROWMSG 'invalid numeric argument' ;-24
\r
606 $THROWMSG 'return stack imbalance' ;-25
\r
607 $THROWMSG 'loop parameters unavailable' ;-26
\r
608 $THROWMSG 'invalid recursion' ;-27
\r
609 $THROWMSG 'user interrupt' ;-28
\r
610 $THROWMSG 'compiler nesting' ;-29
\r
611 $THROWMSG 'obsolescent feature' ;-30
\r
612 $THROWMSG '>BODY used on non-CREATEd definition' ;-31
\r
613 $THROWMSG 'invalid name argument (e.g., TO xxx)' ;-32
\r
614 $THROWMSG 'block read exception' ;-33
\r
615 $THROWMSG 'block write exception' ;-34
\r
616 $THROWMSG 'invalid block number' ;-35
\r
617 $THROWMSG 'invalid file position' ;-36
\r
618 $THROWMSG 'file I/O exception' ;-37
\r
619 $THROWMSG 'non-existent file' ;-38
\r
620 $THROWMSG 'unexpected end of file' ;-39
\r
621 $THROWMSG 'invalid BASE for floating point conversion' ;-40
\r
622 $THROWMSG 'loss of precision' ;-41
\r
623 $THROWMSG 'floating-point divide by zero' ;-42
\r
624 $THROWMSG 'floating-point result out of range' ;-43
\r
625 $THROWMSG 'floating-point stack overflow' ;-44
\r
626 $THROWMSG 'floating-point stack underflow' ;-45
\r
627 $THROWMSG 'floating-point invalid argument' ;-46
\r
628 $THROWMSG 'compilation word list deleted' ;-47
\r
629 $THROWMSG 'invalid POSTPONE' ;-48
\r
630 $THROWMSG 'search-order overflow' ;-49
\r
631 $THROWMSG 'search-order underflow' ;-50
\r
632 $THROWMSG 'compilation word list changed' ;-51
\r
633 $THROWMSG 'control-flow stack overflow' ;-52
\r
634 $THROWMSG 'exception stack overflow' ;-53
\r
635 $THROWMSG 'floating-point underflow' ;-54
\r
636 $THROWMSG 'floating-point unidentified fault' ;-55
\r
637 $THROWMSG 'QUIT' ;-56
\r
638 $THROWMSG 'exception in sending or receiving a character' ;-57
\r
639 $THROWMSG '[IF], [ELSE], or [THEN] exception' ;-58
\r
642 ; System dependent words -- Must be re-defined for each system.
\r
644 ; I/O words must be redefined if serial communication is used instead of
\r
645 ; keyboard. Following words are for MS-DOS system.
\r
648 ; Return true if key is pressed.
\r
650 $CODE 3,'RX?',RXQ,_SLINK
\r
652 MOV AH,0Bh ;get input status of STDIN
\r
659 ; Receive one keyboard event u.
\r
661 $CODE 3,'RX@',RXFetch,_SLINK
\r
664 MOV AH,08h ;MS-DOS Read Keyboard
\r
666 ADD BL,AL ;MOV BL,AL and OR AL,AL
\r
667 JNZ RXFET1 ;extended character code?
\r
673 ; Return true if output device is ready or device state is
\r
676 $CONST 3,'TX?',TXQ,TRUEE,_SLINK ;always true for MS-DOS
\r
679 ; Send char to the output device.
\r
681 $CODE 3,'TX!',TXStore,_SLINK
\r
682 MOV DX,BX ;char in DL
\r
683 MOV AH,02h ;MS-DOS Display output
\r
684 INT 021H ;display character
\r
689 ; Carriage return and linefeed.
\r
691 ; : CR [ carriage-return-char ] LITERAL EMIT [ linefeed-char ] LITERAL EMIT ;
\r
693 $COLON 2,'CR',CR,_FLINK
\r
694 DW DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT
\r
696 ; BYE ( -- ) \ TOOLS EXT
\r
697 ; Return control to the host operation system, if any.
\r
699 $CODE 3,'BYE',BYE,_FLINK
\r
700 MOV AX,04C00h ;close all files and
\r
701 INT 021h ; return to MS-DOS
\r
706 ; : hi CR ." hForth "
\r
707 ; S" CPU" ENVIRONMENT? DROP TYPE SPACE
\r
708 ; S" model" ENVIRONMENT? DROP TYPE SPACE [CHAR] v EMIT
\r
709 ; S" version" ENVIRONMENT? DROP TYPE
\r
710 ; ." by Wonyong Koh, 1997" CR
\r
711 ; ." ALL noncommercial and commercial uses are granted." CR
\r
712 ; ." Please send comment, bug report and suggestions to:" CR
\r
713 ; ." wykoh@pado.krict.re.kr or wykoh@free.xtel.com" CR ;
\r
715 $COLON 2,'hi',HI,_SLINK
\r
720 DW ENVIRONMENTQuery,DROP,TYPEE,SPACE
\r
722 DW ENVIRONMENTQuery,DROP,TYPEE,SPACE,DoLIT,'v',EMIT
\r
724 DW ENVIRONMENTQuery,DROP,TYPEE
\r
725 $INSTR ' by Wonyong Koh, 1997'
\r
727 $INSTR 'All noncommercial and commercial uses are granted.'
\r
729 $INSTR 'Please send comment, bug report and suggestions to:'
\r
731 $INSTR ' wykoh@pado.krict.re.kr or wykoh@free.xtel.com'
\r
735 ; The cold start sequence execution word.
\r
737 ; : COLD sysVar0 var0 [ sysVar0End sysVar0 - ] LITERAL
\r
738 ; MOVE \ initialize system variable
\r
739 ; xhere DUP @ \ free-ROM [free-ROM]
\r
740 ; INVERT SWAP 2DUP ! @ XOR \ writable ROM?
\r
741 ; IF RAMB TO cpVar RAMT TO npVar THEN
\r
742 ; sp0 sp! rp0 rp! \ initialize stack
\r
743 ; 'init-i/o EXECUTE
\r
745 ; QUIT ; \ start interpretation
\r
747 $COLON 4,'COLD',COLD,_SLINK
\r
748 DW SysVar0,VarZero,DoLIT,ULAST-UZERO,MOVE
\r
749 DW XHere,DUPP,Fetch,INVERT,SWAP,TwoDUP,Store,Fetch,XORR
\r
751 DW RAMB,DoTO,AddrCPVar,RAMT,DoTO,AddrNPVar
\r
752 COLD1 DW SPZero,SPStore,RPZero,RPStore
\r
753 DW TickINIT_IO,EXECUTE,TickBoot,EXECUTE
\r
757 ; Set input/output device.
\r
759 ; : set-i/o sysVar0 var0 4 CELLS MOVE \ set i/o vectors
\r
760 ; S" CON" stdin ; \ MS-DOS only
\r
762 $COLON 7,'set-i/o',Set_IO,_SLINK
\r
763 DW SysVar0,VarZero,DoLIT,4*CELLL,MOVE
\r
764 $INSTR 'CON' ;MS-DOS only
\r
765 DW STDIN ;MS-DOS only
\r
769 ; MS-DOS only words -- not necessary for other systems.
\r
771 ; File input using MS-DOS redirection function without using FILE words.
\r
773 ; redirect ( c-addr -- flag )
\r
774 ; Redirect standard input from the device identified by ASCIIZ
\r
775 ; string stored at c-addr. Return error code.
\r
777 $CODE 8,'redirect',Redirect,_SLINK
\r
779 MOV AX,Redirect1stQ
\r
784 INT 021h ; close previously opend file
\r
785 REDIRECT2: MOV AX,03D00h ; open file read-only
\r
786 MOV Redirect1stQ,AX ; set Redirect1stQ true
\r
788 JC REDIRECT1 ; if error
\r
796 REDIRECT1: MOV BX,AX
\r
798 Redirect1stQ DW 0 ; true after the first redirection
\r
799 RedirHandle DW ? ; redirect file handle
\r
801 ; asciiz ( ca1 u -- ca2 )
\r
802 ; Return ASCIIZ string.
\r
804 ; : asciiz xhere SWAP 2DUP + 0 SWAP C! CHARS MOVE xhere ;
\r
806 $COLON 6,'asciiz',ASCIIZ,_SLINK
\r
807 DW XHere,SWAP,TwoDUP,Plus,Zero
\r
808 DW SWAP,CStore,CHARS,MOVE,XHere,EXIT
\r
810 ; stdin ( ca u -- )
\r
812 ; : stdin asciiz redirect ?DUP
\r
813 ; IF -38 THROW THEN ; COMPILE-ONLY
\r
815 $COLON 5,'stdin',STDIN,_SLINK
\r
816 DW ASCIIZ,Redirect,QuestionDUP,ZBranch,STDIN1
\r
820 ; << ( "<spaces>ccc" -- )
\r
821 ; Redirect input from the file 'ccc'. Should be used only in
\r
822 ; interpretation state.
\r
824 ; : << STATE @ IF ." Do not use '<<' in a definition." ABORT THEN
\r
825 ; PARSE-WORD stdin SOURCE >IN ! DROP ; IMMEDIATE
\r
827 $COLON IMMED+2,'<<',FROM,_SLINK
\r
828 DW STATE,Fetch,ZBranch,FROM1
\r
830 $INSTR 'Do not use << in a definition.'
\r
832 FROM1 DW PARSE_WORD,STDIN,SOURCE,ToIN,Store,DROP,EXIT
\r
835 ; Non-Standard words - Processor-dependent definitions
\r
836 ; 16 bit Forth for 8086/8
\r
839 ; microdebugger for debugging new hForth ports by NAC.
\r
841 ; The major problem with debugging Forth code at the assembler level is that
\r
842 ; most of the definitions are lists of execution tokens that get interpreted
\r
843 ; (using doLIST) rather than executed directly. As far as the native processor
\r
844 ; is concerned, these xt are data, and a debugger cannot be set to trap on
\r
847 ; The solution to that problem would seem to be to trap on the native-machine
\r
848 ; 'call' instruction at the start of each definition. However, the threaded
\r
849 ; nature of the code makes it very difficult to follow a particular definition
\r
850 ; through: many definitions are used repeatedly through the code. Simply
\r
851 ; trapping on the 'call' leads to multiple unwanted traps.
\r
853 ; Consider, for example, the code for doS" --
\r
855 ; DW RFrom,SWAP,TwoDUP,Plus,ALIGNED,ToR,EXIT
\r
857 ; It would be useful to run each word in turn; at the end of each word the
\r
858 ; effect upon the stacks could be checked until the faulty word is found.
\r
860 ; This technique allows you to do exactly that.
\r
862 ; All definitions end with $NEXT -- either directly (code definitions) or
\r
863 ; indirectly (colon definitions terminating in EXIT, which is itself a code
\r
864 ; definition). The action of $NEXT is to use the fpc for the next word to
\r
865 ; fetch the xt and jumps to it.
\r
867 ; To use the udebug routine, replace the $NEXT expansion with a jump (not a
\r
868 ; call) to the routine udebug (this requires you to reassemble the code)
\r
870 ; When you want to debug a word, trap at the CALL doLIST at the start of the
\r
871 ; word and then load the location trapfpc with the address of the first xt
\r
872 ; of the word. Make your debugger trap when you execute the final instruction
\r
873 ; in the udebug routine. Now execute your code and your debugger will trap
\r
874 ; after the completion of the first xt in the definition. To stop debugging,
\r
875 ; simply set trapfpc to 0.
\r
877 ; This technique has a number of limitations:
\r
878 ; - It is an assumption that an xt of 0 is illegal
\r
879 ; - You cannot automatically debug a code stream that includes inline string
\r
880 ; definitions, or any other kind of inline literal. You must step into the
\r
881 ; word that includes the definition then hand-edit the appropriate new value
\r
883 ; Clearly, you could overcome these limitations by making udebug more
\r
884 ; complex -- but then you run the risk of introducing bugs in that code.
\r
886 uDebug: MOV DI,Trapfpc
\r
888 CMP AX,SI ; compare the stored address with
\r
889 ; the address we're about to get the
\r
891 JNE uDebug1 ; not the trap address, so we're done
\r
892 ADD AX,CELLL ; next time trap on the next xt
\r
894 NOP ; make debugger TRAP at this address
\r
899 ; same? ( c-addr1 c-addr2 u -- -1|0|1 )
\r
900 ; Return 0 if two strings, ca1 u and ca2 u, are same; -1 if
\r
901 ; string, ca1 u is smaller than ca2 u; 1 otherwise. Used by
\r
902 ; '(search-wordlist)'. Code definition is preferred to speed up
\r
903 ; interpretation. Colon definition is shown below.
\r
905 ; : same? ?DUP IF \ null strings are always same
\r
906 ; 0 DO OVER C@ OVER C@ XOR
\r
907 ; IF UNLOOP C@ SWAP C@ > 2* 1+ EXIT THEN
\r
908 ; CHAR+ SWAP CHAR+ SWAP
\r
912 ; $COLON 5,'same?',SameQ,_SLINK
\r
913 ; DW QuestionDUP,ZBranch,SAMEQ4
\r
915 ; SAMEQ3 DW OVER,CFetch,OVER,CFetch,XORR,ZBranch,SAMEQ2
\r
916 ; DW UNLOOP,CFetch,SWAP,CFetch,GreaterThan
\r
917 ; DW TwoStar,OnePlus,EXIT
\r
918 ; SAMEQ2 DW CHARPlus,SWAP,CHARPlus
\r
920 ; SAMEQ4 DW TwoDROP,Zero,EXIT
\r
922 $CODE 5,'same?',SameQ,_SLINK
\r
940 ; (search-wordlist) ( c-addr u wid -- 0 | xt f 1 | xt f -1)
\r
941 ; Search word list for a match with the given name.
\r
942 ; Return execution token and not-compile-only flag and
\r
943 ; -1 or 1 ( IMMEDIATE) if found. Return 0 if not found.
\r
945 ; format is: wid---->[ a ]
\r
948 ; [ xt' ][ a' ][ccbbaann][ggffeedd]...
\r
952 ; [ xt'' ][ a'' ][ccbbaann][ggffeedd]...
\r
954 ; a, a' etc. point to the cell that contains the name of the
\r
955 ; word. The length is in the low byte of the cell (little byte
\r
956 ; for little-endian, big byte for big-endian).
\r
957 ; Eventually, a''' contains 0 to indicate the end of the wordlist
\r
958 ; (oldest entry). a=0 indicates an empty wordlist.
\r
959 ; xt is the xt of the word. aabbccddeedd etc. is the name of
\r
960 ; the word, packed into cells.
\r
962 ; : (search-wordlist)
\r
963 ; ROT >R SWAP DUP 0= IF -16 THROW THEN
\r
964 ; \ attempt to use zero-length string as a name
\r
965 ; >R \ wid R: ca1 u
\r
966 ; BEGIN @ \ ca2 R: ca1 u
\r
967 ; DUP 0= IF R> R> 2DROP EXIT THEN \ not found
\r
968 ; DUP COUNT [ =mask ] LITERAL AND R@ = \ ca2 ca2+char f
\r
969 ; IF R> R@ SWAP DUP >R \ ca2 ca2+char ca1 u
\r
971 ; \ ELSE DROP -1 \ unnecessary since ca2+char is not 0.
\r
973 ; WHILE cell- \ pointer to next word in wordlist
\r
975 ; R> R> 2DROP DUP name>xt SWAP \ xt ca2
\r
976 ; C@ DUP [ =comp ] LITERAL AND 0= SWAP
\r
977 ; [ =immed ] LITERAL AND 0= 2* 1+ ;
\r
979 ; $COLON 17,'(search-wordlist)',ParenSearch_Wordlist,_SLINK
\r
980 ; DW ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6
\r
983 ; DW DUPP,ZBranch,PSRCH9
\r
984 ; DW DUPP,COUNT,DoLIT,MASKK,ANDD,RFetch,Equals
\r
985 ; DW ZBranch,PSRCH5
\r
986 ; DW RFrom,RFetch,SWAP,DUPP,ToR,SameQ
\r
987 ; PSRCH5 DW ZBranch,PSRCH3
\r
988 ; DW CellMinus,Branch,PSRCH1
\r
989 ; PSRCH3 DW RFrom,RFrom,TwoDROP,DUPP,NameToXT,SWAP
\r
990 ; DW CFetch,DUPP,DoLIT,COMPO,ANDD,ZeroEquals,SWAP
\r
991 ; DW DoLIT,IMMED,ANDD,ZeroEquals,TwoStar,OnePlus,EXIT
\r
992 ; PSRCH9 DW RFrom,RFrom,TwoDROP,EXIT
\r
993 ; PSRCH6 DW DoLIT,-16,THROW
\r
995 $CODE 17,'(search-wordlist)',ParenSearch_Wordlist,_SLINK
\r
1004 PSRCH2: MOV BX,[BX]
\r
1006 JZ PSRCH4 ; end of wordlist?
\r
1008 SUB BX,CELLL ;pointer to nextword
\r
1009 AND CL,MASKK ;max name length = MASKK
\r
1014 ADD DI,CELLL+CHARR
\r
1018 PUSH [BX-CELLL] ;xt
\r
1030 PSRCH1: MOV BX,-16 ;attempt to use zero-length string as a name
\r
1035 ; ?call ( xt1 -- xt1 0 | a-addr xt2 )
\r
1036 ; Return xt of the CALLed run-time word if xt starts with machine
\r
1037 ; CALL instruction and leaves the next cell address after the
\r
1038 ; CALL instruction. Otherwise leaves the original xt1 and zero.
\r
1040 ; : ?call DUP @ [ call-code ] LITERAL =
\r
1041 ; IF CELL+ DUP @ SWAP CELL+ DUP ROT + EXIT THEN
\r
1042 ; \ Direct Threaded Code 8086 relative call
\r
1045 $COLON 5,'?call',QCall,_SLINK
\r
1046 DW DUPP,Fetch,DoLIT,CALLL,Equals,ZBranch,QCALL1
\r
1047 DW CELLPlus,DUPP,Fetch,SWAP,CELLPlus,DUPP,ROT,Plus,EXIT
\r
1048 QCALL1 DW Zero,EXIT
\r
1050 ; xt, ( xt1 -- xt2 )
\r
1051 ; Take a run-time word xt1 for :NONAME , CONSTANT , VARIABLE and
\r
1052 ; CREATE . Return xt2 of current definition.
\r
1054 ; : xt, xhere ALIGNED DUP TOxhere SWAP
\r
1055 ; [ call-code ] LITERAL code, \ Direct Threaded Code
\r
1056 ; xhere CELL+ - code, ; \ 8086 relative call
\r
1058 $COLON 3,'xt,',xtComma,_SLINK
\r
1059 DW XHere,ALIGNED,DUPP,TOXHere,SWAP
\r
1060 DW DoLIT,CALLL,CodeComma
\r
1061 DW XHere,CELLPlus,Minus,CodeComma,EXIT
\r
1064 ; Push an inline literal. The inline literal is at the current
\r
1065 ; value of the fpc, so put it onto the stack and point past it.
\r
1067 $CODE COMPO+5,'doLIT',DoLIT,_SLINK
\r
1073 ; doCONST ( -- x )
\r
1074 ; Run-time routine of CONSTANT and VARIABLE. When you quote a
\r
1075 ; constant or variable you execute its code, which consists of a
\r
1076 ; call to here, followed by an inline literal. The literal is a
\r
1077 ; constant (for a CONSTANT) or the address at which a VARIABLE's
\r
1078 ; value is stored. Although you come here as the result of a
\r
1079 ; native machine call, you never go back to the return address
\r
1080 ; -- you jump back up a level by continuing at the new fpc value.
\r
1081 ; For 8086, Z80 the inline literal is at the return address
\r
1082 ; stored on the top of the hardware stack.
\r
1084 $CODE COMPO+7,'doCONST',DoCONST,_SLINK
\r
1090 ; doVALUE ( -- x )
\r
1091 ; Run-time routine of VALUE. Return the value of VALUE word.
\r
1092 ; This is like an invocation of doCONST for a VARIABLE but
\r
1093 ; instead of returning the address of the variable, we return
\r
1094 ; the value of the variable -- in other words, there is another
\r
1095 ; level of indirection.
\r
1097 $CODE COMPO+7,'doVALUE',DoVALUE,_SLINK
\r
1104 ; doCREATE ( -- a-addr )
\r
1105 ; Run-time routine of CREATE. For CREATEd words with an
\r
1106 ; associated DOES>, get the address of the CREATEd word's data
\r
1107 ; space and execute the DOES> actions. For CREATEd word without
\r
1108 ; an associated DOES>, return the address of the CREATE'd word's
\r
1109 ; data space. A CREATEd word starts its execution through this
\r
1110 ; routine in exactly the same way as a colon definition uses
\r
1111 ; doLIST. In other words, we come here through a native machine
\r
1114 ; Structure of CREATEd word:
\r
1115 ; | call-doCREATE | 0 or DOES> code addr | a-addr |
\r
1117 ; The DOES> address holds a native call to doLIST. This routine
\r
1118 ; doesn't alter the fpc. We never come back *here* so we never
\r
1119 ; need to preserve an address that would bring us back *here*.
\r
1121 ; Example : myVARIABLE CREATE , DOES> ;
\r
1122 ; 56 myVARIABLE JIM
\r
1123 ; JIM \ stacks the address of the data cell that contains 56
\r
1125 ; : doCREATE SWAP \ switch BX and top of 8086 stack item
\r
1126 ; DUP CELL+ @ SWAP @ ?DUP IF EXECUTE THEN ; COMPILE-ONLY
\r
1128 ; $COLON COMPO+8,'doCREATE',DoCREATE,_SLINK
\r
1129 ; DW SWAP,DUPP,CELLPlus,Fetch,SWAP,Fetch,QuestionDUP
\r
1130 ; DW ZBranch,DOCREAT1
\r
1132 ; DOCREAT1: DW EXIT
\r
1134 $CODE COMPO+8,'doCREATE',DoCREATE,_SLINK
\r
1146 ; Run-time routine of TO. Store x at the address in the
\r
1147 ; following cell. The inline literal holds the address
\r
1150 $CODE COMPO+4,'doTO',DoTO,_SLINK
\r
1157 ; doUSER ( -- a-addr )
\r
1158 ; Run-time routine of USER. Return address of data space.
\r
1159 ; This is like doCONST but a variable offset is added to the
\r
1160 ; result. By changing the value at AddrUserP (which happens
\r
1161 ; on a taskswap) the whole set of user variables is switched
\r
1162 ; to the set for the new task.
\r
1164 $CODE COMPO+6,'doUSER',DoUSER,_SLINK
\r
1171 ; doLIST ( -- ) ( R: -- nest-sys )
\r
1172 ; Process colon list.
\r
1173 ; The first word of a definition (the xt for the word) is a
\r
1174 ; native machine-code instruction for the target machine. For
\r
1175 ; high-level definitions, that code is emitted by xt, and
\r
1176 ; performs a call to doLIST. doLIST executes the list of xt that
\r
1177 ; make up the definition. The final xt in the definition is EXIT.
\r
1178 ; The address of the first xt to be executed is passed to doLIST
\r
1179 ; in a target-specific way. Two examples:
\r
1180 ; Z80, 8086: native machine call, leaves the return address on
\r
1181 ; the hardware stack pointer, which is used for the data stack.
\r
1183 $CODE COMPO+6,'doLIST',DoLIST,_SLINK
\r
1185 MOV [BP],SI ;push return stack
\r
1186 POP SI ;new list address
\r
1189 ; doLOOP ( -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
1190 ; Run time routine for LOOP.
\r
1192 $CODE COMPO+6,'doLOOP',DoLOOP,_SLINK
\r
1193 INC WORD PTR [BP] ;increase loop count
\r
1194 JO DoLOOP1 ;?loop end
\r
1195 MOV SI,[SI] ;no, go back
\r
1197 DoLOOP1: ADD SI,CELLL ;yes, continue past the branch offset
\r
1198 ADD BP,2*CELLL ;clear return stack
\r
1201 ; do+LOOP ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
1202 ; Run time routine for +LOOP.
\r
1204 $CODE COMPO+7,'do+LOOP',DoPLOOP,_SLINK
\r
1205 ADD WORD PTR [BP],BX ;increase loop count
\r
1206 JO DoPLOOP1 ;?loop end
\r
1207 MOV SI,[SI] ;no, go back
\r
1210 DoPLOOP1: ADD SI,CELLL ;yes, continue past the branch offset
\r
1211 ADD BP,2*CELLL ;clear return stack
\r
1215 ; 0branch ( flag -- )
\r
1216 ; Branch if flag is zero.
\r
1218 $CODE COMPO+7,'0branch',ZBranch,_SLINK
\r
1220 JZ ZBRAN1 ;yes, so branch
\r
1221 ADD SI,CELLL ;point IP to next cell
\r
1224 ZBRAN1: MOV SI,[SI] ;IP:=(IP)
\r
1229 ; Branch to an inline address.
\r
1231 $CODE COMPO+6,'branch',Branch,_SLINK
\r
1232 MOV SI,[SI] ;IP:=(IP)
\r
1235 ; rp@ ( -- a-addr )
\r
1236 ; Push the current RP to the data stack.
\r
1238 $CODE COMPO+3,'rp@',RPFetch,_SLINK
\r
1243 ; rp! ( a-addr -- )
\r
1244 ; Set the return stack pointer.
\r
1246 $CODE COMPO+3,'rp!',RPStore,_SLINK
\r
1251 ; sp@ ( -- a-addr )
\r
1252 ; Push the current data stack pointer.
\r
1254 $CODE 3,'sp@',SPFetch,_SLINK
\r
1259 ; sp! ( a-addr -- )
\r
1260 ; Set the data stack pointer.
\r
1262 $CODE 3,'sp!',SPStore,_SLINK
\r
1267 ; um+ ( u1 u2 -- u3 1|0 )
\r
1268 ; Add two unsigned numbers, return the sum and carry.
\r
1270 $CODE 3,'um+',UMPlus,_SLINK
\r
1275 RCL CX,1 ;get carry
\r
1279 ; 1chars/ ( n1 -- n2 )
\r
1280 ; Calculate number of chars for n1 address units.
\r
1282 ; : 1chars/ 1 CHARS / ; \ slow, very portable
\r
1283 ; : 1chars/ ; \ fast, must be redefined for each system
\r
1285 $COLON 7,'1chars/',OneCharsSlash,_SLINK
\r
1289 ; Standard words - Processor-dependent definitions
\r
1290 ; 16 bit Forth for 8086/8
\r
1293 ; ALIGN ( -- ) \ CORE
\r
1294 ; Align the data space pointer.
\r
1296 ; : ALIGN hereVar DUP @ ALIGNED SWAP ! ;
\r
1298 $COLON 5,'ALIGN',ALIGNN,_FLINK
\r
1299 DW HereVar,DUPP,Fetch,ALIGNED,SWAP,Store,EXIT
\r
1301 ; ALIGNED ( addr -- a-addr ) \ CORE
\r
1302 ; Align address to the cell boundary.
\r
1304 ; : ALIGNED DUP 0 [ cell-size ] LITERAL UM/MOD DROP DUP
\r
1305 ; IF [ cell-size ] LITERAL SWAP - THEN + ; \ slow, very portable
\r
1307 ; $COLON 7,'ALIGNED',ALIGNED,_FLINK
\r
1308 ; DW DUPP,Zero,DoLIT,CELLL
\r
1309 ; DW UMSlashMOD,DROP,DUPP
\r
1310 ; DW ZBranch,ALGN1
\r
1311 ; DW DoLIT,CELLL,SWAP,Minus
\r
1312 ; ALGN1 DW Plus,EXIT
\r
1314 $CODE 7,'ALIGNED',ALIGNED,_FLINK
\r
1319 ; CELLS ( n1 -- n2 ) \ CORE
\r
1320 ; Calculate number of address units for n1 cells.
\r
1322 ; : CELLS [ cell-size ] LITERAL * ; \ slow, very portable
\r
1323 ; : CELLS 2* ; \ fast, must be redefined for each system
\r
1325 $COLON 5,'CELLS',CELLS,_FLINK
\r
1328 ; CHARS ( n1 -- n2 ) \ CORE
\r
1329 ; Calculate number of address units for n1 characters.
\r
1331 ; : CHARS [ char-size ] LITERAL * ; \ slow, very portable
\r
1332 ; : CHARS ; \ fast, must be redefined for each system
\r
1334 $COLON 5,'CHARS',CHARS,_FLINK
\r
1337 ; It is more convenient to use up-growing stack for some microprocessors such as 8051 family.
\r
1338 ; In those cases I, J, and DEPTH should be redefined.
\r
1340 ; I ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE
\r
1341 ; Push the innermost loop index.
\r
1343 ; : I rp@ [ 1 CELLS ] LITERAL + @
\r
1344 ; rp@ [ 2 CELLS ] LITERAL + @ + ; COMPILE-ONLY
\r
1346 $COLON COMPO+1,'I',I,_FLINK
\r
1347 DW RPFetch,DoLIT,CELLL,Plus,Fetch
\r
1348 DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT
\r
1350 ; J ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE
\r
1351 ; Push the index of next outer loop.
\r
1353 ; : J rp@ [ 3 CELLS ] LITERAL + @
\r
1354 ; rp@ [ 4 CELLS ] LITERAL + @ + ; COMPILE-ONLY
\r
1356 $COLON COMPO+1,'J',J,_FLINK
\r
1357 DW RPFetch,DoLIT,3*CELLL,Plus,Fetch
\r
1358 DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT
\r
1360 ; DEPTH ( -- +n ) \ CORE
\r
1361 ; Return the depth of the data stack.
\r
1363 ; : DEPTH sp@ sp0 SWAP - [ cell-size ] LITERAL / ;
\r
1365 $COLON 5,'DEPTH',DEPTH,_FLINK
\r
1366 DW SPFetch,SPZero,SWAP,Minus
\r
1367 DW DoLIT,CELLL,Slash,EXIT
\r
1369 ; ! ( x a-addr -- ) \ CORE
\r
1370 ; Store x at a aligned address.
\r
1372 $CODE 1,'!',Store,_FLINK
\r
1377 ; 0< ( n -- flag ) \ CORE
\r
1378 ; Return true if n is negative.
\r
1380 $CODE 2,'0<',ZeroLess,_FLINK
\r
1386 ; 0= ( x -- flag ) \ CORE
\r
1387 ; Return true if x is zero.
\r
1389 $CODE 2,'0=',ZeroEquals,_FLINK
\r
1396 ; 2* ( x1 -- x2 ) \ CORE
\r
1397 ; Bit-shift left, filling the least significant bit with 0.
\r
1399 $CODE 2,'2*',TwoStar,_FLINK
\r
1403 ; 2/ ( x1 -- x2 ) \ CORE
\r
1404 ; Bit-shift right, leaving the most significant bit unchanged.
\r
1406 $CODE 2,'2/',TwoSlash,_FLINK
\r
1410 ; >R ( x -- ) ( R: -- x ) \ CORE
\r
1411 ; Move top of the data stack item to the return stack.
\r
1413 $CODE COMPO+2,'>R',ToR,_FLINK
\r
1414 SUB BP,CELLL ;adjust RP
\r
1419 ; @ ( a-addr -- x ) \ CORE
\r
1420 ; Push the contents at a-addr to the data stack.
\r
1422 $CODE 1,'@',Fetch,_FLINK
\r
1426 ; AND ( x1 x2 -- x3 ) \ CORE
\r
1429 $CODE 3,'AND',ANDD,_FLINK
\r
1434 ; C! ( char c-addr -- ) \ CORE
\r
1435 ; Store char at c-addr.
\r
1437 $CODE 2,'C!',CStore,_FLINK
\r
1443 ; C@ ( c-addr -- char ) \ CORE
\r
1444 ; Fetch the character stored at c-addr.
\r
1446 $CODE 2,'C@',CFetch,_FLINK
\r
1451 ; DROP ( x -- ) \ CORE
\r
1452 ; Discard top stack item.
\r
1454 $CODE 4,'DROP',DROP,_FLINK
\r
1458 ; DUP ( x -- x x ) \ CORE
\r
1459 ; Duplicate the top stack item.
\r
1461 $CODE 3,'DUP',DUPP,_FLINK
\r
1465 ; EXECUTE ( i*x xt -- j*x ) \ CORE
\r
1466 ; Perform the semantics indentified by execution token, xt.
\r
1468 $CODE 7,'EXECUTE',EXECUTE,_FLINK
\r
1471 JMP AX ;jump to the code address
\r
1474 ; EXIT ( -- ) ( R: nest-sys -- ) \ CORE
\r
1475 ; Return control to the calling definition.
\r
1477 $CODE COMPO+4,'EXIT',EXIT,_FLINK
\r
1478 XCHG BP,SP ;exchange pointers
\r
1479 POP SI ;pop return stack
\r
1480 XCHG BP,SP ;restore the pointers
\r
1483 ; MOVE ( addr1 addr2 u -- ) \ CORE
\r
1484 ; Copy u address units from addr1 to addr2 if u is greater
\r
1485 ; than zero. This word is CODE defined since no other Standard
\r
1486 ; words can handle address unit directly.
\r
1488 $CODE 4,'MOVE',MOVE,_FLINK
\r
1494 XCHG DX,SI ;save SI
\r
1496 MOV ES,AX ;set ES same as DS
\r
1514 ; OR ( x1 x2 -- x3 ) \ CORE
\r
1515 ; Return bitwise inclusive-or of x1 with x2.
\r
1517 $CODE 2,'OR',ORR,_FLINK
\r
1522 ; OVER ( x1 x2 -- x1 x2 x1 ) \ CORE
\r
1523 ; Copy second stack item to top of the stack.
\r
1525 $CODE 4,'OVER',OVER,_FLINK
\r
1531 ; R> ( -- x ) ( R: x -- ) \ CORE
\r
1532 ; Move x from the return stack to the data stack.
\r
1534 $CODE COMPO+2,'R>',RFrom,_FLINK
\r
1537 ADD BP,CELLL ;adjust RP
\r
1540 ; R@ ( -- x ) ( R: x -- x ) \ CORE
\r
1541 ; Copy top of return stack to the data stack.
\r
1543 $CODE COMPO+2,'R@',RFetch,_FLINK
\r
1548 ; SWAP ( x1 x2 -- x2 x1 ) \ CORE
\r
1549 ; Exchange top two stack items.
\r
1551 $CODE 4,'SWAP',SWAP,_FLINK
\r
1556 ; XOR ( x1 x2 -- x3 ) \ CORE
\r
1557 ; Bitwise exclusive OR.
\r
1559 $CODE 3,'XOR',XORR,_FLINK
\r
1565 ; System constants and variables
\r
1568 ; var0 ( -- a-addr )
\r
1569 ; Start of system variable area.
\r
1571 $CONST 4,'var0',VarZero,RAM0,_SLINK
\r
1573 ; sysVar0 ( -- a-addr )
\r
1574 ; Start of initial value table of system variables.
\r
1576 $CONST 7,'sysVar0',SysVar0,UZERO,_SLINK
\r
1578 ; sysVar00 ( -- a-addr )
\r
1579 ; Start of backup copy of original value table of system variables.
\r
1581 $CONST 8,'sysVar00',SysVar00,UZERO0,_SLINK
\r
1583 ; sysVar0End ( -- a-addr )
\r
1584 ; End of initial value table of system variables.
\r
1586 $CONST 10,'sysVar0End',SysVar0End,ULAST,_SLINK
\r
1588 ; THROWMsgTbl ( -- a-addr ) \ CORE
\r
1589 ; Return the address of the THROW message table.
\r
1591 $CONST 11,'THROWMsgTbl',THROWMsgTbl,AddrTHROWMsgTbl,_SLINK
\r
1593 ; 'ekey? ( -- a-addr )
\r
1594 ; Execution vector of EKEY?.
\r
1596 $VALUE 6,"'ekey?",TickEKEYQ,_SLINK
\r
1598 ; 'ekey ( -- a-addr )
\r
1599 ; Execution vector of EKEY.
\r
1601 $VALUE 5,"'ekey",TickEKEY,_SLINK
\r
1603 ; 'emit? ( -- a-addr )
\r
1604 ; Execution vector of EMIT?.
\r
1606 $VALUE 6,"'emit?",TickEMITQ,_SLINK
\r
1608 ; 'emit ( -- a-addr )
\r
1609 ; Execution vector of EMIT.
\r
1611 $VALUE 5,"'emit",TickEMIT,_SLINK
\r
1613 ; 'init-i/o ( -- a-addr )
\r
1614 ; Execution vector to initialize input/output devices.
\r
1616 $VALUE 9,"'init-i/o",TickINIT_IO,_SLINK
\r
1618 ; 'prompt ( -- a-addr )
\r
1619 ; Execution vector of '.prompt'.
\r
1621 $VALUE 7,"'prompt",TickPrompt,_SLINK
\r
1623 ; 'boot ( -- a-addr )
\r
1624 ; Execution vector of COLD.
\r
1626 $VALUE 5,"'boot",TickBoot,_SLINK
\r
1628 ; SOURCE-ID ( -- 0 | -1 ) \ CORE EXT
\r
1629 ; Identify the input source. -1 for string (via EVALUATE) and
\r
1630 ; 0 for user input device.
\r
1632 $VALUE 9,'SOURCE-ID',SOURCE_ID,_FLINK
\r
1633 AddrSOURCE_ID EQU _VAR -CELLL
\r
1635 ; cpVar ( -- a-addr )
\r
1636 ; Point to the top of the code dictionary.
\r
1638 $VALUE 5,'cpVar',CPVar,_SLINK
\r
1639 AddrCPVar EQU _VAR -CELLL
\r
1641 ; npVar ( -- a-addr )
\r
1642 ; Point to the bottom of the name dictionary.
\r
1644 $VALUE 5,'npVar',NPVar,_SLINK
\r
1645 AddrNPVar EQU _VAR -CELLL
\r
1647 ; hereVar ( -- a-addr )
\r
1648 ; Point to the RAM/ROM data space pointer. Used by , or ALLOT.
\r
1650 $VALUE 7,'hereVar',HereVar,_SLINK
\r
1651 AddrHereVar EQU _VAR -CELLL
\r
1653 ; 'doWord ( -- a-addr )
\r
1654 ; Execution vectors for 'interpret'.
\r
1656 $VAR 7,"'doWord",TickDoWord,_SLINK
\r
1657 _VAR = _VAR +5*CELLL
\r
1659 ; BASE ( -- a-addr ) \ CORE
\r
1660 ; Return the address of the radix base for numeric I/O.
\r
1662 $VAR 4,'BASE',BASE,_FLINK
\r
1664 ; ROMB ( -- a-addr )
\r
1665 ; Bottom of free ROM area.
\r
1667 $VAR 4,'ROMB',ROMB,_SLINK
\r
1668 AddrROMB EQU _VAR -CELLL
\r
1670 ; ROMT ( -- a-addr )
\r
1671 ; Top of free ROM area.
\r
1673 $VAR 4,'ROMT',ROMT,_SLINK
\r
1674 AddrROMT EQU _VAR -CELLL
\r
1676 ; RAMB ( -- a-addr )
\r
1677 ; Bottom of free RAM area.
\r
1679 $VAR 4,'RAMB',RAMB,_SLINK
\r
1680 AddrRAMB EQU _VAR -CELLL
\r
1682 ; RAMT ( -- a-addr )
\r
1683 ; Top of free RAM area.
\r
1685 $VAR 4,'RAMT',RAMT,_SLINK
\r
1686 AddrRAMT EQU _VAR -CELLL
\r
1689 ; Return the depth of control-flow stack.
\r
1691 $VALUE 3,'bal',Bal,_SLINK
\r
1692 AddrBal EQU _VAR -CELLL
\r
1694 ; notNONAME? ( -- f )
\r
1695 ; Used by ';' whether to do 'linkLast' or not
\r
1697 $VALUE 10,'notNONAME?',NotNONAMEQ,_SLINK
\r
1698 AddrNotNONAMEQ EQU _VAR -CELLL
\r
1700 ; rakeVar ( -- a-addr )
\r
1701 ; Used by 'rake' to gather LEAVE.
\r
1703 $VAR 7,'rakeVar',RakeVar,_SLINK
\r
1705 ; #order ( -- a-addr )
\r
1706 ; Hold the search order stack depth.
\r
1708 $VAR 6,'#order',NumberOrder,_SLINK
\r
1709 _VAR = _VAR +OrderDepth*CELLL ;search order stack
\r
1711 ; current ( -- a-addr )
\r
1712 ; Point to the wordlist to be extended.
\r
1714 $VAR 7,'current',Current,_SLINK
\r
1716 ; FORTH-WORDLIST ( -- wid ) \ SEARCH
\r
1717 ; Return wid of Forth wordlist.
\r
1719 $VAR 14,'FORTH-WORDLIST',FORTH_WORDLIST,_FLINK
\r
1720 FORTH_WORDLISTAddr EQU _VAR -CELLL
\r
1721 FORTH_WORDLISTName EQU _NAME +2*CELLL
\r
1723 _VAR = _VAR +2*CELLL
\r
1725 ; NONSTANDARD-WORDLIST ( -- wid )
\r
1726 ; Return wid of non-standard wordlist.
\r
1728 $VAR 20,'NONSTANDARD-WORDLIST',NONSTANDARD_WORDLIST,_FLINK
\r
1729 NONSTANDARD_WORDLISTAddr EQU _VAR -CELLL
\r
1730 NONSTANDARD_WORDLISTName EQU _NAME +2*CELLL
\r
1732 _VAR = _VAR +2*CELLL
\r
1733 _VAR = _VAR +3*(MaxWLISTS-2)*CELLL
\r
1735 ; envQList ( -- wid )
\r
1736 ; Return wid of ENVIRONMENT? string list. Never put this wid in
\r
1737 ; search-order. It should be used only by SET-CURRENT to add new
\r
1738 ; environment query string after addition of a complete wordset.
\r
1740 $VAR 8,'envQList',EnvQList,_SLINK
\r
1742 ; userP ( -- a-addr )
\r
1743 ; Return address of USER variable area of current task.
\r
1745 $VAR 5,'userP',UserP,_SLINK
\r
1751 SysTask EQU _VAR-0
\r
1752 _VAR = _VAR + CELLL
\r
1754 SysUser1 EQU _VAR-0 ;user1
\r
1755 _VAR = _VAR + CELLL
\r
1756 SysTaskName EQU _VAR-0 ;taskName
\r
1757 _VAR = _VAR + CELLL
\r
1758 SysThrowFrame EQU _VAR-0 ;throwFrame
\r
1759 _VAR = _VAR + CELLL
\r
1760 SysStackTop EQU _VAR-0 ;stackTop
\r
1761 _VAR = _VAR + CELLL
\r
1762 SysStatus EQU _VAR-0 ;status
\r
1763 _VAR = _VAR + CELLL
\r
1764 SysUserP EQU _VAR-0
\r
1765 SysFollower EQU _VAR-0 ;follower
\r
1766 _VAR = _VAR + CELLL
\r
1767 _VAR = _VAR + CELLL ;SP0 for system task
\r
1768 _VAR = _VAR + CELLL ;RP0 for system task
\r
1770 ; SystemTask ( -- a-addr )
\r
1771 ; Return system task's tid.
\r
1773 $CONST 10,'SystemTask',SystemTask,SysTask,_SLINK
\r
1774 SystemTaskName EQU _NAME-0
\r
1776 ; follower ( -- a-addr )
\r
1777 ; Point next task's 'status' USER variable.
\r
1779 $USER 8,'follower',Follower,SysFollower-SysUserP,_SLINK
\r
1781 ; status ( -- a-addr )
\r
1782 ; Status of current task. Point 'pass' or 'wake'.
\r
1784 $USER 6,'status',Status,SysStatus-SysUserP,_SLINK
\r
1786 ; stackTop ( -- a-addr )
\r
1787 ; Store current task's top of stack position.
\r
1789 $USER 8,'stackTop',StackTop,SysStackTop-SysUserP,_SLINK
\r
1791 ; throwFrame ( -- a-addr )
\r
1792 ; THROW frame for CATCH and THROW need to be saved for eack task.
\r
1794 $USER 10,'throwFrame',ThrowFrame,SysThrowFrame-SysUserP,_SLINK
\r
1796 ; taskName ( -- a-addr )
\r
1797 ; Current task's task ID.
\r
1799 $USER 8,'taskName',TaskName,SysTaskName-SysUserP,_SLINK
\r
1801 ; user1 ( -- a-addr )
\r
1802 ; One free USER variable for each task.
\r
1804 $USER 5,'user1',User1,SysUser1-SysUserP,_SLINK
\r
1806 ; ENVIRONMENT? strings can be searched using SEARCH-WORDLIST and can be
\r
1807 ; EXECUTEd. This wordlist is completely hidden to Forth system except
\r
1811 DW DoLIT,CPUStr,COUNT,EXIT
\r
1814 DW DoLIT,ModelStr,COUNT,EXIT
\r
1816 $ENVIR 7,'version'
\r
1817 DW DoLIT,VersionStr,COUNT,EXIT
\r
1819 $ENVIR 15,'/COUNTED-STRING'
\r
1820 DW DoLIT,MaxCountedString,EXIT
\r
1823 DW DoLIT,PADSize,EXIT
\r
1826 DW DoLIT,PADSize,EXIT
\r
1828 $ENVIR 17,'ADDRESS-UNIT-BITS'
\r
1832 DW DoLIT,TRUEE,EXIT
\r
1834 $ENVIR 7,'FLOORED'
\r
1835 DW DoLIT,TRUEE,EXIT
\r
1837 $ENVIR 8,'MAX-CHAR'
\r
1838 DW DoLIT,MaxChar,EXIT ;max value of character set
\r
1841 DW DoLIT,MaxUnsigned,DoLIT,MaxSigned,EXIT
\r
1844 DW DoLIT,MaxSigned,EXIT
\r
1847 DW DoLIT,MaxUnsigned,EXIT
\r
1850 DW DoLIT,MaxUnsigned,DoLIT,MaxUnsigned,EXIT
\r
1852 $ENVIR 18,'RETURN-STACK-CELLS'
\r
1853 DW DoLIT,RTCells,EXIT
\r
1855 $ENVIR 11,'STACK-CELLS'
\r
1856 DW DoLIT,DTCells,EXIT
\r
1858 $ENVIR 9,'EXCEPTION'
\r
1859 DW DoLIT,TRUEE,EXIT
\r
1861 $ENVIR 13,'EXCEPTION-EXT'
\r
1862 DW DoLIT,TRUEE,EXIT
\r
1864 $ENVIR 9,'WORDLISTS'
\r
1865 DW DoLIT,OrderDepth,EXIT
\r
1868 ; Non-Standard words - Colon definitions
\r
1871 ; (') ( "<spaces>name" -- xt 1 | xt -1 )
\r
1872 ; Parse a name, find it and return execution token and
\r
1873 ; -1 or 1 ( IMMEDIATE) if found
\r
1875 ; : (') PARSE-WORD search-word ?DUP IF NIP EXIT THEN
\r
1876 ; errWord 2! \ if not found error
\r
1877 ; -13 THROW ; \ undefined word
\r
1879 $COLON 3,"(')",ParenTick,_SLINK
\r
1880 DW PARSE_WORD,Search_word,QuestionDUP,ZBranch,PTICK1
\r
1882 PTICK1 DW ErrWord,TwoStore,DoLIT,-13,THROW
\r
1884 ; (d.) ( d -- c-addr u )
\r
1885 ; Convert a double number to a string.
\r
1887 ; : (d.) SWAP OVER DUP 0< IF DNEGATE THEN
\r
1888 ; <# #S ROT SIGN #> ;
\r
1890 $COLON 4,'(d.)',ParenDDot,_SLINK
\r
1891 DW SWAP,OVER,DUPP,ZeroLess,ZBranch,PARDD1
\r
1893 PARDD1 DW LessNumberSign,NumberSignS,ROT
\r
1894 DW SIGN,NumberSignGreater,EXIT
\r
1901 $COLON 3,'.ok',DotOK,_SLINK
\r
1906 ; Display Forth prompt. This word is vectored.
\r
1908 ; : .prompt 'prompt EXECUTE ;
\r
1910 $COLON 7,'.prompt',DotPrompt,_SLINK
\r
1911 DW TickPrompt,EXECUTE,EXIT
\r
1916 $CONST 1,'0',Zero,0,_SLINK
\r
1921 $CONST 1,'1',One,1,_SLINK
\r
1926 $CONST 2,'-1',MinusOne,-1,_SLINK
\r
1928 ; abort"msg ( -- a-addr )
\r
1929 ; Abort" error message string address.
\r
1931 $VAR 9,'abort"msg',AbortQMsg,_SLINK
\r
1932 _VAR = _VAR +CELLL
\r
1935 ; Increase bal by 1.
\r
1937 ; : bal+ bal 1+ TO bal ;
\r
1939 $COLON 4,'bal+',BalPlus,_SLINK
\r
1940 DW Bal,OnePlus,DoTO,AddrBal,EXIT
\r
1943 ; Decrease bal by 1.
\r
1945 ; : bal- bal 1- TO bal ;
\r
1947 $COLON 4,'bal-',BalMinus,_SLINK
\r
1948 DW Bal,OneMinus,DoTO,AddrBal,EXIT
\r
1950 ; cell- ( a-addr1 -- a-addr2 )
\r
1951 ; Return previous aligned cell address.
\r
1953 ; : cell- [ cell-size NEGATE ] LITERAL + ;
\r
1955 $COLON 5,'cell-',CellMinus,_SLINK
\r
1956 DW DoLIT,0-CELLL,Plus,EXIT
\r
1958 ; COMPILE-ONLY ( -- )
\r
1959 ; Make the most recent definition an compile-only word.
\r
1961 ; : COMPILE-ONLY lastName [ =comp ] LITERAL OVER @ OR SWAP ! ;
\r
1963 $COLON 12,'COMPILE-ONLY',COMPILE_ONLY,_SLINK
\r
1964 DW LastName,DoLIT,COMPO,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
1966 ; doS" ( u -- c-addr u )
\r
1967 ; Run-time function of S" .
\r
1969 ; : doS" R> SWAP 2DUP + ALIGNED >R ; COMPILE-ONLY
\r
1971 $COLON COMPO+4,'doS"',DoSQuote,_SLINK
\r
1972 DW RFrom,SWAP,TwoDUP,Plus,ALIGNED,ToR,EXIT
\r
1974 ; doDO ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )
\r
1975 ; Run-time funtion of DO.
\r
1977 ; : doDO >R [ max-negative ] LITERAL + R> OVER - SWAP R> SWAP >R SWAP >R >R ;
\r
1979 $COLON COMPO+4,'doDO',DoDO,_SLINK
\r
1980 DW ToR,DoLIT,MaxNegative,Plus,RFrom
\r
1981 DW OVER,Minus,SWAP,RFrom,SWAP,ToR,SWAP,ToR,ToR,EXIT
\r
1983 ; errWord ( -- a-addr )
\r
1984 ; Last found word. To be used to display the word causing error.
\r
1986 $VAR 7,'errWord',ErrWord,_SLINK
\r
1987 _VAR = _VAR +CELLL
\r
1989 ; head, ( xt "<spaces>name" -- )
\r
1990 ; Parse a word and build a dictionary entry using xt and name.
\r
1992 ; : head, PARSE-WORD DUP 0=
\r
1993 ; IF errWord 2! -16 THROW THEN
\r
1994 ; \ attempt to use zero-length string as a name
\r
1995 ; DUP [ =mask ] LITERAL > IF -19 THROW THEN
\r
1996 ; \ definition name too long
\r
1997 ; 2DUP GET-CURRENT SEARCH-WORDLIST \ name exist?
\r
1998 ; IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined
\r
1999 ; npVar @ OVER CHARS CHAR+ -
\r
2000 ; DUP ALIGNED SWAP OVER XOR IF CELL- THEN \ aligned to lower addr
\r
2001 ; DUP >R pack" DROP R> \ pack the name in dictionary
\r
2002 ; cell- GET-CURRENT @ OVER ! \ build wordlist link
\r
2003 ; cell- DUP npVar ! ! ; \ adjust name space pointer
\r
2004 ; \ and store xt at code field
\r
2006 $COLON 5,'head,',HeadComma,_SLINK
\r
2007 DW PARSE_WORD,DUPP,ZBranch,HEADC1
\r
2008 DW DUPP,DoLIT,MASKK,GreaterThan,ZBranch,HEADC3
\r
2009 DW DoLIT,-19,THROW
\r
2010 HEADC3 DW TwoDUP,GET_CURRENT,SEARCH_WORDLIST,ZBranch,HEADC2
\r
2012 $INSTR 'redefine '
\r
2013 DW TYPEE,TwoDUP,TYPEE,SPACE
\r
2014 HEADC2 DW NPVar,Fetch,OVER,CHARS,CHARPlus,Minus
\r
2015 DW DUPP,ALIGNED,SWAP,OVER,XORR,ZBranch,HEADC4
\r
2017 HEADC4 DW DUPP,ToR,PackQuote,DROP,RFrom
\r
2018 DW CellMinus,GET_CURRENT,Fetch,OVER,Store
\r
2019 DW CellMinus,DUPP,NPVar,Store,Store,EXIT
\r
2020 HEADC1 DW ErrWord,TwoStore,DoLIT,-16,THROW
\r
2022 ; hld ( -- a-addr )
\r
2023 ; Hold a pointer in building a numeric output string.
\r
2025 $VAR 3,'hld',HLD,_SLINK
\r
2027 ; interpret ( i*x -- j*x )
\r
2028 ; Intrepret input string.
\r
2030 ; : interpret BEGIN DEPTH 0< IF -4 THROW THEN \ stack underflow
\r
2032 ; WHILE 2DUP errWord 2!
\r
2033 ; search-word \ ca u 0 | xt f -1 | xt f 1
\r
2035 ; SWAP STATE @ OR 0= \ compile-only in interpretation
\r
2036 ; IF -14 THROW THEN \ interpreting a compile-only word
\r
2038 ; 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE
\r
2041 $COLON 9,'interpret',Interpret,_SLINK
\r
2042 INTERP1 DW DEPTH,ZeroLess,ZBranch,INTERP2
\r
2044 INTERP2 DW PARSE_WORD,DUPP,ZBranch,INTERP3
\r
2045 DW TwoDUP,ErrWord,TwoStore
\r
2046 DW Search_word,DUPP,ZBranch,INTERP5
\r
2047 DW SWAP,STATE,Fetch,ORR,ZBranch,INTERP4
\r
2048 INTERP5 DW OnePlus,TwoStar,STATE,Fetch,OnePlus,Plus,CELLS
\r
2049 DW TickDoWord,Plus,Fetch,EXECUTE
\r
2051 INTERP3 DW TwoDROP,EXIT
\r
2052 INTERP4 DW DoLIT,-14,THROW
\r
2054 ; optiCOMPILE, ( xt -- )
\r
2055 ; Optimized COMPILE, . Reduce doLIST ... EXIT sequence if
\r
2056 ; xt is COLON definition which contains less than two words.
\r
2059 ; DUP ?call ['] doLIST = IF
\r
2060 ; DUP @ ['] EXIT = IF \ if first word is EXIT
\r
2062 ; DUP CELL+ @ ['] EXIT = IF \ if second word is EXIT
\r
2063 ; @ DUP ['] doLIT XOR \ make sure it is not literal value
\r
2064 ; IF SWAP THEN THEN
\r
2065 ; THEN DROP COMPILE, ;
\r
2067 $COLON 12,'optiCOMPILE,',OptiCOMPILEComma,_SLINK
\r
2068 DW DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2
\r
2069 DW DUPP,Fetch,DoLIT,EXIT,Equals,ZBranch,OPTC1
\r
2071 OPTC1 DW DUPP,CELLPlus,Fetch,DoLIT,EXIT,Equals,ZBranch,OPTC2
\r
2072 DW Fetch,DUPP,DoLIT,DoLIT,XORR,ZBranch,OPTC2
\r
2074 OPTC2 DW DROP,COMPILEComma,EXIT
\r
2076 ; singleOnly ( c-addr u -- x )
\r
2077 ; Handle the word not found in the search-order. If the string
\r
2078 ; is legal, leave a single cell number in interpretation state.
\r
2081 ; 0 DUP 2SWAP OVER C@ [CHAR] -
\r
2082 ; = DUP >R IF 1 /STRING THEN
\r
2083 ; >NUMBER IF -13 THROW THEN \ undefined word
\r
2084 ; 2DROP R> IF NEGATE THEN ;
\r
2086 $COLON 10,'singleOnly',SingleOnly,_SLINK
\r
2087 DW Zero,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\r
2088 DW Equals,DUPP,ToR,ZBranch,SINGLEO4
\r
2089 DW One,SlashSTRING
\r
2090 SINGLEO4 DW ToNUMBER,ZBranch,SINGLEO1
\r
2091 DW DoLIT,-13,THROW
\r
2092 SINGLEO1 DW TwoDROP,RFrom,ZBranch,SINGLEO2
\r
2096 ; singleOnly, ( c-addr u -- )
\r
2097 ; Handle the word not found in the search-order. Compile a
\r
2098 ; single cell number in compilation state.
\r
2101 ; singleOnly POSTPONE LITERAL ;
\r
2103 $COLON 11,'singleOnly,',SingleOnlyComma,_SLINK
\r
2104 DW SingleOnly,LITERAL,EXIT
\r
2106 ; (doubleAlso) ( c-addr u -- x 1 | x x 2 )
\r
2107 ; If the string is legal, leave a single or double cell number
\r
2108 ; and size of the number.
\r
2111 ; 0 DUP 2SWAP OVER C@ [CHAR] -
\r
2112 ; = DUP >R IF 1 /STRING THEN
\r
2114 ; IF 1- IF -13 THROW THEN \ more than one char is remained
\r
2115 ; DUP C@ [CHAR] . XOR \ last char is not '.'
\r
2116 ; IF -13 THROW THEN \ undefined word
\r
2117 ; R> IF DNEGATE THEN
\r
2119 ; 2DROP R> IF NEGATE THEN \ single number
\r
2122 $COLON 12,'(doubleAlso)',ParenDoubleAlso,_SLINK
\r
2123 DW Zero,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\r
2124 DW Equals,DUPP,ToR,ZBranch,DOUBLEA1
\r
2125 DW One,SlashSTRING
\r
2126 DOUBLEA1 DW ToNUMBER,QuestionDUP,ZBranch,DOUBLEA4
\r
2127 DW OneMinus,ZBranch,DOUBLEA3
\r
2128 DOUBLEA2 DW DoLIT,-13,THROW
\r
2129 DOUBLEA3 DW CFetch,DoLIT,'.',Equals,ZBranch,DOUBLEA2
\r
2130 DW RFrom,ZBranch,DOUBLEA5
\r
2132 DOUBLEA5 DW DoLIT,2,EXIT
\r
2133 DOUBLEA4 DW TwoDROP,RFrom,ZBranch,DOUBLEA6
\r
2135 DOUBLEA6 DW One,EXIT
\r
2137 ; doubleAlso ( c-addr u -- x | x x )
\r
2138 ; Handle the word not found in the search-order. If the string
\r
2139 ; is legal, leave a single or double cell number in
\r
2140 ; interpretation state.
\r
2143 ; (doubleAlso) DROP ;
\r
2145 $COLON 10,'doubleAlso',DoubleAlso,_SLINK
\r
2146 DW ParenDoubleAlso,DROP,EXIT
\r
2148 ; doubleAlso, ( c-addr u -- )
\r
2149 ; Handle the word not found in the search-order. If the string
\r
2150 ; is legal, compile a single or double cell number in
\r
2151 ; compilation state.
\r
2154 ; (doubleAlso) 1- IF SWAP POSTPONE LITERAL THEN POSTPONE LITERAL ;
\r
2156 $COLON 11,'doubleAlso,',DoubleAlsoComma,_SLINK
\r
2157 DW ParenDoubleAlso,OneMinus,ZBranch,DOUBC1
\r
2159 DOUBC1 DW LITERAL,EXIT
\r
2162 ; You don't need this word unless you care that '-.' returns
\r
2163 ; double cell number 0. Catching illegal number '-.' in this way
\r
2164 ; is easier than make 'interpret' catch this exception.
\r
2166 ; : -. -13 THROW ; IMMEDIATE \ undefined word
\r
2168 $COLON IMMED+2,'-.',MinusDot,_SLINK
\r
2169 DW DoLIT,-13,THROW
\r
2171 ; lastName ( -- c-addr )
\r
2172 ; Return the address of the last definition name.
\r
2174 ; : lastName npVar @ CELL+ CELL+ ;
\r
2176 $COLON 8,'lastName',LastName,_SLINK
\r
2177 DW NPVar,Fetch,CELLPlus,CELLPlus,EXIT
\r
2180 ; Link the word being defined to the current wordlist.
\r
2181 ; Do nothing if the last definition is made by :NONAME .
\r
2183 ; : linkLast lastName GET-CURRENT ! ;
\r
2185 $COLON 8,'linkLast',LinkLast,_SLINK
\r
2186 DW LastName,GET_CURRENT,Store,EXIT
\r
2188 ; name>xt ( c-addr -- xt )
\r
2189 ; Return execution token using counted string at c-addr.
\r
2191 ; : name>xt cell- cell- @ ;
\r
2193 $COLON 7,'name>xt',NameToXT,_SLINK
\r
2194 DW CellMinus,CellMinus,Fetch,EXIT
\r
2196 ; pack" ( c-addr u a-addr -- a-addr2 )
\r
2197 ; Place a string c-addr u at a-addr and gives the next
\r
2198 ; cell-aligned address. Fill the rest of the last cell with
\r
2201 ; : pack" OVER max-counted-string SWAP U<
\r
2202 ; IF -18 THROW THEN \ parsed string overflow
\r
2203 ; 2DUP SWAP CHARS + CHAR+ DUP >R \ ca u aa aa+u+1
\r
2204 ; ALIGNED cell- 0 SWAP ! \ fill 0 at the end of string
\r
2205 ; 2DUP C! CHAR+ SWAP \ c-addr a-addr+1 u
\r
2206 ; CHARS MOVE R> ALIGNED ; COMPILE-ONLY
\r
2208 $COLON COMPO+5,'pack"',PackQuote,_SLINK
\r
2209 DW OVER,DoLIT,MaxCountedString,SWAP,ULess,ZBranch,PACKQ1
\r
2210 DW DoLIT,-18,THROW
\r
2211 PACKQ1 DW TwoDUP,SWAP,CHARS,Plus,CHARPlus,DUPP,ToR
\r
2212 DW ALIGNED,CellMinus,Zero,SWAP,Store
\r
2213 DW TwoDUP,CStore,CHARPlus,SWAP
\r
2214 DW CHARS,MOVE,RFrom,ALIGNED,EXIT
\r
2216 ; PARSE-WORD ( "<spaces>ccc<space>" -- c-addr u )
\r
2217 ; Skip leading spaces and parse a word. Return the name.
\r
2219 ; : PARSE-WORD BL skipPARSE ;
\r
2221 $COLON 10,'PARSE-WORD',PARSE_WORD,_SLINK
\r
2222 DW BLank,SkipPARSE,EXIT
\r
2224 ; pipe ( -- ) ( R: xt -- )
\r
2225 ; Connect most recently defined word to code following DOES>.
\r
2226 ; Structure of CREATEd word:
\r
2227 ; | call-doCREATE | 0 or DOES> code addr | a-addr |
\r
2229 ; : pipe lastName name>xt ?call DUP IF \ code-addr xt2
\r
2230 ; ['] doCREATE = IF
\r
2231 ; R> SWAP ! \ change DOES> code of CREATEd word
\r
2234 ; -32 THROW \ invalid name argument, no-CREATEd last name
\r
2237 $COLON COMPO+4,'pipe',Pipe,_SLINK
\r
2238 DW LastName,NameToXT,QCall,DUPP,ZBranch,PIPE1
\r
2239 DW DoLIT,DoCREATE,Equals,ZBranch,PIPE1
\r
2240 DW RFrom,SWAP,Store,EXIT
\r
2241 PIPE1 DW DoLIT,-32,THROW
\r
2243 ; skipPARSE ( char "<chars>ccc<char>" -- c-addr u )
\r
2244 ; Skip leading chars and parse a word using char as a
\r
2245 ; delimeter. Return the name.
\r
2248 ; >R SOURCE >IN @ /STRING \ c_addr u R: char
\r
2250 ; BEGIN OVER C@ R@ =
\r
2251 ; WHILE 1- SWAP CHAR+ SWAP DUP 0=
\r
2252 ; UNTIL R> DROP EXIT
\r
2254 ; DROP SOURCE DROP - 1chars/ >IN ! R> PARSE EXIT
\r
2257 $COLON 9,'skipPARSE',SkipPARSE,_SLINK
\r
2258 DW ToR,SOURCE,ToIN,Fetch,SlashSTRING
\r
2259 DW DUPP,ZBranch,SKPAR1
\r
2260 SKPAR2 DW OVER,CFetch,RFetch,Equals,ZBranch,SKPAR3
\r
2261 DW OneMinus,SWAP,CHARPlus,SWAP
\r
2262 DW DUPP,ZeroEquals,ZBranch,SKPAR2
\r
2263 DW RFrom,DROP,EXIT
\r
2264 SKPAR3 DW DROP,SOURCE,DROP,Minus,OneCharsSlash
\r
2265 DW ToIN,Store,RFrom,PARSE,EXIT
\r
2266 SKPAR1 DW RFrom,DROP,EXIT
\r
2268 ; rake ( C: do-sys -- )
\r
2271 ; : rake DUP code, rakeVar @
\r
2273 ; WHILE DUP @ xhere ROT !
\r
2274 ; REPEAT rakeVar ! DROP
\r
2275 ; ?DUP IF \ check for ?DO
\r
2276 ; 1 bal+ POSTPONE THEN \ orig type is 1
\r
2277 ; THEN bal- ; COMPILE-ONLY
\r
2279 $COLON COMPO+4,'rake',rake,_SLINK
\r
2280 DW DUPP,CodeComma,RakeVar,Fetch
\r
2281 RAKE1 DW TwoDUP,ULess,ZBranch,RAKE2
\r
2282 DW DUPP,Fetch,XHere,ROT,Store,Branch,RAKE1
\r
2283 RAKE2 DW RakeVar,Store,DROP
\r
2284 DW QuestionDUP,ZBranch,RAKE3
\r
2285 DW One,BalPlus,THENN
\r
2286 RAKE3 DW BalMinus,EXIT
\r
2288 ; rp0 ( -- a-addr )
\r
2289 ; Pointer to bottom of the return stack.
\r
2291 ; : rp0 userP @ CELL+ CELL+ @ ;
\r
2293 $COLON 3,'rp0',RPZero,_SLINK
\r
2294 DW UserP,Fetch,CELLPlus,CELLPlus,Fetch,EXIT
\r
2296 ; search-word ( c-addr u -- c-addr u 0 | xt f 1 | xt f -1)
\r
2297 ; Search dictionary for a match with the given name. Return
\r
2298 ; execution token, not-compile-only flag and -1 or 1
\r
2299 ; ( IMMEDIATE) if found; c-addr u 0 if not.
\r
2302 ; #order @ DUP \ not found if #order is 0
\r
2304 ; DO 2DUP \ ca u ca u
\r
2305 ; I CELLS #order CELL+ + @ \ ca u ca u wid
\r
2306 ; (search-wordlist) \ ca u; 0 | w f 1 | w f -1
\r
2307 ; ?DUP IF \ ca u; 0 | w f 1 | w f -1
\r
2308 ; >R 2SWAP 2DROP R> UNLOOP EXIT \ xt f 1 | xt f -1
\r
2313 $COLON 11,'search-word',Search_word,_SLINK
\r
2314 DW NumberOrder,Fetch,DUPP,ZBranch,SEARCH1
\r
2316 SEARCH2 DW TwoDUP,I,CELLS,NumberOrder,CELLPlus,Plus,Fetch
\r
2317 DW ParenSearch_Wordlist,QuestionDUP,ZBranch,SEARCH3
\r
2318 DW ToR,TwoSWAP,TwoDROP,RFrom,UNLOOP,EXIT
\r
2319 SEARCH3 DW DoLOOP,SEARCH2
\r
2323 ; sourceVar ( -- a-addr )
\r
2324 ; Hold the current count and address of the terminal input buffer.
\r
2326 $VAR 9,'sourceVar',SourceVar,_SLINK
\r
2327 _VAR = _VAR +CELLL
\r
2329 ; sp0 ( -- a-addr )
\r
2330 ; Pointer to bottom of the data stack.
\r
2332 ; : sp0 userP @ CELL+ @ ;
\r
2334 $COLON 3,'sp0',SPZero,_SLINK
\r
2335 DW UserP,Fetch,CELLPlus,Fetch,EXIT
\r
2337 ; TOxhere ( a-addr -- )
\r
2338 ; Set the next available code space address as a-addr.
\r
2340 ; : TOxhere cpVar ! ;
\r
2342 $COLON 7,'TOxhere',TOXHere,_SLINK
\r
2343 DW CPVar,Store,EXIT
\r
2345 ; xhere ( -- a-addr )
\r
2346 ; Return next available code space address.
\r
2348 ; : xhere cpVar @ ;
\r
2350 $COLON 5,'xhere',XHere,_SLINK
\r
2351 DW CPVar,Fetch,EXIT
\r
2354 ; Reserve one cell in code space and store x in it.
\r
2356 ; : code, xhere DUP CELL+ TOxhere ! ;
\r
2358 $COLON 5,'code,',CodeComma,_SLINK
\r
2359 DW XHere,DUPP,CELLPlus,TOXHere,Store,EXIT
\r
2362 ; Words for multitasking
\r
2366 ; Stop current task and transfer control to the task of which
\r
2367 ; 'status' USER variable is stored in 'follower' USER variable
\r
2368 ; of current task.
\r
2370 ; : PAUSE rp@ sp@ stackTop ! follower @ >R ; COMPILE-ONLY
\r
2372 $COLON COMPO+5,'PAUSE',PAUSE,_SLINK
\r
2373 DW RPFetch,SPFetch,StackTop,Store,Follower,Fetch,ToR,EXIT
\r
2376 ; Wake current task.
\r
2378 ; : wake R> userP ! \ userP points 'follower' of current task
\r
2379 ; stackTop @ sp! \ set data stack
\r
2380 ; rp! ; COMPILE-ONLY \ set return stack
\r
2382 $COLON COMPO+4,'wake',Wake,_SLINK
\r
2383 DW RFrom,UserP,Store,StackTop,Fetch,SPStore,RPStore,EXIT
\r
2386 ; Essential Standard words - Colon definitions
\r
2389 ; # ( ud1 -- ud2 ) \ CORE
\r
2390 ; Extract one digit from ud1 and append the digit to
\r
2391 ; pictured numeric output string. ( ud2 = ud1 / BASE )
\r
2393 ; : # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP
\r
2394 ; 9 OVER < [ CHAR A CHAR 9 1 + - ] LITERAL AND +
\r
2395 ; [ CHAR 0 ] LITERAL + HOLD R> ;
\r
2397 $COLON 1,'#',NumberSign,_FLINK
\r
2398 DW Zero,BASE,Fetch,UMSlashMOD,ToR,BASE,Fetch,UMSlashMOD
\r
2399 DW SWAP,DoLIT,9,OVER,LessThan,DoLIT,'A'-'9'-1,ANDD,Plus
\r
2400 DW DoLIT,'0',Plus,HOLD,RFrom,EXIT
\r
2402 ; #> ( xd -- c-addr u ) \ CORE
\r
2403 ; Prepare the output string to be TYPE'd.
\r
2404 ; ||xhere>WORD/#-work-area|
\r
2406 ; : #> 2DROP hld @ xhere [ size-of-PAD ] LITERAL + OVER - 1chars/ ;
\r
2408 $COLON 2,'#>',NumberSignGreater,_FLINK
\r
2409 DW TwoDROP,HLD,Fetch,XHere,DoLIT,PADSize*CHARR,Plus
\r
2410 DW OVER,Minus,OneCharsSlash,EXIT
\r
2412 ; #S ( ud -- 0 0 ) \ CORE
\r
2413 ; Convert ud until all digits are added to the output string.
\r
2415 ; : #S BEGIN # 2DUP OR 0= UNTIL ;
\r
2417 $COLON 2,'#S',NumberSignS,_FLINK
\r
2418 NUMSS1 DW NumberSign,TwoDUP,ORR
\r
2419 DW ZeroEquals,ZBranch,NUMSS1
\r
2422 ; ' ( "<spaces>name" -- xt ) \ CORE
\r
2423 ; Parse a name, find it and return xt.
\r
2427 $COLON 1,"'",Tick,_FLINK
\r
2428 DW ParenTick,DROP,EXIT
\r
2430 ; + ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
2431 ; Add top two items and gives the sum.
\r
2435 $COLON 1,'+',Plus,_FLINK
\r
2436 DW UMPlus,DROP,EXIT
\r
2438 ; +! ( n|u a-addr -- ) \ CORE
\r
2439 ; Add n|u to the contents at a-addr.
\r
2441 ; : +! SWAP OVER @ + SWAP ! ;
\r
2443 $COLON 2,'+!',PlusStore,_FLINK
\r
2444 DW SWAP,OVER,Fetch,Plus
\r
2445 DW SWAP,Store,EXIT
\r
2447 ; , ( x -- ) \ CORE
\r
2448 ; Reserve one cell in RAM or ROM data space and store x in it.
\r
2450 ; : , HERE ! [ cell-size ] LITERAL hereVar +! ;
\r
2452 $COLON 1,',',Comma,_FLINK
\r
2454 DW DoLIT,CELLL,HereVar,PlusStore,EXIT
\r
2456 ; - ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
2457 ; Subtract n2|u2 from n1|u1, giving the difference n3|u3.
\r
2461 $COLON 1,'-',Minus,_FLINK
\r
2462 DW NEGATE,Plus,EXIT
\r
2464 ; . ( n -- ) \ CORE
\r
2465 ; Display a signed number followed by a space.
\r
2469 $COLON 1,'.',Dot,_FLINK
\r
2472 ; / ( n1 n2 -- n3 ) \ CORE
\r
2473 ; Divide n1 by n2, giving single-cell quotient n3.
\r
2477 $COLON 1,'/',Slash,_FLINK
\r
2478 DW SlashMOD,NIP,EXIT
\r
2480 ; /MOD ( n1 n2 -- n3 n4 ) \ CORE
\r
2481 ; Divide n1 by n2, giving single-cell remainder n3 and
\r
2482 ; single-cell quotient n4.
\r
2484 ; : /MOD >R S>D R> FM/MOD ;
\r
2486 $COLON 4,'/MOD',SlashMOD,_FLINK
\r
2487 DW ToR,SToD,RFrom,FMSlashMOD,EXIT
\r
2489 ; /STRING ( c-addr1 u1 n -- c-addr2 u2 ) \ STRING
\r
2490 ; Adjust the char string at c-addr1 by n chars.
\r
2492 ; : /STRING DUP >R - SWAP R> CHARS + SWAP ;
\r
2494 $COLON 7,'/STRING',SlashSTRING,_FLINK
\r
2495 DW DUPP,ToR,Minus,SWAP,RFrom,CHARS,Plus,SWAP,EXIT
\r
2497 ; 1+ ( n1|u1 -- n2|u2 ) \ CORE
\r
2498 ; Increase top of the stack item by 1.
\r
2502 $COLON 2,'1+',OnePlus,_FLINK
\r
2505 ; 1- ( n1|u1 -- n2|u2 ) \ CORE
\r
2506 ; Decrease top of the stack item by 1.
\r
2510 $COLON 2,'1-',OneMinus,_FLINK
\r
2511 DW MinusOne,Plus,EXIT
\r
2513 ; 2! ( x1 x2 a-addr -- ) \ CORE
\r
2514 ; Store the cell pare x1 x2 at a-addr, with x2 at a-addr and
\r
2515 ; x1 at the next consecutive cell.
\r
2517 ; : 2! SWAP OVER ! CELL+ ! ;
\r
2519 $COLON 2,'2!',TwoStore,_FLINK
\r
2520 DW SWAP,OVER,Store,CELLPlus,Store,EXIT
\r
2522 ; 2@ ( a-addr -- x1 x2 ) \ CORE
\r
2523 ; Fetch the cell pair stored at a-addr. x2 is stored at a-addr
\r
2524 ; and x1 at the next consecutive cell.
\r
2526 ; : 2@ DUP CELL+ @ SWAP @ ;
\r
2528 $COLON 2,'2@',TwoFetch,_FLINK
\r
2529 DW DUPP,CELLPlus,Fetch,SWAP,Fetch,EXIT
\r
2531 ; 2DROP ( x1 x2 -- ) \ CORE
\r
2532 ; Drop cell pair x1 x2 from the stack.
\r
2534 ; : 2DROP DROP DROP ;
\r
2536 $COLON 5,'2DROP',TwoDROP,_FLINK
\r
2539 ; 2DUP ( x1 x2 -- x1 x2 x1 x2 ) \ CORE
\r
2540 ; Duplicate cell pair x1 x2.
\r
2542 ; : 2DUP DUP DUP ;
\r
2544 $COLON 4,'2DUP',TwoDUP,_FLINK
\r
2547 ; 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) \ CORE
\r
2548 ; Exchange the top two cell pairs.
\r
2550 ; : 2SWAP ROT >R ROT R> ;
\r
2552 $COLON 5,'2SWAP',TwoSWAP,_FLINK
\r
2553 DW ROT,ToR,ROT,RFrom,EXIT
\r
2555 ; : ( "<spaces>name" -- colon-sys ) \ CORE
\r
2556 ; Start a new colon definition using next word as its name.
\r
2558 ; : : :NONAME ROT head, -1 TO notNONAME? ;
\r
2560 $COLON 1,':',COLON,_FLINK
\r
2561 DW ColonNONAME,ROT,HeadComma
\r
2562 DW DoLIT,-1,DoTO,AddrNotNONAMEQ,EXIT
\r
2564 ; :NONAME ( -- xt colon-sys ) \ CORE EXT
\r
2565 ; Create an execution token xt, enter compilation state and
\r
2566 ; start the current definition.
\r
2568 ; : :NONAME bal IF -29 THROW THEN \ compiler nesting
\r
2569 ; ['] doLIST xt, DUP -1
\r
2570 ; 0 TO notNONAME? 1 TO bal ] ;
\r
2572 $COLON 7,':NONAME',ColonNONAME,_FLINK
\r
2573 DW Bal,ZBranch,NONAME1
\r
2574 DW DoLIT,-29,THROW
\r
2575 NONAME1 DW DoLIT,DoLIST,xtComma,DUPP,DoLIT,-1
\r
2576 DW Zero,DoTO,AddrNotNONAMEQ
\r
2577 DW One,DoTO,AddrBal,RightBracket,EXIT
\r
2579 ; ; ( colon-sys -- ) \ CORE
\r
2580 ; Terminate a colon definition.
\r
2582 ; : ; bal 1- IF -22 THROW THEN \ control structure mismatch
\r
2583 ; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1
\r
2584 ; notNONAME? IF \ if the last definition is not created by ':'
\r
2585 ; linkLast 0 TO notNONAME? \ link the word to wordlist
\r
2586 ; THEN POSTPONE EXIT \ add EXIT at the end of the definition
\r
2587 ; 0 TO bal POSTPONE [ ; COMPILE-ONLY IMMEDIATE
\r
2589 $COLON IMMED+COMPO+1,';',Semicolon,_FLINK
\r
2590 DW Bal,OneMinus,ZBranch,SEMI1
\r
2591 DW DoLIT,-22,THROW
\r
2592 SEMI1 DW NIP,OnePlus,ZBranch,SEMI2
\r
2593 DW DoLIT,-22,THROW
\r
2594 SEMI2 DW NotNONAMEQ,ZBranch,SEMI3
\r
2595 DW LinkLast,Zero,DoTO,AddrNotNONAMEQ
\r
2596 SEMI3 DW DoLIT,EXIT,COMPILEComma
\r
2597 DW Zero,DoTO,AddrBal,LeftBracket,EXIT
\r
2599 ; < ( n1 n2 -- flag ) \ CORE
\r
2600 ; Returns true if n1 is less than n2.
\r
2602 ; : < 2DUP XOR 0< \ same sign?
\r
2603 ; IF DROP 0< EXIT THEN \ different signs, true if n1 <0
\r
2604 ; - 0< ; \ same signs, true if n1-n2 <0
\r
2606 $COLON 1,'<',LessThan,_FLINK
\r
2607 DW TwoDUP,XORR,ZeroLess,ZBranch,LESS1
\r
2608 DW DROP,ZeroLess,EXIT
\r
2609 LESS1 DW Minus,ZeroLess,EXIT
\r
2611 ; <# ( -- ) \ CORE
\r
2612 ; Initiate the numeric output conversion process.
\r
2613 ; ||xhere>WORD/#-work-area|
\r
2615 ; : <# xhere [ size-of-PAD ] LITERAL + hld ! ;
\r
2617 $COLON 2,'<#',LessNumberSign,_FLINK
\r
2618 DW XHere,DoLIT,PADSize*CHARR,Plus,HLD,Store,EXIT
\r
2620 ; = ( x1 x2 -- flag ) \ CORE
\r
2621 ; Return true if top two are equal.
\r
2625 $COLON 1,'=',Equals,_FLINK
\r
2626 DW XORR,ZeroEquals,EXIT
\r
2628 ; > ( n1 n2 -- flag ) \ CORE
\r
2629 ; Returns true if n1 is greater than n2.
\r
2633 $COLON 1,'>',GreaterThan,_FLINK
\r
2634 DW SWAP,LessThan,EXIT
\r
2636 ; >IN ( -- a-addr ) \ CORE
\r
2637 ; Hold the character pointer while parsing input stream.
\r
2639 $VAR 3,'>IN',ToIN,_FLINK
\r
2641 ; >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ CORE
\r
2642 ; Add number string's value to ud1. Leaves string of any
\r
2643 ; unconverted chars.
\r
2645 ; : >NUMBER BEGIN DUP
\r
2646 ; WHILE >R DUP >R C@ \ ud char R: u c-addr
\r
2647 ; DUP [ CHAR 9 1+ ] LITERAL [CHAR] A WITHIN
\r
2648 ; IF DROP R> R> EXIT THEN
\r
2649 ; [ CHAR 0 ] LITERAL - 9 OVER <
\r
2650 ; [ CHAR A CHAR 9 1 + - ] LITERAL AND -
\r
2651 ; DUP 0 BASE @ WITHIN
\r
2652 ; WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> R> 1 /STRING
\r
2653 ; REPEAT DROP R> R>
\r
2656 $COLON 7,'>NUMBER',ToNUMBER,_FLINK
\r
2657 TONUM1 DW DUPP,ZBranch,TONUM3
\r
2658 DW ToR,DUPP,ToR,CFetch,DUPP
\r
2659 DW DoLIT,'9'+1,DoLIT,'A',WITHIN,ZeroEquals,ZBranch,TONUM2
\r
2660 DW DoLIT,'0',Minus,DoLIT,9,OVER,LessThan
\r
2661 DW DoLIT,'A'-'9'-1,ANDD,Minus,DUPP
\r
2662 DW Zero,BASE,Fetch,WITHIN,ZBranch,TONUM2
\r
2663 DW SWAP,BASE,Fetch,UMStar,DROP,ROT,BASE,Fetch
\r
2664 DW UMStar,DPlus,RFrom,RFrom,One,SlashSTRING
\r
2666 TONUM2 DW DROP,RFrom,RFrom
\r
2669 ; ?DUP ( x -- x x | 0 ) \ CORE
\r
2670 ; Duplicate top of the stack if it is not zero.
\r
2672 ; : ?DUP DUP IF DUP THEN ;
\r
2674 $COLON 4,'?DUP',QuestionDUP,_FLINK
\r
2675 DW DUPP,ZBranch,QDUP1
\r
2679 ; ABORT ( i*x -- ) ( R: j*x -- ) \ EXCEPTION EXT
\r
2680 ; Reset data stack and jump to QUIT.
\r
2682 ; : ABORT -1 THROW ;
\r
2684 $COLON 5,'ABORT',ABORT,_FLINK
\r
2687 ; ACCEPT ( c-addr +n1 -- +n2 ) \ CORE
\r
2688 ; Accept a string of up to +n1 chars. Return with actual count.
\r
2689 ; Implementation-defined editing. Stops at EOL# .
\r
2690 ; Supports backspace and delete editing.
\r
2693 ; BEGIN DUP R@ < \ ca n2 f R: n1
\r
2694 ; WHILE KEY DUP BL <
\r
2695 ; IF DUP [ cr# ] LITERAL = IF ROT 2DROP R> DROP EXIT THEN
\r
2696 ; DUP [ tab# ] LITERAL =
\r
2697 ; IF DROP 2DUP + BL DUP EMIT SWAP C! 1+
\r
2698 ; ELSE DUP [ bsp# ] LITERAL =
\r
2699 ; SWAP [ del# ] LITERAL = OR
\r
2700 ; IF DUP \ discard the last char if not 1st char
\r
2701 ; IF 1- [ bsp# ] LITERAL EMIT
\r
2702 ; BL EMIT [ bsp# ] LITERAL EMIT THEN
\r
2705 ; ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+
\r
2707 ; REPEAT SWAP R> 2DROP ;
\r
2709 $COLON 6,'ACCEPT',ACCEPT,_FLINK
\r
2711 ACCPT1 DW DUPP,RFetch,LessThan,ZBranch,ACCPT5
\r
2712 DW KEY,DUPP,BLank,LessThan,ZBranch,ACCPT3
\r
2713 DW DUPP,DoLIT,CRR,Equals,ZBranch,ACCPT4
\r
2714 DW ROT,TwoDROP,RFrom,DROP,EXIT
\r
2715 ACCPT4 DW DUPP,DoLIT,TABB,Equals,ZBranch,ACCPT6
\r
2716 DW DROP,TwoDUP,Plus,BLank,DUPP,EMIT,SWAP,CStore,OnePlus
\r
2718 ACCPT6 DW DUPP,DoLIT,BKSPP,Equals
\r
2719 DW SWAP,DoLIT,DEL,Equals,ORR,ZBranch,ACCPT1
\r
2720 DW DUPP,ZBranch,ACCPT1
\r
2721 DW OneMinus,DoLIT,BKSPP,EMIT,BLank,EMIT,DoLIT,BKSPP,EMIT
\r
2723 ACCPT3 DW ToR,TwoDUP,CHARS,Plus,RFrom,DUPP,EMIT,SWAP,CStore
\r
2724 DW OnePlus,Branch,ACCPT1
\r
2725 ACCPT5 DW SWAP,RFrom,TwoDROP,EXIT
\r
2727 ; AGAIN ( C: dest -- ) \ CORE EXT
\r
2728 ; Resolve backward reference dest. Typically used as
\r
2729 ; BEGIN ... AGAIN . Move control to the location specified by
\r
2730 ; dest on execution.
\r
2732 ; : AGAIN IF -22 THROW THEN \ control structure mismatch; dest type is 0
\r
2733 ; POSTPONE branch code, bal- ; COMPILE-ONLY IMMEDIATE
\r
2735 $COLON IMMED+COMPO+5,'AGAIN',AGAIN,_FLINK
\r
2737 DW DoLIT,-22,THROW
\r
2738 AGAIN1 DW DoLIT,Branch,COMPILEComma,CodeComma,BalMinus,EXIT
\r
2740 ; AHEAD ( C: -- orig ) \ TOOLS EXT
\r
2741 ; Put the location of a new unresolved forward reference onto
\r
2742 ; control-flow stack.
\r
2744 ; : AHEAD POSTPONE branch xhere 0 code,
\r
2745 ; 1 bal+ \ orig type is 1
\r
2746 ; ; COMPILE-ONLY IMMEDIATE
\r
2748 $COLON IMMED+COMPO+5,'AHEAD',AHEAD,_FLINK
\r
2749 DW DoLIT,Branch,COMPILEComma,XHere,Zero,CodeComma
\r
2750 DW One,BalPlus,EXIT
\r
2752 ; BL ( -- char ) \ CORE
\r
2753 ; Return the value of the blank character.
\r
2755 ; : BL blank-char-value EXIT ;
\r
2757 $CONST 2,'BL',BLank,' ',_FLINK
\r
2759 ; CATCH ( i*x xt -- j*x 0 | i*x n ) \ EXCEPTION
\r
2760 ; Push an exception frame on the exception stack and then execute
\r
2761 ; the execution token xt in such a way that control can be
\r
2762 ; transferred to a point just after CATCH if THROW is executed
\r
2763 ; during the execution of xt.
\r
2765 ; : CATCH sp@ >R throwFrame @ >R \ save error frame
\r
2766 ; rp@ throwFrame ! EXECUTE \ execute
\r
2767 ; R> throwFrame ! \ restore error frame
\r
2768 ; R> DROP 0 ; \ no error
\r
2770 $COLON 5,'CATCH',CATCH,_FLINK
\r
2771 DW SPFetch,ToR,ThrowFrame,Fetch,ToR
\r
2772 DW RPFetch,ThrowFrame,Store,EXECUTE
\r
2773 DW RFrom,ThrowFrame,Store
\r
2774 DW RFrom,DROP,Zero,EXIT
\r
2776 ; CELL+ ( a-addr1 -- a-addr2 ) \ CORE
\r
2777 ; Return next aligned cell address.
\r
2779 ; : CELL+ [ cell-size ] LITERAL + ;
\r
2781 $COLON 5,'CELL+',CELLPlus,_FLINK
\r
2782 DW DoLIT,CELLL,Plus,EXIT
\r
2784 ; CHAR+ ( c-addr1 -- c-addr2 ) \ CORE
\r
2785 ; Returns next character-aligned address.
\r
2787 ; : CHAR+ [ char-size ] LITERAL + ;
\r
2789 $COLON 5,'CHAR+',CHARPlus,_FLINK
\r
2790 DW DoLIT,CHARR,Plus,EXIT
\r
2792 ; COMPILE, ( xt -- ) \ CORE EXT
\r
2793 ; Compile the execution token on data stack into current
\r
2794 ; colon definition.
\r
2796 ; : COMPILE, code, ; COMPILE-ONLY
\r
2798 $COLON COMPO+8,'COMPILE,',COMPILEComma,_FLINK
\r
2801 ; CONSTANT ( x "<spaces>name" -- ) \ CORE
\r
2802 ; name Execution: ( -- x )
\r
2803 ; Create a definition for name which pushes x on the stack on
\r
2806 ; : CONSTANT bal IF -29 THROW THEN \ compiler nesting
\r
2807 ; ['] doCONST xt, head, code, linkLast ;
\r
2809 $COLON 8,'CONSTANT',CONSTANT,_FLINK
\r
2810 DW Bal,ZBranch,CONST1
\r
2811 DW DoLIT,-29,THROW
\r
2812 CONST1 DW DoLIT,DoCONST,xtComma,HeadComma,CodeComma,LinkLast,EXIT
\r
2814 ; COUNT ( c-addr1 -- c-addr2 u ) \ CORE
\r
2815 ; Convert counted string to string specification. c-addr2 is
\r
2816 ; the next char-aligned address after c-addr1 and u is the
\r
2817 ; contents at c-addr1.
\r
2819 ; : COUNT DUP CHAR+ SWAP C@ ;
\r
2821 $COLON 5,'COUNT',COUNT,_FLINK
\r
2822 DW DUPP,CHARPlus,SWAP,CFetch,EXIT
\r
2824 ; CREATE ( "<spaces>name" -- ) \ CORE
\r
2825 ; name Execution: ( -- a-addr )
\r
2826 ; Create a data object in RAM/ROM data space, which return
\r
2827 ; data object address on execution
\r
2829 ; : CREATE bal IF -29 THROW THEN \ compiler nesting
\r
2830 ; ['] doCREATE xt, head,
\r
2831 ; xhere DUP CELL+ CELL+ TOxhere \ reserve two cells
\r
2832 ; 0 OVER ! \ no DOES> code yet
\r
2833 ; ALIGN HERE SWAP CELL+ ! \ >BODY returns this address
\r
2834 ; linkLast ; \ link CREATEd word to current wordlist
\r
2836 $COLON 6,'CREATE',CREATE,_FLINK
\r
2837 DW Bal,ZBranch,CREAT1
\r
2838 DW DoLIT,-29,THROW
\r
2839 CREAT1 DW DoLIT,DoCREATE,xtComma,HeadComma
\r
2840 DW XHere,DUPP,CELLPlus,CELLPlus,TOXHere
\r
2841 DW Zero,OVER,Store
\r
2842 DW ALIGNN,HERE,SWAP,CELLPlus,Store
\r
2845 ; D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE
\r
2846 ; Add double-cell numbers.
\r
2848 ; : D+ >R SWAP >R um+ R> R> + + ;
\r
2850 $COLON 2,'D+',DPlus,_FLINK
\r
2851 DW ToR,SWAP,ToR,UMPlus
\r
2852 DW RFrom,RFrom,Plus,Plus,EXIT
\r
2854 ; D. ( d -- ) \ DOUBLE
\r
2855 ; Display d in free field format followed by a space.
\r
2857 ; : D. (d.) TYPE SPACE ;
\r
2859 $COLON 2,'D.',DDot,_FLINK
\r
2860 DW ParenDDot,TYPEE,SPACE,EXIT
\r
2862 ; DECIMAL ( -- ) \ CORE
\r
2863 ; Set the numeric conversion radix to decimal 10.
\r
2865 ; : DECIMAL 10 BASE ! ;
\r
2867 $COLON 7,'DECIMAL',DECIMAL,_FLINK
\r
2868 DW DoLIT,10,BASE,Store,EXIT
\r
2870 ; DNEGATE ( d1 -- d2 ) \ DOUBLE
\r
2871 ; Two's complement of double-cell number.
\r
2873 ; : DNEGATE INVERT >R INVERT 1 um+ R> + ;
\r
2875 $COLON 7,'DNEGATE',DNEGATE,_FLINK
\r
2876 DW INVERT,ToR,INVERT
\r
2878 DW RFrom,Plus,EXIT
\r
2880 ; EKEY ( -- u ) \ FACILITY EXT
\r
2881 ; Receive one keyboard event u.
\r
2883 ; : EKEY BEGIN PAUSE EKEY? UNTIL 'ekey EXECUTE ;
\r
2885 $COLON 4,'EKEY',EKEY,_FLINK
\r
2886 EKEY1 DW PAUSE,EKEYQuestion,ZBranch,EKEY1
\r
2887 DW TickEKEY,EXECUTE,EXIT
\r
2889 ; EMIT ( x -- ) \ CORE
\r
2890 ; Send a character to the output device.
\r
2892 ; : EMIT 'emit EXECUTE ;
\r
2894 $COLON 4,'EMIT',EMIT,_FLINK
\r
2895 DW TickEMIT,EXECUTE,EXIT
\r
2897 ; FM/MOD ( d n1 -- n2 n3 ) \ CORE
\r
2898 ; Signed floored divide of double by single. Return mod n2
\r
2899 ; and quotient n3.
\r
2901 ; : FM/MOD DUP >R 2DUP XOR >R >R DUP 0< IF DNEGATE THEN
\r
2903 ; R> 0< IF SWAP NEGATE SWAP THEN
\r
2904 ; R> 0< IF NEGATE \ negative quotient
\r
2905 ; OVER IF R@ ROT - SWAP 1- THEN
\r
2907 ; 0 OVER < IF -11 THROW THEN \ result out of range
\r
2909 ; R> DROP DUP 0< IF -11 THROW THEN ; \ result out of range
\r
2911 $COLON 6,'FM/MOD',FMSlashMOD,_FLINK
\r
2912 DW DUPP,ToR,TwoDUP,XORR,ToR,ToR,DUPP,ZeroLess
\r
2915 FMMOD1 DW RFetch,ABSS,UMSlashMOD
\r
2916 DW RFrom,ZeroLess,ZBranch,FMMOD2
\r
2917 DW SWAP,NEGATE,SWAP
\r
2918 FMMOD2 DW RFrom,ZeroLess,ZBranch,FMMOD3
\r
2919 DW NEGATE,OVER,ZBranch,FMMOD4
\r
2920 DW RFetch,ROT,Minus,SWAP,OneMinus
\r
2921 FMMOD4 DW RFrom,DROP
\r
2922 DW DoLIT,0,OVER,LessThan,ZBranch,FMMOD6
\r
2923 DW DoLIT,-11,THROW
\r
2925 FMMOD3 DW RFrom,DROP,DUPP,ZeroLess,ZBranch,FMMOD6
\r
2926 DW DoLIT,-11,THROW
\r
2928 ; GET-CURRENT ( -- wid ) \ SEARCH
\r
2929 ; Return the indentifier of the compilation wordlist.
\r
2931 ; : GET-CURRENT current @ ;
\r
2933 $COLON 11,'GET-CURRENT',GET_CURRENT,_FLINK
\r
2934 DW Current,Fetch,EXIT
\r
2936 ; HERE ( -- addr ) \ CORE
\r
2937 ; Return data space pointer.
\r
2939 ; : HERE hereVar @ ;
\r
2941 $COLON 4,'HERE',HERE,_FLINK
\r
2942 DW HereVar,Fetch,EXIT
\r
2944 ; HOLD ( char -- ) \ CORE
\r
2945 ; Add char to the beginning of pictured numeric output string.
\r
2947 ; : HOLD hld @ 1 CHARS - DUP hld ! C! ;
\r
2949 $COLON 4,'HOLD',HOLD,_FLINK
\r
2950 DW HLD,Fetch,DoLIT,0-CHARR,Plus
\r
2951 DW DUPP,HLD,Store,CStore,EXIT
\r
2953 ; IF Compilation: ( C: -- orig ) \ CORE
\r
2954 ; Run-time: ( x -- )
\r
2955 ; Put the location of a new unresolved forward reference orig
\r
2956 ; onto the control flow stack. On execution jump to location
\r
2957 ; specified by the resolution of orig if x is zero.
\r
2959 ; : IF POSTPONE 0branch xhere 0 code,
\r
2960 ; 1 bal+ \ orig type is 1
\r
2961 ; ; COMPILE-ONLY IMMEDIATE
\r
2963 $COLON IMMED+COMPO+2,'IF',IFF,_FLINK
\r
2964 DW DoLIT,ZBranch,COMPILEComma,XHere,Zero,CodeComma
\r
2965 DW One,BalPlus,EXIT
\r
2967 ; INVERT ( x1 -- x2 ) \ CORE
\r
2968 ; Return one's complement of x1.
\r
2970 ; : INVERT -1 XOR ;
\r
2972 $COLON 6,'INVERT',INVERT,_FLINK
\r
2973 DW MinusOne,XORR,EXIT
\r
2975 ; KEY ( -- char ) \ CORE
\r
2976 ; Receive a character. Do not display char.
\r
2978 ; : KEY EKEY [ max-char ] LITERAL AND ;
\r
2980 $COLON 3,'KEY',KEY,_FLINK
\r
2981 DW EKEY,DoLIT,MaxChar,ANDD,EXIT
\r
2983 ; LITERAL Compilation: ( x -- ) \ CORE
\r
2984 ; Run-time: ( -- x )
\r
2985 ; Append following run-time semantics. Put x on the stack on
\r
2988 ; : LITERAL POSTPONE doLIT code, ; COMPILE-ONLY IMMEDIATE
\r
2990 $COLON IMMED+COMPO+7,'LITERAL',LITERAL,_FLINK
\r
2991 DW DoLIT,DoLIT,COMPILEComma,CodeComma,EXIT
\r
2993 ; NEGATE ( n1 -- n2 ) \ CORE
\r
2994 ; Return two's complement of n1.
\r
2996 ; : NEGATE INVERT 1+ ;
\r
2998 $COLON 6,'NEGATE',NEGATE,_FLINK
\r
2999 DW INVERT,OnePlus,EXIT
\r
3001 ; NIP ( n1 n2 -- n2 ) \ CORE EXT
\r
3002 ; Discard the second stack item.
\r
3004 ; : NIP SWAP DROP ;
\r
3006 $COLON 3,'NIP',NIP,_FLINK
\r
3009 ; PARSE ( char "ccc<char>"-- c-addr u ) \ CORE EXT
\r
3010 ; Scan input stream and return counted string delimited by char.
\r
3012 ; : PARSE >R SOURCE >IN @ /STRING \ c-addr u R: char
\r
3014 ; CHARS OVER + OVER \ c-addr c-addr+u c-addr R: char
\r
3015 ; BEGIN DUP C@ R@ XOR
\r
3016 ; WHILE CHAR+ 2DUP =
\r
3017 ; UNTIL DROP OVER - 1chars/ DUP
\r
3018 ; ELSE NIP OVER - 1chars/ DUP CHAR+
\r
3020 ; THEN R> DROP EXIT ;
\r
3022 $COLON 5,'PARSE',PARSE,_FLINK
\r
3023 DW ToR,SOURCE,ToIN,Fetch,SlashSTRING
\r
3024 DW DUPP,ZBranch,PARSE4
\r
3025 DW CHARS,OVER,Plus,OVER
\r
3026 PARSE1 DW DUPP,CFetch,RFetch,XORR,ZBranch,PARSE3
\r
3027 DW CHARPlus,TwoDUP,Equals,ZBranch,PARSE1
\r
3028 PARSE2 DW DROP,OVER,Minus,DUPP,OneCharsSlash,Branch,PARSE5
\r
3029 PARSE3 DW NIP,OVER,Minus,DUPP,OneCharsSlash,CHARPlus
\r
3030 PARSE5 DW ToIN,PlusStore
\r
3031 PARSE4 DW RFrom,DROP,EXIT
\r
3033 ; QUIT ( -- ) ( R: i*x -- ) \ CORE
\r
3034 ; Empty the return stack, store zero in SOURCE-ID, make the user
\r
3035 ; input device the input source, and start text interpreter.
\r
3038 ; rp0 rp! 0 TO SOURCE-ID 0 TO bal POSTPONE [
\r
3039 ; BEGIN CR REFILL DROP SPACE \ REFILL returns always true
\r
3040 ; ['] interpret CATCH ?DUP 0=
\r
3041 ; WHILE STATE @ 0= IF .prompt THEN
\r
3043 ; DUP -1 XOR IF \ ABORT
\r
3044 ; DUP -2 = IF SPACE abort"msg 2@ TYPE ELSE \ ABORT"
\r
3045 ; SPACE errWord 2@ TYPE
\r
3046 ; SPACE [CHAR] ? EMIT SPACE
\r
3047 ; DUP -1 -58 WITHIN IF ." Exception # " . ELSE \ undefined exception
\r
3048 ; CELLS THROWMsgTbl + @ COUNT TYPE THEN THEN THEN
\r
3052 $COLON 4,'QUIT',QUIT,_FLINK
\r
3053 QUIT1 DW RPZero,RPStore,Zero,DoTO,AddrSOURCE_ID
\r
3054 DW Zero,DoTO,AddrBal,LeftBracket
\r
3055 QUIT2 DW CR,REFILL,DROP,SPACE
\r
3056 DW DoLIT,Interpret,CATCH,QuestionDUP,ZeroEquals
\r
3058 DW STATE,Fetch,ZeroEquals,ZBranch,QUIT2
\r
3059 DW DotPrompt,Branch,QUIT2
\r
3060 QUIT3 DW DUPP,MinusOne,XORR,ZBranch,QUIT5
\r
3061 DW DUPP,DoLIT,-2,Equals,ZBranch,QUIT4
\r
3062 DW SPACE,AbortQMsg,TwoFetch,TYPEE,Branch,QUIT5
\r
3063 QUIT4 DW SPACE,ErrWord,TwoFetch,TYPEE
\r
3064 DW SPACE,DoLIT,'?',EMIT,SPACE
\r
3065 DW DUPP,MinusOne,DoLIT,-58,WITHIN,ZBranch,QUIT7
\r
3066 $INSTR ' Exception # '
\r
3067 DW TYPEE,Dot,Branch,QUIT5
\r
3068 QUIT7 DW CELLS,THROWMsgTbl,Plus,Fetch,COUNT,TYPEE
\r
3069 QUIT5 DW SPZero,SPStore,Branch,QUIT1
\r
3071 ; REFILL ( -- flag ) \ CORE EXT
\r
3072 ; Attempt to fill the input buffer from the input source. Make
\r
3073 ; the result the input buffer, set >IN to zero, and return true
\r
3074 ; if successful. Return false if the input source is a string
\r
3077 ; : REFILL SOURCE-ID IF 0 EXIT THEN
\r
3078 ; npVar @ [ size-of-PAD CHARS 2* ] LITERAL - DUP
\r
3079 ; [ size-of-PAD ] LITERAL ACCEPT sourceVar 2!
\r
3082 $COLON 6,'REFILL',REFILL,_FLINK
\r
3083 DW SOURCE_ID,ZBranch,REFIL1
\r
3085 REFIL1 DW NPVar,Fetch,DoLIT,PADSize*CHARR*2,Minus,DUPP
\r
3086 DW DoLIT,PADSize*CHARR,ACCEPT,SourceVar,TwoStore
\r
3087 DW Zero,ToIN,Store,MinusOne,EXIT
\r
3089 ; ROT ( x1 x2 x3 -- x2 x3 x1 ) \ CORE
\r
3090 ; Rotate the top three data stack items.
\r
3092 ; : ROT >R SWAP R> SWAP ;
\r
3094 $COLON 3,'ROT',ROT,_FLINK
\r
3095 DW ToR,SWAP,RFrom,SWAP,EXIT
\r
3097 ; S>D ( n -- d ) \ CORE
\r
3098 ; Convert a single-cell number n to double-cell number.
\r
3102 $COLON 3,'S>D',SToD,_FLINK
\r
3103 DW DUPP,ZeroLess,EXIT
\r
3105 ; SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1) \ SEARCH
\r
3106 ; Search word list for a match with the given name.
\r
3107 ; Return execution token and -1 or 1 ( IMMEDIATE) if found.
\r
3108 ; Return 0 if not found.
\r
3110 ; : SEARCH-WORDLIST
\r
3111 ; (search-wordlist) DUP IF NIP THEN ;
\r
3113 $COLON 15,'SEARCH-WORDLIST',SEARCH_WORDLIST,_FLINK
\r
3114 DW ParenSearch_Wordlist,DUPP,ZBranch,SRCHW1
\r
3118 ; SIGN ( n -- ) \ CORE
\r
3119 ; Add a minus sign to the numeric output string if n is negative.
\r
3121 ; : SIGN 0< IF [CHAR] - HOLD THEN ;
\r
3123 $COLON 4,'SIGN',SIGN,_FLINK
\r
3124 DW ZeroLess,ZBranch,SIGN1
\r
3128 ; SOURCE ( -- c-addr u ) \ CORE
\r
3129 ; Return input buffer string.
\r
3131 ; : SOURCE sourceVar 2@ ;
\r
3133 $COLON 6,'SOURCE',SOURCE,_FLINK
\r
3134 DW SourceVar,TwoFetch,EXIT
\r
3136 ; SPACE ( -- ) \ CORE
\r
3137 ; Send the blank character to the output device.
\r
3139 ; : SPACE 32 EMIT ;
\r
3141 $COLON 5,'SPACE',SPACE,_FLINK
\r
3142 DW BLank,EMIT,EXIT
\r
3144 ; STATE ( -- a-addr ) \ CORE
\r
3145 ; Return the address of a cell containing compilation-state flag
\r
3146 ; which is true in compilation state or false otherwise.
\r
3148 $VAR 5,'STATE',STATE,_FLINK
\r
3150 ; THEN Compilation: ( C: orig -- ) \ CORE
\r
3151 ; Run-time: ( -- )
\r
3152 ; Resolve the forward reference orig.
\r
3154 ; : THEN 1- IF -22 THROW THEN \ control structure mismatch
\r
3155 ; \ orig type is 1
\r
3156 ; xhere SWAP ! bal- ; COMPILE-ONLY IMMEDIATE
\r
3158 $COLON IMMED+COMPO+4,'THEN',THENN,_FLINK
\r
3159 DW OneMinus,ZBranch,THEN1
\r
3160 DW DoLIT,-22,THROW
\r
3161 THEN1 DW XHere,SWAP,Store,BalMinus,EXIT
\r
3163 ; THROW ( k*x n -- k*x | i*x n ) \ EXCEPTION
\r
3164 ; If n is not zero, pop the topmost exception frame from the
\r
3165 ; exception stack, along with everything on the return stack
\r
3166 ; above the frame. Then restore the condition before CATCH and
\r
3167 ; transfer control just after the CATCH that pushed that
\r
3168 ; exception frame.
\r
3171 ; IF throwFrame @ rp! \ restore return stack
\r
3172 ; R> throwFrame ! \ restore THROW frame
\r
3173 ; R> SWAP >R sp! \ restore data stack
\r
3175 ; 'init-i/o EXECUTE
\r
3178 $COLON 5,'THROW',THROW,_FLINK
\r
3179 DW QuestionDUP,ZBranch,THROW1
\r
3180 DW ThrowFrame,Fetch,RPStore,RFrom,ThrowFrame,Store
\r
3181 DW RFrom,SWAP,ToR,SPStore,DROP,RFrom
\r
3182 DW TickINIT_IO,EXECUTE
\r
3185 ; TYPE ( c-addr u -- ) \ CORE
\r
3186 ; Display the character string if u is greater than zero.
\r
3188 ; : TYPE ?DUP IF 0 DO DUP C@ EMIT CHAR+ LOOP THEN DROP ;
\r
3190 $COLON 4,'TYPE',TYPEE,_FLINK
\r
3191 DW QuestionDUP,ZBranch,TYPE2
\r
3193 TYPE1 DW DUPP,CFetch,EMIT,CHARPlus,DoLOOP,TYPE1
\r
3194 TYPE2 DW DROP,EXIT
\r
3196 ; U< ( u1 u2 -- flag ) \ CORE
\r
3197 ; Unsigned compare of top two items. True if u1 < u2.
\r
3199 ; : U< 2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;
\r
3201 $COLON 2,'U<',ULess,_FLINK
\r
3202 DW TwoDUP,XORR,ZeroLess
\r
3204 DW NIP,ZeroLess,EXIT
\r
3205 ULES1 DW Minus,ZeroLess,EXIT
\r
3207 ; UM* ( u1 u2 -- ud ) \ CORE
\r
3208 ; Unsigned multiply. Return double-cell product.
\r
3210 ; : UM* 0 SWAP [ cell-size-in-bits ] LITERAL 0 DO
\r
3211 ; DUP um+ >R >R DUP um+ R> +
\r
3212 ; R> IF >R OVER um+ R> + THEN \ if carry
\r
3215 $COLON 3,'UM*',UMStar,_FLINK
\r
3216 DW Zero,SWAP,DoLIT,CELLL*8,Zero,DoDO
\r
3217 UMST1 DW DUPP,UMPlus,ToR,ToR
\r
3218 DW DUPP,UMPlus,RFrom,Plus,RFrom
\r
3220 DW ToR,OVER,UMPlus,RFrom,Plus
\r
3221 UMST2 DW DoLOOP,UMST1
\r
3224 ; UM/MOD ( ud u1 -- u2 u3 ) \ CORE
\r
3225 ; Unsigned division of a double-cell number ud by a single-cell
\r
3226 ; number u1. Return remainder u2 and quotient u3.
\r
3228 ; : UM/MOD DUP 0= IF -10 THROW THEN \ divide by zero
\r
3230 ; NEGATE [ cell-size-in-bits ] LITERAL 0
\r
3231 ; DO >R DUP um+ >R >R DUP um+ R> + DUP
\r
3232 ; R> R@ SWAP >R um+ R> OR
\r
3233 ; IF >R DROP 1+ R> ELSE DROP THEN
\r
3234 ; LOOP DROP SWAP EXIT
\r
3235 ; ELSE -11 THROW \ result out of range
\r
3238 $COLON 6,'UM/MOD',UMSlashMOD,_FLINK
\r
3239 DW DUPP,ZBranch,UMM5
\r
3240 DW TwoDUP,ULess,ZBranch,UMM4
\r
3241 DW NEGATE,DoLIT,CELLL*8,Zero,DoDO
\r
3242 UMM1 DW ToR,DUPP,UMPlus,ToR,ToR,DUPP,UMPlus,RFrom,Plus,DUPP
\r
3243 DW RFrom,RFetch,SWAP,ToR,UMPlus,RFrom,ORR,ZBranch,UMM2
\r
3244 DW ToR,DROP,OnePlus,RFrom,Branch,UMM3
\r
3246 UMM3 DW RFrom,DoLOOP,UMM1
\r
3248 UMM5 DW DoLIT,-10,THROW
\r
3249 UMM4 DW DoLIT,-11,THROW
\r
3251 ; UNLOOP ( -- ) ( R: loop-sys -- ) \ CORE
\r
3252 ; Discard loop-control parameters for the current nesting level.
\r
3253 ; An UNLOOP is required for each nesting level before the
\r
3254 ; definition may be EXITed.
\r
3256 ; : UNLOOP R> R> R> 2DROP >R ; COMPILE-ONLY
\r
3258 $COLON COMPO+6,'UNLOOP',UNLOOP,_FLINK
\r
3259 DW RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT
\r
3261 ; WITHIN ( n1|u1 n2|n2 n3|u3 -- flag ) \ CORE EXT
\r
3262 ; Return true if (n2|u2<=n1|u1 and n1|u1<n3|u3) or
\r
3263 ; (n2|u2>n3|u3 and (n2|u2<=n1|u1 or n1|u1<n3|u3)).
\r
3265 ; : WITHIN OVER - >R - R> U< ;
\r
3267 $COLON 6,'WITHIN',WITHIN,_FLINK
\r
3268 DW OVER,Minus,ToR ;ul <= u < uh
\r
3269 DW Minus,RFrom,ULess,EXIT
\r
3272 ; Enter interpretation state.
\r
3274 ; : [ 0 STATE ! ; COMPILE-ONLY IMMEDIATE
\r
3276 $COLON IMMED+COMPO+1,'[',LeftBracket,_FLINK
\r
3277 DW Zero,STATE,Store,EXIT
\r
3280 ; Enter compilation state.
\r
3282 ; : ] -1 STATE ! ;
\r
3284 $COLON 1,']',RightBracket,_FLINK
\r
3285 DW MinusOne,STATE,Store,EXIT
\r
3288 ; Rest of CORE words and two facility words, EKEY? and EMIT?
\r
3290 ; Following definitions can be removed from assembler source and
\r
3291 ; can be colon-defined later.
\r
3293 ; ( ( "ccc<)>" -- ) \ CORE
\r
3294 ; Ignore following string up to next ) . A comment.
\r
3296 ; : ( [CHAR] ) PARSE 2DROP ; IMMEDIATE
\r
3298 $COLON IMMED+1,'(',Paren,_FLINK
\r
3299 DW DoLIT,')',PARSE,TwoDROP,EXIT
\r
3301 ; * ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
3302 ; Multiply n1|u1 by n2|u2 giving a single product.
\r
3306 $COLON 1,'*',Star,_FLINK
\r
3307 DW UMStar,DROP,EXIT
\r
3309 ; */ ( n1 n2 n3 -- n4 ) \ CORE
\r
3310 ; Multiply n1 by n2 producing double-cell intermediate,
\r
3311 ; then divide it by n3. Return single-cell quotient.
\r
3313 ; : */ */MOD NIP ;
\r
3315 $COLON 2,'*/',StarSlash,_FLINK
\r
3316 DW StarSlashMOD,NIP,EXIT
\r
3318 ; */MOD ( n1 n2 n3 -- n4 n5 ) \ CORE
\r
3319 ; Multiply n1 by n2 producing double-cell intermediate,
\r
3320 ; then divide it by n3. Return single-cell remainder and
\r
3321 ; single-cell quotient.
\r
3323 ; : */MOD >R M* R> FM/MOD ;
\r
3325 $COLON 5,'*/MOD',StarSlashMOD,_FLINK
\r
3326 DW ToR,MStar,RFrom,FMSlashMOD,EXIT
\r
3328 ; +LOOP Compilation: ( C: do-sys -- ) \ CORE
\r
3329 ; Run-time: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
3330 ; Terminate a DO-+LOOP structure. Resolve the destination of all
\r
3331 ; unresolved occurences of LEAVE.
\r
3332 ; On execution add n to the loop index. If loop index did not
\r
3333 ; cross the boundary between loop_limit-1 and loop_limit,
\r
3334 ; continue execution at the beginning of the loop. Otherwise,
\r
3335 ; finish the loop.
\r
3337 ; : +LOOP POSTPONE do+LOOP rake ; COMPILE-ONLY IMMEDIATE
\r
3339 $COLON IMMED+COMPO+5,'+LOOP',PlusLOOP,_FLINK
\r
3340 DW DoLIT,DoPLOOP,COMPILEComma,rake,EXIT
\r
3342 ; ." ( "ccc<">" -- ) \ CORE
\r
3344 ; Compile an inline string literal to be typed out at run time.
\r
3346 ; : ." POSTPONE S" POSTPONE TYPE ; COMPILE-ONLY IMMEDIATE
\r
3348 $COLON IMMED+COMPO+2,'."',DotQuote,_FLINK
\r
3349 DW SQuote,DoLIT,TYPEE,COMPILEComma,EXIT
\r
3351 ; 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) \ CORE
\r
3352 ; Copy cell pair x1 x2 to the top of the stack.
\r
3354 ; : 2OVER >R >R 2DUP R> R> 2SWAP ;
\r
3356 $COLON 5,'2OVER',TwoOVER,_FLINK
\r
3357 DW ToR,ToR,TwoDUP,RFrom,RFrom,TwoSWAP,EXIT
\r
3359 ; >BODY ( xt -- a-addr ) \ CORE
\r
3360 ; Push data field address of CREATEd word.
\r
3361 ; Structure of CREATEd word:
\r
3362 ; | call-doCREATE | 0 or DOES> code addr | a-addr |
\r
3364 ; : >BODY ?call DUP IF \ code-addr xt2
\r
3365 ; ['] doCREATE = IF \ should be call-doCREATE
\r
3368 ; -31 THROW ; \ >BODY used on non-CREATEd definition
\r
3370 $COLON 5,'>BODY',ToBODY,_FLINK
\r
3371 DW QCall,DUPP,ZBranch,TBODY1
\r
3372 DW DoLIT,DoCREATE,Equals,ZBranch,TBODY1
\r
3373 DW CELLPlus,Fetch,EXIT
\r
3374 TBODY1 DW DoLIT,-31,THROW
\r
3376 ; ABORT" ( "ccc<">" -- ) \ EXCEPTION EXT
\r
3377 ; Run-time ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )
\r
3378 ; Conditional abort with an error message.
\r
3380 ; : ABORT" POSTPONE S" POSTPONE ROT
\r
3381 ; POSTPONE IF POSTPONE abort"msg POSTPONE 2!
\r
3382 ; -2 POSTPONE LITERAL POSTPONE THROW
\r
3383 ; POSTPONE ELSE POSTPONE 2DROP POSTPONE THEN
\r
3384 ; ; COMPILE-ONLY IMMEDIATE
\r
3386 $COLON IMMED+COMPO+6,'ABORT"',ABORTQuote,_FLINK
\r
3387 DW SQuote,DoLIT,ROT,COMPILEComma
\r
3388 DW IFF,DoLIT,AbortQMsg,COMPILEComma ; IF is immediate
\r
3389 DW DoLIT,TwoStore,COMPILEComma
\r
3390 DW DoLIT,-2,LITERAL ; LITERAL is immediate
\r
3391 DW DoLIT,THROW,COMPILEComma
\r
3392 DW ELSEE,DoLIT,TwoDROP,COMPILEComma ; ELSE and THEN are
\r
3393 DW THENN,EXIT ; immediate
\r
3395 ; ABS ( n -- u ) \ CORE
\r
3396 ; Return the absolute value of n.
\r
3398 ; : ABS DUP 0< IF NEGATE THEN ;
\r
3400 $COLON 3,'ABS',ABSS,_FLINK
\r
3401 DW DUPP,ZeroLess,ZBranch,ABS1
\r
3405 ; ALLOT ( n -- ) \ CORE
\r
3406 ; Allocate n bytes in RAM or ROM data space.
\r
3408 ; : ALLOT hereVar +! ;
\r
3410 $COLON 5,'ALLOT',ALLOT,_FLINK
\r
3411 DW HereVar,PlusStore,EXIT
\r
3413 ; BEGIN ( C: -- dest ) \ CORE
\r
3414 ; Start an infinite or indefinite loop structure. Put the next
\r
3415 ; location for a transfer of control, dest, onto the data
\r
3418 ; : BEGIN xhere 0 bal+ \ dest type is 0
\r
3419 ; ; COMPILE-ONLY IMMEDIATE
\r
3421 $COLON IMMED+COMPO+5,'BEGIN',BEGIN,_FLINK
\r
3422 DW XHere,Zero,BalPlus,EXIT
\r
3424 ; C, ( char -- ) \ CORE
\r
3425 ; Compile a character into data space.
\r
3427 ; : C, HERE C! [ char-size ] LITERAL hereVar +! ;
\r
3429 $COLON 2,'C,',CComma,_FLINK
\r
3430 DW HERE,CStore,DoLIT,CHARR,HereVar,PlusStore,EXIT
\r
3432 ; CHAR ( "<spaces>ccc" -- char ) \ CORE
\r
3433 ; Parse next word and return the value of first character.
\r
3435 ; : CHAR PARSE-WORD DROP C@ ;
\r
3437 $COLON 4,'CHAR',CHAR,_FLINK
\r
3438 DW PARSE_WORD,DROP,CFetch,EXIT
\r
3440 ; DO Compilation: ( C: -- do-sys ) \ CORE
\r
3441 ; Run-time: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )
\r
3442 ; Start a DO-LOOP structure in a colon definition. Place do-sys
\r
3443 ; on control-flow stack, which will be resolved by LOOP or +LOOP.
\r
3445 ; : DO 0 rakeVar ! 0 \ ?DO-orig is 0 for DO
\r
3446 ; POSTPONE doDO xhere bal+ \ DO-dest
\r
3447 ; ; COMPILE-ONLY IMMEDIATE
\r
3449 $COLON IMMED+COMPO+2,'DO',DO,_FLINK
\r
3450 DW Zero,RakeVar,Store,Zero
\r
3451 DW DoLIT,DoDO,COMPILEComma,XHere,BalPlus,EXIT
\r
3453 ; DOES> ( C: colon-sys1 -- colon-sys2 ) \ CORE
\r
3454 ; Build run time code of the data object CREATEd.
\r
3456 ; : DOES> bal 1- IF -22 THROW THEN \ control structure mismatch
\r
3457 ; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1
\r
3458 ; POSTPONE pipe ['] doLIST xt, -1 ; COMPILE-ONLY IMMEDIATE
\r
3460 $COLON IMMED+COMPO+5,'DOES>',DOESGreater,_FLINK
\r
3461 DW Bal,OneMinus,ZBranch,DOES1
\r
3462 DW DoLIT,-22,THROW
\r
3463 DOES1 DW NIP,OnePlus,ZBranch,DOES2
\r
3464 DW DoLIT,-22,THROW
\r
3465 DOES2 DW DoLIT,Pipe,COMPILEComma
\r
3466 DW DoLIT,DoLIST,xtComma,DoLIT,-1,EXIT
\r
3468 ; ELSE Compilation: ( C: orig1 -- orig2 ) \ CORE
\r
3469 ; Run-time: ( -- )
\r
3470 ; Start the false clause in an IF-ELSE-THEN structure.
\r
3471 ; Put the location of new unresolved forward reference orig2
\r
3472 ; onto control-flow stack.
\r
3474 ; : ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMEDIATE
\r
3476 $COLON IMMED+COMPO+4,'ELSE',ELSEE,_FLINK
\r
3477 DW AHEAD,TwoSWAP,THENN,EXIT
\r
3479 ; ENVIRONMENT? ( c-addr u -- false | i*x true ) \ CORE
\r
3480 ; Environment query.
\r
3483 ; envQList SEARCH-WORDLIST
\r
3484 ; DUP >R IF EXECUTE THEN R> ;
\r
3486 $COLON 12,'ENVIRONMENT?',ENVIRONMENTQuery,_FLINK
\r
3487 DW EnvQList,SEARCH_WORDLIST
\r
3488 DW DUPP,ToR,ZBranch,ENVRN1
\r
3490 ENVRN1 DW RFrom,EXIT
\r
3492 ; EVALUATE ( i*x c-addr u -- j*x ) \ CORE
\r
3493 ; Evaluate the string. Save the input source specification.
\r
3494 ; Store -1 in SOURCE-ID.
\r
3496 ; : EVALUATE SOURCE >R >R >IN @ >R SOURCE-ID >R
\r
3498 ; sourceVar 2! 0 >IN ! interpret
\r
3500 ; R> >IN ! R> R> sourceVar 2! ;
\r
3502 $COLON 8,'EVALUATE',EVALUATE,_FLINK
\r
3503 DW SOURCE,ToR,ToR,ToIN,Fetch,ToR,SOURCE_ID,ToR
\r
3504 DW MinusOne,DoTO,AddrSOURCE_ID
\r
3505 DW SourceVar,TwoStore,Zero,ToIN,Store,Interpret
\r
3506 DW RFrom,DoTO,AddrSOURCE_ID
\r
3507 DW RFrom,ToIN,Store,RFrom,RFrom,SourceVar,TwoStore,EXIT
\r
3509 ; FILL ( c-addr u char -- ) \ CORE
\r
3510 ; Store char in each of u consecutive characters of memory
\r
3511 ; beginning at c-addr.
\r
3513 ; : FILL ROT ROT ?DUP IF 0 DO 2DUP C! CHAR+ LOOP THEN 2DROP ;
\r
3515 $COLON 4,'FILL',FILL,_FLINK
\r
3516 DW ROT,ROT,QuestionDUP,ZBranch,FILL2
\r
3518 FILL1 DW TwoDUP,CStore,CHARPlus,DoLOOP,FILL1
\r
3519 FILL2 DW TwoDROP,EXIT
\r
3521 ; FIND ( c-addr -- c-addr 0 | xt 1 | xt -1) \ SEARCH
\r
3522 ; Search dictionary for a match with the given counted name.
\r
3523 ; Return execution token and -1 or 1 ( IMMEDIATE) if found;
\r
3524 ; c-addr 0 if not found.
\r
3526 ; : FIND DUP COUNT search-word ?DUP IF NIP ROT DROP EXIT THEN
\r
3529 $COLON 4,'FIND',FIND,_FLINK
\r
3530 DW DUPP,COUNT,Search_word,QuestionDUP,ZBranch,FIND1
\r
3531 DW NIP,ROT,DROP,EXIT
\r
3532 FIND1 DW TwoDROP,Zero,EXIT
\r
3534 ; IMMEDIATE ( -- ) \ CORE
\r
3535 ; Make the most recent definition an immediate word.
\r
3537 ; : IMMEDIATE lastName [ =immed ] LITERAL OVER @ OR SWAP ! ;
\r
3539 $COLON 9,'IMMEDIATE',IMMEDIATE,_FLINK
\r
3540 DW LastName,DoLIT,IMMED,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
3542 ; LEAVE ( -- ) ( R: loop-sys -- ) \ CORE
\r
3543 ; Terminate definite loop, DO|?DO ... LOOP|+LOOP, immediately.
\r
3545 ; : LEAVE POSTPONE UNLOOP POSTPONE branch
\r
3546 ; xhere rakeVar DUP @ code, ! ; COMPILE-ONLY IMMEDIATE
\r
3548 $COLON IMMED+COMPO+5,'LEAVE',LEAVEE,_FLINK
\r
3549 DW DoLIT,UNLOOP,COMPILEComma,DoLIT,Branch,COMPILEComma
\r
3550 DW XHere,RakeVar,DUPP,Fetch,CodeComma,Store,EXIT
\r
3552 ; LOOP Compilation: ( C: do-sys -- ) \ CORE
\r
3553 ; Run-time: ( -- ) ( R: loop-sys1 -- loop-sys2 )
\r
3554 ; Terminate a DO|?DO ... LOOP structure. Resolve the destination
\r
3555 ; of all unresolved occurences of LEAVE.
\r
3557 ; : LOOP POSTPONE doLOOP rake ; COMPILE-ONLY IMMEDIATE
\r
3559 $COLON IMMED+COMPO+4,'LOOP',LOOPP,_FLINK
\r
3560 DW DoLIT,DoLOOP,COMPILEComma,rake,EXIT
\r
3562 ; LSHIFT ( x1 u -- x2 ) \ CORE
\r
3563 ; Perform a logical left shift of u bit-places on x1, giving x2.
\r
3564 ; Put 0 into the least significant bits vacated by the shift.
\r
3566 ; : LSHIFT ?DUP IF 0 DO 2* LOOP THEN ;
\r
3568 $COLON 6,'LSHIFT',LSHIFT,_FLINK
\r
3569 DW QuestionDUP,ZBranch,LSHIFT2
\r
3571 LSHIFT1 DW TwoStar,DoLOOP,LSHIFT1
\r
3574 ; M* ( n1 n2 -- d ) \ CORE
\r
3575 ; Signed multiply. Return double product.
\r
3577 ; : M* 2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;
\r
3579 $COLON 2,'M*',MStar,_FLINK
\r
3580 DW TwoDUP,XORR,ZeroLess,ToR,ABSS,SWAP,ABSS
\r
3581 DW UMStar,RFrom,ZBranch,MSTAR1
\r
3585 ; MAX ( n1 n2 -- n3 ) \ CORE
\r
3586 ; Return the greater of two top stack items.
\r
3588 ; : MAX 2DUP < IF SWAP THEN DROP ;
\r
3590 $COLON 3,'MAX',MAX,_FLINK
\r
3591 DW TwoDUP,LessThan,ZBranch,MAX1
\r
3595 ; MIN ( n1 n2 -- n3 ) \ CORE
\r
3596 ; Return the smaller of top two stack items.
\r
3598 ; : MIN 2DUP > IF SWAP THEN DROP ;
\r
3600 $COLON 3,'MIN',MIN,_FLINK
\r
3601 DW TwoDUP,GreaterThan,ZBranch,MIN1
\r
3605 ; MOD ( n1 n2 -- n3 ) \ CORE
\r
3606 ; Divide n1 by n2, giving the single cell remainder n3.
\r
3607 ; Returns modulo of floored division in this implementation.
\r
3609 ; : MOD /MOD DROP ;
\r
3611 $COLON 3,'MOD',MODD,_FLINK
\r
3612 DW SlashMOD,DROP,EXIT
\r
3614 ; PICK ( x_u ... x1 x0 u -- x_u ... x1 x0 x_u ) \ CORE EXT
\r
3615 ; Remove u and copy the uth stack item to top of the stack. An
\r
3616 ; ambiguous condition exists if there are less than u+2 items
\r
3617 ; on the stack before PICK is executed.
\r
3619 ; : PICK DEPTH DUP 2 < IF -4 THROW THEN \ stack underflow
\r
3620 ; 2 - OVER U< IF -4 THROW THEN
\r
3621 ; 1+ CELLS sp@ + @ ;
\r
3623 $COLON 4,'PICK',PICK,_FLINK
\r
3624 DW DEPTH,DUPP,DoLIT,2,LessThan,ZBranch,PICK1
\r
3626 PICK1 DW DoLIT,2,Minus,OVER,ULess,ZBranch,PICK2
\r
3628 PICK2 DW OnePlus,CELLS,SPFetch,Plus,Fetch,EXIT
\r
3630 ; POSTPONE ( "<spaces>name" -- ) \ CORE
\r
3631 ; Parse name and find it. Append compilation semantics of name
\r
3632 ; to current definition.
\r
3634 ; : POSTPONE (') 0< IF POSTPONE LITERAL
\r
3635 ; POSTPONE COMPILE, EXIT THEN \ non-IMMEDIATE
\r
3636 ; COMPILE, ; COMPILE-ONLY IMMEDIATE \ IMMEDIATE
\r
3638 $COLON IMMED+COMPO+8,'POSTPONE',POSTPONE,_FLINK
\r
3639 DW ParenTick,ZeroLess,ZBranch,POSTP1
\r
3640 DW LITERAL,DoLIT,COMPILEComma
\r
3641 POSTP1 DW COMPILEComma,EXIT
\r
3643 ; RECURSE ( -- ) \ CORE
\r
3644 ; Append the execution semactics of the current definition to
\r
3645 ; the current definition.
\r
3647 ; : RECURSE bal 1- 2* PICK 1+ IF -22 THROW THEN
\r
3648 ; \ control structure mismatch; colon-sys type is -1
\r
3649 ; bal 1- 2* 1+ PICK \ xt of current definition
\r
3650 ; COMPILE, ; COMPILE-ONLY IMMEDIATE
\r
3652 $COLON IMMED+COMPO+7,'RECURSE',RECURSE,_FLINK
\r
3653 DW Bal,OneMinus,TwoStar,PICK,OnePlus,ZBranch,RECUR1
\r
3654 DW DoLIT,-22,THROW
\r
3655 RECUR1 DW Bal,OneMinus,TwoStar,OnePlus,PICK
\r
3656 DW COMPILEComma,EXIT
\r
3658 ; REPEAT ( C: orig dest -- ) \ CORE
\r
3659 ; Terminate a BEGIN-WHILE-REPEAT indefinite loop. Resolve
\r
3660 ; backward reference dest and forward reference orig.
\r
3662 ; : REPEAT POSTPONE AGAIN POSTPONE THEN ; COMPILE-ONLY IMMEDIATE
\r
3664 $COLON IMMED+COMPO+6,'REPEAT',REPEATT,_FLINK
\r
3665 DW AGAIN,THENN,EXIT
\r
3667 ; RSHIFT ( x1 u -- x2 ) \ CORE
\r
3668 ; Perform a logical right shift of u bit-places on x1, giving x2.
\r
3669 ; Put 0 into the most significant bits vacated by the shift.
\r
3671 ; : RSHIFT ?DUP IF
\r
3672 ; 0 SWAP [ cell-size-in-bits ] LITERAL SWAP -
\r
3673 ; 0 DO 2DUP D+ LOOP
\r
3677 $COLON 6,'RSHIFT',RSHIFT,_FLINK
\r
3678 DW QuestionDUP,ZBranch,RSHIFT2
\r
3679 DW Zero,SWAP,DoLIT,CELLL*8,SWAP,Minus,Zero,DoDO
\r
3680 RSHIFT1 DW TwoDUP,DPlus,DoLOOP,RSHIFT1
\r
3684 ; SLITERAL ( c-addr1 u -- ) \ STRING
\r
3685 ; Run-time ( -- c-addr2 u )
\r
3686 ; Compile a string literal. Return the string on execution.
\r
3688 ; : SLITERAL DUP POSTPONE LITERAL POSTPONE doS"
\r
3689 ; CHARS xhere 2DUP + ALIGNED TOxhere
\r
3690 ; SWAP MOVE ; COMPILE-ONLY IMMEDIATE
\r
3692 $COLON IMMED+COMPO+8,'SLITERAL',SLITERAL,_FLINK
\r
3693 DW DUPP,LITERAL,DoLIT,DoSQuote,COMPILEComma
\r
3694 DW CHARS,XHere,TwoDUP,Plus,ALIGNED,TOXHere
\r
3697 ; S" Compilation: ( "ccc<">" -- ) \ CORE
\r
3698 ; Run-time: ( -- c-addr u )
\r
3699 ; Parse ccc delimetered by " . Return the string specification
\r
3700 ; c-addr u on execution.
\r
3702 ; : S" [CHAR] " PARSE POSTPONE SLITERAL ; COMPILE-ONLY IMMEDIATE
\r
3704 $COLON IMMED+COMPO+2,'S"',SQuote,_FLINK
\r
3705 DW DoLIT,'"',PARSE,SLITERAL,EXIT
\r
3707 ; SM/REM ( d n1 -- n2 n3 ) \ CORE
\r
3708 ; Symmetric divide of double by single. Return remainder n2
\r
3709 ; and quotient n3.
\r
3711 ; : SM/REM 2DUP XOR >R OVER >R >R DUP 0< IF DNEGATE THEN
\r
3713 ; R> 0< IF SWAP NEGATE SWAP THEN
\r
3714 ; R> 0< IF \ negative quotient
\r
3715 ; NEGATE 0 OVER < 0= IF EXIT THEN
\r
3716 ; -11 THROW THEN \ result out of range
\r
3717 ; DUP 0< IF -11 THROW THEN ; \ result out of range
\r
3719 $COLON 6,'SM/REM',SMSlashREM,_FLINK
\r
3720 DW TwoDUP,XORR,ToR,OVER,ToR,ToR,DUPP,ZeroLess
\r
3723 SMREM1 DW RFrom,ABSS,UMSlashMOD
\r
3724 DW RFrom,ZeroLess,ZBranch,SMREM2
\r
3725 DW SWAP,NEGATE,SWAP
\r
3726 SMREM2 DW RFrom,ZeroLess,ZBranch,SMREM3
\r
3727 DW NEGATE,DoLIT,0,OVER,LessThan,ZeroEquals,ZBranch,SMREM4
\r
3729 SMREM3 DW DUPP,ZeroLess,ZBranch,SMREM5
\r
3730 SMREM4 DW DoLIT,-11,THROW
\r
3732 ; SPACES ( n -- ) \ CORE
\r
3733 ; Send n spaces to the output device if n is greater than zero.
\r
3735 ; : SPACES DUP 0 > IF 0 DO SPACE LOOP EXIT THEN DROP;
\r
3737 $COLON 6,'SPACES',SPACES,_FLINK
\r
3738 DW DUPP,Zero,GreaterThan,ZBranch,SPACES1
\r
3740 SPACES2 DW SPACE,DoLOOP,SPACES2
\r
3742 SPACES1 DW DROP,EXIT
\r
3744 ; TO Interpretation: ( x "<spaces>name" -- ) \ CORE EXT
\r
3745 ; Compilation: ( "<spaces>name" -- )
\r
3746 ; Run-time: ( x -- )
\r
3747 ; Store x in name.
\r
3749 ; : TO ' ?call DUP IF \ should be call-doVALUE
\r
3750 ; ['] doVALUE = \ verify VALUE marker
\r
3752 ; IF POSTPONE doTO code, EXIT THEN
\r
3755 ; -32 THROW ; IMMEDIATE \ invalid name argument (e.g. TO xxx)
\r
3757 $COLON IMMED+2,'TO',TO,_FLINK
\r
3758 DW Tick,QCall,DUPP,ZBranch,TO1
\r
3759 DW DoLIT,DoVALUE,Equals,ZBranch,TO1
\r
3760 DW Fetch,STATE,Fetch,ZBranch,TO2
\r
3761 DW DoLIT,DoTO,COMPILEComma,CodeComma,EXIT
\r
3763 TO1 DW DoLIT,-32,THROW
\r
3765 ; U. ( u -- ) \ CORE
\r
3766 ; Display u in free field format followed by space.
\r
3770 $COLON 2,'U.',UDot,_FLINK
\r
3773 ; UNTIL ( C: dest -- ) \ CORE
\r
3774 ; Terminate a BEGIN-UNTIL indefinite loop structure.
\r
3776 ; : UNTIL IF -22 THROW THEN \ control structure mismatch; dest type is 0
\r
3777 ; POSTPONE 0branch code, bal- ; COMPILE-ONLY IMMEDIATE
\r
3779 $COLON IMMED+COMPO+5,'UNTIL',UNTIL,_FLINK
\r
3781 DW DoLIT,-22,THROW
\r
3782 UNTIL1 DW DoLIT,ZBranch,COMPILEComma,CodeComma,BalMinus,EXIT
\r
3784 ; VALUE ( x "<spaces>name" -- ) \ CORE EXT
\r
3785 ; name Execution: ( -- x )
\r
3786 ; Create a value object with initial value x.
\r
3788 ; : VALUE bal IF -29 THROW THEN \ compiler nesting
\r
3789 ; ['] doVALUE xt, head,
\r
3790 ; xhere DUP CELL+ TOxhere
\r
3792 ; , linkLast ; \ store x and link VALUE word to current wordlist
\r
3794 $COLON 5,'VALUE',VALUE,_FLINK
\r
3795 DW Bal,ZBranch,VALUE1
\r
3796 DW DoLIT,-29,THROW
\r
3797 VALUE1 DW DoLIT,DoVALUE,xtComma,HeadComma
\r
3798 DW XHere,DUPP,CELLPlus,TOXHere,RAMB,Fetch,SWAP,Store
\r
3799 DW Comma,LinkLast,EXIT
\r
3801 ; VARIABLE ( "<spaces>name" -- ) \ CORE
\r
3802 ; name Execution: ( -- a-addr )
\r
3803 ; Parse a name and create a variable with the name.
\r
3804 ; Resolve one cell of data space at an aligned address.
\r
3805 ; Return the address on execution.
\r
3807 ; : VARIABLE bal IF -29 THROW THEN \ compiler nesting
\r
3808 ; ['] doCONST xt, head,
\r
3809 ; xhere DUP CELL+ TOxhere
\r
3810 ; RAMB @ DUP CELL+ RAMB ! \ allocate one cell in RAM area
\r
3811 ; SWAP ! linkLast ;
\r
3813 $COLON 8,'VARIABLE',VARIABLE,_FLINK
\r
3814 DW Bal,ZBranch,VARIA1
\r
3815 DW DoLIT,-29,THROW
\r
3816 VARIA1 DW DoLIT,DoCONST,xtComma,HeadComma
\r
3817 DW XHere,DUPP,CELLPlus,TOXHere
\r
3818 DW RAMB,Fetch,DUPP,CELLPlus,RAMB,Store
\r
3819 DW SWAP,Store,LinkLast,EXIT
\r
3821 ; WHILE ( C: dest -- orig dest ) \ CORE
\r
3822 ; Put the location of a new unresolved forward reference orig
\r
3823 ; onto the control flow stack under the existing dest. Typically
\r
3824 ; used in BEGIN ... WHILE ... REPEAT structure.
\r
3826 ; : WHILE POSTPONE IF 2SWAP ; COMPILE-ONLY IMMEDIATE
\r
3828 $COLON IMMED+COMPO+5,'WHILE',WHILEE,_FLINK
\r
3829 DW IFF,TwoSWAP,EXIT
\r
3831 ; WORD ( char "<chars>ccc<char>" -- c-addr ) \ CORE
\r
3832 ; Skip leading delimeters and parse a word. Return the address
\r
3833 ; of a transient region containing the word as counted string.
\r
3835 ; : WORD skipPARSE xhere pack" DROP xhere ;
\r
3837 $COLON 4,'WORD',WORDD,_FLINK
\r
3838 DW SkipPARSE,XHere,PackQuote,DROP,XHere,EXIT
\r
3840 ; ['] Compilation: ( "<spaces>name" -- ) \ CORE
\r
3841 ; Run-time: ( -- xt )
\r
3842 ; Parse name. Return the execution token of name on execution.
\r
3844 ; : ['] ' POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE
\r
3846 $COLON IMMED+COMPO+3,"[']",BracketTick,_FLINK
\r
3847 DW Tick,LITERAL,EXIT
\r
3849 ; [CHAR] Compilation: ( "<spaces>name" -- ) \ CORE
\r
3850 ; Run-time: ( -- char )
\r
3851 ; Parse name. Return the value of the first character of name
\r
3854 ; : [CHAR] CHAR POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE
\r
3856 $COLON IMMED+COMPO+6,'[CHAR]',BracketCHAR,_FLINK
\r
3857 DW CHAR,LITERAL,EXIT
\r
3859 ; \ ( "ccc<eol>" -- ) \ CORE EXT
\r
3860 ; Parse and discard the remainder of the parse area.
\r
3862 ; : \ SOURCE >IN ! DROP ; IMMEDIATE
\r
3864 $COLON IMMED+1,'\',Backslash,_FLINK
\r
3865 DW SOURCE,ToIN,Store,DROP,EXIT
\r
3867 ; Optional Facility words
\r
3869 ; EKEY? ( -- flag ) \ FACILITY EXT
\r
3870 ; If a keyboard event is available, return true.
\r
3872 ; : EKEY? 'ekey? EXECUTE ;
\r
3874 $COLON 5,'EKEY?',EKEYQuestion,_FLINK
\r
3875 DW TickEKEYQ,EXECUTE,EXIT
\r
3877 ; EMIT? ( -- flag ) \ FACILITY EXT
\r
3878 ; flag is true if the user output device is ready to accept data
\r
3879 ; and the execution of EMIT in place of EMIT? would not have
\r
3880 ; suffered an indefinite delay. If device state is indeterminate,
\r
3883 ; : EMIT? 'emit? EXECUTE ;
\r
3885 $COLON 5,'EMIT?',EMITQuestion,_FLINK
\r
3886 DW TickEMITQ,EXECUTE,EXIT
\r
3889 ; RAM/ROM System Only
\r
3892 ; RESET-SYSTEM ( -- )
\r
3893 ; Reset the system. Restore initialization values of system
\r
3897 ; sysVar00 sysVar0 [ sysVar0End sysVar0 - ] LITERAL MOVE COLD ;
\r
3899 $COLON 12,'RESET-SYSTEM',RESET_SYSTEM,_SLINK
\r
3900 DW DoLIT,UZERO0,SysVar0,DoLIT,ULAST-UZERO
\r
3914 DW OptiCOMPILEComma
\r
3916 DW DoubleAlsoComma
\r
3929 DW FORTH_WORDLISTAddr
\r
3930 DW NONSTANDARD_WORDLISTAddr
\r
3931 DW (OrderDepth-2) DUP (0)
\r
3932 DW FORTH_WORDLISTAddr
\r
3934 DW NONSTANDARD_WORDLISTAddr
\r
3935 DW FORTH_WORDLISTName
\r
3938 DW NONSTANDARD_WORDLISTName
\r
3939 DW 3*(MaxWLISTS-2) DUP (0)
\r
3952 ;===============================================================
\r
3954 LASTENV EQU _ENVLINK-0
\r
3955 LASTSYSTEM EQU _SLINK-0 ;last SYSTEM word name address
\r
3956 LASTFORTH EQU _FLINK-0 ;last FORTH word name address
\r
3958 NTOP EQU _NAME-0 ;next available memory in name dictionary
\r
3959 CTOP EQU $-0 ;next available memory in code dictionary
\r
3960 VTOP EQU _VAR-0 ;next available memory in variable area
\r
3965 ;===============================================================
\r
public / hf86v099.git / blob