1 TITLE hForth 8086 EXE Model
\r
3 PAGE 62,132 ;62 lines per page, 132 characters per line
\r
5 ;===============================================================
\r
7 ; hForth 8086 EXE model v0.9.9 by Wonyong Koh, 1997
\r
10 ; Fix SPACES. Thank Benjamin Hoyt.
\r
14 ; Fix the problem that data are corrupted at segment boundary
\r
15 ; when .EXE file saved by SAVE-INPUT-AS is larger
\r
16 ; than 64 KB. Now code segment is full 64 KB in
\r
19 ; Split environmental variable systemID into CPU and Model.
\r
21 ; Add Neal Crook's comments on assembly definitions.
\r
23 ; Add $THROWMSG macro and revise accordingly.
\r
25 ; Replace 'LODS CS:CSDummy' with 'LODS WORD PTR CS:[SI]'. This
\r
26 ; opcode works for TASM v0.9.9 and MASM v6.11.
\r
28 ; Remove 'NullString' from assembly source.
\r
32 ; Revise PICK to catch stack underflow.
\r
34 ; Implement control-flow stack on data stack. Control-flow stack
\r
35 ; item consists of two data stack items, one for value
\r
36 ; and one for the type of control-flow stack item.
\r
38 ; control-flow stack item data stack representation
\r
39 ; dest control-flow_destination 0
\r
40 ; orig control-flow_origin 1
\r
41 ; of-sys OF_origin 2
\r
42 ; case-sys x (any value) 3
\r
43 ; do-sys ?DO_origin DO_destination
\r
44 ; colon-sys xt_of_current_definition -1
\r
47 ; 'bal' is now the depth of control-flow stack.
\r
49 ; Introduce 'notNONAME?'
\r
50 ; Add 'bal+' and 'bal-'. Drop 'orig+', 'orig-', 'dest+', 'dest-',
\r
51 ; 'dosys+', and 'dosys-'.
\r
52 ; Revise ':NONAME', ':', ';', 'linkLast', 'head,', RECURSE, 'DOES>',
\r
53 ; CONSTANT, CREATE, VALUE, VARIABLE, and QUIT.
\r
54 ; This change makes RECURSE work properly in ':NONAME ... ;'
\r
55 ; and '... DOES> ... ;'.
\r
56 ; Revise 'rake', AGAIN, AHEAD, IF, THEN, +LOOP, BEGIN, DO, ELSE, LOOP,
\r
60 ; Revise SLITERAL, '."', 'doS"' to allow a string larger than
\r
62 ; Revise $INSTR and remove 'do."'.
\r
67 ; Replace 'COMPILE,' with 'code,' in the definition of 'compileCREATE'.
\r
71 ; Changes from 0.9.7
\r
74 ; Revise FM/MOD and SM/REM to catch result-out-of-range error in
\r
75 ; '80000. 2 FM/MOD'.
\r
77 ; Rename 'x,' to 'code,'; 'x@' to 'code@'; 'x!' to 'code!';
\r
78 ; 'xb@' to 'codeB@' and 'xb!' to 'codeB!'.
\r
80 ; Rename non-Standard 'parse-word' to PARSE-WORD.
\r
82 ; Drop '?doLIST' and revise 'optiCOMPILE,'.
\r
84 ; Drop 'LIT,:' all together.
\r
85 ; Return CELLS to non-IMMEDIATE definition.
\r
87 ; Changes from 0.9.6
\r
90 ; Make 'lastXT' VALUE word.
\r
92 ; Revise doCREATE, CREATE, pipe, DOES>, and >BODY.
\r
93 ; 'pipe' is no longer processor-dependent.
\r
95 ; Move ERASE to ASM8086.F.
\r
97 ; Changes from 0.9.5
\r
100 ; Fix MOVE to check whether 'u' is 0.
\r
103 ; Revise 'orig+', 'dosys+', etc to catch 'DO IF LOOP' mismatch.
\r
105 ; Change 'lastName' to VALUE type. Remove '(lastName)'.
\r
107 ; Changes from 0.9.2
\r
110 ; Move terminal input buffer (TIB) at the end of the memory to
\r
111 ; prevent accidental overwriting it. It was too close
\r
112 ; to HERE and might be overwritten by ALLOT or , .
\r
113 ; TIB address is only known to REFILL . Revise REFILL .
\r
114 ; Move PAD also with TIB.
\r
116 ; Revise EVALUATE for FILE words.
\r
118 ; Chris Jakeman kindly report several bugs and made suggestions.
\r
119 ; CHARS is added in the definition of /STRING .
\r
120 ; '1chars/' is introduced to convert # address units to # chars.
\r
121 ; 'skipPARSE' is introduced. 'parse-word' and 'WORD' are
\r
122 ; redefined using it.
\r
124 ; Changes from 0.9.0
\r
127 ; Make HERE VALUE type and remove 'hereP'. Revise 'xhere'
\r
128 ; and remove 'TOxhere'.
\r
129 ; Make SOURCE-ID VALUE type, replace TOsource-id with
\r
130 ; "TO SOURCE-ID" and remove TOsource-id .
\r
132 ; Make 'ekey? , 'ekey , 'emit? , 'emit , 'init-i/o , 'prompt
\r
133 ; and 'boot VALUE type and replace "'emit @ EXECUTE"
\r
134 ; with "'emit EXECUTE".
\r
136 ; Add doVALUE , doTO , VALUE and TO .
\r
137 ; Replace 'DUP' with '?DUP' in the definition of "(')".
\r
138 ; Replace 'CREATEd' with 'doCREATE' and remove CREATEd .
\r
140 ; Move "'init-i/o @ EXECUTE" from QUIT to THROW according
\r
141 ; to the suggestion from Chris Jakeman.
\r
143 ; Fix code definition of SPACES .
\r
145 ; Revise $ENVIR for portability.
\r
146 ; 'CR' is a system dependent definition.
\r
148 ; Rename '.ok' and '.OKay' as '.prompt' and '.ok' respectively.
\r
152 ; Redefine $CONST .
\r
154 ;; hForth EXE ¡¡
\95I·e A
\8ba åËa
\9d¡
\90a
\92å 8086·
\81 ¡A¡¡
\9f¡ ¡¡
\95IµA xÂ
\81´á
\r
155 ;; hForth RAM ¡¡
\95I·i
\89¡Áa¬á e
\97i´ö¯s
\93¡
\94a.
\r
157 ;; hForth RAM ¡¡
\95I
\89Á
\94a
\9fe ¸ñ
\97i·i ´a
\9c\81µA ¸â´ö¯s
\93¡
\94a.
\8b¡
\89\81´á ¸÷·
\81\97i·i
\r
158 ;; Ða
\90a
\95¡
\89¡Ã¡»¡ ´g
\89¡ Å¡
\97a A
\8ba åËa·
\81 µ¡ÏaU º
\81¡
\9fi
\94a
\9e\81\8b¡ ¶áÐe
\r
159 ;; Å¡
\97a
\90{ i 4
\88\81 e·i
\94áÐ
\96¯s
\93¡
\94a. ´áQ§i
\9f¡ ¤aÈw¥¥µA¬á aÇa
\9d¡µÁ ¡y
\r
160 ;;
\88\81·
\81 °w¸ñ ¸÷·
\81\9fi ¤a
\8e\81´ö¯s
\93¡
\94a.
\r
162 ;; 1. ¬a¸å·
\81 \8a\81¹¡
\9fi ¤a
\8e\81´ö¯s
\93¡
\94a. hForth RAM ¡¡
\95IµA¬á
\93e Å¡
\97a, ·¡
\9fq,
\r
163 ;; ¸a
\9ea ¸a
\9f¡
\88a ´a
\9c\81Àá
\9cñ ¡¡
\96\81 ¬ãµa ·¶´ö»¡ e
\r
165 ;; //·µ
\8b¡/·¡
\9fq/·¡
\9fq
\88a
\9f¡Ç±/Å¡
\97a>
\r
167 ;; hForth EXE ¡¡
\95IµA¬á
\93e Å¡
\97a ¸a
\9f¡
\9fi 8086 Ïa
\9d¡A¬á·
\81 \94a
\9fe
\r
168 ;; A
\8ba åËa
\9d¡ ´a
\9c\81Àá
\9cñ µ«
\89v¯s
\93¡
\94a
\r
170 ;; CS A
\8ba åËa: //·¡
\9fq
\88a
\9f¡Ç±/Å¡
\97a>
\r
171 ;; DS, SS A
\8ba åËa: //¯¡Ç±Îa/·µ
\8b¡/·¡
\9fq>
\r
173 ;; µa
\8b¡¬á '¯¡Ç±Îa(xt)'
\93e Å¡
\97a·
\81 ¯¡¸b µ¡ÏaU º
\81¡·³
\93¡
\94a. $NAME
\r
174 ;; aÇa
\9d¡
\9fi
\94áÐa
\89¡ $CODE, $COLON, $CONST, $VAR, $USER, $ENVIR
\r
175 ;; aÇa
\9d¡
\9fi ¤a
\8e\81´ö¯s
\93¡
\94a. RAM ¡¡
\95I·
\81 $VAR
\93e ¡¡
\96\81 $CONST
\9fi °á¬á
\r
176 ;;
\89¡Áv¯s
\93¡
\94a.
\r
178 ;; 2. head,µÁ name>xt
\9fi ¤a
\8e\81´ö¯s
\93¡
\94a. ¯¡Ç±Îa(xt)
\9fi head,µA
\89A
\88å
\91A
\r
179 ;; º
\89 ®
\81 ·¶
\8b¡
\98\81¢
\85µA : , CONSTANT , CREATE , VARIABLE·i ROM
\r
180 ;; ¡¡
\95IÀá
\9cñ ¤a
\8e\81´ö¯s
\93¡
\94a. name>xt
\88a ROM ¡¡
\95I
\89Á
\88{´a¹v
\8b¡
\98\81¢
\85µA
\r
181 ;; (search-wordlist)·
\81 \8b¡
\89\81´á ¸÷·
\81\9fi ROM ¡¡
\95I
\89Á
\88{
\89A
\r
182 ;; ¤a
\8e\81´ö¯s
\93¡
\94a (°w¸ñ ¸÷·
\81\93e
\89¡Ã© Ï©¶a
\88a ´ô¯s
\93¡
\94a).
\r
184 ;; 3. CS: ¡w
\9dw·i $NEXT aÇa
\9d¡µÁ
\8b¡
\89\81´á ¸÷·
\81-doLIT, doCONST,
\r
185 ;; doCREATE, doUSER, doLOOP, do+LOOP, 0branch, branch-µA
\r
186 ;;
\94áÐ
\96¯s
\93¡
\94a. doVAR
\9fi ¨
\96¯s
\93¡
\94a.
\r
188 ;; 4. Å¡
\97a A
\8ba åËa·
\81 µ¡ÏaU º
\81¡·¥ 'Å¡
\97a-º
\81¡(code-addr)'
\9ca
\93e
\r
189 ;; ¸a
\9eaÑw·i
\95¡·³Ð
\96¯s
\93¡
\94a. x@ , x! , xb@ , xb!·
\81 \91A
\8b¡
\89\81´á ¸÷·
\81\9fi
\r
190 ;;
\94áÐ
\96¯s
\93¡
\94a. x@, x!, xP
\9fi °á¬á ?call , COMPILE, , optiCOMPILE,
\r
191 ;; , THEN , >BODY , pipe , rake , xhere , TOxhere
\8b¡
\89\81´á ¸÷·
\81\9fi
\r
192 ;;
\89¡Áv¯s
\93¡
\94a. xb@µÁ xb!
\93e
\90aº
\97µA
\94áÐi ´áQ§i
\9cá
\88a Å¡
\97a ¸a
\9f¡µA
\r
193 ;; ¤a·¡Ëa
\88t·i ·ª
\89¡ ³i ®
\81 ·¶
\89A
\90ý´á
\96\81´ö¯s
\93¡
\94a.
\r
195 ;; 5. S" , SLITERAL , ."·i ¤a
\8e\81´ö¯s
\93¡
\94a. $INSTR aÇa
\9d¡µÁ do."µÁ
\r
196 ;; doS"·i ¨
\96¯s
\93¡
\94a.
\r
198 ;; 6. ¬a¶w¸a ¢
\81\9fe
\88t statusµÁ follower
\88a Å¡
\97a ¸a
\9f¡·
\81 º
\81¡
\9fi
\88a
\9f¡Ç¡
\89A
\r
199 ;; Ð
\96¯s
\93¡
\94a.
\88b ¸b´ó·¡ ¸a¯¥·
\81 ¬a¶w¸a ¢
\81\9fe
\88t·i Àx·i ®
\81 ·¶
\95¡
\9d¢
\r
200 ;; Å¡
\97a ¸a
\9f¡µA
\88a
\9f¡Ç±
\88t·i
\90ý´ö¯s
\93¡
\94a. wakeµÁ PAUSE
\9fi
\r
201 ;; ¤a
\8e\81´ö¯s
\93¡
\94a. ¤a
\8e\85 °w¸ñ ¸÷·
\81\93e RAM ¡¡
\95I¥¡
\94a 6% ¸÷
\95¡
\93a
\9f³
\93¡
\94a.
\r
202 ;; wakeµÁ PAUSE
\9fi
\8b¡
\89\81´á
\9d¡ ¸÷·
\81Ð
\96¯s
\93¡
\94a. wakeµÁ PAUSE·
\81 \8b¡
\89\81´á
\r
203 ;; ¸÷·
\81\93e RAM ¡¡
\95I·
\81 °w¸ñ ¸÷·
\81¥¡
\94a 30% ¸÷
\95¡ ¨a
\9fs
\93¡
\94a.
\r
205 ;; 7. '+'µÁ '-'
\97w·
\81 µa
\9cá °w¸ñ ¸÷·
\81\97i·i
\8b¡
\89\81´á ¸÷·
\81\9d¡ ¤a
\8e\81´ö¯s
\93¡
\94a.
\r
206 ;; ¶¥
\9c\81·
\81 °w¸ñ ¸÷·
\81\97i·e
\94õ¦
\9b·± i
\9d¡
\90q
\89a
\96\81´ö¯s
\93¡
\94a.
\r
209 ; hForth EXE model is derived from hForth RAM model and adapted
\r
210 ; to segmented 8086 memory model.
\r
212 ; Differences from hForth RAM model is described below. No low
\r
213 ; level CODE definitions is changed and only four words to access
\r
214 ; code segment address are added. Some macros in the assembler
\r
215 ; source and high level colon definitions are redefined.
\r
217 ; 1. The structure of the dictionary is changed. Code space is
\r
218 ; separated into different 8086 segment. Name and data spaces
\r
219 ; are combined in hForth EXE model as below
\r
221 ; CS segment: //pointer_to_name/code>
\r
222 ; DS,SS segment: //xt/link/name>
\r
224 ; while they are intermingled in hForth RAM model as below
\r
226 ; //link/name/pointer_to_name/code>
\r
228 ; where xt is the starting address of code. $NAME macro is added
\r
229 ; and $CODE, $COLON, $CONST, $VAR, $USER and $ENVIR macros are
\r
230 ; redefined in assembly source. $VAR in RAM model source is
\r
231 ; replaced with $CONST.
\r
233 ; 2. 'head,' and 'name>xt' are redefined. Redefine ':', 'CONSTANT',
\r
234 ; 'CREATE', 'VARIABLE' similar to hForth 8086 ROM model since xt
\r
235 ; can be given to 'head,'. Set code definition of
\r
236 ; '(search-wordlist)' same as in ROM model since 'name>xt' is
\r
237 ; the same as ROM model redefined (although colon definition need
\r
238 ; not be changed at all).
\r
240 ; 3. CS: suffix is added into $NEXT macro and CODE definitions -
\r
241 ; 'doLIT', 'doCONST', 'doCREATE', 'doUSER', 'doLOOP', 'do+LOOP',
\r
242 ; '0branch', 'branch'. 'doVAR' is removed.
\r
244 ; 4. New data type 'code-addr' in introduced which is offset in CS:
\r
245 ; segment. CODE definitions 'x@', 'x!', 'xb@' and 'xb!' and system
\r
246 ; variable 'xP' is added. '?call', 'COMPILE,', ; 'optiCOMPILE,',
\r
247 ; 'THEN', '>BODY', 'pipe', 'rake', 'xhere' ; and 'TOxhere' are
\r
248 ; redefined using 'x@', 'x!' and 'xP'. 'xb@' and 'xb!' will be used
\r
249 ; by assembler to read and write byte values in code space.
\r
251 ; 5. 'S"', 'SLITERAL' and '."' are redefined. $INSTR macro and 'do."'
\r
252 ; and 'doS"' are dropped.
\r
254 ; 6. USER variable 'status' and 'follower' points code space
\r
255 ; addresses. Pointer to user variable area are added into code
\r
256 ; space for each task. Revise 'wake' and 'PAUSE'. High level
\r
257 ; definitions of 'wake' and 'PAUSE' are about 6% slower compared to
\r
258 ; RAM model. CODE definitions of 'wake' and 'PAUSE' are given,
\r
259 ; which makes task-switching 30% faster than RAM model.
\r
261 ; 7. Many high level colon definitions such as '+' and '-' are
\r
262 ; redefined as CODE definitions. Colon definitions are left as
\r
263 ; comments in assembly source.
\r
265 ;===============================================================
\r
267 ; 8086/8 register usages
\r
268 ; Double segment model. DS and SS are same but CS is different.
\r
269 ; The direction bit must be cleared before returning to Forth
\r
270 ; interpreter(CLD).
\r
271 ; SP: data stack pointer
\r
272 ; BP: return stack pointer
\r
273 ; SI: Forth virtual machine instruction pointer
\r
274 ; BX: top of data stack item
\r
275 ; All other registers are free.
\r
277 ; Structure of a task
\r
278 ; userP points follower.
\r
279 ; //userP//<return_stack//<data_stack//
\r
280 ; //user_area/user1/taskName/throwFrame/stackTop/status/follower/sp0/rp0
\r
282 ;===============================================================
\r
285 ; Assembly Constants
\r
291 CHARR EQU 1 ;byte size of a character
\r
292 CELLL EQU 2 ;byte size of a cell
\r
293 MaxChar EQU 0FFh ;Extended character set
\r
294 ; Use 07Fh for ASCII only
\r
295 MaxSigned EQU 07FFFh ;max value of signed integer
\r
296 MaxUnsigned EQU 0FFFFh ;max value of unsigned integer
\r
297 MaxNegative EQU 8000h ;max value of negative integer
\r
300 PADSize EQU 258 ;PAD area size
\r
301 RTCells EQU 64 ;return stack size
\r
302 DTCells EQU 256 ;data stack size
\r
304 BASEE EQU 10 ;default radix
\r
305 OrderDepth EQU 10 ;depth of search order stack
\r
307 COMPO EQU 020h ;lexicon compile only bit
\r
308 IMMED EQU 040h ;lexicon immediate bit
\r
309 SEMAN EQU 080h ;lexicon compilation semantics bit
\r
310 MASKK EQU 1Fh ;lexicon bit mask
\r
311 ;extended character set
\r
312 ;maximum name length = 1Fh
\r
314 BKSPP EQU 8 ;backspace
\r
316 LFF EQU 10 ;line feed
\r
317 CRR EQU 13 ;carriage return
\r
318 DEL EQU 127 ;delete
\r
320 CALLL EQU 0E890h ;NOP CALL opcodes
\r
322 ; Memory allocation
\r
323 ; code segment ||code>--||
\r
324 ; data segment ||name/data>WORDworkarea|--//--|PAD|TIB||
\r
326 ; Initialize assembly variables
\r
328 _SLINK = 0 ;force a null link
\r
329 _FLINK = 0 ;force a null link
\r
330 _ENVLINK = 0 ;farce a null link
\r
331 _THROW = 0 ;current throw str addr offset
\r
337 ; Adjust an address to the next cell boundary.
\r
340 EVEN ;for 16 bit systems
\r
343 ; Add a name to name space of dictionary.
\r
345 $STR MACRO LABEL,STRING
\r
356 ; Add a THROW message in name space. THROW messages won't be
\r
357 ; needed if target system do not need names of Forth words.
\r
359 $THROWMSG MACRO STRING
\r
365 _THROW = _THROW + CELLL
\r
366 ORG AddrTHROWMsgTbl - _THROW
\r
371 ; Compile a definition header in name space.
\r
373 $NAME MACRO LEX,NAME,LABEL,AddrNAME,LINK
\r
374 $ALIGN ;force to cell boundary
\r
378 LINK = $ ;link points to a name string
\r
380 DB LEX,NAME ;name string
\r
384 ; Compile a code definition.
\r
386 $CODE MACRO NAME,LABEL
\r
388 LABEL: ;assembly label
\r
391 ; Compile a colon definition.
\r
393 $COLON MACRO NAME,LABEL
\r
395 NOP ;align to cell boundary
\r
396 CALL DoLIST ;include CALL doLIST
\r
399 ; Compile a system CONSTANT and VARIABLE.
\r
401 $CONST MACRO NAME,LABEL,VALUE
\r
410 ; Compile a system VALUE header.
\r
412 $VALUE MACRO NAME,LABEL,OFFSET
\r
419 ; Compile a system USER variable.
\r
421 $USER MACRO NAME,LABEL,OFFSET
\r
428 ; Compile a environment query string header.
\r
430 $ENVIR MACRO LEX,NAME,LABEL
\r
431 $ALIGN ;force to cell boundary
\r
434 _ENVLINK = $ ;link points to a name string
\r
435 DB LEX,NAME ;name string
\r
439 ; Assemble inline direct threaded code ending.
\r
442 LODS WORD PTR CS:[SI]
\r
443 JMP AX ;jump directly to code address
\r
447 ;===============================================================
\r
449 FIRST SEGMENT PARA PUBLIC 'CODES'
\r
452 ;===============================================================
\r
457 $STR ModelStr,'EXE Model'
\r
458 $STR VersionStr,'0.9.9'
\r
460 ; system variables.
\r
462 $ALIGN ;align to cell boundary
\r
463 AddrTickEKEYQ DW RXQ ;'ekey?
\r
464 AddrTickEKEY DW RXFetch ;'ekey
\r
465 AddrTickEMITQ DW TXQ ;'emit?
\r
466 AddrTickEMIT DW TXStore ;'emit
\r
467 AddrTickINIT_IO DW Set_IO ;'init-i/o
\r
468 AddrTickPrompt DW DotOK ;'prompt
\r
469 AddrTickBoot DW HI ;'boot
\r
470 AddrSOURCE_ID DW 0 ;SOURCE-ID
\r
471 AddrHERE DW DTOP ;data space pointer
\r
472 AddrXHere DW CTOP ;code space pointer
\r
473 AddrTickDoWord DW OptiCOMPILEComma ;nonimmediate word - compilation
\r
474 DW EXECUTE ;nonimmediate word - interpretation
\r
475 DW DoubleAlsoComma ;not found word - compilateion
\r
476 DW DoubleAlso ;not found word - interpretation
\r
477 DW EXECUTE ;immediate word - compilation
\r
478 DW EXECUTE ;immediate word - interpretation
\r
479 AddrBASE DW 10 ;BASE
\r
480 AddrMemTop DW 0FFFEh ;memTop
\r
482 AddrNotNONAMEQ DW 0 ;notNONAME?
\r
483 AddrRakeVar DW 0 ;rakeVar
\r
484 AddrNumberOrder DW 2 ;#order
\r
485 DW AddrFORTH_WORDLIST ;search order stack
\r
486 DW AddrNONSTANDARD_WORDLIST
\r
487 DW (OrderDepth-2) DUP (0)
\r
488 AddrCurrent DW AddrFORTH_WORDLIST ;current pointer
\r
489 AddrFORTH_WORDLIST DW LASTFORTH ;FORTH-WORDLIST
\r
490 DW AddrNONSTANDARD_WORDLIST;wordlist link
\r
491 DW FORTH_WORDLISTName ;name of the WORDLIST
\r
492 AddrNONSTANDARD_WORDLIST DW LASTSYSTEM ;NONSTANDARD-WORDLIST
\r
493 DW 0 ;wordlist link
\r
494 DW NONSTANDARD_WORDLISTName;name of the WORDLIST
\r
495 AddrEnvQList DW LASTENV ;envQList
\r
496 AddrUserP DW SysUserP ;user pointer
\r
497 SysTask DW SysUserP ;system task's tid
\r
498 SysUser1 DW ? ;user1
\r
499 SysTaskName DW SystemTaskName ;taskName
\r
500 SysThrowFrame DW ? ;throwFrame
\r
501 SysStackTop DW ? ;stackTop
\r
502 SysStatus DW XSysStatus ;status
\r
504 SysFollower DW XSysFollower ;follower
\r
505 DW SPP ;system task's sp0
\r
506 DW RPP ;system task's rp0
\r
508 AddrNumberOrder0 DW 2 ;#order0
\r
509 DW AddrFORTH_WORDLIST ;search order stack
\r
510 DW AddrNONSTANDARD_WORDLIST
\r
511 DW (OrderDepth-2) DUP (0)
\r
513 AddrAbortQMsg DW 2 DUP (?)
\r
515 AddrErrWord DW 2 DUP (?)
\r
518 AddrSourceVar DW 2 DUP (?)
\r
521 AddrSpecialCompQ DW ?
\r
523 RStack DW RTCells DUP (0AAAAh) ;to see how deep stack grows
\r
525 DStack DW DTCells DUP (05555h) ;to see how deep stack grows
\r
528 ; THROW code messages
\r
530 DW 58 DUP (?) ;number of throw messages = 58
\r
533 $THROWMSG 'ABORT' ;-01
\r
534 $THROWMSG 'ABORT"' ;-02
\r
535 $THROWMSG 'stack overflow' ;-03
\r
536 $THROWMSG 'stack underflow' ;-04
\r
537 $THROWMSG 'return stack overflow' ;-05
\r
538 $THROWMSG 'return stack underflow' ;-06
\r
539 $THROWMSG 'do-loops nested too deeply during execution' ;-07
\r
540 $THROWMSG 'dictionary overflow' ;-08
\r
541 $THROWMSG 'invalid memory address' ;-09
\r
542 $THROWMSG 'division by zero' ;-10
\r
543 $THROWMSG 'result out of range' ;-11
\r
544 $THROWMSG 'argument type mismatch' ;-12
\r
545 $THROWMSG 'undefined word' ;-13
\r
546 $THROWMSG 'interpreting a compile-only word' ;-14
\r
547 $THROWMSG 'invalid FORGET' ;-15
\r
548 $THROWMSG 'attempt to use zero-length string as a name' ;-16
\r
549 $THROWMSG 'pictured numeric output string overflow' ;-17
\r
550 $THROWMSG 'parsed string overflow' ;-18
\r
551 $THROWMSG 'definition name too long' ;-19
\r
552 $THROWMSG 'write to a read-only location' ;-20
\r
553 $THROWMSG 'unsupported operation (e.g., AT-XY on a too-dumb terminal)' ;-21
\r
554 $THROWMSG 'control structure mismatch' ;-22
\r
555 $THROWMSG 'address alignment exception' ;-23
\r
556 $THROWMSG 'invalid numeric argument' ;-24
\r
557 $THROWMSG 'return stack imbalance' ;-25
\r
558 $THROWMSG 'loop parameters unavailable' ;-26
\r
559 $THROWMSG 'invalid recursion' ;-27
\r
560 $THROWMSG 'user interrupt' ;-28
\r
561 $THROWMSG 'compiler nesting' ;-29
\r
562 $THROWMSG 'obsolescent feature' ;-30
\r
563 $THROWMSG '>BODY used on non-CREATEd definition' ;-31
\r
564 $THROWMSG 'invalid name argument (e.g., TO xxx)' ;-32
\r
565 $THROWMSG 'block read exception' ;-33
\r
566 $THROWMSG 'block write exception' ;-34
\r
567 $THROWMSG 'invalid block number' ;-35
\r
568 $THROWMSG 'invalid file position' ;-36
\r
569 $THROWMSG 'file I/O exception' ;-37
\r
570 $THROWMSG 'non-existent file' ;-38
\r
571 $THROWMSG 'unexpected end of file' ;-39
\r
572 $THROWMSG 'invalid BASE for floating point conversion' ;-40
\r
573 $THROWMSG 'loss of precision' ;-41
\r
574 $THROWMSG 'floating-point divide by zero' ;-42
\r
575 $THROWMSG 'floating-point result out of range' ;-43
\r
576 $THROWMSG 'floating-point stack overflow' ;-44
\r
577 $THROWMSG 'floating-point stack underflow' ;-45
\r
578 $THROWMSG 'floating-point invalid argument' ;-46
\r
579 $THROWMSG 'compilation word list deleted' ;-47
\r
580 $THROWMSG 'invalid POSTPONE' ;-48
\r
581 $THROWMSG 'search-order overflow' ;-49
\r
582 $THROWMSG 'search-order underflow' ;-50
\r
583 $THROWMSG 'compilation word list changed' ;-51
\r
584 $THROWMSG 'control-flow stack overflow' ;-52
\r
585 $THROWMSG 'exception stack overflow' ;-53
\r
586 $THROWMSG 'floating-point underflow' ;-54
\r
587 $THROWMSG 'floating-point unidentified fault' ;-55
\r
588 $THROWMSG 'QUIT' ;-56
\r
589 $THROWMSG 'exception in sending or receiving a character' ;-57
\r
590 $THROWMSG '[IF], [ELSE], or [THEN] exception' ;-58
\r
592 $NAME 3,'RX?',RXQ,NameRXQ,_SLINK
\r
593 $NAME 3,'RX@',RXFetch,NameRXFetch,_SLINK
\r
594 $NAME SEMAN+3,'TX?',TXQ,NameTXQ,_SLINK
\r
595 $NAME 3,'TX!',TXStore,NameTXStore,_SLINK
\r
596 $NAME 2,'CR',CR,NameCR,_FLINK
\r
597 $NAME 3,'BYE',BYE,NameBYE,_FLINK
\r
598 $NAME 2,'hi',HI,NameHI,_SLINK
\r
599 $STR HiStr1,'hForth '
\r
601 $STR ModelQStr,'model'
\r
602 $STR VersionQStr,'version'
\r
603 $STR HiStr2,' by Wonyong Koh, 1997'
\r
604 $STR HiStr3,'ALL noncommercial and commercial uses are granted.'
\r
605 $STR HiStr4,'Please send comment, bug report and suggestions to:'
\r
606 $STR HiStr5,' wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr'
\r
607 $NAME 4,'COLD',COLD,NameCOLD,_SLINK
\r
608 $NAME 7,'set-i/o',Set_IO,NameSet_IO,_SLINK
\r
609 $STR Set_IOstr,'CON'
\r
610 $NAME 8,'redirect',Redirect,NameRedirect,_SLINK
\r
611 $NAME 6,'asciiz',ASCIIZ,NameASCIIZ,_SLINK
\r
612 $NAME 5,'stdin',STDIN,NameSTDIN,_SLINK
\r
613 $NAME IMMED+2,'<<',FROM,NameFROM,_SLINK
\r
614 $STR FROMstr,'Do not use << in a definition.'
\r
615 $NAME 5,'same?',SameQ,NameSameQ,_SLINK
\r
616 $NAME 17,'(search-wordlist)',ParenSearch_Wordlist,NameParenSearch_Wordlist,_SLINK
\r
617 $NAME 5,'?call',QCall,NameQCall,_SLINK
\r
618 $NAME COMPO+4,'pipe',Pipe,NamePipe,_SLINK
\r
619 $NAME 3,'xt,',xtComma,NamextComma,_SLINK
\r
620 $NAME COMPO+13,'compileCREATE',CompileCREATE,NameCompileCREATE,_SLINK
\r
621 $NAME COMPO+12,'compileCONST',CompileCONST,NameCompileCONST,_SLINK
\r
622 $NAME COMPO+5,'doLIT',DoLIT,NameDoLIT,_SLINK
\r
623 $NAME COMPO+7,'doCONST',DoCONST,NameDoCONST,_SLINK
\r
624 $NAME COMPO+8,'doCREATE',DoCREATE,NameDoCREATE,_SLINK
\r
625 $NAME COMPO+7,'doVALUE',DoVALUE,NameDoVALUE,_SLINK
\r
626 $NAME COMPO+4,'doTO',DoTO,NameDoTO,_SLINK
\r
627 $NAME COMPO+6,'doUSER',DoUSER,NameDoUSER,_SLINK
\r
628 $NAME COMPO+6,'doLIST',DoLIST,NameDoLIST,_SLINK
\r
629 $NAME COMPO+6,'doLOOP',DoLOOP,NameDoLOOP,_SLINK
\r
630 $NAME COMPO+7,'do+LOOP',DoPLOOP,NameDoPLOOP,_SLINK
\r
631 $NAME COMPO+7,'0branch',ZBranch,NameZBranch,_SLINK
\r
632 $NAME COMPO+6,'branch',Branch,NameBranch,_SLINK
\r
633 $NAME COMPO+3,'rp@',RPFetch,NameRPFetch,_SLINK
\r
634 $NAME COMPO+3,'rp!',RPStore,NameRPStore,_SLINK
\r
635 $NAME 3,'sp@',SPFetch,NameSPFetch,_SLINK
\r
636 $NAME 3,'sp!',SPStore,NameSPStore,_SLINK
\r
637 $NAME 3,'um+',UMPlus,NameUMPlus,_SLINK
\r
638 $NAME 5,'code!',CodeStore,NameCodeStore,_SLINK
\r
639 $NAME 6,'codeB!',CodeBStore,NameCodeBStore,_SLINK
\r
640 $NAME 5,'code@',CodeFetch,NameCodeFetch,_SLINK
\r
641 $NAME 6,'codeB@',CodeBFetch,NameCodeBFetch,_SLINK
\r
642 $NAME 5,'code,',CodeComma,NameCodeComma,_SLINK
\r
643 $NAME 5,'ALIGN',ALIGNN,NameALIGNN,_FLINK
\r
644 $NAME 7,'ALIGNED',ALIGNED,NameALIGNED,_FLINK
\r
645 $NAME 5,'pack"',PackQuote,NamePackQuote,_SLINK
\r
646 $NAME 5,'CELLS',CELLS,NameCELLS,_FLINK
\r
647 $NAME 5,'CHARS',CHARS,NameCHARS,_FLINK
\r
648 $NAME 7,'1chars/',OneCharsSlash,NameOneCharsSlash,_SLINK
\r
649 $NAME 1,'!',Store,NameStore,_FLINK
\r
650 $NAME 2,'0<',ZeroLess,NameZeroLess,_FLINK
\r
651 $NAME 2,'0=',ZeroEquals,NameZeroEquals,_FLINK
\r
652 $NAME 2,'2*',TwoStar,NameTwoStar,_FLINK
\r
653 $NAME 2,'2/',TwoSlash,NameTwoSlash,_FLINK
\r
654 $NAME COMPO+2,'>R',ToR,NameToR,_FLINK
\r
655 $NAME 1,'@',Fetch,NameFetch,_FLINK
\r
656 $NAME 3,'AND',ANDD,NameANDD,_FLINK
\r
657 $NAME 2,'C!',CStore,NameCStore,_FLINK
\r
658 $NAME 2,'C@',CFetch,NameCFetch,_FLINK
\r
659 $NAME 4,'DROP',DROP,NameDROP,_FLINK
\r
660 $NAME 3,'DUP',DUPP,NameDUPP,_FLINK
\r
661 $NAME 7,'EXECUTE',EXECUTE,NameEXECUTE,_FLINK
\r
662 $NAME COMPO+4,'EXIT',EXIT,NameEXIT,_FLINK
\r
663 $NAME 4,'MOVE',MOVE,NameMOVE,_FLINK
\r
664 $NAME 2,'OR',ORR,NameORR,_FLINK
\r
665 $NAME 4,'OVER',OVER,NameOVER,_FLINK
\r
666 $NAME COMPO+2,'R>',RFrom,NameRFrom,_FLINK
\r
667 $NAME COMPO+2,'R@',RFetch,NameRFetch,_FLINK
\r
668 $NAME 4,'SWAP',SWAP,NameSWAP,_FLINK
\r
669 $NAME 3,'XOR',XORR,NameXORR,_FLINK
\r
670 $NAME SEMAN+7,'#order0',NumberOrder0,NameNumberOrder0,_SLINK
\r
671 $NAME 6,"'ekey?",TickEKEYQ,NameTickEKEYQ,_SLINK
\r
672 $NAME 5,"'ekey",TickEKEY,NameTickEKEY,_SLINK
\r
673 $NAME 6,"'emit?",TickEMITQ,NameTickEMITQ,_SLINK
\r
674 $NAME 5,"'emit",TickEMIT,NameTickEMIT,_SLINK
\r
675 $NAME 9,"'init-i/o",TickINIT_IO,NameTickINIT_IO,_SLINK
\r
676 $NAME 7,"'prompt",TickPrompt,NameTickPrompt,_SLINK
\r
677 $NAME 5,"'boot",TickBoot,NameTickBoot,_SLINK
\r
678 $NAME 9,'SOURCE-ID',SOURCE_ID,NameSOURCE_ID,_FLINK
\r
679 $NAME 4,'HERE',HERE,NameHERE,_FLINK
\r
680 $NAME 5,'xhere',XHere,NameXHere,_SLINK
\r
681 $NAME SEMAN+7,"'doWord",TickDoWord,NameTickDoWord,_SLINK
\r
682 $NAME SEMAN+4,'BASE',BASE,NameBASE,_FLINK
\r
683 $NAME SEMAN+11,'THROWMsgTbl',THROWMsgTbl,NameTHROWMsgTbl,_SLINK
\r
684 $NAME 6,'memTop',MemTop,NameMemTop,_SLINK
\r
685 $NAME 3,'bal',Bal,NameBal,_SLINK
\r
686 $NAME 10,'notNONAME?',NotNONAMEQ,NameNotNONAMEQ,_SLINK
\r
687 $NAME SEMAN+7,'rakeVar',RakeVar,NameRakeVar,_SLINK
\r
688 $NAME SEMAN+6,'#order',NumberOrder,NameNumberOrder,_SLINK
\r
689 $NAME SEMAN+7,'current',Current,NameCurrent,_SLINK
\r
690 $NAME SEMAN+14,'FORTH-WORDLIST',FORTH_WORDLIST,NameFORTH_WORDLIST,_FLINK
\r
691 FORTH_WORDLISTName EQU _NAME-0
\r
692 $NAME SEMAN+20,'NONSTANDARD-WORDLIST',NONSTANDARD_WORDLIST,NameNONSTANDARD_WORDLIST,_FLINK
\r
693 NONSTANDARD_WORDLISTName EQU _NAME-0
\r
694 $NAME SEMAN+8,'envQList',EnvQList,NameEnvQList,_SLINK
\r
695 $NAME SEMAN+5,'userP',UserP,NameUserP,_SLINK
\r
696 $NAME SEMAN+10,'SystemTask',SystemTask,NameSystemTask,_SLINK
\r
697 SystemTaskName EQU _NAME-0
\r
698 $NAME 8,'follower',Follower,NameFollower,_SLINK
\r
699 $NAME 6,'status',Status,NameStatus,_SLINK
\r
700 $NAME 8,'stackTop',StackTop,NameStackTop,_SLINK
\r
701 $NAME 10,'throwFrame',ThrowFrame,NameThrowFrame,_SLINK
\r
702 $NAME 8,'taskName',TaskName,NameTaskName,_SLINK
\r
703 $NAME 5,'user1',User1,NameUser1,_SLINK
\r
705 $ENVIR 5,'model',Model
\r
706 $ENVIR 7,'version',Version
\r
707 $ENVIR 15,'/COUNTED-STRING',SlashCOUNTED_STRING
\r
708 $ENVIR 5,'/HOLD',SlashHOLD
\r
709 $ENVIR 4,'/PAD',SlashPAD
\r
710 $ENVIR 17,'ADDRESS-UNIT-BITS',ADDRESS_UNIT_BITS
\r
711 $ENVIR 4,'CORE',CORE
\r
712 $ENVIR 7,'FLOORED',FLOORED
\r
713 $ENVIR 8,'MAX-CHAR',MAX_CHAR
\r
714 $ENVIR 5,'MAX-D',MAX_D
\r
715 $ENVIR 5,'MAX-N',MAX_N
\r
716 $ENVIR 5,'MAX-U',MAX_U
\r
717 $ENVIR 6,'MAX-UD',MAX_UD
\r
718 $ENVIR 18,'RETURN-STACK-CELLS',RETURN_STACK_CELLS
\r
719 $ENVIR 11,'STACK-CELLS',STACK_CELLS
\r
720 $ENVIR 9,'EXCEPTION',EXCEPTION
\r
721 $ENVIR 13,'EXCEPTION-EXT',EXCEPTION_EXT
\r
722 $ENVIR 9,'WORDLISTS',WORDLISTS
\r
723 $NAME 3,"(')",ParenTick,NameParenTick,_SLINK
\r
724 $NAME 4,'(d.)',ParenDDot,NameParenDDot,_SLINK
\r
725 $NAME 3,'.ok',DotOK,NameDotOK,_SLINK
\r
727 $NAME 7,'.prompt',DotPrompt,NameDotOK,_SLINK
\r
728 $NAME SEMAN+1,'0',Zero,NameZero,_SLINK
\r
729 $NAME SEMAN+1,'1',One,NameOne,_SLINK
\r
730 $NAME SEMAN+2,'-1',MinusOne,NameMinusOne,_SLINK
\r
731 $NAME SEMAN+9,'abort"msg',AbortQMsg,NameAbortQMsg,_SLINK
\r
732 $NAME 4,'bal+',BalPlus,NameBalPlus,_SLINK
\r
733 $NAME 4,'bal-',BalMinus,NameBalMinus,_SLINK
\r
734 $NAME 5,'cell-',CellMinus,NameCellMinus,_SLINK
\r
735 $NAME 12,'COMPILE-ONLY',COMPILE_ONLY,NameCOMPILE_ONLY,_SLINK
\r
736 $NAME COMPO+4,'doDO',DoDO,NameDoDO,_SLINK
\r
737 $NAME SEMAN+7,'errWord',ErrWord,NameErrWord,_SLINK
\r
738 $NAME 5,'head,',HeadComma,NameHeadComma,_SLINK
\r
739 $STR HEADCstr,'redefine '
\r
740 $NAME SEMAN+3,'hld',HLD,NameHLD,_SLINK
\r
741 $NAME 9,'interpret',Interpret,NameInterpret,_SLINK
\r
742 $NAME 12,'optiCOMPILE,',OptiCOMPILEComma,NameOptiCOMPILEComma,_SLINK
\r
743 $NAME 10,'singleOnly',SingleOnly,NameSingleOnly,_SLINK
\r
744 $NAME 11,'singleOnly,',SingleOnlyComma,NameSingleOnlyComma,_SLINK
\r
745 $NAME 12,'(doubleAlso)',ParenDoubleAlso,NameParenDoubleAlso,_SLINK
\r
746 $NAME 10,'doubleAlso',DoubleAlso,NameDoubleAlso,_SLINK
\r
747 $NAME 11,'doubleAlso,',DoubleAlsoComma,NameDoubleAlsoComma,_SLINK
\r
748 $NAME IMMED+2,'-.',MinusDot,NameMinusDot,_SLINK
\r
749 $NAME 8,'lastName',LastName,NameLastName,_SLINK
\r
750 $NAME 8,'linkLast',LinkLast,NameLinkLast,_SLINK
\r
751 $NAME 7,'name>xt',NameToXT,NameNameToXT,_SLINK
\r
752 $NAME 9,'skipPARSE',SkipPARSE,NameSkipPARSE,_SLINK
\r
753 $NAME 12,'specialComp?',SpecialCompQ,NameSpecialCompQ,_SLINK
\r
754 $NAME 10,'PARSE-WORD',PARSE_WORD,NamePARSE_WORD,_SLINK
\r
755 $NAME COMPO+4,'rake',rake,Namerake,_SLINK
\r
756 $NAME 3,'rp0',RPZero,NameRPZero,_SLINK
\r
757 $NAME 11,'search-word',Search_word,NameSearch_word,_SLINK
\r
758 $NAME SEMAN+9,'sourceVar',SourceVar,NameSourceVar,_SLINK
\r
759 $NAME 3,'sp0',SPZero,NameSPZero,_SLINK
\r
760 $NAME COMPO+5,'PAUSE',PAUSE,NamePAUSE,_SLINK
\r
761 $NAME COMPO+4,'wake',Wake,NameWake,_SLINK
\r
762 $NAME 1,'#',NumberSign,NameNumberSign,_FLINK
\r
763 $NAME 2,'#>',NumberSignGreater,NameNumberSignGreater,_FLINK
\r
764 $NAME 2,'#S',NumberSignS,NameNumberSignS,_FLINK
\r
765 $NAME 1,"'",Tick,NameTick,_FLINK
\r
766 $NAME 1,'+',Plus,NamePlus,_FLINK
\r
767 $NAME 2,'+!',PlusStore,NamePlusStore,_FLINK
\r
768 $NAME 1,',',Comma,NameComma,_FLINK
\r
769 $NAME 1,'-',Minus,NameMinus,_FLINK
\r
770 $NAME 1,'.',Dot,NameDot,_FLINK
\r
771 $NAME 1,'/',Slash,NameSlash,_FLINK
\r
772 $NAME 4,'/MOD',SlashMOD,NameSlashMOD,_FLINK
\r
773 $NAME 7,'/STRING',SlashSTRING,NameSlashSTRING,_FLINK
\r
774 $NAME 2,'1+',OnePlus,NameOnePlus,_FLINK
\r
775 $NAME 2,'1-',OneMinus,NameOneMinus,_FLINK
\r
776 $NAME 2,'2!',TwoStore,NameTwoStore,_FLINK
\r
777 $NAME 2,'2@',TwoFetch,NameTwoFetch,_FLINK
\r
778 $NAME 5,'2DROP',TwoDROP,NameTwoDROP,_FLINK
\r
779 $NAME 4,'2DUP',TwoDUP,NameTwoDUP,_FLINK
\r
780 $NAME 5,'2SWAP',TwoSWAP,NameTwoSWAP,_FLINK
\r
781 $NAME 1,':',COLON,NameCOLON,_FLINK
\r
782 $NAME 7,':NONAME',ColonNONAME,NameColonNONAME,_FLINK
\r
783 $NAME IMMED+COMPO+1,';',Semicolon,NameSemicolon,_FLINK
\r
784 $NAME 1,'<',LessThan,NameLessThan,_FLINK
\r
785 $NAME 2,'<#',LessNumberSign,NameLessNumberSign,_FLINK
\r
786 $NAME 1,'=',Equals,NameEquals,_FLINK
\r
787 $NAME 1,'>',GreaterThan,NameGreaterThan,_FLINK
\r
788 $NAME SEMAN+3,'>IN',ToIN,NameToIN,_FLINK
\r
789 $NAME 7,'>NUMBER',ToNUMBER,NameToNUMBER,_FLINK
\r
790 $NAME 4,'?DUP',QuestionDUP,NameQuestionDUP,_FLINK
\r
791 $NAME 5,'ABORT',ABORT,NameABORT,_FLINK
\r
792 $NAME 6,'ACCEPT',ACCEPT,NameACCEPT,_FLINK
\r
793 $NAME IMMED+COMPO+5,'AGAIN',AGAIN,NameAGAIN,_FLINK
\r
794 $NAME IMMED+COMPO+5,'AHEAD',AHEAD,NameAHEAD,_FLINK
\r
795 $NAME SEMAN+2,'BL',BLank,NameBLank,_FLINK
\r
796 $NAME 5,'CATCH',CATCH,NameCATCH,_FLINK
\r
797 $NAME 5,'CELL+',CELLPlus,NameCELLPlus,_FLINK
\r
798 $NAME 5,'CHAR+',CHARPlus,NameCHARPlus,_FLINK
\r
799 $NAME COMPO+8,'COMPILE,',COMPILEComma,NameCOMPILEComma,_FLINK
\r
800 $NAME 8,'CONSTANT',CONSTANT,NameCONSTANT,_FLINK
\r
801 $NAME 5,'COUNT',COUNT,NameCOUNT,_FLINK
\r
802 $NAME 6,'CREATE',CREATE,NameCREATE,_FLINK
\r
803 $NAME 2,'D+',DPlus,NameDPlus,_FLINK
\r
804 $NAME 2,'D.',DDot,NameDDot,_FLINK
\r
805 $NAME 7,'DECIMAL',DECIMAL,NameDECIMAL,_FLINK
\r
806 $NAME 5,'DEPTH',DEPTH,NameDEPTH,_FLINK
\r
807 $NAME 7,'DNEGATE',DNEGATE,NameDNEGATE,_FLINK
\r
808 $NAME 4,'EKEY',EKEY,NameEKEY,_FLINK
\r
809 $NAME 4,'EMIT',EMIT,NameEMIT,_FLINK
\r
810 $NAME 6,'FM/MOD',FMSlashMOD,NameFMSlashMOD,_FLINK
\r
811 $NAME 11,'GET-CURRENT',GET_CURRENT,NameGET_CURRENT,_FLINK
\r
812 $NAME 4,'HOLD',HOLD,NameHOLD,_FLINK
\r
813 $NAME COMPO+1,'I',I,NameI,_FLINK
\r
814 $NAME IMMED+COMPO+2,'IF',IFF,NameIFF,_FLINK
\r
815 $NAME 6,'INVERT',INVERT,NameINVERT,_FLINK
\r
816 $NAME 3,'KEY',KEY,NameKEY,_FLINK
\r
817 $NAME IMMED+COMPO+7,'LITERAL',LITERAL,NameLITERAL,_FLINK
\r
818 $NAME 6,'NEGATE',NEGATE,NameNEGATE,_FLINK
\r
819 $NAME 3,'NIP',NIP,NameNIP,_FLINK
\r
820 $NAME 5,'PARSE',PARSE,NamePARSE,_FLINK
\r
821 $NAME 4,'QUIT',QUIT,NameQUIT,_FLINK
\r
822 $STR QUITstr,' Exception # '
\r
823 $NAME 6,'REFILL',REFILL,NameREFILL,_FLINK
\r
824 $NAME 3,'ROT',ROT,NameROT,_FLINK
\r
825 $NAME 3,'S>D',SToD,NameSToD,_FLINK
\r
826 $NAME 15,'SEARCH-WORDLIST',SEARCH_WORDLIST,NameSEARCH_WORDLIST,_FLINK
\r
827 $NAME 4,'SIGN',SIGN,NameSIGN,_FLINK
\r
828 $NAME 6,'SOURCE',SOURCE,NameSOURCE,_FLINK
\r
829 $NAME 5,'SPACE',SPACE,NameSPACE,_FLINK
\r
830 $NAME SEMAN+5,'STATE',STATE,NameSTATE,_FLINK
\r
831 $NAME IMMED+COMPO+4,'THEN',THENN,NameTHENN,_FLINK
\r
832 $NAME 5,'THROW',THROW,NameTHROW,_FLINK
\r
833 $NAME 4,'TYPE',TYPEE,NameTYPEE,_FLINK
\r
834 $NAME 2,'U<',ULess,NameULess,_FLINK
\r
835 $NAME 3,'UM*',UMStar,NameUMStar,_FLINK
\r
836 $NAME 6,'UM/MOD',UMSlashMOD,NameUMSlashMOD,_FLINK
\r
837 $NAME COMPO+6,'UNLOOP',UNLOOP,NameUNLOOP,_FLINK
\r
838 $NAME 6,'WITHIN',WITHIN,NameWITHIN,_FLINK
\r
839 $NAME IMMED+COMPO+1,'[',LeftBracket,NameLeftBracket,_FLINK
\r
840 $NAME 1,']',RightBracket,NameRightBracket,_FLINK
\r
841 $NAME IMMED+1,'(',Paren,NameParen,_FLINK
\r
842 $NAME 1,'*',Star,NameStar,_FLINK
\r
843 $NAME 2,'*/',StarSlash,NameStarSlash,_FLINK
\r
844 $NAME 5,'*/MOD',StarSlashMOD,NameStarSlashMOD,_FLINK
\r
845 $NAME IMMED+COMPO+5,'+LOOP',PlusLOOP,NamePlusLOOP,_FLINK
\r
846 $NAME IMMED+COMPO+2,'."',DotQuote,NameDotQuote,_FLINK
\r
847 $NAME 5,'2OVER',TwoOVER,NameTwoOVER,_FLINK
\r
848 $NAME 5,'>BODY',ToBODY,NameToBODY,_FLINK
\r
849 $NAME IMMED+COMPO+6,'ABORT"',ABORTQuote,NameABORTQuote,_FLINK
\r
850 $NAME 3,'ABS',ABSS,NameABSS,_FLINK
\r
851 $NAME 5,'ALLOT',ALLOT,NameALLOT,_FLINK
\r
852 $NAME IMMED+COMPO+5,'BEGIN',BEGIN,NameBEGIN,_FLINK
\r
853 $NAME 2,'C,',CComma,NameCComma,_FLINK
\r
854 $NAME 4,'CHAR',CHAR,NameCHAR,_FLINK
\r
855 $NAME IMMED+COMPO+2,'DO',DO,NameDO,_FLINK
\r
856 $NAME IMMED+COMPO+5,'DOES>',DOESGreater,NameDOESGreater,_FLINK
\r
857 $NAME IMMED+COMPO+4,'ELSE',ELSEE,NameELSEE,_FLINK
\r
858 $NAME 12,'ENVIRONMENT?',ENVIRONMENTQuery,NameENVIRONMENTQuery,_FLINK
\r
859 $NAME 8,'EVALUATE',EVALUATE,NameEVALUATE,_FLINK
\r
860 $NAME 4,'FILL',FILL,NameFILL,_FLINK
\r
861 $NAME 4,'FIND',FIND,NameFIND,_FLINK
\r
862 $NAME 9,'IMMEDIATE',IMMEDIATE,NameIMMEDIATE,_FLINK
\r
863 $NAME COMPO+1,'J',J,NameJ,_FLINK
\r
864 $NAME IMMED+COMPO+5,'LEAVE',LEAVEE,NameLEAVEE,_FLINK
\r
865 $NAME IMMED+COMPO+4,'LOOP',LOOPP,NameLOOPP,_FLINK
\r
866 $NAME 6,'LSHIFT',LSHIFT,NameLSHIFT,_FLINK
\r
867 $NAME 2,'M*',MStar,NameMStar,_FLINK
\r
868 $NAME 3,'MAX',MAX,NameMAX,_FLINK
\r
869 $NAME 3,'MIN',MIN,NameMIN,_FLINK
\r
870 $NAME 3,'MOD',MODD,NameMODD,_FLINK
\r
871 $NAME 4,'PICK',PICK,NamePICK,_FLINK
\r
872 $NAME IMMED+COMPO+8,'POSTPONE',POSTPONE,NamePOSTPONE,_FLINK
\r
873 $NAME IMMED+COMPO+7,'RECURSE',RECURSE,NameRECURSE,_FLINK
\r
874 $NAME IMMED+COMPO+6,'REPEAT',REPEATT,NameREPEAT,_FLINK
\r
875 $NAME 6,'RSHIFT',RSHIFT,NameRSHIFT,_FLINK
\r
876 $NAME IMMED+COMPO+8,'SLITERAL',SLITERAL,NameSLITERAL,_FLINK
\r
877 $NAME IMMED+COMPO+2,'S"',SQuote,NameSQuote,_FLINK
\r
878 $STR SQUOTstr1,'Use of S" in interpretation state is non-portable.'
\r
879 $STR SQUOTstr2,'Use instead CHAR " PARSE word" or BL PARSE word .'
\r
880 $NAME 6,'SM/REM',SMSlashREM,NameSMSlashREM,_FLINK
\r
881 $NAME 6,'SPACES',SPACES,NameSPACES,_FLINK
\r
882 $NAME IMMED+2,'TO',TO,NameTO,_FLINK
\r
883 $NAME 2,'U.',UDot,NameUDot,_FLINK
\r
884 $NAME IMMED+COMPO+5,'UNTIL',UNTIL,NameUNTIL,_FLINK
\r
885 $NAME 5,'VALUE',VALUE,NameVALUE,_FLINK
\r
886 $NAME 8,'VARIABLE',VARIABLE,NameVARIABLE,_FLINK
\r
887 $NAME IMMED+COMPO+5,'WHILE',WHILEE,NameWHILE,_FLINK
\r
888 $NAME 4,'WORD',WORDD,NameWORDD,_FLINK
\r
889 $NAME IMMED+COMPO+3,"[']",BracketTick,NameBracketTick,_FLINK
\r
890 $NAME IMMED+COMPO+6,'[CHAR]',BracketCHAR,NameBracketCHAR,_FLINK
\r
891 $NAME IMMED+1,'\',Backslash,NameBackslash,_FLINK
\r
892 $NAME 5,'EKEY?',EKEYQuestion,NameEKEYQuestion,_FLINK
\r
893 $NAME 5,'EMIT?',EMITQuestion,NameEMITQuestion,_FLINK
\r
895 LASTENV EQU _ENVLINK-0
\r
896 LASTSYSTEM EQU _SLINK-0 ;last SYSTEM word name address
\r
897 LASTFORTH EQU _FLINK-0 ;last FORTH word name address
\r
899 DTOP EQU $-0 ;next available memory in data space
\r
903 ;===============================================================
\r
905 CODE SEGMENT PARA PUBLIC 'CODES'
\r
907 ASSUME CS:CODE,DS:DATA,SS:DATA
\r
910 ; Main entry points and COLD start data
\r
913 XSysStatus DW Wake ;for multitasker
\r
914 XSysFollower DW XSysStatus ;for multitasker
\r
915 DW SysUserP ;for multitasker
\r
918 ADD DX,1000h ;64KB full segment
\r
919 MOV DS,DX ;new data segment
\r
920 CLI ;disable interrupts, old 808x CPU bug
\r
921 MOV SS,DX ;SS is same as DS
\r
922 MOV SP,OFFSET SPP ;initialize SP
\r
923 STI ;enable interrupts
\r
924 MOV BP,OFFSET RPP ;initialize RP
\r
925 CLD ;direction flag, increment
\r
926 XOR AX,AX ;MS-DOS only
\r
927 MOV CS:Redirect1stQ,AX ;MS-DOS only
\r
928 JMP COLD ;to high level cold start
\r
931 ; System dependent words -- Must be re-definded for each system.
\r
933 ; I/O words must be redefined if serial communication is used instead of
\r
934 ; keyboard. Following words are for MS-DOS system.
\r
937 ; Return true if key is pressed.
\r
941 MOV AH,0Bh ;get input status of STDIN
\r
948 ; Receive one keyboard event u.
\r
950 $CODE NameRXFetch,RXFetch
\r
953 MOV AH,08h ;MS-DOS Read Keyboard
\r
955 ADD BL,AL ;MOV BL,AL and OR AL,AL
\r
956 JNZ RXFET1 ;extended character code?
\r
962 ; Return true if output device is ready or device state is
\r
965 $CONST NameTXQ,TXQ,TRUEE ;always true for MS-DOS
\r
968 ; Send char to the output device.
\r
970 $CODE NameTXStore,TXStore
\r
971 MOV DX,BX ;char in DL
\r
972 MOV AH,02h ;MS-DOS Display output
\r
973 INT 021H ;display character
\r
978 ; Carriage return and linefeed.
\r
980 ; : CR carriage-return-char EMIT linefeed-char EMIT ;
\r
983 DW DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT
\r
985 ; BYE ( -- ) \ TOOLS EXT
\r
986 ; Return control to the host operation system, if any.
\r
989 MOV AX,04C00h ;close all files and
\r
990 INT 021h ; return to MS-DOS
\r
995 ; : hi CR ." hForth "
\r
996 ; S" CPU" ENVIRONMENT? DROP TYPE SPACE
\r
997 ; S" model" ENVIRONMENT? DROP TYPE SPACE [CHAR] v EMIT
\r
998 ; S" version" ENVIRONMENT? DROP TYPE
\r
999 ; ." by Wonyong Koh, 1997" CR
\r
1000 ; ." ALL noncommercial and commercial uses are granted." CR
\r
1001 ; ." Please send comment, bug report and suggestions to:" CR
\r
1002 ; ." wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr" CR ;
\r
1005 DW CR,DoLIT,HiStr1,COUNT,TYPEE
\r
1006 DW DoLIT,CPUQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE,SPACE
\r
1007 DW DoLIT,ModelQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE
\r
1008 DW SPACE,DoLIT,'v',EMIT
\r
1009 DW DoLIT,VersionQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE
\r
1010 DW DoLIT,HiStr2,COUNT,TYPEE,CR
\r
1011 DW DoLIT,HiStr3,COUNT,TYPEE,CR
\r
1012 DW DoLIT,HiStr4,COUNT,TYPEE,CR
\r
1013 DW DoLIT,HiStr5,COUNT,TYPEE,CR,EXIT
\r
1016 ; The cold start sequence execution word.
\r
1018 ; : COLD sp0 sp! rp0 rp! \ initialize stack
\r
1019 ; 'init-i/o EXECUTE
\r
1021 ; QUIT ; \ start interpretation
\r
1023 $COLON NameCOLD,COLD
\r
1024 DW SPZero,SPStore,RPZero,RPStore
\r
1025 DW TickINIT_IO,EXECUTE,TickBoot,EXECUTE
\r
1029 ; Set input/output device.
\r
1031 ; : set-i/o S" CON" stdin ; \ MS-DOS only
\r
1033 $COLON NameSet_IO,Set_IO
\r
1034 DW DoLIT,Set_IOstr ;MS-DOS only
\r
1035 DW COUNT,STDIN ;MS-DOS only
\r
1039 ; MS-DOS only words -- not necessary for other systems.
\r
1041 ; File input using MS-DOS redirection function without using FILE words.
\r
1043 ; redirect ( c-addr -- flag )
\r
1044 ; Redirect standard input from the device identified by ASCIIZ
\r
1045 ; string stored at c-addr. Return error code.
\r
1047 $CODE NameRedirect,Redirect
\r
1049 MOV AX,CS:Redirect1stQ
\r
1053 MOV BX,CS:RedirHandle
\r
1054 INT 021h ; close previously opend file
\r
1055 REDIRECT2: MOV AX,03D00h ; open file read-only
\r
1056 MOV CS:Redirect1stQ,AX ; set Redirect1stQ true
\r
1058 JC REDIRECT1 ; if error
\r
1059 MOV CS:RedirHandle,AX
\r
1066 REDIRECT1: MOV BX,AX
\r
1068 Redirect1stQ DW 0 ; true after the first redirection
\r
1069 RedirHandle DW ? ; redirect file handle
\r
1071 ; asciiz ( ca1 u -- ca2 )
\r
1072 ; Return ASCIIZ string.
\r
1074 ; : asciiz HERE SWAP 2DUP + 0 SWAP C! CHARS MOVE HERE ;
\r
1076 $COLON NameASCIIZ,ASCIIZ
\r
1077 DW HERE,SWAP,TwoDUP,Plus,DoLIT,0
\r
1078 DW SWAP,CStore,CHARS,MOVE,HERE,EXIT
\r
1080 ; stdin ( ca u -- )
\r
1082 ; : stdin asciiz redirect ?DUP
\r
1083 ; IF -38 THROW THEN \ non-existent file
\r
1086 $COLON NameSTDIN,STDIN
\r
1087 DW ASCIIZ,Redirect,QuestionDUP,ZBranch,STDIN1
\r
1088 DW DoLIT,-38,THROW
\r
1091 ; << ( "<spaces>ccc" -- )
\r
1092 ; Redirect input from the file 'ccc'. Should be used only in
\r
1093 ; interpretation state.
\r
1095 ; : << STATE @ IF ." Do not use '<<' in a definition." ABORT THEN
\r
1096 ; PARSE-WORD stdin SOURCE >IN ! DROP ; IMMEDIATE
\r
1098 $COLON NameFROM,FROM
\r
1099 DW DoLIT,AddrSTATE,Fetch,ZBranch,FROM1
\r
1102 DW COUNT,TYPEE,ABORT
\r
1103 FROM1 DW PARSE_WORD,STDIN,SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT
\r
1106 ; Non-Standard words - Processor-dependent definitions
\r
1107 ; 16 bit Forth for 8086/8
\r
1111 ; Stop current task and transfer control to the task of which
\r
1112 ; 'status' USER variable is stored in 'follower' USER variable
\r
1113 ; of current task.
\r
1115 ; : PAUSE rp@ DUP sp@ stackTop ! follower @ code@ >R ; COMPILE-ONLY
\r
1117 ; $COLON NamePAUSE,PAUSE
\r
1118 ; DW RPFetch,DUPP,SPFetch,StackTop,Store
\r
1119 ; DW Follower,Fetch,CodeFetch,ToR,EXIT
\r
1121 $CODE NamePAUSE,PAUSE
\r
1127 MOV BX,WORD PTR AddrUserP
\r
1128 StackTopOffset = SysStackTop - SysUserP
\r
1129 MOV [BX+StackTopOffset],SP
\r
1130 FollowerOffset = SysFollower - SysUserP
\r
1131 MOV BX,[BX+FollowerOffset]
\r
1136 ; Wake current task.
\r
1138 ; : wake R> CELL+ code@ userP ! \ userP points 'follower' of current task
\r
1139 ; stackTop @ sp! DROP \ set data stack
\r
1140 ; rp! ; COMPILE-ONLY \ set return stack
\r
1142 ; $COLON NameWake,Wake
\r
1143 ; DW RFrom,CELLPlus,CodeFetch,DoLIT,AddrUserP,Store
\r
1144 ; DW StackTop,Fetch,SPStore,DROP,RPStore,EXIT
\r
1146 $CODE NameWake,Wake
\r
1147 MOV BX,CS:[SI+CELLL]
\r
1148 MOV WORD PTR AddrUserP,BX
\r
1149 MOV SP,[BX+StackTopOffset]
\r
1157 ; same? ( c-addr1 c-addr2 u -- -1|0|1 )
\r
1158 ; Return 0 if two strings, ca1 u and ca2 u, are same; -1 if
\r
1159 ; string, ca1 u is smaller than ca2 u; 1 otherwise. Used by
\r
1160 ; '(search-wordlist)'. Code definition is preferred to speed up
\r
1161 ; interpretation. Colon definition is shown below.
\r
1163 ; : same? ?DUP IF \ null strings are always same
\r
1164 ; 0 DO OVER C@ OVER C@ XOR
\r
1165 ; IF UNLOOP C@ SWAP C@ > 2* 1+ EXIT THEN
\r
1166 ; CHAR+ SWAP CHAR+ SWAP
\r
1170 ; $COLON NameSameQ,SameQ
\r
1171 ; DW QuestionDUP,ZBranch,SAMEQ4
\r
1173 ; SAMEQ3 DW OVER,CFetch,OVER,CFetch,XORR,ZBranch,SAMEQ2
\r
1174 ; DW UNLOOP,CFetch,SWAP,CFetch,GreaterThan
\r
1175 ; DW TwoStar,OnePlus,EXIT
\r
1176 ; SAMEQ2 DW CHARPlus,SWAP,CHARPlus
\r
1177 ; DW DoLOOP,SAMEQ3
\r
1178 ; SAMEQ4 DW TwoDROP,DoLIT,0,EXIT
\r
1180 $CODE NameSameQ,SameQ
\r
1184 MOV DX,SI ;save SI
\r
1198 ; (search-wordlist) ( c-addr u wid -- 0 | xt f 1 | xt f -1)
\r
1199 ; Search word list for a match with the given name.
\r
1200 ; Return execution token and not-compile-only flag and
\r
1201 ; -1 or 1 ( IMMEDIATE) if found. Return 0 if not found.
\r
1203 ; format is: wid---->[ a ]
\r
1206 ; [ xt' ][ a' ][ccbbaann][ggffeedd]...
\r
1210 ; [ xt'' ][ a'' ][ccbbaann][ggffeedd]...
\r
1212 ; a, a' etc. point to the cell that contains the name of the
\r
1213 ; word. The length is in the low byte of the cell (little byte
\r
1214 ; for little-endian, big byte for big-endian).
\r
1215 ; Eventually, a''' contains 0 to indicate the end of the wordlist
\r
1216 ; (oldest entry). a=0 indicates an empty wordlist.
\r
1217 ; xt is the xt of the word. aabbccddeedd etc. is the name of
\r
1218 ; the word, packed into cells.
\r
1220 ; : (search-wordlist)
\r
1221 ; ROT >R SWAP DUP 0= IF -16 THROW THEN
\r
1222 ; \ attempt to use zero-length string as a name
\r
1223 ; >R \ wid R: ca1 u
\r
1224 ; BEGIN @ \ ca2 R: ca1 u
\r
1225 ; DUP 0= IF R> R> 2DROP EXIT THEN \ not found
\r
1226 ; DUP COUNT [ =MASK ] LITERAL AND R@ = \ ca2 ca2+char f
\r
1227 ; IF R> R@ SWAP DUP >R \ ca2 ca2+char ca1 u
\r
1228 ; same? \ ca2 flag
\r
1229 ; \ ELSE DROP -1 \ unnecessary since ca2+char is not 0.
\r
1231 ; WHILE cell- \ pointer to next word in wordlist
\r
1233 ; R> R> 2DROP DUP name>xt SWAP \ xt ca2
\r
1234 ; C@ 2DUP [ =seman ] LITERAL AND 0= 0= \ xt char xt f
\r
1235 ; AND TO specialComp?
\r
1236 ; DUP [ =compo ] LITERAL AND 0= SWAP
\r
1237 ; [ =immed ] LITERAL AND 0= 2* 1+ ;
\r
1239 ; $COLON NameParenSearch_Wordlist,ParenSearch_Wordlist
\r
1240 ; DW ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6
\r
1243 ; DW DUPP,ZBranch,PSRCH9
\r
1244 ; DW DUPP,COUNT,DoLIT,MASKK,ANDD,RFetch,Equals
\r
1245 ; DW ZBranch,PSRCH5
\r
1246 ; DW RFrom,RFetch,SWAP,DUPP,ToR,SameQ
\r
1247 ; PSRCH5 DW ZBranch,PSRCH3
\r
1248 ; DW CellMinus,Branch,PSRCH1
\r
1249 ; PSRCH3 DW RFrom,RFrom,TwoDROP,DUPP,NameToXT,SWAP
\r
1250 ; DW CFetch,TwoDUP,DoLIT,SEMAN,ANDD,ZeroEquals,ZeroEquals
\r
1251 ; DW ANDD,DoTO,AddrSpecialCompQ
\r
1252 ; DW DUPP,DoLIT,COMPO,ANDD,ZeroEquals,SWAP
\r
1253 ; DW DoLIT,IMMED,ANDD,ZeroEquals,TwoStar,OnePlus,EXIT
\r
1254 ; PSRCH9 DW RFrom,RFrom,TwoDROP,EXIT
\r
1255 ; PSRCH6 DW DoLIT,-16,THROW
\r
1257 $CODE NameParenSearch_Wordlist,ParenSearch_Wordlist
\r
1266 PSRCH2: MOV BX,[BX]
\r
1268 JZ PSRCH4 ; end of wordlist?
\r
1270 SUB BX,CELLL ;pointer to nextword
\r
1271 AND CL,MASKK ;max name length = MASKK
\r
1276 ADD DI,CELLL+CHARR
\r
1280 PUSH [BX-CELLL] ;xt
\r
1283 AND AL,CL ;test SEMAN = 080h
\r
1287 MOV AddrSpecialCompQ,DX
\r
1298 PSRCH1: MOV BX,-16 ;attempt to use zero-length string as a name
\r
1303 ; ?call ( xt1 -- xt1 0 | code-addr xt2 )
\r
1304 ; Return xt of the CALLed run-time word if xt starts with machine
\r
1305 ; CALL instruction and leaves the next cell address after the
\r
1306 ; CALL instruction. Otherwise leaves the original xt1 and zero.
\r
1308 ; : ?call DUP code@ call-code =
\r
1309 ; IF CELL+ DUP code@ SWAP CELL+ DUP ROT + EXIT THEN
\r
1310 ; \ Direct Threaded Code 8086 relative call
\r
1313 ; $COLON NameQCall,QCall
\r
1314 ; DW DUPP,CodeFetch,DoLIT,CALLL,Equals,ZBranch,QCALL1
\r
1315 ; DW CELLPlus,DUPP,CodeFetch,SWAP,CELLPlus,DUPP,ROT,Plus
\r
1317 ; QCALL1 DW DoLIT,0,EXIT
\r
1319 $CODE NameQCall,QCall
\r
1326 QCALL1: ADD BX,2*CELLL
\r
1328 ADD BX,CS:[BX-CELLL]
\r
1331 ; xt, ( xt1 -- xt2 )
\r
1332 ; Take a run-time word xt1 for :NONAME , CONSTANT , VARIABLE and
\r
1333 ; CREATE . Return xt2 of current definition.
\r
1335 ; : xt, xhere ALIGNED DUP TO xhere SWAP
\r
1336 ; call-code code, \ Direct Threaded Code
\r
1337 ; xhere CELL+ - code, ; \ 8086 relative call
\r
1339 ; $COLON NamextComma,xtComma
\r
1340 ; DW XHere,ALIGNED,DUPP,DoTO,AddrXHere,SWAP
\r
1341 ; DW DoLIT,CALLL,CodeComma
\r
1342 ; DW XHere,CELLPlus,Minus,CodeComma,EXIT
\r
1344 $CODE NamextComma,xtComma
\r
1349 MOV WORD PTR CS:[BX],CALLL
\r
1354 MOV CS:[BX+CELLL],AX
\r
1358 ; Push an inline literal. The inline literal is at the current
\r
1359 ; value of the fpc, so put it onto the stack and point past it.
\r
1361 $CODE NameDoLIT,DoLIT
\r
1363 LODS WORD PTR CS:[SI]
\r
1367 ; doCONST ( -- x )
\r
1368 ; Run-time routine of CONSTANT and initializable system
\r
1369 ; VARIABLE. When you quote a constant or variable you execute
\r
1370 ; its code, which consists of a call to here, followed by an
\r
1371 ; inline literal. The literal is a constant (for a CONSTANT) or
\r
1372 ; the address at which a VARIABLE's value is stored. Although
\r
1373 ; you come here as the result of a native machine call, you
\r
1374 ; never go back to the return address -- you jump back up a
\r
1375 ; level by continuing at the new fpc value. For 8086, Z80 the
\r
1376 ; inline literal is at the return address stored on the top of
\r
1377 ; the hardware stack.
\r
1379 $CODE NameDoCONST,DoCONST
\r
1385 ; doVALUE ( -- x )
\r
1386 ; Run-time routine of VALUE. Return the value of VALUE word.
\r
1387 ; This is like an invocation of doCONST for a VARIABLE but
\r
1388 ; instead of returning the address of the variable, we return
\r
1389 ; the value of the variable -- in other words, there is another
\r
1390 ; level of indirection.
\r
1392 $CODE NameDoVALUE,DoVALUE
\r
1399 ; doCREATE ( -- a-addr )
\r
1400 ; Run-time routine of CREATE. For CREATEd words with an
\r
1401 ; associated DOES>, get the address of the CREATEd word's data
\r
1402 ; space and execute the DOES> actions. For CREATEd word without
\r
1403 ; an associated DOES>, return the address of the CREATE'd word's
\r
1404 ; data space. A CREATEd word starts its execution through this
\r
1405 ; routine in exactly the same way as a colon definition uses
\r
1406 ; doLIST. In other words, we come here through a native machine
\r
1409 ; Structure of CREATEd word:
\r
1410 ; | call-doCREATE | 0 or DOES> code addr | a-addr |
\r
1412 ; The DOES> address holds a native call to doLIST. This routine
\r
1413 ; doesn't alter the fpc. We never come back *here* so we never
\r
1414 ; need to preserve an address that would bring us back *here*.
\r
1416 ; Example : myVARIABLE CREATE , DOES> ;
\r
1417 ; 56 myVARIABLE JIM
\r
1418 ; JIM \ stacks the address of the data cell that contains 56
\r
1420 ; : doCREATE SWAP \ switch BX and top of 8086 stack item
\r
1421 ; DUP CELL+ code@ SWAP code@ ?DUP IF EXECUTE THEN
\r
1424 ; $COLON NameDoCREATE,DoCREATE
\r
1425 ; DW SWAP,CELLPlus,DUPP,CodeFetch,SWAP,CodeFetch
\r
1426 ; DW QuestionDUP,ZBranch,DOCREAT1
\r
1428 ; DOCREAT1 DW EXIT
\r
1430 $CODE NameDoCREATE,DoCREATE
\r
1434 MOV BX,CS:[BX+CELLL]
\r
1442 ; Run-time routine of TO. Store x at the address in the
\r
1443 ; following cell. The inline literal holds the address
\r
1446 $CODE NameDoTO,DoTO
\r
1447 LODS WORD PTR CS:[SI]
\r
1453 ; doUSER ( -- a-addr )
\r
1454 ; Run-time routine of USER. Return address of data space.
\r
1455 ; This is like doCONST but a variable offset is added to the
\r
1456 ; result. By changing the value at AddrUserP (which happens
\r
1457 ; on a taskswap) the whole set of user variables is switched
\r
1458 ; to the set for the new task.
\r
1460 $CODE NameDoUSER,DoUSER
\r
1467 ; doLIST ( -- ) ( R: -- nest-sys )
\r
1468 ; Process colon list.
\r
1469 ; The first word of a definition (the xt for the word) is a
\r
1470 ; native machine-code instruction for the target machine. For
\r
1471 ; high-level definitions, that code is emitted by xt, and
\r
1472 ; performs a call to doLIST. doLIST executes the list of xt that
\r
1473 ; make up the definition. The final xt in the definition is EXIT.
\r
1474 ; The address of the first xt to be executed is passed to doLIST
\r
1475 ; in a target-specific way. Two examples:
\r
1476 ; Z80, 8086: native machine call, leaves the return address on
\r
1477 ; the hardware stack pointer, which is used for the data stack.
\r
1479 $CODE NameDoLIST,DoLIST
\r
1481 MOV [BP],SI ;push return stack
\r
1482 POP SI ;new list address
\r
1485 ; doLOOP ( -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
1486 ; Run time routine for LOOP.
\r
1488 $CODE NameDoLOOP,DoLOOP
\r
1489 INC WORD PTR [BP] ;increase loop count
\r
1490 JO DoLOOP1 ;?loop end
\r
1491 MOV SI,CS:[SI] ;no, go back
\r
1493 DoLOOP1: ADD SI,CELLL ;yes, continue past the branch offset
\r
1494 ADD BP,2*CELLL ;clear return stack
\r
1497 ; do+LOOP ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
1498 ; Run time routine for +LOOP.
\r
1500 $CODE NameDoPLOOP,DoPLOOP
\r
1501 ADD WORD PTR [BP],BX ;increase loop count
\r
1502 JO DoPLOOP1 ;?loop end
\r
1503 MOV SI,CS:[SI] ;no, go back
\r
1506 DoPLOOP1: ADD SI,CELLL ;yes, continue past the branch offset
\r
1507 ADD BP,2*CELLL ;clear return stack
\r
1511 ; 0branch ( flag -- )
\r
1512 ; Branch if flag is zero.
\r
1514 $CODE NameZBranch,ZBranch
\r
1516 JZ ZBRAN1 ;yes, so branch
\r
1517 ADD SI,CELLL ;point IP to next cell
\r
1520 ZBRAN1: MOV SI,CS:[SI] ;IP:=(IP)
\r
1525 ; Branch to an inline address.
\r
1527 $CODE NameBranch,Branch
\r
1528 MOV SI,CS:[SI] ;IP:=(IP)
\r
1531 ; rp@ ( -- a-addr )
\r
1532 ; Push the current RP to the data stack.
\r
1534 $CODE NameRPFetch,RPFetch
\r
1539 ; rp! ( a-addr -- )
\r
1540 ; Set the return stack pointer.
\r
1542 $CODE NameRPStore,RPStore
\r
1547 ; sp@ ( -- a-addr )
\r
1548 ; Push the current data stack pointer.
\r
1550 $CODE NameSPFetch,SPFetch
\r
1555 ; sp! ( a-addr -- )
\r
1556 ; Set the data stack pointer.
\r
1558 $CODE NameSPStore,SPStore
\r
1563 ; um+ ( u1 u2 -- u3 1|0 )
\r
1564 ; Add two unsigned numbers, return the sum and carry.
\r
1566 $CODE NameUMPlus,UMPlus
\r
1571 RCL CX,1 ;get carry
\r
1575 ; code! ( x code-addr -- )
\r
1576 ; Store x at a code space address.
\r
1578 $CODE NameCodeStore,CodeStore
\r
1583 ; codeB! ( b code-addr -- )
\r
1584 ; Store byte at a code space address.
\r
1586 $CODE NameCodeBStore,CodeBStore
\r
1592 ; code@ ( code-addr -- x )
\r
1593 ; Push the contents at code space addr to the data stack.
\r
1595 $CODE NameCodeFetch,CodeFetch
\r
1599 ; codeB@ ( code-addr -- b )
\r
1600 ; Push the contents at code space byte addr to the data stack.
\r
1602 $CODE NameCodeBFetch,CodeBFetch
\r
1608 ; Reserve one cell in code space and store x in it.
\r
1610 ; : code, xhere DUP CELL+ TO xhere code! ; COMPILE-ONLY
\r
1612 ; $COLON NameCodeComma,CodeComma
\r
1613 ; DW XHere,DUPP,CELLPlus,DoTO,AddrXHere,CodeStore,EXIT
\r
1615 $CODE NameCodeComma,CodeComma
\r
1624 ; Standard words - Processor-dependent definitions
\r
1625 ; 16 bit Forth for 8086/8
\r
1628 ; ALIGN ( -- ) \ CORE
\r
1629 ; Align the data space pointer.
\r
1631 ; : ALIGN HERE ALIGNED TO HERE ;
\r
1633 $COLON NameALIGNN,ALIGNN
\r
1634 DW HERE,ALIGNED,DoTO,AddrHERE,EXIT
\r
1636 ; ALIGNED ( addr -- a-addr ) \ CORE
\r
1637 ; Align address to the cell boundary.
\r
1639 ; : ALIGNED DUP 0 cell-size UM/MOD DROP DUP
\r
1640 ; IF cell-size SWAP - THEN + ;
\r
1642 ; $COLON NameALIGNED,ALIGNED
\r
1643 ; DW DUPP,DoLIT,0,DoLIT,CELLL
\r
1644 ; DW UMSlashMOD,DROP,DUPP
\r
1645 ; DW ZBranch,ALGN1
\r
1646 ; DW DoLIT,CELLL,SWAP,Minus
\r
1647 ; ALGN1 DW Plus,EXIT
\r
1649 $CODE NameALIGNED,ALIGNED
\r
1654 ; CELLS ( n1 -- n2 ) \ CORE
\r
1655 ; Calculate number of address units for n1 cells.
\r
1657 ; : CELLS cell-size * ; \ slow, very portable
\r
1658 ; : CELLS 2* ; \ fast, must be redefined for each system
\r
1660 ; $COLON NameCELLS,CELLS
\r
1663 $CODE NameCELLS,CELLS
\r
1667 ; CHARS ( n1 -- n2 ) \ CORE
\r
1668 ; Calculate number of address units for n1 characters.
\r
1670 ; : CHARS char-size * ; \ slow, very portable
\r
1671 ; : CHARS ; \ fast, must be redefined for each system
\r
1673 $COLON NameCHARS,CHARS
\r
1676 ; 1chars/ ( n1 -- n2 )
\r
1677 ; Calculate number of chars for n1 address units.
\r
1679 ; : 1chars/ 1 CHARS / ; \ slow, very portable
\r
1680 ; : 1chars/ ; \ fast, must be redefined for each system
\r
1682 $COLON NameOneCharsSlash,OneCharsSlash
\r
1685 ; ! ( x a-addr -- ) \ CORE
\r
1686 ; Store x at a aligned address.
\r
1688 $CODE NameStore,Store
\r
1693 ; 0< ( n -- flag ) \ CORE
\r
1694 ; Return true if n is negative.
\r
1696 $CODE NameZeroLess,ZeroLess
\r
1702 ; 0= ( x -- flag ) \ CORE
\r
1703 ; Return true if x is zero.
\r
1705 $CODE NameZeroEquals,ZeroEquals
\r
1712 ; 2* ( x1 -- x2 ) \ CORE
\r
1713 ; Bit-shift left, filling the least significant bit with 0.
\r
1715 $CODE NameTwoStar,TwoStar
\r
1719 ; 2/ ( x1 -- x2 ) \ CORE
\r
1720 ; Bit-shift right, leaving the most significant bit unchanged.
\r
1722 $CODE NameTwoSlash,TwoSlash
\r
1726 ; >R ( x -- ) ( R: -- x ) \ CORE
\r
1727 ; Move top of the data stack item to the return stack.
\r
1730 SUB BP,CELLL ;adjust RP
\r
1735 ; @ ( a-addr -- x ) \ CORE
\r
1736 ; Push the contents at a-addr to the data stack.
\r
1738 $CODE NameFetch,Fetch
\r
1742 ; AND ( x1 x2 -- x3 ) \ CORE
\r
1745 $CODE NameANDD,ANDD
\r
1750 ; C! ( char c-addr -- ) \ CORE
\r
1751 ; Store char at c-addr.
\r
1753 $CODE NameCStore,CStore
\r
1759 ; C@ ( c-addr -- char ) \ CORE
\r
1760 ; Fetch the character stored at c-addr.
\r
1762 $CODE NameCFetch,CFetch
\r
1767 ; DROP ( x -- ) \ CORE
\r
1768 ; Discard top stack item.
\r
1770 $CODE NameDROP,DROP
\r
1774 ; DUP ( x -- x x ) \ CORE
\r
1775 ; Duplicate the top stack item.
\r
1777 $CODE NameDUPP,DUPP
\r
1781 ; EXECUTE ( i*x xt -- j*x ) \ CORE
\r
1782 ; Perform the semantics indentified by execution token, xt.
\r
1784 $CODE NameEXECUTE,EXECUTE
\r
1787 JMP AX ;jump to the code address
\r
1790 ; EXIT ( -- ) ( R: nest-sys -- ) \ CORE
\r
1791 ; Return control to the calling definition.
\r
1793 $CODE NameEXIT,EXIT
\r
1794 XCHG BP,SP ;exchange pointers
\r
1795 POP SI ;pop return stack
\r
1796 XCHG BP,SP ;restore the pointers
\r
1799 ; MOVE ( addr1 addr2 u -- ) \ CORE
\r
1800 ; Copy u address units from addr1 to addr2 if u is greater
\r
1801 ; than zero. This word is CODE defined since no other Standard
\r
1802 ; words can handle address unit directly.
\r
1804 $CODE NameMOVE,MOVE
\r
1810 XCHG DX,SI ;save SI
\r
1812 MOV ES,AX ;set ES same as DS
\r
1830 ; OR ( x1 x2 -- x3 ) \ CORE
\r
1831 ; Return bitwise inclusive-or of x1 with x2.
\r
1838 ; OVER ( x1 x2 -- x1 x2 x1 ) \ CORE
\r
1839 ; Copy second stack item to top of the stack.
\r
1841 $CODE NameOVER,OVER
\r
1847 ; R> ( -- x ) ( R: x -- ) \ CORE
\r
1848 ; Move x from the return stack to the data stack.
\r
1850 $CODE NameRFrom,RFrom
\r
1853 ADD BP,CELLL ;adjust RP
\r
1856 ; R@ ( -- x ) ( R: x -- x ) \ CORE
\r
1857 ; Copy top of return stack to the data stack.
\r
1859 $CODE NameRFetch,RFetch
\r
1864 ; SWAP ( x1 x2 -- x2 x1 ) \ CORE
\r
1865 ; Exchange top two stack items.
\r
1867 $CODE NameSWAP,SWAP
\r
1872 ; XOR ( x1 x2 -- x3 ) \ CORE
\r
1873 ; Bitwise exclusive OR.
\r
1875 $CODE NameXORR,XORR
\r
1881 ; System constants and variables
\r
1884 ; #order0 ( -- a-addr )
\r
1885 ; Start address of default search order.
\r
1887 $CONST NameNumberOrder0,NumberOrder0,AddrNumberOrder0
\r
1889 ; 'ekey? ( -- a-addr )
\r
1890 ; Execution vector of EKEY?.
\r
1892 $VALUE NameTickEKEYQ,TickEKEYQ,AddrTickEKEYQ
\r
1894 ; 'ekey ( -- a-addr )
\r
1895 ; Execution vector of EKEY.
\r
1897 $VALUE NameTickEKEY,TickEKEY,AddrTickEKEY
\r
1899 ; 'emit? ( -- a-addr )
\r
1900 ; Execution vector of EMIT?.
\r
1902 $VALUE NameTickEMITQ,TickEMITQ,AddrTickEMITQ
\r
1904 ; 'emit ( -- a-addr )
\r
1905 ; Execution vector of EMIT.
\r
1907 $VALUE NameTickEMIT,TickEMIT,AddrTickEMIT
\r
1909 ; 'init-i/o ( -- a-addr )
\r
1910 ; Execution vector to initialize input/output devices.
\r
1912 $VALUE NameTickINIT_IO,TickINIT_IO,AddrTickINIT_IO
\r
1914 ; 'prompt ( -- a-addr )
\r
1915 ; Execution vector of '.prompt'.
\r
1917 $VALUE NameTickPrompt,TickPrompt,AddrTickPrompt
\r
1919 ; 'boot ( -- a-addr )
\r
1920 ; Execution vector of COLD.
\r
1922 $VALUE NameTickBoot,TickBoot,AddrTickBoot
\r
1924 ; SOURCE-ID ( -- 0 | -1 ) \ CORE EXT
\r
1925 ; Identify the input source. -1 for string (via EVALUATE) and
\r
1926 ; 0 for user input device.
\r
1928 $VALUE NameSOURCE_ID,SOURCE_ID,AddrSOURCE_ID
\r
1930 ; HERE ( -- addr ) \ CORE
\r
1931 ; Return data space pointer.
\r
1933 $VALUE NameHERE,HERE,AddrHERE
\r
1935 ; xhere ( -- code-addr )
\r
1936 ; Return next available code space address.
\r
1938 $VALUE NameXHere,XHere,AddrXHere
\r
1940 ; 'doWord ( -- a-addr )
\r
1941 ; Execution vectors for 'interpret'.
\r
1943 $CONST NameTickDoWord,TickDoWord,AddrTickDoWord
\r
1945 ; BASE ( -- a-addr ) \ CORE
\r
1946 ; Return the address of the radix base for numeric I/O.
\r
1948 $CONST NameBASE,BASE,AddrBASE
\r
1950 ; THROWMsgTbl ( -- a-addr ) \ CORE
\r
1951 ; Return the address of the THROW message table.
\r
1953 $CONST NameTHROWMsgTbl,THROWMsgTbl,AddrTHROWMsgTbl
\r
1955 ; memTop ( -- a-addr )
\r
1956 ; Top of free memory.
\r
1958 $VALUE NameMemTop,MemTop,AddrMemTop
\r
1961 ; Return the depth of control-flow stack.
\r
1963 $VALUE NameBal,Bal,AddrBal
\r
1965 ; notNONAME? ( -- f )
\r
1966 ; Used by ';' whether to do 'linkLast' or not
\r
1968 $VALUE NameNotNONAMEQ,NotNONAMEQ,AddrNotNONAMEQ
\r
1970 ; rakeVar ( -- a-addr )
\r
1971 ; Used by 'rake' to gather LEAVE.
\r
1973 $CONST NameRakeVar,RakeVar,AddrRakeVar
\r
1975 ; #order ( -- a-addr )
\r
1976 ; Hold the search order stack depth.
\r
1978 $CONST NameNumberOrder,NumberOrder,AddrNumberOrder
\r
1980 ; current ( -- a-addr )
\r
1981 ; Point to the wordlist to be extended.
\r
1983 $CONST NameCurrent,Current,AddrCurrent
\r
1985 ; FORTH-WORDLIST ( -- wid ) \ SEARCH
\r
1986 ; Return wid of Forth wordlist.
\r
1988 $CONST NameFORTH_WORDLIST,FORTH_WORDLIST,AddrFORTH_WORDLIST
\r
1990 ; NONSTANDARD-WORDLIST ( -- wid )
\r
1991 ; Return wid of non-standard wordlist.
\r
1993 $CONST NameNONSTANDARD_WORDLIST,NONSTANDARD_WORDLIST,AddrNONSTANDARD_WORDLIST
\r
1995 ; envQList ( -- wid )
\r
1996 ; Return wid of ENVIRONMENT? string list. Never put this wid in
\r
1997 ; search-order. It should be used only by SET-CURRENT to add new
\r
1998 ; environment query string after addition of a complete wordset.
\r
2000 $CONST NameEnvQList,EnvQList,AddrEnvQList
\r
2002 ; userP ( -- a-addr )
\r
2003 ; Return address of USER variable area of current task.
\r
2005 $CONST NameUserP,UserP,AddrUserP
\r
2007 ; SystemTask ( -- a-addr )
\r
2008 ; Return system task's tid.
\r
2010 $CONST NameSystemTask,SystemTask,SysTask
\r
2012 ; follower ( -- a-addr )
\r
2013 ; Point next task's 'status' USER variable.
\r
2015 $USER NameFollower,Follower,SysFollower-SysUserP
\r
2017 ; status ( -- a-addr )
\r
2018 ; Status of current task. Point 'pass' or 'wake'.
\r
2020 $USER NameStatus,Status,SysStatus-SysUserP
\r
2022 ; stackTop ( -- a-addr )
\r
2023 ; Store current task's top of stack position.
\r
2025 $USER NameStackTop,StackTop,SysStackTop-SysUserP
\r
2027 ; throwFrame ( -- a-addr )
\r
2028 ; THROW frame for CATCH and THROW need to be saved for eack task.
\r
2030 $USER NameThrowFrame,ThrowFrame,SysThrowFrame-SysUserP
\r
2032 ; taskName ( -- a-addr )
\r
2033 ; Current task's task ID.
\r
2035 $USER NameTaskName,TaskName,SysTaskName-SysUserP
\r
2037 ; user1 ( -- a-addr )
\r
2038 ; One free USER variable for each task.
\r
2040 $USER NameUser1,User1,SysUser1-SysUserP
\r
2042 ; ENVIRONMENT? strings can be searched using SEARCH-WORDLIST and can be
\r
2043 ; EXECUTEd. This wordlist is completely hidden to Forth system except
\r
2049 DW DoLIT,CPUStr,COUNT,EXIT
\r
2054 DW DoLIT,ModelStr,COUNT,EXIT
\r
2059 DW DoLIT,VersionStr,COUNT,EXIT
\r
2061 SlashCOUNTED_STRING:
\r
2076 ADDRESS_UNIT_BITS:
\r
2094 DW MaxChar ;max value of character set
\r
2099 DW DoLIT,MaxUnsigned,DoLIT,MaxSigned,EXIT
\r
2114 DW MAX_U,MAX_U,EXIT
\r
2116 RETURN_STACK_CELLS:
\r
2142 ; Non-Standard words - Colon definitions
\r
2145 ; (') ( "<spaces>name" -- xt 1 | xt -1 )
\r
2146 ; Parse a name, find it and return execution token and
\r
2147 ; -1 or 1 ( IMMEDIATE) if found
\r
2149 ; : (') PARSE-WORD search-word ?DUP IF NIP EXIT THEN
\r
2150 ; errWord 2! \ if not found error
\r
2151 ; -13 THROW ; \ undefined word
\r
2153 $COLON NameParenTick,ParenTick
\r
2154 DW PARSE_WORD,Search_word,QuestionDUP,ZBranch,PTICK1
\r
2156 PTICK1 DW DoLIT,AddrErrWord,TwoStore,DoLIT,-13,THROW
\r
2158 ; (d.) ( d -- c-addr u )
\r
2159 ; Convert a double number to a string.
\r
2161 ; : (d.) SWAP OVER DUP 0< IF DNEGATE THEN
\r
2162 ; <# #S ROT SIGN #> ;
\r
2164 $COLON NameParenDDot,ParenDDot
\r
2165 DW SWAP,OVER,DUPP,ZeroLess,ZBranch,PARDD1
\r
2167 PARDD1 DW LessNumberSign,NumberSignS,ROT
\r
2168 DW SIGN,NumberSignGreater,EXIT
\r
2175 $COLON NameDotOK,DotOK
\r
2177 DW COUNT,TYPEE,EXIT
\r
2180 ; Disply Forth prompt. This word is vectored.
\r
2182 ; : .prompt 'prompt EXECUTE ;
\r
2184 $COLON NameDotOK,DotPrompt
\r
2185 DW TickPrompt,EXECUTE,EXIT
\r
2190 $CONST NameZero,Zero,0
\r
2195 $CONST NameOne,One,1
\r
2200 $CONST NameMinusOne,MinusOne,-1
\r
2202 ; abort"msg ( -- a-addr )
\r
2203 ; Abort" error message string address.
\r
2205 $CONST NameAbortQMsg,AbortQMsg,AddrAbortQMsg
\r
2208 ; Increase bal by 1.
\r
2210 ; : bal+ bal 1+ TO bal ;
\r
2212 ; $COLON 4,'bal+',BalPlus,_SLINK
\r
2213 ; DW Bal,OnePlus,DoTO,AddrBal,EXIT
\r
2215 $CODE NameBalPlus,BalPlus
\r
2220 ; Decrease bal by 1.
\r
2222 ; : bal- bal 1- TO bal ;
\r
2224 ; $COLON NameBalMinus,BalMinus
\r
2225 ; DW Bal,OneMinus,DoTO,AddrBal,EXIT
\r
2227 $CODE NameBalMinus,BalMinus
\r
2231 ; cell- ( a-addr1 -- a-addr2 )
\r
2232 ; Return previous aligned cell address.
\r
2234 ; : cell- [ cell-size NEGATE ] LITERAL + ;
\r
2236 ; $COLON NameCellMinus,CellMinus
\r
2237 ; DW DoLIT,0-CELLL,Plus,EXIT
\r
2239 $CODE NameCellMinus,CellMinus
\r
2243 ; COMPILE-ONLY ( -- )
\r
2244 ; Make the most recent definition an compile-only word.
\r
2246 ; : COMPILE-ONLY lastName [ =compo ] LITERAL OVER @ OR SWAP ! ;
\r
2248 $COLON NameCOMPILE_ONLY,COMPILE_ONLY
\r
2249 DW LastName,DoLIT,COMPO,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
2251 ; doDO ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )
\r
2252 ; Run-time funtion of DO.
\r
2254 ; : doDO >R max-negative + R> OVER - SWAP R> SWAP >R SWAP >R >R ;
\r
2256 ; $COLON NameDoDO,DoDO
\r
2257 ; DW ToR,DoLIT,MaxNegative,Plus,RFrom
\r
2258 ; DW OVER,Minus,SWAP,RFrom,SWAP,ToR,SWAP,ToR,ToR,EXIT
\r
2260 $CODE NameDoDO,DoDO
\r
2263 ADD AX,MaxNegative
\r
2270 ; errWord ( -- a-addr )
\r
2271 ; Last found word. To be used to display the word causing error.
\r
2273 $CONST NameErrWord,ErrWord,AddrErrWord
\r
2275 ; head, ( xt "<spaces>name" -- )
\r
2276 ; Parse a word and build a dictionary entry.
\r
2278 ; : head, >R PARSE-WORD DUP 0=
\r
2279 ; IF errWord 2! -16 THROW THEN
\r
2280 ; \ attempt to use zero-length string as a name
\r
2281 ; DUP =mask > IF -19 THROW THEN \ definition name too long
\r
2282 ; 2DUP GET-CURRENT SEARCH-WORDLIST \ name exist?
\r
2283 ; IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined
\r
2284 ; ALIGN R@ , \ align and store xt
\r
2285 ; GET-CURRENT @ , \ build wordlist link
\r
2286 ; HERE DUP >R pack" ALIGNED TO HERE \ pack the name in name space
\r
2287 ; R> DUP R> cell- code! \ store name addr in code space
\r
2290 $COLON NameHeadComma,HeadComma
\r
2291 DW ToR,PARSE_WORD,DUPP,ZBranch,HEADC1
\r
2292 DW DUPP,DoLIT,MASKK,GreaterThan,ZBranch,HEADC3
\r
2293 DW DoLIT,-19,THROW
\r
2294 HEADC3 DW TwoDUP,GET_CURRENT,SEARCH_WORDLIST,ZBranch,HEADC2
\r
2297 DW COUNT,TYPEE,TwoDUP,TYPEE,SPACE
\r
2298 HEADC2 DW ALIGNN,RFetch,Comma
\r
2299 DW GET_CURRENT,Fetch,Comma
\r
2300 DW HERE,DUPP,ToR,PackQuote,ALIGNED,DoTO,AddrHERE
\r
2301 DW RFrom,DUPP,RFrom,CellMinus,CodeStore
\r
2302 DW DoTO,AddrLastName,EXIT
\r
2303 HEADC1 DW DoLIT,AddrErrWord,TwoStore,DoLIT,-16,THROW
\r
2305 ; hld ( -- a-addr )
\r
2306 ; Hold a pointer in building a numeric output string.
\r
2308 $CONST NameHLD,HLD,AddrHLD
\r
2310 ; interpret ( i*x -- j*x )
\r
2311 ; Intrepret input string.
\r
2313 ; : interpret BEGIN DEPTH 0< IF -4 THROW THEN \ stack underflow
\r
2315 ; WHILE 2DUP errWord 2!
\r
2316 ; search-word \ ca u 0 | xt f -1 | xt f 1
\r
2318 ; SWAP STATE @ OR 0= \ compile-only in interpretation
\r
2319 ; IF -14 THROW THEN \ interpreting a compile-only word
\r
2321 ; 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE
\r
2324 $COLON NameInterpret,Interpret
\r
2325 INTERP1 DW DEPTH,ZeroLess,ZBranch,INTERP2
\r
2327 INTERP2 DW PARSE_WORD,DUPP,ZBranch,INTERP3
\r
2328 DW TwoDUP,DoLIT,AddrErrWord,TwoStore
\r
2329 DW Search_word,DUPP,ZBranch,INTERP5
\r
2330 DW SWAP,DoLIT,AddrSTATE,Fetch,ORR,ZBranch,INTERP4
\r
2331 INTERP5 DW OnePlus,TwoStar,DoLIT,AddrSTATE,Fetch,OnePlus,Plus,CELLS
\r
2332 DW DoLIT,AddrTickDoWord,Plus,Fetch,EXECUTE
\r
2334 INTERP3 DW TwoDROP,EXIT
\r
2335 INTERP4 DW DoLIT,-14,THROW
\r
2337 ; optiCOMPILE, ( xt -- )
\r
2338 ; Optimized COMPILE, . Reduce doLIST ... EXIT sequence if
\r
2339 ; xt is COLON definition which contains less than two words.
\r
2342 ; DUP ?call ['] doLIST = IF
\r
2343 ; DUP code@ ['] EXIT = IF \ if first word is EXIT
\r
2345 ; DUP CELL+ code@ ['] EXIT = IF \ if second word is EXIT
\r
2346 ; code@ DUP ['] doLIT XOR \ make sure it is not literal
\r
2347 ; IF SWAP THEN THEN
\r
2348 ; THEN THEN DROP COMPILE, ;
\r
2350 ; $COLON NameOptiCOMPILEComma,OptiCOMPILEComma
\r
2351 ; DW DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2
\r
2352 ; DW DUPP,CodeFetch,DoLIT,EXIT,Equals,ZBranch,OPTC1
\r
2354 ; OPTC1 DW DUPP,CELLPlus,CodeFetch,DoLIT,EXIT,Equals
\r
2355 ; DW ZBranch,OPTC2
\r
2356 ; DW CodeFetch,DUPP,DoLIT,DoLIT,XORR,ZBranch,OPTC2
\r
2358 ; OPTC2 DW DROP,COMPILEComma,EXIT
\r
2360 $CODE NameOptiCOMPILEComma,OptiCOMPILEComma
\r
2361 CMP WORD PTR CS:[BX],CALLL
\r
2363 MOV AX,CS:[BX+CELLL]
\r
2366 CMP AX,OFFSET DoLIST
\r
2368 MOV DX,OFFSET EXIT
\r
2369 MOV AX,CS:[BX+2*CELLL]
\r
2372 CMP DX,CS:[BX+3*CELLL]
\r
2374 CMP AX,OFFSET DoLIT
\r
2377 OPTC1: JMP COMPILEComma
\r
2381 ; singleOnly ( c-addr u -- x )
\r
2382 ; Handle the word not found in the search-order. If the string
\r
2383 ; is legal, leave a single cell number in interpretation state.
\r
2386 ; 0 DUP 2SWAP OVER C@ [CHAR] -
\r
2387 ; = DUP >R IF 1 /STRING THEN
\r
2388 ; >NUMBER IF -13 THROW THEN \ undefined word
\r
2389 ; 2DROP R> IF NEGATE THEN ;
\r
2391 $COLON NameSingleOnly,SingleOnly
\r
2392 DW DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\r
2393 DW Equals,DUPP,ToR,ZBranch,SINGLEO4
\r
2394 DW DoLIT,1,SlashSTRING
\r
2395 SINGLEO4 DW ToNUMBER,ZBranch,SINGLEO1
\r
2396 DW DoLIT,-13,THROW
\r
2397 SINGLEO1 DW TwoDROP,RFrom,ZBranch,SINGLEO2
\r
2401 ; singleOnly, ( c-addr u -- )
\r
2402 ; Handle the word not found in the search-order. Compile a
\r
2403 ; single cell number in compilation state.
\r
2406 ; singleOnly LITERAL ;
\r
2408 $COLON NameSingleOnlyComma,SingleOnlyComma
\r
2409 DW SingleOnly,LITERAL,EXIT
\r
2411 ; (doubleAlso) ( c-addr u -- x 1 | x x 2 )
\r
2412 ; If the string is legal, leave a single or double cell number
\r
2413 ; and size of the number.
\r
2416 ; 0 DUP 2SWAP OVER C@ [CHAR] -
\r
2417 ; = DUP >R IF 1 /STRING THEN
\r
2419 ; IF 1- IF -13 THROW THEN \ more than one char is remained
\r
2420 ; DUP C@ [CHAR] . XOR \ last char is not '.'
\r
2421 ; IF -13 THROW THEN \ undefined word
\r
2422 ; R> IF DNEGATE THEN
\r
2424 ; 2DROP R> IF NEGATE THEN \ single number
\r
2427 $COLON NameParenDoubleAlso,ParenDoubleAlso
\r
2428 DW DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\r
2429 DW Equals,DUPP,ToR,ZBranch,DOUBLEA1
\r
2430 DW DoLIT,1,SlashSTRING
\r
2431 DOUBLEA1 DW ToNUMBER,QuestionDUP,ZBranch,DOUBLEA4
\r
2432 DW OneMinus,ZBranch,DOUBLEA3
\r
2433 DOUBLEA2 DW DoLIT,-13,THROW
\r
2434 DOUBLEA3 DW CFetch,DoLIT,'.',Equals,ZBranch,DOUBLEA2
\r
2435 DW RFrom,ZBranch,DOUBLEA5
\r
2437 DOUBLEA5 DW DoLIT,2,EXIT
\r
2438 DOUBLEA4 DW TwoDROP,RFrom,ZBranch,DOUBLEA6
\r
2440 DOUBLEA6 DW DoLIT,1,EXIT
\r
2442 ; doubleAlso ( c-addr u -- x | x x )
\r
2443 ; Handle the word not found in the search-order. If the string
\r
2444 ; is legal, leave a single or double cell number in
\r
2445 ; interpretation state.
\r
2448 ; (doubleAlso) DROP ;
\r
2450 $COLON NameDoubleAlso,DoubleAlso
\r
2451 DW ParenDoubleAlso,DROP,EXIT
\r
2453 ; doubleAlso, ( c-addr u -- )
\r
2454 ; Handle the word not found in the search-order. If the string
\r
2455 ; is legal, compile a single or double cell number in
\r
2456 ; compilation state.
\r
2459 ; (doubleAlso) 1- IF SWAP LITERAL THEN LITERAL ;
\r
2461 $COLON NameDoubleAlsoComma,DoubleAlsoComma
\r
2462 DW ParenDoubleAlso,OneMinus,ZBranch,DOUBC1
\r
2464 DOUBC1 DW LITERAL,EXIT
\r
2467 ; You don't need this word unless you care that '-.' returns
\r
2468 ; double cell number 0. Catching illegal number '-.' in this way
\r
2469 ; is easier than make 'interpret' catch this exception.
\r
2471 ; : -. -13 THROW ; IMMEDIATE \ undefined word
\r
2473 $COLON NameMinusDot,MinusDot
\r
2474 DW DoLIT,-13,THROW
\r
2476 ; lastName ( -- c-addr )
\r
2477 ; Return the address of the last definition name.
\r
2479 $VALUE NameLastName,LastName,AddrLastName
\r
2482 ; Link the word being defined to the current wordlist.
\r
2483 ; Do nothing if the last definition is made by :NONAME .
\r
2485 ; : linkLast lastName GET-CURRENT ! ;
\r
2487 ; $COLON NameLinkLast,LinkLast
\r
2488 ; DW LastName,GET_CURRENT,Store,EXIT
\r
2490 $CODE NameLinkLast,LinkLast
\r
2491 MOV AX,AddrLastName
\r
2492 MOV DI,AddrCurrent
\r
2496 ; name>xt ( c-addr -- xt )
\r
2497 ; Return execution token using counted string at c-addr.
\r
2499 ; : name>xt cell- cell- @ ;
\r
2501 ; $COLON NameNameToXT,NameToXT
\r
2502 ; DW CellMinus,CellMinus,Fetch,EXIT
\r
2504 $CODE NameNameToXT,NameToXT
\r
2505 MOV BX,[BX-2*CELLL]
\r
2508 ; pack" ( c-addr u a-addr -- a-addr2 )
\r
2509 ; Place a string c-addr u at a-addr and gives the next
\r
2510 ; cell-aligned address. Fill the rest of the last cell with
\r
2513 ; : pack" 2DUP SWAP CHARS + CHAR+ DUP >R \ ca u aa aa+u+1
\r
2514 ; ALIGNED cell- 0 SWAP ! \ fill 0 at the end of string
\r
2515 ; 2DUP C! CHAR+ SWAP \ c-addr a-addr+1 u
\r
2516 ; CHARS MOVE R> ALIGNED ; COMPILE-ONLY
\r
2518 ; $COLON 5,'pack"',PackQuote,_SLINK
\r
2519 ; DW TwoDUP,SWAP,CHARS,Plus,CHARPlus,DUPP,ToR
\r
2520 ; DW ALIGNED,CellMinus,Zero,SWAP,Store
\r
2521 ; DW TwoDUP,CStore,CHARPlus,SWAP
\r
2522 ; DW CHARS,MOVE,RFrom,ALIGNED,EXIT
\r
2524 $CODE NamePackQuote,PackQuote
\r
2531 MOV BYTE PTR [DI],CL
\r
2534 TEST DI,1 ;odd address?
\r
2536 MOV BYTE PTR [DI],0
\r
2542 ; PARSE-WORD ( "<spaces>ccc<space>" -- c-addr u )
\r
2543 ; Skip leading spaces and parse a word. Return the name.
\r
2545 ; : PARSE-WORD BL skipPARSE ;
\r
2547 ; $COLON NamePARSE_WORD,PARSE_WORD
\r
2548 ; DW DoLIT,' ',SkipPARSE,EXIT
\r
2550 $CODE NamePARSE_WORD,PARSE_WORD
\r
2556 ; pipe ( -- ) ( R: xt -- )
\r
2557 ; Connect most recently defined word to code following DOES>.
\r
2558 ; Structure of CREATEd word:
\r
2559 ; |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |
\r
2561 ; : pipe lastName name>xt ?call DUP IF \ code-addr xt2
\r
2562 ; ['] doCREATE = IF
\r
2563 ; R> SWAP code! \ change DOES> code of CREATEd word
\r
2566 ; -32 THROW \ invalid name argument, no-CREATEd last name
\r
2569 $COLON NamePipe,Pipe
\r
2570 DW LastName,NameToXT,QCall,DUPP,ZBranch,PIPE1
\r
2571 DW DoLIT,DoCREATE,Equals,ZBranch,PIPE1
\r
2572 DW RFrom,SWAP,CodeStore,EXIT
\r
2573 PIPE1 DW DoLIT,-32,THROW
\r
2575 ; skipPARSE ( char "<chars>ccc<char>" -- c-addr u )
\r
2576 ; Skip leading chars and parse a word using char as a
\r
2577 ; delimeter. Return the name.
\r
2580 ; >R SOURCE >IN @ /STRING \ c_addr u R: char
\r
2582 ; BEGIN OVER C@ R@ =
\r
2583 ; WHILE 1- SWAP CHAR+ SWAP DUP 0=
\r
2584 ; UNTIL R> DROP EXIT
\r
2586 ; DROP SOURCE DROP - 1chars/ >IN ! R> PARSE EXIT
\r
2589 ; $COLON NameSkipPARSE,SkipPARSE
\r
2590 ; DW ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING
\r
2591 ; DW DUPP,ZBranch,SKPAR1
\r
2592 ; SKPAR2 DW OVER,CFetch,RFetch,Equals,ZBranch,SKPAR3
\r
2593 ; DW OneMinus,SWAP,CHARPlus,SWAP
\r
2594 ; DW DUPP,ZeroEquals,ZBranch,SKPAR2
\r
2595 ; DW RFrom,DROP,EXIT
\r
2596 ; SKPAR3 DW DROP,SOURCE,DROP,Minus,OneCharsSlash
\r
2597 ; DW DoLIT,AddrToIN,Store,RFrom,PARSE,EXIT
\r
2598 ; SKPAR1 DW RFrom,DROP,EXIT
\r
2600 $CODE NameSkipPARSE,SkipPARSE
\r
2603 MOV SI,AddrSourceVar+CELLL
\r
2604 MOV BX,AddrSourceVar
\r
2617 MOV AX,AddrSourceVar
\r
2623 SUB SI,AddrSourceVar+CELLL
\r
2631 ; specialComp? ( -- xt|0 )
\r
2632 ; Return xt for special compilation semantics of the last found
\r
2633 ; word. Return 0 if there is no special compilation action.
\r
2635 $VALUE NameSpecialCompQ,SpecialCompQ,AddrSpecialCompQ
\r
2637 ; rake ( C: do-sys -- )
\r
2640 ; : rake DUP code, rakeVar @
\r
2642 ; WHILE DUP code@ xhere ROT code!
\r
2643 ; REPEAT rakeVar ! DROP
\r
2644 ; ?DUP IF \ check for ?DO
\r
2645 ; 1 bal+ POSTPONE THEN \ orig type is 1
\r
2646 ; THEN bal- ; COMPILE-ONLY
\r
2648 $COLON Namerake,rake
\r
2649 DW DUPP,CodeComma,DoLIT,AddrRakeVar,Fetch
\r
2650 RAKE1 DW TwoDUP,ULess,ZBranch,RAKE2
\r
2651 DW DUPP,CodeFetch,XHere,ROT,CodeStore,Branch,RAKE1
\r
2652 RAKE2 DW DoLIT,AddrRakeVar,Store,DROP
\r
2653 DW QuestionDUP,ZBranch,RAKE3
\r
2654 DW One,BalPlus,THENN
\r
2655 RAKE3 DW BalMinus,EXIT
\r
2657 ; rp0 ( -- a-addr )
\r
2658 ; Pointer to bottom of the return stack.
\r
2660 ; : rp0 userP @ CELL+ CELL+ @ ;
\r
2662 $COLON NameRPZero,RPZero
\r
2663 DW DoLIT,AddrUserP,Fetch,CELLPlus,CELLPlus,Fetch,EXIT
\r
2665 ; search-word ( c-addr u -- c-addr u 0 | xt f 1 | xt f -1)
\r
2666 ; Search dictionary for a match with the given name. Return
\r
2667 ; execution token, not-compile-only flag and -1 or 1
\r
2668 ; ( IMMEDIATE) if found; c-addr u 0 if not.
\r
2671 ; #order @ DUP \ not found if #order is 0
\r
2673 ; DO 2DUP \ ca u ca u
\r
2674 ; I CELLS #order CELL+ + @ \ ca u ca u wid
\r
2675 ; (search-wordlist) \ ca u; 0 | w f 1 | w f -1
\r
2676 ; ?DUP IF \ ca u; 0 | w f 1 | w f -1
\r
2677 ; >R 2SWAP 2DROP R> UNLOOP EXIT \ xt f 1 | xt f -1
\r
2682 $COLON NameSearch_word,Search_word
\r
2683 DW NumberOrder,Fetch,DUPP,ZBranch,SEARCH1
\r
2685 SEARCH2 DW TwoDUP,I,CELLS,NumberOrder,CELLPlus,Plus,Fetch
\r
2686 DW ParenSearch_Wordlist,QuestionDUP,ZBranch,SEARCH3
\r
2687 DW ToR,TwoSWAP,TwoDROP,RFrom,UNLOOP,EXIT
\r
2688 SEARCH3 DW DoLOOP,SEARCH2
\r
2692 ; sourceVar ( -- a-addr )
\r
2693 ; Hold the current count and address of the terminal input buffer.
\r
2695 $CONST NameSourceVar,SourceVar,AddrSourceVar
\r
2697 ; sp0 ( -- a-addr )
\r
2698 ; Pointer to bottom of the data stack.
\r
2700 ; : sp0 userP @ CELL+ @ ;
\r
2702 $COLON NameSPZero,SPZero
\r
2703 DW DoLIT,AddrUserP,Fetch,CELLPlus,Fetch,EXIT
\r
2706 ; Essential Standard words - Colon definitions
\r
2709 ; # ( ud1 -- ud2 ) \ CORE
\r
2710 ; Extract one digit from ud1 and append the digit to
\r
2711 ; pictured numeric output string. ( ud2 = ud1 / BASE )
\r
2713 ; : # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP
\r
2714 ; 9 OVER < [ CHAR A CHAR 9 1 + - ] LITERAL AND +
\r
2715 ; [ CHAR 0 ] LITERAL + HOLD R> ;
\r
2717 ; $COLON NameNumberSign,NumberSign
\r
2718 ; DW DoLIT,0,DoLITFetch,AddrBASE,UMSlashMOD,ToR
\r
2719 ; DW DoLITFetch,AddrBASE,UMSlashMOD,SWAP
\r
2720 ; DW DoLIT,9,OVER,LessThan,DoLIT,'A'-'9'-1,ANDD,Plus
\r
2721 ; DW DoLIT,'0',Plus,HOLD,RFrom,EXIT
\r
2723 $CODE NameNumberSign,NumberSign
\r
2727 DIV CX ;0:TOS / BASE
\r
2728 MOV BX,AX ;quotient
\r
2731 PUSH AX ;BX:AX = ud2
\r
2736 NUMSN1: ADD AL,'0'
\r
2743 ; #> ( xd -- c-addr u ) \ CORE
\r
2744 ; Prepare the output string to be TYPE'd.
\r
2745 ; ||HERE>WORD/#-work-area|
\r
2747 ; : #> 2DROP hld @ HERE size-of-PAD + OVER - 1chars/ ;
\r
2749 $COLON NameNumberSignGreater,NumberSignGreater
\r
2750 DW TwoDROP,DoLIT,AddrHLD,Fetch,HERE,DoLIT,PADSize*CHARR,Plus
\r
2751 DW OVER,Minus,OneCharsSlash,EXIT
\r
2753 ; #S ( ud -- 0 0 ) \ CORE
\r
2754 ; Convert ud until all digits are added to the output string.
\r
2756 ; : #S BEGIN # 2DUP OR 0= UNTIL ;
\r
2758 $COLON NameNumberSignS,NumberSignS
\r
2759 NUMSS1 DW NumberSign,TwoDUP,ORR
\r
2760 DW ZeroEquals,ZBranch,NUMSS1
\r
2763 ; ' ( "<spaces>name" -- xt ) \ CORE
\r
2764 ; Parse a name, find it and return xt.
\r
2768 $COLON NameTick,Tick
\r
2769 DW ParenTick,DROP,EXIT
\r
2771 ; + ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
2772 ; Add top two items and gives the sum.
\r
2776 ; $COLON NamePlus,Plus
\r
2777 ; DW UMPlus,DROP,EXIT
\r
2779 $CODE NamePlus,Plus
\r
2784 ; +! ( n|u a-addr -- ) \ CORE
\r
2785 ; Add n|u to the contents at a-addr.
\r
2787 ; : +! SWAP OVER @ + SWAP ! ;
\r
2789 ; $COLON NamePlusStore,PlusStore
\r
2790 ; DW SWAP,OVER,Fetch,Plus
\r
2791 ; DW SWAP,Store,EXIT
\r
2793 $CODE NamePlusStore,PlusStore
\r
2799 ; , ( x -- ) \ CORE
\r
2800 ; Reserve one cell in data space and store x in it.
\r
2802 ; : , HERE ! HERE CELL+ TO HERE ;
\r
2804 ; $COLON NameComma,Comma
\r
2805 ; DW HERE,Store,HERE,CELLPlus,DoTO,AddrHERE,EXIT
\r
2807 $CODE NameComma,Comma
\r
2815 ; - ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
2816 ; Subtract n2|u2 from n1|u1, giving the difference n3|u3.
\r
2820 ; $COLON NameMinus,Minus
\r
2821 ; DW NEGATE,Plus,EXIT
\r
2823 $CODE NameMinus,Minus
\r
2829 ; . ( n -- ) \ CORE
\r
2830 ; Display a signed number followed by a space.
\r
2834 $COLON NameDot,Dot
\r
2837 ; / ( n1 n2 -- n3 ) \ CORE
\r
2838 ; Divide n1 by n2, giving single-cell quotient n3.
\r
2842 $COLON NameSlash,Slash
\r
2843 DW SlashMOD,NIP,EXIT
\r
2845 ; /MOD ( n1 n2 -- n3 n4 ) \ CORE
\r
2846 ; Divide n1 by n2, giving single-cell remainder n3 and
\r
2847 ; single-cell quotient n4.
\r
2849 ; : /MOD >R S>D R> FM/MOD ;
\r
2851 ; $COLON NameSlashMOD,SlashMOD
\r
2852 ; DW ToR,SToD,RFrom,FMSlashMOD,EXIT
\r
2854 $CODE NameSlashMOD,SlashMOD
\r
2862 ; /STRING ( c-addr1 u1 n -- c-addr2 u2 ) \ STRING
\r
2863 ; Adjust the char string at c-addr1 by n chars.
\r
2865 ; : /STRING DUP >R - SWAP R> CHARS + SWAP ;
\r
2867 ; $COLON NameSlashSTRING,SlashSTRING
\r
2868 ; DW DUPP,ToR,Minus,SWAP,RFrom,CHARS,Plus,SWAP,EXIT
\r
2870 $CODE NameSlashSTRING,SlashSTRING
\r
2879 ; 1+ ( n1|u1 -- n2|u2 ) \ CORE
\r
2880 ; Increase top of the stack item by 1.
\r
2884 ; $COLON NameOnePlus,OnePlus
\r
2885 ; DW DoLIT,1,Plus,EXIT
\r
2887 $CODE NameOnePlus,OnePlus
\r
2891 ; 1- ( n1|u1 -- n2|u2 ) \ CORE
\r
2892 ; Decrease top of the stack item by 1.
\r
2896 ; $COLON NameOneMinus,OneMinus
\r
2897 ; DW DoLIT,-1,Plus,EXIT
\r
2899 $CODE NameOneMinus,OneMinus
\r
2903 ; 2! ( x1 x2 a-addr -- ) \ CORE
\r
2904 ; Store the cell pare x1 x2 at a-addr, with x2 at a-addr and
\r
2905 ; x1 at the next consecutive cell.
\r
2907 ; : 2! SWAP OVER ! CELL+ ! ;
\r
2909 ; $COLON NameTwoStore,TwoStore
\r
2910 ; DW SWAP,OVER,Store,CELLPlus,Store,EXIT
\r
2912 $CODE NameTwoStore,TwoStore
\r
2918 ; 2@ ( a-addr -- x1 x2 ) \ CORE
\r
2919 ; Fetch the cell pair stored at a-addr. x2 is stored at a-addr
\r
2920 ; and x1 at the next consecutive cell.
\r
2922 ; : 2@ DUP CELL+ @ SWAP @ ;
\r
2924 ; $COLON NameTwoFetch,TwoFetch
\r
2925 ; DW DUPP,CELLPlus,Fetch,SWAP,Fetch,EXIT
\r
2927 $CODE NameTwoFetch,TwoFetch
\r
2932 ; 2DROP ( x1 x2 -- ) \ CORE
\r
2933 ; Drop cell pair x1 x2 from the stack.
\r
2935 ; $COLON NameTwoDROP,TwoDROP
\r
2936 ; DW DROP,DROP,EXIT
\r
2938 $CODE NameTwoDROP,TwoDROP
\r
2943 ; 2DUP ( x1 x2 -- x1 x2 x1 x2 ) \ CORE
\r
2944 ; Duplicate cell pair x1 x2.
\r
2946 ; $COLON NameTwoDUP,TwoDUP
\r
2947 ; DW OVER,OVER,EXIT
\r
2949 $CODE NameTwoDUP,TwoDUP
\r
2955 ; 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) \ CORE
\r
2956 ; Exchange the top two cell pairs.
\r
2958 ; : 2SWAP ROT >R ROT R> ;
\r
2960 ; $COLON NameTwoSWAP,TwoSWAP
\r
2961 ; DW ROT,ToR,ROT,RFrom,EXIT
\r
2963 $CODE NameTwoSWAP,TwoSWAP
\r
2973 ; : ( "<spaces>name" -- colon-sys ) \ CORE
\r
2974 ; Start a new colon definition using next word as its name.
\r
2976 ; : : xhere ALIGNED CELL+ TO xhere \ reserve a cell for name pointer
\r
2977 ; :NONAME ROT head, -1 TO notNONAME? ;
\r
2979 $COLON NameCOLON,COLON
\r
2980 DW XHere,ALIGNED,CELLPlus,DoTO,AddrXHere
\r
2981 DW ColonNONAME,ROT,HeadComma
\r
2982 DW DoLIT,-1,DoTO,AddrNotNONAMEQ,EXIT
\r
2984 ; :NONAME ( -- xt colon-sys ) \ CORE EXT
\r
2985 ; Create an execution token xt, enter compilation state and
\r
2986 ; start the current definition.
\r
2988 ; : :NONAME bal IF -29 THROW THEN \ compiler nesting
\r
2989 ; ['] doLIST xt, DUP -1
\r
2990 ; 0 TO notNONAME? 1 TO bal ] ;
\r
2992 $COLON NameColonNONAME,ColonNONAME
\r
2993 DW Bal,ZBranch,NONAME1
\r
2994 DW DoLIT,-29,THROW
\r
2995 NONAME1 DW DoLIT,DoLIST,xtComma,DUPP,DoLIT,-1
\r
2996 DW DoLIT,0,DoTO,AddrNotNONAMEQ
\r
2997 DW One,DoTO,AddrBal,RightBracket,EXIT
\r
2999 ; ; ( colon-sys -- ) \ CORE
\r
3000 ; Terminate a colon definition.
\r
3002 ; : ; bal 1- IF -22 THROW THEN \ control structure mismatch
\r
3003 ; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1
\r
3004 ; notNONAME? IF \ if the last definition is not created by ':'
\r
3005 ; linkLast 0 TO notNONAME? \ link the word to wordlist
\r
3006 ; THEN POSTPONE EXIT \ add EXIT at the end of the definition
\r
3007 ; 0 TO bal POSTPONE [ ; COMPILE-ONLY IMMEDIATE
\r
3009 $COLON NameSemicolon,Semicolon
\r
3010 DW Bal,OneMinus,ZBranch,SEMI1
\r
3011 DW DoLIT,-22,THROW
\r
3012 SEMI1 DW NIP,OnePlus,ZBranch,SEMI2
\r
3013 DW DoLIT,-22,THROW
\r
3014 SEMI2 DW NotNONAMEQ,ZBranch,SEMI3
\r
3015 DW LinkLast,DoLIT,0,DoTO,AddrNotNONAMEQ
\r
3016 SEMI3 DW DoLIT,EXIT,COMPILEComma
\r
3017 DW DoLIT,0,DoTO,AddrBal,LeftBracket,EXIT
\r
3019 ; < ( n1 n2 -- flag ) \ CORE
\r
3020 ; Returns true if n1 is less than n2.
\r
3022 ; : < 2DUP XOR 0< \ same sign?
\r
3023 ; IF DROP 0< EXIT THEN \ different signs, true if n1 <0
\r
3024 ; - 0< ; \ same signs, true if n1-n2 <0
\r
3026 ; $COLON NameLessThan,LessThan
\r
3027 ; DW TwoDUP,XORR,ZeroLess,ZBranch,LESS1
\r
3028 ; DW DROP,ZeroLess,EXIT
\r
3029 ; LESS1 DW Minus,ZeroLess,EXIT
\r
3031 $CODE NameLessThan,LessThan
\r
3039 ; <# ( -- ) \ CORE
\r
3040 ; Initiate the numeric output conversion process.
\r
3041 ; ||HERE>WORD/#-work-area|
\r
3043 ; : <# HERE size-of-PAD + hld ! ;
\r
3045 $COLON NameLessNumberSign,LessNumberSign
\r
3046 DW HERE,DoLIT,PADSize*CHARR,Plus,DoLIT,AddrHLD,Store,EXIT
\r
3048 ; = ( x1 x2 -- flag ) \ CORE
\r
3049 ; Return true if top two are equal.
\r
3053 ; $COLON NameEquals,Equals
\r
3054 ; DW XORR,ZeroEquals,EXIT
\r
3056 $CODE NameEquals,Equals
\r
3064 ; > ( n1 n2 -- flag ) \ CORE
\r
3065 ; Returns true if n1 is greater than n2.
\r
3069 ; $COLON NameGreaterThan,GreaterThan
\r
3070 ; DW SWAP,LessThan,EXIT
\r
3072 $CODE NameGreaterThan,GreaterThan
\r
3080 ; >IN ( -- a-addr )
\r
3081 ; Hold the character pointer while parsing input stream.
\r
3083 $CONST NameToIN,ToIN,AddrToIN
\r
3085 ; >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ CORE
\r
3086 ; Add number string's value to ud1. Leaves string of any
\r
3087 ; unconverted chars.
\r
3089 ; : >NUMBER BEGIN DUP
\r
3090 ; WHILE >R DUP >R C@ \ ud char R: u c-addr
\r
3091 ; DUP [ CHAR 9 1+ ] LITERAL [CHAR] A WITHIN
\r
3092 ; IF DROP R> R> EXIT THEN
\r
3093 ; [ CHAR 0 ] LITERAL - 9 OVER <
\r
3094 ; [ CHAR A CHAR 9 1 + - ] LITERAL AND -
\r
3095 ; DUP 0 BASE @ WITHIN
\r
3096 ; WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> R> 1 /STRING
\r
3097 ; REPEAT DROP R> R>
\r
3100 ; $COLON NameToNUMBER,ToNUMBER
\r
3101 ; TONUM1 DW DUPP,ZBranch,TONUM3
\r
3102 ; DW ToR,DUPP,ToR,CFetch,DUPP
\r
3103 ; DW DoLIT,'9'+1,DoLIT,'A',WITHIN,ZeroEquals,ZBranch,TONUM2
\r
3104 ; DW DoLIT,'0',Minus,DoLIT,9,OVER,LessThan
\r
3105 ; DW DoLIT,'A'-'9'-1,ANDD,Minus,DUPP
\r
3106 ; DW DoLIT,0,DoLIT,AddrBASE,Fetch,WITHIN,ZBranch,TONUM2
\r
3107 ; DW SWAP,DoLIT,AddrBASE,Fetch,UMStar,DROP,ROT,DoLIT,AddrBASE,Fetch
\r
3108 ; DW UMStar,DPlus,RFrom,RFrom,DoLIT,1,SlashSTRING
\r
3109 ; DW Branch,TONUM1
\r
3110 ; TONUM2 DW DROP,RFrom,RFrom
\r
3113 $CODE NameToNUMBER,ToNUMBER
\r
3120 JS TONUM2 ;not valid digit
\r
3124 JL TONUM2 ;not valid digit
\r
3126 TONUM3: CMP CX,AddrBASE
\r
3127 JGE TONUM2 ;not valid digit
\r
3145 ; ?DUP ( x -- x x | 0 ) \ CORE
\r
3146 ; Duplicate top of the stack if it is not zero.
\r
3148 ; : ?DUP DUP IF DUP THEN ;
\r
3150 ; $COLON NameQuestionDUP,QuestionDUP
\r
3151 ; DW DUPP,ZBranch,QDUP1
\r
3155 $CODE NameQuestionDUP,QuestionDUP
\r
3161 ; ABORT ( i*x -- ) ( R: j*x -- ) \ EXCEPTION EXT
\r
3162 ; Reset data stack and jump to QUIT.
\r
3164 ; : ABORT -1 THROW ;
\r
3166 $COLON NameABORT,ABORT
\r
3169 ; ACCEPT ( c-addr +n1 -- +n2 ) \ CORE
\r
3170 ; Accept a string of up to +n1 chars. Return with actual count.
\r
3171 ; Implementation-defined editing. Stops at EOL# .
\r
3172 ; Supports backspace and delete editing.
\r
3175 ; BEGIN DUP R@ < \ ca n2 f R: n1
\r
3176 ; WHILE EKEY max-char AND
\r
3178 ; IF DUP cr# = IF ROT 2DROP R> DROP EXIT THEN
\r
3180 ; IF DROP 2DUP + BL DUP EMIT SWAP C! 1+
\r
3184 ; \ discard the last char if not 1st char
\r
3185 ; IF 1- bsp# EMIT BL EMIT bsp# EMIT THEN THEN
\r
3187 ; ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+ THEN
\r
3189 ; REPEAT SWAP R> 2DROP ;
\r
3191 $COLON NameACCEPT,ACCEPT
\r
3193 ACCPT1 DW DUPP,RFetch,LessThan,ZBranch,ACCPT5
\r
3194 DW EKEY,DoLIT,MaxChar,ANDD
\r
3195 DW DUPP,DoLIT,' ',LessThan,ZBranch,ACCPT3
\r
3196 DW DUPP,DoLIT,CRR,Equals,ZBranch,ACCPT4
\r
3197 DW ROT,TwoDROP,RFrom,DROP,EXIT
\r
3198 ACCPT4 DW DUPP,DoLIT,TABB,Equals,ZBranch,ACCPT6
\r
3199 DW DROP,TwoDUP,Plus,DoLIT,' ',DUPP,EMIT,SWAP,CStore,OnePlus
\r
3201 ACCPT6 DW DUPP,DoLIT,BKSPP,Equals
\r
3202 DW SWAP,DoLIT,DEL,Equals,ORR,ZBranch,ACCPT1
\r
3203 DW DUPP,ZBranch,ACCPT1
\r
3204 DW OneMinus,DoLIT,BKSPP,EMIT,DoLIT,' ',EMIT,DoLIT,BKSPP,EMIT
\r
3206 ACCPT3 DW ToR,TwoDUP,CHARS,Plus,RFrom,DUPP,EMIT,SWAP,CStore
\r
3207 DW OnePlus,Branch,ACCPT1
\r
3208 ACCPT5 DW SWAP,RFrom,TwoDROP,EXIT
\r
3210 ; AGAIN ( C: dest -- ) \ CORE EXT
\r
3211 ; Resolve backward reference dest. Typically used as
\r
3212 ; BEGIN ... AGAIN . Move control to the location specified by
\r
3213 ; dest on execution.
\r
3215 ; : AGAIN IF -22 THROW THEN \ control structure mismatch; dest type is 0
\r
3216 ; POSTPONE branch code, bal- ; COMPILE-ONLY IMMEDIATE
\r
3218 $COLON NameAGAIN,AGAIN
\r
3220 DW DoLIT,-22,THROW
\r
3221 AGAIN1 DW DoLIT,Branch,COMPILEComma,CodeComma,BalMinus,EXIT
\r
3223 ; AHEAD ( C: -- orig ) \ TOOLS EXT
\r
3224 ; Put the location of a new unresolved forward reference onto
\r
3225 ; control-flow stack.
\r
3227 ; : AHEAD POSTPONE branch xhere 0 code,
\r
3228 ; 1 bal+ \ orig type is 1
\r
3229 ; ; COMPILE-ONLY IMMEDIATE
\r
3231 $COLON NameAHEAD,AHEAD
\r
3232 DW DoLIT,Branch,COMPILEComma,XHere,DoLIT,0,CodeComma
\r
3233 DW One,BalPlus,EXIT
\r
3235 ; BL ( -- char ) \ CORE
\r
3236 ; Return the value of the blank character.
\r
3238 ; : BL blank-char-value EXIT ;
\r
3240 $CONST NameBLank,BLank,' '
\r
3242 ; CATCH ( i*x xt -- j*x 0 | i*x n ) \ EXCEPTION
\r
3243 ; Push an exception frame on the exception stack and then execute
\r
3244 ; the execution token xt in such a way that control can be
\r
3245 ; transferred to a point just after CATCH if THROW is executed
\r
3246 ; during the execution of xt.
\r
3248 ; : CATCH sp@ >R throwFrame @ >R \ save error frame
\r
3249 ; rp@ throwFrame ! EXECUTE \ execute
\r
3250 ; R> throwFrame ! \ restore error frame
\r
3251 ; R> DROP 0 ; \ no error
\r
3253 $COLON NameCATCH,CATCH
\r
3254 DW SPFetch,ToR,ThrowFrame,Fetch,ToR
\r
3255 DW RPFetch,ThrowFrame,Store,EXECUTE
\r
3256 DW RFrom,ThrowFrame,Store
\r
3257 DW RFrom,DROP,DoLIT,0,EXIT
\r
3259 ; CELL+ ( a-addr1 -- a-addr2 ) \ CORE
\r
3260 ; Return next aligned cell address.
\r
3262 ; : CELL+ cell-size + ;
\r
3264 ; $COLON NameCELLPlus,CELLPlus
\r
3265 ; DW DoLIT,CELLL,Plus,EXIT
\r
3267 $CODE NameCELLPlus,CELLPlus
\r
3271 ; CHAR+ ( c-addr1 -- c-addr2 ) \ CORE
\r
3272 ; Returns next character-aligned address.
\r
3274 ; : CHAR+ char-size + ;
\r
3276 ; $COLON NameCHARPlus,CHARPlus
\r
3277 ; DW DoLIT,CHARR,Plus,EXIT
\r
3279 $CODE NameCHARPlus,CHARPlus
\r
3283 ; COMPILE, ( xt -- ) \ CORE EXT
\r
3284 ; Compile the execution token on data stack into current
\r
3285 ; colon definition.
\r
3286 ; Structure of words with special compilation action
\r
3287 ; for default compilation behavior
\r
3288 ; |compile_xt|name_ptr| execution_code |
\r
3290 ; : COMPILE, DUP specialComp? = IF DUP cell- cell- code@ EXECUTE EXIT THEN
\r
3293 ; $COLON NameCOMPILEComma,COMPILEComma
\r
3294 ; DW DUPP,SpecialCompQ,Equals,ZBranch,COMPILEC1
\r
3295 ; DW DUPP,CellMinus,CellMinus,CodeFetch,EXECUTE,EXIT
\r
3296 ; COMPILEC1 DW CodeComma,EXIT
\r
3298 $CODE NameCOMPILEComma,COMPILEComma
\r
3299 CMP BX,AddrSpecialCompQ
\r
3307 COMPILEC1: MOV AX,CS:[BX-2*CELLL]
\r
3311 ; compileCONST ( xt -- )
\r
3312 ; Compile a CONSTANT word of which xt is given.
\r
3313 ; Structure of CONSTANT word:
\r
3314 ; |compile_xt|name_ptr| call-doCONST | x |
\r
3317 ; CELL+ CELL+ code@ POSTPONE LITERAL ;
\r
3319 ; $COLON NameCompileCONST,CompileCONST
\r
3320 ; DW CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT
\r
3322 $CODE NameCompileCONST,CompileCONST
\r
3323 MOV CX,CS:[BX+2*CELLL]
\r
3325 MOV AX,OFFSET DoLIT
\r
3327 MOV CS:[DI+CELLL],CX
\r
3333 ; CONSTANT ( x "<spaces>name" -- ) \ CORE
\r
3334 ; name Execution: ( -- x )
\r
3335 ; Create a definition for name which pushes x on the stack on
\r
3338 ; : CONSTANT bal IF -29 THROW THEN \ compiler nesting
\r
3339 ; xhere ALIGNED TO xhere
\r
3340 ; ['] compileCONST code,
\r
3341 ; xhere CELL+ TO xhere
\r
3342 ; ['] doCONST xt, head,
\r
3344 ; lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;
\r
3346 $COLON NameCONSTANT,CONSTANT
\r
3347 DW Bal,ZBranch,CONST1
\r
3348 DW DoLIT,-29,THROW
\r
3349 CONST1 DW XHere,ALIGNED,DoTO,AddrXHere
\r
3350 DW DoLIT,CompileCONST,CodeComma
\r
3351 DW XHere,CELLPlus,DoTO,AddrXHere
\r
3352 DW DoLIT,DoCONST,xtComma,HeadComma
\r
3353 DW CodeComma,LinkLast
\r
3354 DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
3356 ; COUNT ( c-addr1 -- c-addr2 u ) \ CORE
\r
3357 ; Convert counted string to string specification. c-addr2 is
\r
3358 ; the next char-aligned address after c-addr1 and u is the
\r
3359 ; contents at c-addr1.
\r
3361 ; : COUNT DUP CHAR+ SWAP C@ ;
\r
3363 ; $COLON NameCOUNT,COUNT
\r
3364 ; DW DUPP,CHARPlus,SWAP,CFetch,EXIT
\r
3366 $CODE NameCOUNT,COUNT
\r
3374 ; compileCREATE ( xt -- )
\r
3375 ; Compile a CREATEd word of which xt is given.
\r
3376 ; Structure of CREATEd word:
\r
3377 ; |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |
\r
3380 ; DUP CELL+ CELL+ code@ \ 0 or DOES>_xt
\r
3381 ; IF code, EXIT THEN
\r
3382 ; CELL+ CELL+ CELL+ code@ LITERAL ;
\r
3384 $COLON NameCompileCREATE,CompileCREATE
\r
3385 DW DUPP,CELLPlus,CELLPlus,CodeFetch,ZBranch,COMPCREAT1
\r
3387 COMPCREAT1 DW CELLPlus,CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT
\r
3389 ; CREATE ( "<spaces>name" -- ) \ CORE
\r
3390 ; name Execution: ( -- a-addr )
\r
3391 ; Create a data object in RAM/ROM data space, which return
\r
3392 ; data object address on execution
\r
3394 ; : CREATE bal IF -29 THROW THEN \ compiler nesting
\r
3395 ; xhere ALIGNED TO xhere
\r
3396 ; ['] compileCREATE code,
\r
3397 ; xhere CELL+ TO xhere \ reserve space for nfa
\r
3398 ; ['] doCREATE xt, head,
\r
3399 ; 0 code, \ no DOES> code yet
\r
3400 ; ALIGN HERE code, \ >BODY returns this address
\r
3401 ; linkLast \ link CREATEd word to current wordlist
\r
3402 ; lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;
\r
3404 $COLON NameCREATE,CREATE
\r
3405 DW Bal,ZBranch,CREAT1
\r
3406 DW DoLIT,-29,THROW
\r
3407 CREAT1 DW XHere,ALIGNED,DoTO,AddrXHere
\r
3408 DW DoLIT,CompileCREATE,CodeComma
\r
3409 DW XHere,CELLPlus,DoTO,AddrXHere
\r
3410 DW DoLIT,DoCREATE,xtComma,HeadComma,DoLIT,0,CodeComma
\r
3411 DW ALIGNN,HERE,CodeComma,LinkLast
\r
3412 DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
3414 ; D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE
\r
3415 ; Add double-cell numbers.
\r
3417 ; : D+ >R SWAP >R um+ R> R> + + ;
\r
3419 ; $COLON NameDPlus,DPlus
\r
3420 ; DW ToR,SWAP,ToR,UMPlus
\r
3421 ; DW RFrom,RFrom,Plus,Plus,EXIT
\r
3423 $CODE NameDPlus,DPlus
\r
3432 ; D. ( d -- ) \ DOUBLE
\r
3433 ; Display d in free field format followed by a space.
\r
3435 ; : D. (d.) TYPE SPACE ;
\r
3437 $COLON NameDDot,DDot
\r
3438 DW ParenDDot,TYPEE,SPACE,EXIT
\r
3440 ; DECIMAL ( -- ) \ CORE
\r
3441 ; Set the numeric conversion radix to decimal 10.
\r
3443 ; : DECIMAL 10 BASE ! ;
\r
3445 $COLON NameDECIMAL,DECIMAL
\r
3446 DW DoLIT,10,DoLIT,AddrBASE,Store,EXIT
\r
3448 ; DEPTH ( -- +n ) \ CORE
\r
3449 ; Return the depth of the data stack.
\r
3451 ; : DEPTH sp@ sp0 SWAP - cell-size / ;
\r
3453 ; $COLON NameDEPTH,DEPTH
\r
3454 ; DW SPFetch,SPZero,SWAP,Minus
\r
3455 ; DW DoLIT,CELLL,Slash,EXIT
\r
3457 $CODE NameDEPTH,DEPTH
\r
3465 ; DNEGATE ( d1 -- d2 ) \ DOUBLE
\r
3466 ; Two's complement of double-cell number.
\r
3468 ; : DNEGATE INVERT >R INVERT 1 um+ R> + ;
\r
3470 ; $COLON NameDNEGATE,DNEGATE
\r
3471 ; DW INVERT,ToR,INVERT
\r
3472 ; DW DoLIT,1,UMPlus
\r
3473 ; DW RFrom,Plus,EXIT
\r
3475 $CODE NameDNEGATE,DNEGATE
\r
3483 ; EKEY ( -- u ) \ FACILITY EXT
\r
3484 ; Receive one keyboard event u.
\r
3486 ; : EKEY BEGIN PAUSE EKEY? UNTIL 'ekey EXECUTE ;
\r
3488 $COLON NameEKEY,EKEY
\r
3489 EKEY1 DW PAUSE,EKEYQuestion,ZBranch,EKEY1
\r
3490 DW TickEKEY,EXECUTE,EXIT
\r
3492 ; EMIT ( x -- ) \ CORE
\r
3493 ; Send a character to the output device.
\r
3495 ; : EMIT 'emit EXECUTE ;
\r
3497 ; $COLON NameEMIT,EMIT
\r
3498 ; DW TickEMIT,EXECUTE,EXIT
\r
3500 $CODE NameEMIT,EMIT
\r
3501 MOV AX,AddrTickEMIT
\r
3505 ; FM/MOD ( d n1 -- n2 n3 ) \ CORE
\r
3506 ; Signed floored divide of double by single. Return mod n2
\r
3507 ; and quotient n3.
\r
3509 ; : FM/MOD DUP >R 2DUP XOR >R >R DUP 0< IF DNEGATE THEN
\r
3510 ; R@ ABS UM/MOD DUP 0<
\r
3511 ; IF DUP 08000h XOR IF -11 THROW THEN THEN \ result out of range
\r
3512 ; SWAP R> 0< IF NEGATE THEN
\r
3513 ; SWAP R> 0< IF NEGATE OVER IF R@ ROT - SWAP 1- THEN THEN
\r
3516 ; $COLON 6,'FM/MOD',FMSlashMOD,_FLINK
\r
3517 ; DW DUPP,ToR,TwoDUP,XORR,ToR,ToR,DUPP,ZeroLess
\r
3518 ; DW ZBranch,FMMOD1
\r
3520 ; FMMOD1 DW RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,FMMOD2
\r
3521 ; DW DUPP,DoLIT,08000h,XORR,ZBranch,FMMOD2
\r
3522 ; DW DoLIT,-11,THROW
\r
3523 ; FMMOD2 DW SWAP,RFrom,ZeroLess,ZBranch,FMMOD3
\r
3525 ; FMMOD3 DW SWAP,RFrom,ZeroLess,ZBranch,FMMOD4
\r
3526 ; DW NEGATE,OVER,ZBranch,FMMOD4
\r
3527 ; DW RFetch,ROT,Minus,SWAP,OneMinus
\r
3528 ; FMMOD4 DW RFrom,DROP,EXIT
\r
3530 $CODE NameFMSlashMOD,FMSlashMOD
\r
3540 DIV BX ;positive dividend, positive divisor
\r
3546 FMMOD3: NEG BX ;positive dividend, negative divisor
\r
3553 JZ FMMOD7 ;modulo = 0
\r
3559 FMMOD2: NEG AX ;DNEGATE
\r
3565 CMP DX,BX ;negative dividend, positive divisor
\r
3581 FMMOD4: NEG BX ;negative dividend, negative divisor
\r
3591 FMMOD6: MOV BX,-11 ;result out of range
\r
3593 FMMOD1: MOV BX,-10 ;divide by zero
\r
3597 ; GET-CURRENT ( -- wid ) \ SEARCH
\r
3598 ; Return the indentifier of the compilation wordlist.
\r
3600 ; : GET-CURRENT current @ ;
\r
3602 $COLON NameGET_CURRENT,GET_CURRENT
\r
3603 DW DoLIT,AddrCurrent,Fetch,EXIT
\r
3605 ; HOLD ( char -- ) \ CORE
\r
3606 ; Add char to the beginning of pictured numeric output string.
\r
3608 ; : HOLD hld @ 1 CHARS - DUP hld ! C! ;
\r
3610 ; $COLON NameHOLD,HOLD
\r
3611 ; DW DoLIT,AddrHLD,Fetch,DoLIT,0-CHARR,Plus
\r
3612 ; DW DUPP,DoLIT,AddrHLD,Store,CStore,EXIT
\r
3614 $CODE NameHOLD,HOLD
\r
3622 ; I ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE
\r
3623 ; Push the innermost loop index.
\r
3625 ; : I rp@ [ 1 CELLS ] LITERAL + @
\r
3626 ; rp@ [ 2 CELLS ] LITERAL + @ + ; COMPILE-ONLY
\r
3629 ; DW RPFetch,DoLIT,CELLL,Plus,Fetch
\r
3630 ; DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT
\r
3638 ; IF Compilation: ( C: -- orig ) \ CORE
\r
3639 ; Run-time: ( x -- )
\r
3640 ; Put the location of a new unresolved forward reference orig
\r
3641 ; onto the control flow stack. On execution jump to location
\r
3642 ; specified by the resolution of orig if x is zero.
\r
3644 ; : IF POSTPONE 0branch xhere 0 code,
\r
3645 ; 1 bal+ \ orig type is 1
\r
3647 $COLON NameIFF,IFF
\r
3648 DW DoLIT,ZBranch,COMPILEComma,XHere,DoLIT,0,CodeComma
\r
3649 DW One,BalPlus,EXIT
\r
3651 ; INVERT ( x1 -- x2 ) \ CORE
\r
3652 ; Return one's complement of x1.
\r
3654 ; : INVERT -1 XOR ;
\r
3656 ; $COLON NameINVERT,INVERT
\r
3657 ; DW DoLIT,-1,XORR,EXIT
\r
3659 $CODE NameINVERT,INVERT
\r
3663 ; KEY ( -- char ) \ CORE
\r
3664 ; Receive a character. Do not display char.
\r
3666 ; : KEY EKEY max-char AND ;
\r
3668 $COLON NameKEY,KEY
\r
3669 DW EKEY,DoLIT,MaxChar,ANDD,EXIT
\r
3671 ; LITERAL Compilation: ( x -- ) \ CORE
\r
3672 ; Run-time: ( -- x )
\r
3673 ; Append following run-time semantics. Put x on the stack on
\r
3676 ; : LITERAL POSTPONE doLIT code, ; COMPILE-ONLY IMMEDIATE
\r
3678 $COLON NameLITERAL,LITERAL
\r
3679 DW DoLIT,DoLIT,COMPILEComma,CodeComma,EXIT
\r
3681 ; NEGATE ( n1 -- n2 ) \ CORE
\r
3682 ; Return two's complement of n1.
\r
3684 ; : NEGATE INVERT 1+ ;
\r
3686 ; $COLON NameNEGATE,NEGATE
\r
3687 ; DW INVERT,OnePlus,EXIT
\r
3689 $CODE NameNEGATE,NEGATE
\r
3693 ; NIP ( n1 n2 -- n2 ) \ CORE EXT
\r
3694 ; Discard the second stack item.
\r
3696 ; : NIP SWAP DROP ;
\r
3698 ; $COLON NameNIP,NIP
\r
3699 ; DW SWAP,DROP,EXIT
\r
3705 ; PARSE ( char "ccc<char>"-- c-addr u ) \ CORE EXT
\r
3706 ; Scan input stream and return counted string delimited by char.
\r
3708 ; : PARSE >R SOURCE >IN @ /STRING \ c-addr u R: char
\r
3710 ; OVER CHARS + OVER \ c-addr c-addr+u c-addr R: char
\r
3711 ; BEGIN DUP C@ R@ XOR
\r
3712 ; WHILE CHAR+ 2DUP =
\r
3713 ; UNTIL DROP OVER - 1chars/ DUP
\r
3714 ; ELSE NIP OVER - 1chars/ DUP CHAR+
\r
3716 ; THEN R> DROP EXIT ;
\r
3718 ; $COLON 5,'PARSE',PARSE,_FLINK
\r
3719 ; DW ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING
\r
3720 ; DW DUPP,ZBranch,PARSE4
\r
3721 ; DW OVER,CHARS,Plus,OVER
\r
3722 ; PARSE1 DW DUPP,CFetch,RFetch,XORR,ZBranch,PARSE3
\r
3723 ; DW CHARPlus,TwoDUP,Equals,ZBranch,PARSE1
\r
3724 ; PARSE2 DW DROP,OVER,Minus,DUPP,OneCharsSlash,Branch,PARSE5
\r
3725 ; PARSE3 DW NIP,OVER,Minus,DUPP,OneCharsSlash,CHARPlus
\r
3726 ; PARSE5 DW DoLIT,AddrToIN,PlusStore
\r
3727 ; PARSE4 DW RFrom,DROP,EXIT
\r
3729 $CODE NamePARSE,PARSE
\r
3732 MOV SI,AddrSourceVar+CELLL
\r
3733 MOV BX,AddrSourceVar
\r
3748 SUB SI,AddrSourceVar+CELLL
\r
3754 SUB SI,AddrSourceVar+CELLL
\r
3761 ; QUIT ( -- ) ( R: i*x -- ) \ CORE
\r
3762 ; Empty the return stack, store zero in SOURCE-ID, make the user
\r
3763 ; input device the input source, and start text interpreter.
\r
3766 ; rp0 rp! 0 TO SOURCE-ID 0 TO bal POSTPONE [
\r
3767 ; BEGIN CR REFILL DROP SPACE \ REFILL returns always true
\r
3768 ; ['] interpret CATCH ?DUP 0=
\r
3769 ; WHILE STATE @ 0= IF .prompt THEN
\r
3771 ; DUP -1 XOR IF \ ABORT
\r
3772 ; DUP -2 = IF SPACE abort"msg 2@ TYPE ELSE \ ABORT"
\r
3773 ; SPACE errWord 2@ TYPE
\r
3774 ; SPACE [CHAR] ? EMIT SPACE
\r
3775 ; DUP -1 -58 WITHIN IF ." Exception # " . ELSE \ undefined exception
\r
3776 ; CELLS THROWMsgTbl + @ COUNT TYPE THEN THEN THEN
\r
3780 $COLON NameQUIT,QUIT
\r
3781 QUIT1 DW RPZero,RPStore,DoLIT,0,DoTO,AddrSOURCE_ID
\r
3782 DW DoLIT,0,DoTO,AddrBal,LeftBracket
\r
3783 QUIT2 DW CR,REFILL,DROP,SPACE
\r
3784 DW DoLIT,Interpret,CATCH,QuestionDUP,ZeroEquals
\r
3786 DW DoLIT,AddrSTATE,Fetch,ZeroEquals,ZBranch,QUIT2
\r
3787 DW DotPrompt,Branch,QUIT2
\r
3788 QUIT3 DW DUPP,DoLIT,-1,XORR,ZBranch,QUIT5
\r
3789 DW DUPP,DoLIT,-2,Equals,ZBranch,QUIT4
\r
3790 DW SPACE,DoLIT,AddrAbortQMsg,TwoFetch,TYPEE,Branch,QUIT5
\r
3791 QUIT4 DW SPACE,DoLIT,AddrErrWord,TwoFetch,TYPEE
\r
3792 DW SPACE,DoLIT,'?',EMIT,SPACE
\r
3793 DW DUPP,DoLIT,-1,DoLIT,-58,WITHIN,ZBranch,QUIT7
\r
3795 DW COUNT,TYPEE,Dot,Branch,QUIT5
\r
3796 QUIT7 DW CELLS,DoLIT,AddrTHROWMsgTbl,Plus,Fetch,COUNT,TYPEE
\r
3797 QUIT5 DW SPZero,SPStore,Branch,QUIT1
\r
3799 ; REFILL ( -- flag ) \ CORE EXT
\r
3800 ; Attempt to fill the input buffer from the input source. Make
\r
3801 ; the result the input buffer, set >IN to zero, and return true
\r
3802 ; if successful. Return false if the input source is a string
\r
3805 ; : REFILL SOURCE-ID IF 0 EXIT THEN
\r
3806 ; memTop [ size-of-PAD CHARS ] LITERAL - DUP
\r
3807 ; size-of-PAD ACCEPT sourceVar 2!
\r
3810 $COLON NameREFILL,REFILL
\r
3811 DW SOURCE_ID,ZBranch,REFIL1
\r
3813 REFIL1 DW MemTop,DoLIT,0-PADSize*CHARR,Plus,DUPP
\r
3814 DW DoLIT,PADSize*CHARR,ACCEPT,DoLIT,AddrSourceVar,TwoStore
\r
3815 DW DoLIT,0,DoLIT,AddrToIN,Store,DoLIT,-1,EXIT
\r
3817 ; ROT ( x1 x2 x3 -- x2 x3 x1 ) \ CORE
\r
3818 ; Rotate the top three data stack items.
\r
3820 ; : ROT >R SWAP R> SWAP ;
\r
3822 ; $COLON NameROT,ROT
\r
3823 ; DW ToR,SWAP,RFrom,SWAP,EXIT
\r
3833 ; S>D ( n -- d ) \ CORE
\r
3834 ; Convert a single-cell number n to double-cell number.
\r
3838 ; $COLON NameSToD,SToD
\r
3839 ; DW DUPP,ZeroLess,EXIT
\r
3841 $CODE NameSToD,SToD
\r
3848 ; SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1) \ SEARCH
\r
3849 ; Search word list for a match with the given name.
\r
3850 ; Return execution token and -1 or 1 ( IMMEDIATE) if found.
\r
3851 ; Return 0 if not found.
\r
3853 ; : SEARCH-WORDLIST
\r
3854 ; (search-wordlist) DUP IF NIP THEN ;
\r
3856 $COLON NameSEARCH_WORDLIST,SEARCH_WORDLIST
\r
3857 DW ParenSearch_Wordlist,DUPP,ZBranch,SRCHW1
\r
3861 ; SIGN ( n -- ) \ CORE
\r
3862 ; Add a minus sign to the numeric output string if n is negative.
\r
3864 ; : SIGN 0< IF [CHAR] - HOLD THEN ;
\r
3866 ; $COLON NameSIGN,SIGN
\r
3867 ; DW ZeroLess,ZBranch,SIGN1
\r
3868 ; DW DoLIT,'-',HOLD
\r
3871 $CODE NameSIGN,SIGN
\r
3882 ; SOURCE ( -- c-addr u ) \ CORE
\r
3883 ; Return input buffer string.
\r
3885 ; : SOURCE sourceVar 2@ ;
\r
3887 $COLON NameSOURCE,SOURCE
\r
3888 DW DoLIT,AddrSourceVar,TwoFetch,EXIT
\r
3890 ; SPACE ( -- ) \ CORE
\r
3891 ; Send the blank character to the output device.
\r
3893 ; : SPACE 32 EMIT ;
\r
3895 ; $COLON NameSPACE,SPACE
\r
3896 ; DW DoLIT,' ',EMIT,EXIT
\r
3898 $CODE NameSPACE,SPACE
\r
3901 MOV AX,AddrTickEMIT
\r
3905 ; STATE ( -- a-addr ) \ CORE
\r
3906 ; Return the address of a cell containing compilation-state flag
\r
3907 ; which is true in compilation state or false otherwise.
\r
3909 $CONST NameSTATE,STATE,AddrSTATE
\r
3911 ; THEN Compilation: ( C: orig -- ) \ CORE
\r
3912 ; Run-time: ( -- )
\r
3913 ; Resolve the forward reference orig.
\r
3915 ; : THEN 1- IF -22 THROW THEN \ control structure mismatch
\r
3916 ; \ orig type is 1
\r
3917 ; xhere SWAP code! bal- ; COMPILE-ONLY IMMEDIATE
\r
3919 $COLON NameTHENN,THENN
\r
3920 DW OneMinus,ZBranch,THEN1
\r
3921 DW DoLIT,-22,THROW
\r
3922 THEN1 DW XHere,SWAP,CodeStore,BalMinus,EXIT
\r
3924 ; THROW ( k*x n -- k*x | i*x n ) \ EXCEPTION
\r
3925 ; If n is not zero, pop the topmost exception frame from the
\r
3926 ; exception stack, along with everything on the return stack
\r
3927 ; above the frame. Then restore the condition before CATCH and
\r
3928 ; transfer control just after the CATCH that pushed that
\r
3929 ; exception frame.
\r
3932 ; IF throwFrame @ rp! \ restore return stack
\r
3933 ; R> throwFrame ! \ restore THROW frame
\r
3934 ; R> SWAP >R sp! \ restore data stack
\r
3936 ; 'init-i/o EXECUTE
\r
3939 $COLON NameTHROW,THROW
\r
3940 DW QuestionDUP,ZBranch,THROW1
\r
3941 DW ThrowFrame,Fetch,RPStore,RFrom,ThrowFrame,Store
\r
3942 DW RFrom,SWAP,ToR,SPStore,DROP,RFrom
\r
3943 DW TickINIT_IO,EXECUTE
\r
3946 ; TYPE ( c-addr u -- ) \ CORE
\r
3947 ; Display the character string if u is greater than zero.
\r
3949 ; : TYPE ?DUP IF 0 DO DUP C@ EMIT CHAR+ LOOP THEN DROP ;
\r
3951 ; $COLON NameTYPEE,TYPEE
\r
3952 ; DW QuestionDUP,ZBranch,TYPE2
\r
3954 ; TYPE1 DW DUPP,CFetch,EMIT,CHARPlus,DoLOOP,TYPE1
\r
3955 ; TYPE2 DW DROP,EXIT
\r
3957 $CODE NameTYPEE,TYPEE
\r
3970 MOV SI,OFFSET TYPE3
\r
3971 MOV AX,AddrTickEMIT
\r
3973 TYPE1: DEC WORD PTR [BP]
\r
3981 ; U< ( u1 u2 -- flag ) \ CORE
\r
3982 ; Unsigned compare of top two items. True if u1 < u2.
\r
3984 ; : U< 2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;
\r
3986 ; $COLON NameULess,ULess
\r
3987 ; DW TwoDUP,XORR,ZeroLess
\r
3988 ; DW ZBranch,ULES1
\r
3989 ; DW NIP,ZeroLess,EXIT
\r
3990 ; ULES1 DW Minus,ZeroLess,EXIT
\r
3992 $CODE NameULess,ULess
\r
4000 ; UM* ( u1 u2 -- ud ) \ CORE
\r
4001 ; Unsigned multiply. Return double-cell product.
\r
4003 ; : UM* 0 SWAP cell-size-in-bits 0 DO
\r
4004 ; DUP um+ >R >R DUP um+ R> +
\r
4005 ; R> IF >R OVER um+ R> + THEN \ if carry
\r
4008 ; $COLON NameUMStar,UMStar
\r
4009 ; DW DoLIT,0,SWAP,DoLIT,CELLL*8,DoLIT,0,DoDO
\r
4010 ; UMST1 DW DUPP,UMPlus,ToR,ToR
\r
4011 ; DW DUPP,UMPlus,RFrom,Plus,RFrom
\r
4012 ; DW ZBranch,UMST2
\r
4013 ; DW ToR,OVER,UMPlus,RFrom,Plus
\r
4014 ; UMST2 DW DoLOOP,UMST1
\r
4015 ; DW ROT,DROP,EXIT
\r
4017 $CODE NameUMStar,UMStar
\r
4024 ; UM/MOD ( ud u1 -- u2 u3 ) \ CORE
\r
4025 ; Unsigned division of a double-cell number ud by a single-cell
\r
4026 ; number u1. Return remainder u2 and quotient u3.
\r
4028 ; : UM/MOD DUP 0= IF -10 THROW THEN \ divide by zero
\r
4030 ; NEGATE cell-size-in-bits 0
\r
4031 ; DO >R DUP um+ >R >R DUP um+ R> + DUP
\r
4032 ; R> R@ SWAP >R um+ R> OR
\r
4033 ; IF >R DROP 1+ R> THEN
\r
4036 ; LOOP DROP SWAP EXIT
\r
4037 ; ELSE -11 THROW \ result out of range
\r
4040 ; $COLON NameUMSlashMOD,UMSlashMOD
\r
4041 ; DW DUPP,ZBranch,UMM5
\r
4042 ; DW TwoDUP,ULess,ZBranch,UMM4
\r
4043 ; DW NEGATE,DoLIT,CELLL*8,DoLIT,0,DoDO
\r
4044 ; UMM1 DW ToR,DUPP,UMPlus,ToR,ToR,DUPP,UMPlus,RFrom,Plus,DUPP
\r
4045 ; DW RFrom,RFetch,SWAP,ToR,UMPlus,RFrom,ORR,ZBranch,UMM2
\r
4046 ; DW ToR,DROP,OnePlus,RFrom,Branch,UMM3
\r
4048 ; UMM3 DW RFrom,DoLOOP,UMM1
\r
4049 ; DW DROP,SWAP,EXIT
\r
4050 ; UMM5 DW DoLIT,-10,THROW
\r
4051 ; UMM4 DW DoLIT,-11,THROW
\r
4053 $CODE NameUMSlashMOD,UMSlashMOD
\r
4064 UMM1: MOV BX,-10 ;divide by zero
\r
4066 UMM2: MOV BX,-11 ;result out of range
\r
4070 ; UNLOOP ( -- ) ( R: loop-sys -- ) \ CORE
\r
4071 ; Discard loop-control parameters for the current nesting level.
\r
4072 ; An UNLOOP is required for each nesting level before the
\r
4073 ; definition may be EXITed.
\r
4075 ; : UNLOOP R> R> R> 2DROP >R ;
\r
4077 ; $COLON NameUNLOOP,UNLOOP
\r
4078 ; DW RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT
\r
4080 $CODE NameUNLOOP,UNLOOP
\r
4084 ; WITHIN ( n1|u1 n2|n2 n3|u3 -- flag ) \ CORE EXT
\r
4085 ; Return true if (n2|u2<=n1|u1 and n1|u1<n3|u3) or
\r
4086 ; (n2|u2>n3|u3 and (n2|u2<=n1|u1 or n1|u1<n3|u3)).
\r
4088 ; : WITHIN OVER - >R - R> U< ;
\r
4090 ; $COLON NameWITHIN,WITHIN
\r
4091 ; DW OVER,Minus,ToR ;ul <= u < uh
\r
4092 ; DW Minus,RFrom,ULess,EXIT
\r
4094 $CODE NameWITHIN,WITHIN
\r
4106 ; Enter interpretation state.
\r
4108 ; : [ 0 STATE ! ; COMPILE-ONLY IMMEDIATE
\r
4110 $COLON NameLeftBracket,LeftBracket
\r
4111 DW DoLIT,0,DoLIT,AddrSTATE,Store,EXIT
\r
4114 ; Enter compilation state.
\r
4116 ; : ] -1 STATE ! ;
\r
4118 $COLON NameRightBracket,RightBracket
\r
4119 DW DoLIT,-1,DoLIT,AddrSTATE,Store,EXIT
\r
4122 ; Rest of CORE words and two facility words, EKEY? and EMIT?
\r
4124 ; Following definitions can be removed from assembler source and
\r
4125 ; can be colon-defined later.
\r
4127 ; ( ( "ccc<)>" -- ) \ CORE
\r
4128 ; Ignore following string up to next ) . A comment.
\r
4130 ; : ( [CHAR] ) PARSE 2DROP ;
\r
4132 $COLON NameParen,Paren
\r
4133 DW DoLIT,')',PARSE,TwoDROP,EXIT
\r
4135 ; * ( n1|u1 n2|u2 -- n3|u3 ) \ CORE
\r
4136 ; Multiply n1|u1 by n2|u2 giving a single product.
\r
4140 ; $COLON NameStar,Star
\r
4141 ; DW UMStar,DROP,EXIT
\r
4143 $CODE NameStar,Star
\r
4149 ; */ ( n1 n2 n3 -- n4 ) \ CORE
\r
4150 ; Multiply n1 by n2 producing double-cell intermediate,
\r
4151 ; then divide it by n3. Return single-cell quotient.
\r
4153 ; : */ */MOD NIP ;
\r
4155 $COLON NameStarSlash,StarSlash
\r
4156 DW StarSlashMOD,NIP,EXIT
\r
4158 ; */MOD ( n1 n2 n3 -- n4 n5 ) \ CORE
\r
4159 ; Multiply n1 by n2 producing double-cell intermediate,
\r
4160 ; then divide it by n3. Return single-cell remainder and
\r
4161 ; single-cell quotient.
\r
4163 ; : */MOD >R M* R> FM/MOD ;
\r
4165 ; $COLON NameStarSlashMOD,StarSlashMOD
\r
4166 ; DW ToR,MStar,RFrom,FMSlashMOD,EXIT
\r
4168 $CODE NameStarSlashMOD,StarSlashMOD
\r
4177 ; +LOOP Compilation: ( C: do-sys -- ) \ CORE
\r
4178 ; Run-time: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\r
4179 ; Terminate a DO-+LOOP structure. Resolve the destination of all
\r
4180 ; unresolved occurences of LEAVE.
\r
4181 ; On execution add n to the loop index. If loop index did not
\r
4182 ; cross the boundary between loop_limit-1 and loop_limit,
\r
4183 ; continue execution at the beginning of the loop. Otherwise,
\r
4184 ; finish the loop.
\r
4186 ; : +LOOP POSTPONE do+LOOP rake ; COMPILE-ONLY IMMEDIATE
\r
4188 $COLON NamePlusLOOP,PlusLOOP
\r
4189 DW DoLIT,DoPLOOP,COMPILEComma,rake,EXIT
\r
4191 ; ." ( "ccc<">" -- ) \ CORE
\r
4193 ; Compile an inline string literal to be typed out at run time.
\r
4195 ; : ." POSTPONE S" POSTPONE TYPE ; COMPILE-ONLY IMMEDIATE
\r
4197 $COLON NameDotQuote,DotQuote
\r
4198 DW SQuote,DoLIT,TYPEE,COMPILEComma,EXIT
\r
4200 ; 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) \ CORE
\r
4201 ; Copy cell pair x1 x2 to the top of the stack.
\r
4203 ; : 2OVER >R >R 2DUP R> R> 2SWAP ;
\r
4205 ; $COLON NameTwoOVER,TwoOVER
\r
4206 ; DW ToR,ToR,TwoDUP,RFrom,RFrom,TwoSWAP,EXIT
\r
4208 $CODE NameTwoOVER,TwoOVER
\r
4215 ; >BODY ( xt -- a-addr ) \ CORE
\r
4216 ; Push data field address of CREATEd word.
\r
4218 ; : >BODY ?call DUP IF \ code-addr xt2
\r
4219 ; ['] doCREATE = IF \ should be call-doCREATE
\r
4220 ; CELL+ code@ EXIT
\r
4222 ; -31 THROW ; \ >BODY used on non-CREATEd definition
\r
4224 $COLON NameToBODY,ToBODY
\r
4225 DW QCall,DUPP,ZBranch,TBODY1
\r
4226 DW DoLIT,DoCREATE,Equals,ZBranch,TBODY1
\r
4227 DW CELLPlus,CodeFetch,EXIT
\r
4228 TBODY1 DW DoLIT,-31,THROW
\r
4230 ; ABORT" ( "ccc<">" -- ) \ EXCEPTION EXT
\r
4231 ; Run-time ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )
\r
4232 ; Conditional abort with an error message.
\r
4234 ; : ABORT" S" POSTPONE ROT
\r
4235 ; POSTPONE IF POSTPONE abort"msg POSTPONE 2!
\r
4236 ; -2 POSTPONE LITERAL POSTPONE THROW
\r
4237 ; POSTPONE ELSE POSTPONE 2DROP POSTPONE THEN
\r
4238 ; ; COMPILE-ONLY IMMEDIATE
\r
4240 $COLON NameABORTQuote,ABORTQuote
\r
4241 DW SQuote,DoLIT,ROT,COMPILEComma
\r
4242 DW IFF,DoLIT,AbortQMsg,COMPILEComma ; IF is immediate
\r
4243 DW DoLIT,TwoStore,COMPILEComma
\r
4244 DW DoLIT,-2,LITERAL ; LITERAL is immediate
\r
4245 DW DoLIT,THROW,COMPILEComma
\r
4246 DW ELSEE,DoLIT,TwoDROP,COMPILEComma ; ELSE and THEN are
\r
4247 DW THENN,EXIT ; immediate
\r
4249 ; ABS ( n -- u ) \ CORE
\r
4250 ; Return the absolute value of n.
\r
4252 ; : ABS DUP 0< IF NEGATE THEN ;
\r
4254 ; $COLON NameABSS,ABSS
\r
4255 ; DW DUPP,ZeroLess,ZBranch,ABS1
\r
4259 $CODE NameABSS,ABSS
\r
4265 ; ALLOT ( n -- ) \ CORE
\r
4266 ; Allocate n bytes in data space.
\r
4268 ; : ALLOT HERE + TO HERE ;
\r
4270 $COLON NameALLOT,ALLOT
\r
4271 DW HERE,Plus,DoTO,AddrHERE,EXIT
\r
4273 ; BEGIN ( C: -- dest ) \ CORE
\r
4274 ; Start an infinite or indefinite loop structure. Put the next
\r
4275 ; location for a transfer of control, dest, onto the data
\r
4278 ; : BEGIN xhere 0 bal+ \ dest type is 0
\r
4279 ; ; COMPILE-ONLY IMMDEDIATE
\r
4281 $COLON NameBEGIN,BEGIN
\r
4282 DW XHere,DoLIT,0,BalPlus,EXIT
\r
4284 ; C, ( char -- ) \ CORE
\r
4285 ; Compile a character into data space.
\r
4287 ; : C, HERE C! HERE CHAR+ TO HERE ;
\r
4289 ; $COLON NameCComma,CComma
\r
4290 ; DW HERE,CStore,HERE,CHARPlus,DoTO,AddrHERE,EXIT
\r
4292 $CODE NameCComma,CComma
\r
4300 ; CHAR ( "<spaces>ccc" -- char ) \ CORE
\r
4301 ; Parse next word and return the value of first character.
\r
4303 ; : CHAR PARSE-WORD DROP C@ ;
\r
4305 $COLON NameCHAR,CHAR
\r
4306 DW PARSE_WORD,DROP,CFetch,EXIT
\r
4308 ; DO Compilation: ( C: -- do-sys ) \ CORE
\r
4309 ; Run-time: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )
\r
4310 ; Start a DO-LOOP structure in a colon definition. Place do-sys
\r
4311 ; on control-flow stack, which will be resolved by LOOP or +LOOP.
\r
4313 ; : DO 0 rakeVar ! 0 \ ?DO-orig is 0 for DO
\r
4314 ; POSTPONE doDO xhere bal+ \ DO-dest
\r
4317 DW DoLIT,0,RakeVar,Store,DoLIT,0
\r
4318 DW DoLIT,DoDO,COMPILEComma,XHere,BalPlus,EXIT
\r
4320 ; DOES> ( C: colon-sys1 -- colon-sys2 ) \ CORE
\r
4321 ; Build run time code of the data object CREATEd.
\r
4323 ; : DOES> bal 1- IF -22 THROW THEN \ control structure mismatch
\r
4324 ; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1
\r
4325 ; POSTPONE pipe ['] doLIST xt, -1 ; COMPILE-ONLY IMMEDIATE
\r
4327 $COLON NameDOESGreater,DOESGreater
\r
4328 DW Bal,OneMinus,ZBranch,DOES1
\r
4329 DW DoLIT,-22,THROW
\r
4330 DOES1 DW NIP,OnePlus,ZBranch,DOES2
\r
4331 DW DoLIT,-22,THROW
\r
4332 DOES2 DW DoLIT,Pipe,COMPILEComma
\r
4333 DW DoLIT,DoLIST,xtComma,DoLIT,-1,EXIT
\r
4335 ; ELSE Compilation: ( C: orig1 -- orig2 ) \ CORE
\r
4336 ; Run-time: ( -- )
\r
4337 ; Start the false clause in an IF-ELSE-THEN structure.
\r
4338 ; Put the location of new unresolved forward reference orig2
\r
4339 ; onto control-flow stack.
\r
4341 ; : ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMDEDIATE
\r
4343 $COLON NameELSEE,ELSEE
\r
4344 DW AHEAD,TwoSWAP,THENN,EXIT
\r
4346 ; ENVIRONMENT? ( c-addr u -- false | i*x true ) \ CORE
\r
4347 ; Environment query.
\r
4350 ; envQList SEARCH-WORDLIST
\r
4351 ; DUP >R IF EXECUTE THEN R> ;
\r
4353 $COLON NameENVIRONMENTQuery,ENVIRONMENTQuery
\r
4354 DW DoLIT,AddrEnvQList,SEARCH_WORDLIST
\r
4355 DW DUPP,ToR,ZBranch,ENVRN1
\r
4357 ENVRN1 DW RFrom,EXIT
\r
4359 ; EVALUATE ( i*x c-addr u -- j*x ) \ CORE
\r
4360 ; Evaluate the string. Save the input source specification.
\r
4361 ; Store -1 in SOURCE-ID.
\r
4363 ; : EVALUATE SOURCE >R >R >IN @ >R SOURCE-ID >R
\r
4365 ; sourceVar 2! 0 >IN ! interpret
\r
4367 ; R> >IN ! R> R> sourceVar 2! ;
\r
4369 $COLON NameEVALUATE,EVALUATE
\r
4370 DW SOURCE,ToR,ToR,DoLIT,AddrToIN,Fetch,ToR,SOURCE_ID,ToR
\r
4371 DW DoLIT,-1,DoTO,AddrSOURCE_ID
\r
4372 DW DoLIT,AddrSourceVar,TwoStore,DoLIT,0,DoLIT,AddrToIN,Store,Interpret
\r
4373 DW RFrom,DoTO,AddrSOURCE_ID
\r
4374 DW RFrom,DoLIT,AddrToIN,Store,RFrom,RFrom,DoLIT,AddrSourceVar,TwoStore,EXIT
\r
4376 ; FILL ( c-addr u char -- ) \ CORE
\r
4377 ; Store char in each of u consecutive characters of memory
\r
4378 ; beginning at c-addr.
\r
4380 ; : FILL ROT ROT ?DUP IF 0 DO 2DUP C! CHAR+ LOOP THEN 2DROP ;
\r
4382 ; $COLON NameFILL,FILL
\r
4383 ; DW ROT,ROT,QuestionDUP,ZBranch,FILL2
\r
4385 ; FILL1 DW TwoDUP,CStore,CHARPlus,DoLOOP,FILL1
\r
4386 ; FILL2 DW TwoDROP,EXIT
\r
4388 $CODE NameFILL,FILL
\r
4405 ; FIND ( c-addr -- c-addr 0 | xt 1 | xt -1) \ SEARCH
\r
4406 ; Search dictionary for a match with the given counted name.
\r
4407 ; Return execution token and -1 or 1 ( IMMEDIATE) if found;
\r
4408 ; c-addr 0 if not found.
\r
4410 ; : FIND DUP COUNT search-word ?DUP IF NIP ROT DROP EXIT THEN
\r
4413 $COLON NameFIND,FIND
\r
4414 DW DUPP,COUNT,Search_word,QuestionDUP,ZBranch,FIND1
\r
4415 DW NIP,ROT,DROP,EXIT
\r
4416 FIND1 DW TwoDROP,DoLIT,0,EXIT
\r
4418 ; IMMEDIATE ( -- ) \ CORE
\r
4419 ; Make the most recent definition an immediate word.
\r
4421 ; : IMMEDIATE lastName [ =immed ] LITERAL OVER @ OR SWAP ! ;
\r
4423 $COLON NameIMMEDIATE,IMMEDIATE
\r
4424 DW LastName,DoLIT,IMMED,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
4426 ; J ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE
\r
4427 ; Push the index of next outer loop.
\r
4429 ; : J rp@ [ 3 CELLS ] LITERAL + @
\r
4430 ; rp@ [ 4 CELLS ] LITERAL + @ + ; COMPILE-ONLY
\r
4433 ; DW RPFetch,DoLIT,3*CELLL,Plus,Fetch
\r
4434 ; DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT
\r
4438 MOV BX,[BP+2*CELLL]
\r
4439 ADD BX,[BP+3*CELLL]
\r
4442 ; LEAVE ( -- ) ( R: loop-sys -- ) \ CORE
\r
4443 ; Terminate definite loop, DO|?DO ... LOOP|+LOOP, immediately.
\r
4445 ; : LEAVE POSTPONE UNLOOP POSTPONE branch
\r
4446 ; xhere rakeVar DUP @ code, ! ; COMPILE-ONLY IMMEDIATE
\r
4448 $COLON NameLEAVEE,LEAVEE
\r
4449 DW DoLIT,UNLOOP,COMPILEComma,DoLIT,Branch,COMPILEComma
\r
4450 DW XHere,DoLIT,AddrRakeVar,DUPP,Fetch,CodeComma,Store,EXIT
\r
4452 ; LOOP Compilation: ( C: do-sys -- ) \ CORE
\r
4453 ; Run-time: ( -- ) ( R: loop-sys1 -- loop-sys2 )
\r
4454 ; Terminate a DO|?DO ... LOOP structure. Resolve the destination
\r
4455 ; of all unresolved occurences of LEAVE.
\r
4457 ; : LOOP POSTPONE doLOOP rake ; COMPILE-ONLY IMMEDIATE
\r
4459 $COLON NameLOOPP,LOOPP
\r
4460 DW DoLIT,DoLOOP,COMPILEComma,rake,EXIT
\r
4462 ; LSHIFT ( x1 u -- x2 ) \ CORE
\r
4463 ; Perform a logical left shift of u bit-places on x1, giving x2.
\r
4464 ; Put 0 into the least significant bits vacated by the shift.
\r
4466 ; : LSHIFT ?DUP IF 0 DO 2* LOOP THEN ;
\r
4468 ; $COLON NameLSHIFT,LSHIFT
\r
4469 ; DW QuestionDUP,ZBranch,LSHIFT2
\r
4471 ; LSHIFT1 DW TwoStar,DoLOOP,LSHIFT1
\r
4474 $CODE NameLSHIFT,LSHIFT
\r
4482 ; M* ( n1 n2 -- d ) \ CORE
\r
4483 ; Signed multiply. Return double product.
\r
4485 ; : M* 2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;
\r
4487 ; $COLON NameMStar,MStar
\r
4488 ; DW TwoDUP,XORR,ZeroLess,ToR,ABSS,SWAP,ABSS
\r
4489 ; DW UMStar,RFrom,ZBranch,MSTAR1
\r
4493 $CODE NameMStar,MStar
\r
4500 ; MAX ( n1 n2 -- n3 ) \ CORE
\r
4501 ; Return the greater of two top stack items.
\r
4503 ; : MAX 2DUP < IF SWAP THEN DROP ;
\r
4505 ; $COLON NameMAX,MAX
\r
4506 ; DW TwoDUP,LessThan,ZBranch,MAX1
\r
4508 ; MAX1 DW DROP,EXIT
\r
4517 ; MIN ( n1 n2 -- n3 ) \ CORE
\r
4518 ; Return the smaller of top two stack items.
\r
4520 ; : MIN 2DUP > IF SWAP THEN DROP ;
\r
4522 ; $COLON NameMIN,MIN
\r
4523 ; DW TwoDUP,GreaterThan,ZBranch,MIN1
\r
4525 ; MIN1 DW DROP,EXIT
\r
4534 ; MOD ( n1 n2 -- n3 ) \ CORE
\r
4535 ; Divide n1 by n2, giving the single cell remainder n3.
\r
4536 ; Returns modulo of floored division in this implementation.
\r
4538 ; : MOD /MOD DROP ;
\r
4540 $COLON NameMODD,MODD
\r
4541 DW SlashMOD,DROP,EXIT
\r
4543 ; PICK ( x_u ... x1 x0 u -- x_u ... x1 x0 x_u ) \ CORE EXT
\r
4544 ; Remove u and copy the uth stack item to top of the stack. An
\r
4545 ; ambiguous condition exists if there are less than u+2 items
\r
4546 ; on the stack before PICK is executed.
\r
4548 ; : PICK DEPTH DUP 2 < IF -4 THROW THEN \ stack underflow
\r
4549 ; 2 - OVER U< IF -4 THROW THEN
\r
4550 ; 1+ CELLS sp@ + @ ;
\r
4552 ; $COLON NamePICK,PICK
\r
4553 ; DW DEPTH,DUPP,DoLIT,2,LessThan,ZBranch,PICK1
\r
4554 ; DW DoLIT,-4,THROW
\r
4555 ; PICK1 DW DoLIT,2,Minus,OVER,ULess,ZBranch,PICK2
\r
4556 ; DW DoLIT,-4,THROW
\r
4557 ; PICK2 DW OnePlus,CELLS,SPFetch,Plus,Fetch,EXIT
\r
4559 $CODE NamePICK,PICK
\r
4561 MOV DI,[DI+CELLL] ; sp0
\r
4563 SAR DI,1 ; depth-1 in DI
\r
4576 ; POSTPONE ( "<spaces>name" -- ) \ CORE
\r
4577 ; Parse name and find it. Append compilation semantics of name
\r
4578 ; to current definition.
\r
4579 ; Structure of words with special compilation action
\r
4580 ; for default compilation behavior
\r
4581 ; |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |
\r
4583 ; : POSTPONE (') 0< IF
\r
4584 ; specialComp? OVER = IF \ special compilation action
\r
4585 ; DUP POSTPONE LITERAL
\r
4586 ; cell- cell- code@
\r
4587 ; POSTPONE LITERAL
\r
4588 ; POSTPONE EXECUTE EXIT THEN
\r
4589 ; POSTPONE LITERAL \ non-IMMEDIATE
\r
4590 ; POSTPONE code, EXIT THEN
\r
4591 ; code, ; COMPILE-ONLY IMMEDIATE \ IMMEDIATE
\r
4593 $COLON NamePOSTPONE,POSTPONE
\r
4594 DW ParenTick,ZeroLess,ZBranch,POSTP1
\r
4595 DW SpecialCompQ,OVER,Equals,ZBranch,POSTP2
\r
4596 DW DUPP,LITERAL,CellMinus,CellMinus,CodeFetch
\r
4597 DW LITERAL,DoLIT,EXECUTE,CodeComma,EXIT
\r
4598 POSTP2 DW LITERAL,DoLIT,CodeComma
\r
4599 POSTP1 DW CodeComma,EXIT
\r
4601 ; RECURSE ( -- ) \ CORE
\r
4602 ; Append the execution semactics of the current definition to
\r
4603 ; the current definition.
\r
4605 ; : RECURSE bal 1- 2* PICK 1+ IF -22 THROW THEN
\r
4606 ; \ control structure mismatch; colon-sys type is -1
\r
4607 ; bal 1- 2* 1+ PICK \ xt of current definition
\r
4608 ; COMPILE, ; COMPILE-ONLY IMMEDIATE
\r
4610 $COLON NameRECURSE,RECURSE
\r
4611 DW Bal,OneMinus,TwoStar,PICK,OnePlus,ZBranch,RECUR1
\r
4612 DW DoLIT,-22,THROW
\r
4613 RECUR1 DW Bal,OneMinus,TwoStar,OnePlus,PICK
\r
4614 DW COMPILEComma,EXIT
\r
4616 ; REPEAT ( C: orig dest -- ) \ CORE
\r
4617 ; Terminate a BEGIN-WHILE-REPEAT indefinite loop. Resolve
\r
4618 ; backward reference dest and forward reference orig.
\r
4620 ; : REPEAT AGAIN THEN ; COMPILE-ONLY IMMEDIATE
\r
4622 $COLON NameREPEAT,REPEATT
\r
4623 DW AGAIN,THENN,EXIT
\r
4625 ; RSHIFT ( x1 u -- x2 ) \ CORE
\r
4626 ; Perform a logical right shift of u bit-places on x1, giving x2.
\r
4627 ; Put 0 into the most significant bits vacated by the shift.
\r
4629 ; : RSHIFT ?DUP IF
\r
4630 ; 0 SWAP cell-size-in-bits SWAP -
\r
4631 ; 0 DO 2DUP D+ LOOP
\r
4635 ; $COLON NameRSHIFT,RSHIFT
\r
4636 ; DW QuestionDUP,ZBranch,RSHIFT2
\r
4637 ; DW DoLIT,0,SWAP,DoLIT,CELLL*8,SWAP,Minus,DoLIT,0,DoDO
\r
4638 ; RSHIFT1 DW TwoDUP,DPlus,DoLOOP,RSHIFT1
\r
4642 $CODE NameRSHIFT,RSHIFT
\r
4650 ; SLITERAL ( c-addr1 u -- ) \ STRING
\r
4651 ; Run-time ( -- c-addr2 u )
\r
4652 ; Compile a string literal. Return the string on execution.
\r
4654 ; : SLITERAL ALIGN HERE LITERAL DUP LITERAL
\r
4655 ; CHARS HERE 2DUP + ALIGNED TO HERE
\r
4656 ; SWAP MOVE ; COMPILE-ONLY IMMEDIATE
\r
4658 $COLON NameSLITERAL,SLITERAL
\r
4659 DW ALIGNN,HERE,LITERAL,DUPP,LITERAL
\r
4660 DW CHARS,HERE,TwoDUP,Plus,ALIGNED,DoTO,AddrHERE
\r
4663 ; S" Compilation: ( "ccc<">" -- ) \ CORE
\r
4664 ; Run-time: ( -- c-addr u )
\r
4665 ; Parse ccc delimetered by " . Return the string specification
\r
4666 ; c-addr u on execution.
\r
4668 ; : S" [CHAR] " PARSE POSTPONE SLITERAL ; COMPILE-ONLY IMMEDIATE
\r
4670 $COLON NameSQuote,SQuote
\r
4671 DW DoLIT,'"',PARSE,SLITERAL,EXIT
\r
4673 ; SM/REM ( d n1 -- n2 n3 ) \ CORE
\r
4674 ; Symmetric divide of double by single. Return remainder n2
\r
4675 ; and quotient n3.
\r
4677 ; : SM/REM OVER >R >R DUP 0< IF DNEGATE THEN
\r
4678 ; R@ ABS UM/MOD DUP 0<
\r
4679 ; IF DUP 08000h XOR IF -11 THROW THEN THEN \ result out of range
\r
4680 ; R> R@ XOR 0< IF NEGATE THEN
\r
4681 ; R> 0< IF SWAP NEGATE SWAP THEN ;
\r
4683 ; $COLON 6,'SM/REM',SMSlashREM,_FLINK
\r
4684 ; DW OVER,ToR,ToR,DUPP,ZeroLess,ZBranch,SMREM1
\r
4686 ; SMREM1 DW RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,SMREM4
\r
4687 ; DW DUPP,DoLIT,08000h,XORR,ZBranch,SMREM4
\r
4688 ; DW DoLIT,-11,THROW
\r
4689 ; SMREM4 DW RFrom,RFetch,XORR,ZeroLess,ZBranch,SMREM2
\r
4691 ; SMREM2 DW RFrom,ZeroLess,ZBranch,SMREM3
\r
4692 ; DW SWAP,NEGATE,SWAP
\r
4695 $CODE NameSMSlashREM,SMSlashREM
\r
4705 DIV BX ;positive dividend, positive divisor
\r
4711 SMREM3: NEG BX ;positive dividend, negative divisor
\r
4721 SMREM2: NEG AX ;DNEGATE
\r
4727 CMP DX,BX ;negative dividend, positive divisor
\r
4737 SMREM4: NEG BX ;negative dividend, negative divisor
\r
4747 SMREM6: MOV BX,-11 ;result out of range
\r
4749 SMREM1: MOV BX,-10 ;divide by zero
\r
4753 ; SPACES ( n -- ) \ CORE
\r
4754 ; Send n spaces to the output device if n is greater than zero.
\r
4756 ; : SPACES DUP 0 > IF 0 DO SPACE LOOP EXIT THEN DROP;
\r
4758 ; $COLON 6,'SPACES',SPACES,_FLINK
\r
4759 ; DW DUPP,Zero,GreaterThan,ZBranch,SPACES1
\r
4761 ; SPACES2 DW SPACE,DoLOOP,SPACES2
\r
4763 ; SPACES1 DW DROP,EXIT
\r
4765 $CODE NameSPACES,SPACES
\r
4773 MOV SI,OFFSET SPACES3
\r
4774 MOV AX,AddrTickEMIT
\r
4776 SPACES1: DEC WORD PTR [BP]
\r
4782 SPACES3 DW SPACES1
\r
4784 ; TO Interpretation: ( x "<spaces>name" -- ) \ CORE EXT
\r
4785 ; Compilation: ( "<spaces>name" -- )
\r
4786 ; Run-time: ( x -- )
\r
4787 ; Store x in name.
\r
4789 ; : TO ' ?call ?DUP IF \ should be CALL
\r
4790 ; ['] doVALUE = \ verify VALUE marker
\r
4791 ; IF code@ STATE @
\r
4792 ; IF POSTPONE doTO code, EXIT THEN
\r
4795 ; -32 THROW ; IMMEDIATE \ invalid name argument (e.g. TO xxx)
\r
4798 DW Tick,QCall,QuestionDUP,ZBranch,TO1
\r
4799 DW DoLIT,DoVALUE,Equals,ZBranch,TO1
\r
4800 DW CodeFetch,DoLIT,AddrSTATE,Fetch,ZBranch,TO2
\r
4801 DW DoLIT,DoTO,COMPILEComma,CodeComma,EXIT
\r
4803 TO1 DW DoLIT,-32,THROW
\r
4805 ; U. ( u -- ) \ CORE
\r
4806 ; Display u in free field format followed by space.
\r
4810 $COLON NameUDot,UDot
\r
4811 DW DoLIT,0,DDot,EXIT
\r
4813 ; UNTIL ( C: dest -- ) \ CORE
\r
4814 ; Terminate a BEGIN-UNTIL indefinite loop structure.
\r
4816 ; : UNTIL IF -22 THROW THEN \ control structure mismatch; dest type is 0
\r
4817 ; POSTPONE 0branch code, bal- ; COMPILE-ONLY IMMEDIATE
\r
4819 $COLON NameUNTIL,UNTIL
\r
4821 DW DoLIT,-22,THROW
\r
4822 UNTIL1 DW DoLIT,ZBranch,COMPILEComma,CodeComma,BalMinus,EXIT
\r
4824 ; VALUE ( x "<spaces>name" -- ) \ CORE EXT
\r
4825 ; name Execution: ( -- x )
\r
4826 ; Create a value object with initial value x.
\r
4828 ; : VALUE bal IF -29 THROW THEN \ compiler nesting
\r
4829 ; xhere ALIGNED CELL+ TO xhere
\r
4830 ; ['] doVALUE xt, head,
\r
4831 ; ALIGN HERE code,
\r
4832 ; , linkLast ; \ store x and link CREATEd word to current wordlist
\r
4834 $COLON NameVALUE,VALUE
\r
4835 DW Bal,ZBranch,VALUE1
\r
4836 DW DoLIT,-29,THROW
\r
4837 VALUE1 DW XHere,ALIGNED,CELLPlus,DoTO,AddrXHere
\r
4838 DW DoLIT,DoVALUE,xtComma,HeadComma
\r
4839 DW ALIGNN,HERE,CodeComma
\r
4840 DW Comma,LinkLast,EXIT
\r
4842 ; VARIABLE ( "<spaces>name" -- ) \ CORE
\r
4843 ; name Execution: ( -- a-addr )
\r
4844 ; Parse a name and create a variable with the name.
\r
4845 ; Resolve one cell of data space at an aligned address.
\r
4846 ; Return the address on execution.
\r
4848 ; : VARIABLE bal IF -29 THROW THEN \ compiler nesting
\r
4849 ; xhere ALIGNED TO xhere
\r
4850 ; ['] compileCONST code,
\r
4851 ; xhere CELL+ TO xhere
\r
4852 ; ['] doCONST xt, head,
\r
4854 ; 1 CELLS ALLOT \ allocate one cell in data space
\r
4856 ; lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;
\r
4858 $COLON NameVARIABLE,VARIABLE
\r
4859 DW Bal,ZBranch,VARIA1
\r
4860 DW DoLIT,-29,THROW
\r
4861 VARIA1 DW XHere,ALIGNED,DoTO,AddrXHere
\r
4862 DW DoLIT,CompileCONST,CodeComma
\r
4863 DW XHere,CELLPlus,DoTO,AddrXHere
\r
4864 DW DoLIT,DoCONST,xtComma,HeadComma
\r
4865 DW ALIGNN,HERE,DoLIT,1*CELLL,ALLOT
\r
4866 DW CodeComma,LinkLast
\r
4867 DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT
\r
4869 ; WHILE ( C: dest -- orig dest ) \ CORE
\r
4870 ; Put the location of a new unresolved forward reference orig
\r
4871 ; onto the control flow stack under the existing dest. Typically
\r
4872 ; used in BEGIN ... WHILE ... REPEAT structure.
\r
4874 ; : WHILE POSTPONE IF 2SWAP ; COMPILE-ONLY IMMEDIATE
\r
4876 $COLON NameWHILE,WHILEE
\r
4877 DW IFF,TwoSWAP,EXIT
\r
4879 ; WORD ( char "<chars>ccc<char>" -- c-addr ) \ CORE
\r
4880 ; Skip leading delimeters and parse a word. Return the address
\r
4881 ; of a transient region containing the word as counted string.
\r
4883 ; : WORD skipPARSE HERE pack" DROP HERE ;
\r
4885 $COLON NameWORDD,WORDD
\r
4886 DW SkipPARSE,HERE,PackQuote,DROP,HERE,EXIT
\r
4888 ; ['] Compilation: ( "<spaces>name" -- ) \ CORE
\r
4889 ; Run-time: ( -- xt )
\r
4890 ; Parse name. Return the execution token of name on execution.
\r
4892 ; : ['] ' POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE
\r
4894 $COLON NameBracketTick,BracketTick
\r
4895 DW Tick,LITERAL,EXIT
\r
4897 ; [CHAR] Compilation: ( "<spaces>name" -- ) \ CORE
\r
4898 ; Run-time: ( -- char )
\r
4899 ; Parse name. Return the value of the first character of name
\r
4902 ; : [CHAR] CHAR POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE
\r
4904 $COLON NameBracketCHAR,BracketCHAR
\r
4905 DW CHAR,LITERAL,EXIT
\r
4907 ; \ ( "ccc<eol>" -- ) \ CORE EXT
\r
4908 ; Parse and discard the remainder of the parse area.
\r
4910 ; : \ SOURCE >IN ! DROP ; IMMEDIATE
\r
4912 $COLON NameBackslash,Backslash
\r
4913 DW SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT
\r
4915 ; Optional Facility words
\r
4917 ; EKEY? ( -- flag ) \ FACILITY EXT
\r
4918 ; If a keyboard event is available, return true.
\r
4920 ; : EKEY? 'ekey? EXECUTE ;
\r
4922 ; $COLON NameEKEYQuestion,EKEYQuestion
\r
4923 ; DW TickEKEYQ,EXECUTE,EXIT
\r
4925 $CODE NameEKEYQuestion,EKEYQuestion
\r
4926 MOV AX,AddrTickEKEYQ
\r
4930 ; EMIT? ( -- flag ) \ FACILITY EXT
\r
4931 ; flag is true if the user output device is ready to accept data
\r
4932 ; and the execution of EMIT in place of EMIT? would not have
\r
4933 ; suffered an indefinite delay. If device state is indeterminate,
\r
4936 ; : EMIT? 'emit? EXECUTE ;
\r
4938 ; $COLON NameEMITQuestion,EMITQuestion
\r
4939 ; DW TickEMITQ,EXECUTE,EXIT
\r
4941 $CODE NameEMITQuestion,EMITQuestion
\r
4942 MOV AX,AddrTickEMITQ
\r
4946 ;===============================================================
\r
4948 CTOP DB (0FFFEh-($-XSysStatus)) DUP (?)
\r
4949 ;code segment occupies 64KB
\r
4953 ;===============================================================
\r
public / hf86v099.git / blob