From 60cfebfcfa400a0a7bfd3268265fc2e9b0c90e5d Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Sun, 4 Nov 2018 11:09:09 +0800
Subject: [PATCH] Initial CamelForth commit
---
Source/HBIOS/Forth/Build.cmd | 17 +
Source/HBIOS/Forth/Clean.cmd | 7 +
Source/HBIOS/Forth/camel80.azm | 1043 ++++++++
Source/HBIOS/Forth/camel80.bin | Bin 0 -> 5632 bytes
Source/HBIOS/Forth/camel80.hex | 354 +++
Source/HBIOS/Forth/camel80.prn | 4464 +++++++++++++++++++++++++++++++
Source/HBIOS/Forth/camel80d.azm | 154 ++
Source/HBIOS/Forth/camel80h.azm | 1024 +++++++
Source/HBIOS/Forth/cameltst.azm | 93 +
Source/HBIOS/Forth/camldump.azm | 7 +
Source/HBIOS/Forth/copying | 674 +++++
Source/HBIOS/Forth/glosshi.txt | 184 ++
Source/HBIOS/Forth/glosslo.txt | 112 +
Source/HBIOS/Forth/readme.z80 | 167 +-
14 files changed, 8299 insertions(+), 1 deletion(-)
create mode 100644 Source/HBIOS/Forth/Build.cmd
create mode 100644 Source/HBIOS/Forth/Clean.cmd
create mode 100644 Source/HBIOS/Forth/camel80.azm
create mode 100644 Source/HBIOS/Forth/camel80.bin
create mode 100644 Source/HBIOS/Forth/camel80.hex
create mode 100644 Source/HBIOS/Forth/camel80.prn
create mode 100644 Source/HBIOS/Forth/camel80d.azm
create mode 100644 Source/HBIOS/Forth/camel80h.azm
create mode 100644 Source/HBIOS/Forth/cameltst.azm
create mode 100644 Source/HBIOS/Forth/camldump.azm
create mode 100644 Source/HBIOS/Forth/copying
create mode 100644 Source/HBIOS/Forth/glosshi.txt
create mode 100644 Source/HBIOS/Forth/glosslo.txt
diff --git a/Source/HBIOS/Forth/Build.cmd b/Source/HBIOS/Forth/Build.cmd
new file mode 100644
index 00000000..a332af02
--- /dev/null
+++ b/Source/HBIOS/Forth/Build.cmd
@@ -0,0 +1,17 @@
+@echo off
+setlocal
+
+set TOOLS=../../../Tools
+
+set PATH=%TOOLS%\tasm32;%TOOLS%\zx;%PATH%
+
+set TASMTABS=%TOOLS%\tasm32
+
+set ZXBINDIR=%TOOLS%/cpm/bin/
+set ZXLIBDIR=%TOOLS%/cpm/lib/
+set ZXINCDIR=%TOOLS%/cpm/include/
+
+zx z80mr camel80
+zx MLOAD25 -camel80.bin=camel80.hex
+
+goto :eof
diff --git a/Source/HBIOS/Forth/Clean.cmd b/Source/HBIOS/Forth/Clean.cmd
new file mode 100644
index 00000000..e2e6145a
--- /dev/null
+++ b/Source/HBIOS/Forth/Clean.cmd
@@ -0,0 +1,7 @@
+@echo off
+setlocal
+
+if exist *.bin del *.bin
+if exist *.lst del *.lst
+if exist *.prn del *.prn
+if exist *.hex del *.hex
diff --git a/Source/HBIOS/Forth/camel80.azm b/Source/HBIOS/Forth/camel80.azm
new file mode 100644
index 00000000..07ae6330
--- /dev/null
+++ b/Source/HBIOS/Forth/camel80.azm
@@ -0,0 +1,1043 @@
+
+; Listing 2.
+; ===============================================
+; CamelForth for the Zilog Z80
+; Copyright (c) 1994,1995 Bradford J. Rodriguez
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 3 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program. If not, see .
+
+; Commercial inquiries should be directed to the author at
+; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+; or via email to bj@camelforth.com
+;
+; ===============================================
+; CAMEL80.AZM: Code Primitives
+; Source code is for the Z80MR macro assembler.
+; Forth words are documented as follows:
+;x NAME stack -- stack description
+; where x=C for ANS Forth Core words, X for ANS
+; Extensions, Z for internal or private words.
+;
+; Direct-Threaded Forth model for Zilog Z80
+; 16 bit cell, 8 bit char, 8 bit (byte) adrs unit
+; Z80 BC = Forth TOS (top Param Stack item)
+; HL = W working register
+; DE = IP Interpreter Pointer
+; SP = PSP Param Stack Pointer
+; IX = RSP Return Stack Pointer
+; IY = UP User area Pointer
+; A, alternate register set = temporaries
+;
+; Revision history:
+; 19 Aug 94 v1.0
+; 25 Jan 95 v1.01 now using BDOS function 0Ah
+; for interpreter input; TIB at 82h.
+; 02 Mar 95 v1.02 changed ALIGN to ALIGNED in
+; S" (S"); changed ,BRANCH to ,XT in DO.
+; ===============================================
+; Macros to define Forth headers
+; HEAD label,length,name,action
+; IMMED label,length,name,action
+; label = assembler name for this word
+; (special characters not allowed)
+; length = length of name field
+; name = Forth's name for this word
+; action = code routine for this word, e.g.
+; DOCOLON, or DOCODE for code words
+; IMMED defines a header for an IMMEDIATE word.
+;
+DOCODE EQU 0 ; flag to indicate CODE words
+link DEFL 0 ; link to previous Forth word
+
+head MACRO #label,#length,#name,#action
+ DW link
+ DB 0
+link DEFL $
+ DB #length,'#name'
+#label:
+ IF .NOT.(#action=DOCODE)
+ call #action
+ ENDIF
+ ENDM
+
+immed MACRO #label,#length,#name,#action
+ DW link
+ DB 1
+link DEFL $
+ DB #length,'#name'
+#label:
+ IF .NOT.(#action=DOCODE)
+ call #action
+ ENDIF
+ ENDM
+
+; The NEXT macro (7 bytes) assembles the 'next'
+; code in-line in every Z80 CamelForth CODE word.
+next MACRO
+ ex de,hl
+ ld e,(hl)
+ inc hl
+ ld d,(hl)
+ inc hl
+ ex de,hl
+ jp (hl)
+ ENDM
+
+; NEXTHL is used when the IP is already in HL.
+nexthl MACRO
+ ld e,(hl)
+ inc hl
+ ld d,(hl)
+ inc hl
+ ex de,hl
+ jp (hl)
+ ENDM
+
+; RESET AND INTERRUPT VECTORS ===================
+; ...are not used in the CP/M implementation
+; Instead, we have the...
+
+; CP/M ENTRY POINT
+ org 100h
+reset: ld hl,(6h) ; BDOS address, rounded down
+ ld l,0 ; = end of avail.mem (EM)
+ dec h ; EM-100h
+ ld sp,hl ; = top of param stack
+ inc h ; EM
+ push hl
+ pop ix ; = top of return stack
+ dec h ; EM-200h
+ dec h
+ push hl
+ pop iy ; = bottom of user area
+ ld de,1 ; do reset if COLD returns
+ jp COLD ; enter top-level Forth word
+
+; Memory map:
+; 0080h Terminal Input Buffer, 128 bytes
+; 0100h Forth kernel = start of CP/M TPA
+; ? h Forth dictionary (user RAM)
+; EM-200h User area, 128 bytes
+; EM-180h Parameter stack, 128B, grows down
+; EM-100h HOLD area, 40 bytes, grows down
+; EM-0D8h PAD buffer, 88 bytes
+; EM-80h Return stack, 128 B, grows down
+; EM End of RAM = start of CP/M BDOS
+; See also the definitions of U0, S0, and R0
+; in the "system variables & constants" area.
+; A task w/o terminal input requires 200h bytes.
+; Double all except TIB and PAD for 32-bit CPUs.
+
+; INTERPRETER LOGIC =============================
+; See also "defining words" at end of this file
+
+;C EXIT -- exit a colon definition
+ head EXIT,4,EXIT,docode
+ ld e,(ix+0) ; pop old IP from ret stk
+ inc ix
+ ld d,(ix+0)
+ inc ix
+ next
+
+;Z lit -- x fetch inline literal to stack
+; This is the primtive compiled by LITERAL.
+ head lit,3,lit,docode
+ push bc ; push old TOS
+ ld a,(de) ; fetch cell at IP to TOS,
+ ld c,a ; advancing IP
+ inc de
+ ld a,(de)
+ ld b,a
+ inc de
+ next
+
+;C EXECUTE i*x xt -- j*x execute Forth word
+;C at 'xt'
+ head EXECUTE,7,EXECUTE,docode
+ ld h,b ; address of word -> HL
+ ld l,c
+ pop bc ; get new TOS
+ jp (hl) ; go do Forth word
+
+; DEFINING WORDS ================================
+
+; ENTER, a.k.a. DOCOLON, entered by CALL ENTER
+; to enter a new high-level thread (colon def'n.)
+; (internal code fragment, not a Forth word)
+; N.B.: DOCOLON must be defined before any
+; appearance of 'docolon' in a 'word' macro!
+docolon: ; (alternate name)
+enter: dec ix ; push old IP on ret stack
+ ld (ix+0),d
+ dec ix
+ ld (ix+0),e
+ pop hl ; param field adrs -> IP
+ nexthl ; use the faster 'nexthl'
+
+;C VARIABLE -- define a Forth variable
+; CREATE 1 CELLS ALLOT ;
+; Action of RAM variable is identical to CREATE,
+; so we don't need a DOES> clause to change it.
+ head VARIABLE,8,VARIABLE,docolon
+ DW CREATE,LIT,1,CELLS,ALLOT,EXIT
+; DOVAR, code action of VARIABLE, entered by CALL
+; DOCREATE, code action of newly created words
+docreate:
+dovar: ; -- a-addr
+ pop hl ; parameter field address
+ push bc ; push old TOS
+ ld b,h ; pfa = variable's adrs -> TOS
+ ld c,l
+ next
+
+;C CONSTANT n -- define a Forth constant
+; CREATE , DOES> (machine code fragment)
+ head CONSTANT,8,CONSTANT,docolon
+ DW CREATE,COMMA,XDOES
+; DOCON, code action of CONSTANT,
+; entered by CALL DOCON
+docon: ; -- x
+ pop hl ; parameter field address
+ push bc ; push old TOS
+ ld c,(hl) ; fetch contents of parameter
+ inc hl ; field -> TOS
+ ld b,(hl)
+ next
+
+;Z USER n -- define user variable 'n'
+; CREATE , DOES> (machine code fragment)
+ head USER,4,USER,docolon
+ DW CREATE,COMMA,XDOES
+; DOUSER, code action of USER,
+; entered by CALL DOUSER
+douser: ; -- a-addr
+ pop hl ; parameter field address
+ push bc ; push old TOS
+ ld c,(hl) ; fetch contents of parameter
+ inc hl ; field
+ ld b,(hl)
+ push iy ; copy user base address to HL
+ pop hl
+ add hl,bc ; and add offset
+ ld b,h ; put result in TOS
+ ld c,l
+ next
+
+; DODOES, code action of DOES> clause
+; entered by CALL fragment
+; parameter field
+; ...
+; fragment: CALL DODOES
+; high-level thread
+; Enters high-level thread with address of
+; parameter field on top of stack.
+; (internal code fragment, not a Forth word)
+dodoes: ; -- a-addr
+ dec ix ; push old IP on ret stk
+ ld (ix+0),d
+ dec ix
+ ld (ix+0),e
+ pop de ; adrs of new thread -> IP
+ pop hl ; adrs of parameter field
+ push bc ; push old TOS onto stack
+ ld b,h ; pfa -> new TOS
+ ld c,l
+ next
+
+; CP/M TERMINAL I/O =============================
+cpmbdos EQU 5h ; CP/M BDOS entry point
+
+;Z BDOS de c -- a call CP/M BDOS
+ head BDOS,4,BDOS,docode
+ ex de,hl ; save important Forth regs
+ pop de ; (DE,IX,IY) & pop DE value
+ push hl
+ push ix
+ push iy
+ call cpmbdos
+ ld c,a ; result in TOS
+ ld b,0
+ pop iy ; restore Forth regs
+ pop ix
+ pop de
+ next
+
+;C EMIT c -- output character to console
+; 6 BDOS DROP ;
+; warning: if c=0ffh, will read one keypress
+ head EMIT,4,EMIT,docolon
+ DW LIT,06H,BDOS,DROP,EXIT
+
+;Z SAVEKEY -- addr temporary storage for KEY?
+ head savekey,7,SAVEKEY,dovar
+ DW 0
+
+;X KEY? -- f return true if char waiting
+; 0FF 6 BDOS DUP SAVEKEY C! ; rtns 0 or key
+; must use BDOS function 6 to work with KEY
+ head querykey,4,KEY?,docolon
+ DW LIT,0FFH,LIT,06H,BDOS
+ DW DUP,SAVEKEY,CSTORE,EXIT
+
+;C KEY -- c get character from keyboard
+; BEGIN SAVEKEY C@ 0= WHILE KEY? DROP REPEAT
+; SAVEKEY C@ 0 SAVEKEY C! ;
+; must use CP/M direct console I/O to avoid echo
+; (BDOS function 6, contained within KEY?)
+ head KEY,3,KEY,docolon
+KEY1: DW SAVEKEY,CFETCH,ZEROEQUAL,qbranch,KEY2
+ DW QUERYKEY,DROP,branch,KEY1
+KEY2: DW SAVEKEY,CFETCH,LIT,0,SAVEKEY,CSTORE
+ DW EXIT
+
+;Z CPMACCEPT c-addr +n -- +n' get line of input
+; SWAP 2 - TUCK C! max # of characters
+; DUP 0A BDOS DROP CP/M Get Console Buffer
+; 1+ C@ 0A EMIT ; get returned count
+; Note: requires the two locations before c-addr
+; to be available for use.
+ head CPMACCEPT,9,CPMACCEPT,docolon
+ DW SWOP,LIT,2,MINUS,TUCK,CSTORE
+ DW DUP,LIT,0Ah,BDOS,DROP
+ DW ONEPLUS,CFETCH,LIT,0Ah,EMIT,EXIT
+
+;X BYE i*x -- return to CP/M
+ head bye,3,bye,docode
+ jp 0
+
+; STACK OPERATIONS ==============================
+
+;C DUP x -- x x duplicate top of stack
+ head DUP,3,DUP,docode
+pushtos: push bc
+ next
+
+;C ?DUP x -- 0 | x x DUP if nonzero
+ head QDUP,4,?DUP,docode
+ ld a,b
+ or c
+ jr nz,pushtos
+ next
+
+;C DROP x -- drop top of stack
+ head DROP,4,DROP,docode
+poptos: pop bc
+ next
+
+;C SWAP x1 x2 -- x2 x1 swap top two items
+ head SWOP,4,SWAP,docode
+ pop hl
+ push bc
+ ld b,h
+ ld c,l
+ next
+
+;C OVER x1 x2 -- x1 x2 x1 per stack diagram
+ head OVER,4,OVER,docode
+ pop hl
+ push hl
+ push bc
+ ld b,h
+ ld c,l
+ next
+
+;C ROT x1 x2 x3 -- x2 x3 x1 per stack diagram
+ head ROT,3,ROT,docode
+ ; x3 is in TOS
+ pop hl ; x2
+ ex (sp),hl ; x2 on stack, x1 in hl
+ push bc
+ ld b,h
+ ld c,l
+ next
+
+;X NIP x1 x2 -- x2 per stack diagram
+ head NIP,3,NIP,docolon
+ DW SWOP,DROP,EXIT
+
+;X TUCK x1 x2 -- x2 x1 x2 per stack diagram
+ head TUCK,4,TUCK,docolon
+ DW SWOP,OVER,EXIT
+
+;C >R x -- R: -- x push to return stack
+ head TOR,2,>R,docode
+ dec ix ; push TOS onto rtn stk
+ ld (ix+0),b
+ dec ix
+ ld (ix+0),c
+ pop bc ; pop new TOS
+ next
+
+;C R> -- x R: x -- pop from return stack
+ head RFROM,2,R>,docode
+ push bc ; push old TOS
+ ld c,(ix+0) ; pop top rtn stk item
+ inc ix ; to TOS
+ ld b,(ix+0)
+ inc ix
+ next
+
+;C R@ -- x R: x -- x fetch from rtn stk
+ head RFETCH,2,R@,docode
+ push bc ; push old TOS
+ ld c,(ix+0) ; fetch top rtn stk item
+ ld b,(ix+1) ; to TOS
+ next
+
+;Z SP@ -- a-addr get data stack pointer
+ head SPFETCH,3,SP@,docode
+ push bc
+ ld hl,0
+ add hl,sp
+ ld b,h
+ ld c,l
+ next
+
+;Z SP! a-addr -- set data stack pointer
+ head SPSTORE,3,SP!,docode
+ ld h,b
+ ld l,c
+ ld sp,hl
+ pop bc ; get new TOS
+ next
+
+;Z RP@ -- a-addr get return stack pointer
+ head RPFETCH,3,RP@,docode
+ push bc
+ push ix
+ pop bc
+ next
+
+;Z RP! a-addr -- set return stack pointer
+ head RPSTORE,3,RP!,docode
+ push bc
+ pop ix
+ pop bc
+ next
+
+; MEMORY AND I/O OPERATIONS =====================
+
+;C ! x a-addr -- store cell in memory
+ head STORE,1,!,docode
+ ld h,b ; address in hl
+ ld l,c
+ pop bc ; data in bc
+ ld (hl),c
+ inc hl
+ ld (hl),b
+ pop bc ; pop new TOS
+ next
+
+;C C! char c-addr -- store char in memory
+ head CSTORE,2,C!,docode
+ ld h,b ; address in hl
+ ld l,c
+ pop bc ; data in bc
+ ld (hl),c
+ pop bc ; pop new TOS
+ next
+
+;C @ a-addr -- x fetch cell from memory
+ head FETCH,1,@,docode
+ ld h,b ; address in hl
+ ld l,c
+ ld c,(hl)
+ inc hl
+ ld b,(hl)
+ next
+
+;C C@ c-addr -- char fetch char from memory
+ head CFETCH,2,C@,docode
+ ld a,(bc)
+ ld c,a
+ ld b,0
+ next
+
+;Z PC! char c-addr -- output char to port
+ head PCSTORE,3,PC!,docode
+ pop hl ; char in L
+ out (c),l ; to port (BC)
+ pop bc ; pop new TOS
+ next
+
+;Z PC@ c-addr -- char input char from port
+ head PCFETCH,3,PC@,docode
+ in c,(c) ; read port (BC) to C
+ ld b,0
+ next
+
+; ARITHMETIC AND LOGICAL OPERATIONS =============
+
+;C + n1/u1 n2/u2 -- n3/u3 add n1+n2
+ head PLUS,1,+,docode
+ pop hl
+ add hl,bc
+ ld b,h
+ ld c,l
+ next
+
+;X M+ d n -- d add single to double
+ head MPLUS,2,M+,docode
+ ex de,hl
+ pop de ; hi cell
+ ex (sp),hl ; lo cell, save IP
+ add hl,bc
+ ld b,d ; hi result in BC (TOS)
+ ld c,e
+ jr nc,mplus1
+ inc bc
+mplus1: pop de ; restore saved IP
+ push hl ; push lo result
+ next
+
+;C - n1/u1 n2/u2 -- n3/u3 subtract n1-n2
+ head MINUS,1,-,docode
+ pop hl
+ or a
+ sbc hl,bc
+ ld b,h
+ ld c,l
+ next
+
+;C AND x1 x2 -- x3 logical AND
+ head AND,3,AND,docode
+ pop hl
+ ld a,b
+ and h
+ ld b,a
+ ld a,c
+ and l
+ ld c,a
+ next
+
+;C OR x1 x2 -- x3 logical OR
+ head OR,2,OR,docode
+ pop hl
+ ld a,b
+ or h
+ ld b,a
+ ld a,c
+ or l
+ ld c,a
+ next
+
+;C XOR x1 x2 -- x3 logical XOR
+ head XOR,3,XOR,docode
+ pop hl
+ ld a,b
+ xor h
+ ld b,a
+ ld a,c
+ xor l
+ ld c,a
+ next
+
+;C INVERT x1 -- x2 bitwise inversion
+ head INVERT,6,INVERT,docode
+ ld a,b
+ cpl
+ ld b,a
+ ld a,c
+ cpl
+ ld c,a
+ next
+
+;C NEGATE x1 -- x2 two's complement
+ head NEGATE,6,NEGATE,docode
+ ld a,b
+ cpl
+ ld b,a
+ ld a,c
+ cpl
+ ld c,a
+ inc bc
+ next
+
+;C 1+ n1/u1 -- n2/u2 add 1 to TOS
+ head ONEPLUS,2,1+,docode
+ inc bc
+ next
+
+;C 1- n1/u1 -- n2/u2 subtract 1 from TOS
+ head ONEMINUS,2,1-,docode
+ dec bc
+ next
+
+;Z >< x1 -- x2 swap bytes (not ANSI)
+ head swapbytes,2,><,docode
+ ld a,b
+ ld b,c
+ ld c,a
+ next
+
+;C 2* x1 -- x2 arithmetic left shift
+ head TWOSTAR,2,2*,docode
+ sla c
+ rl b
+ next
+
+;C 2/ x1 -- x2 arithmetic right shift
+ head TWOSLASH,2,2/,docode
+ sra b
+ rr c
+ next
+
+;C LSHIFT x1 u -- x2 logical L shift u places
+ head LSHIFT,6,LSHIFT,docode
+ ld b,c ; b = loop counter
+ pop hl ; NB: hi 8 bits ignored!
+ inc b ; test for counter=0 case
+ jr lsh2
+lsh1: add hl,hl ; left shift HL, n times
+lsh2: djnz lsh1
+ ld b,h ; result is new TOS
+ ld c,l
+ next
+
+;C RSHIFT x1 u -- x2 logical R shift u places
+ head RSHIFT,6,RSHIFT,docode
+ ld b,c ; b = loop counter
+ pop hl ; NB: hi 8 bits ignored!
+ inc b ; test for counter=0 case
+ jr rsh2
+rsh1: srl h ; right shift HL, n times
+ rr l
+rsh2: djnz rsh1
+ ld b,h ; result is new TOS
+ ld c,l
+ next
+
+;C +! n/u a-addr -- add cell to memory
+ head PLUSSTORE,2,+!,docode
+ pop hl
+ ld a,(bc) ; low byte
+ add a,l
+ ld (bc),a
+ inc bc
+ ld a,(bc) ; high byte
+ adc a,h
+ ld (bc),a
+ pop bc ; pop new TOS
+ next
+
+; COMPARISON OPERATIONS =========================
+
+;C 0= n/u -- flag return true if TOS=0
+ head ZEROEQUAL,2,0=,docode
+ ld a,b
+ or c ; result=0 if bc was 0
+ sub 1 ; cy set if bc was 0
+ sbc a,a ; propagate cy through A
+ ld b,a ; put 0000 or FFFF in TOS
+ ld c,a
+ next
+
+;C 0< n -- flag true if TOS negative
+ head ZEROLESS,2,0<,docode
+ sla b ; sign bit -> cy flag
+ sbc a,a ; propagate cy through A
+ ld b,a ; put 0000 or FFFF in TOS
+ ld c,a
+ next
+
+;C = x1 x2 -- flag test x1=x2
+ head EQUAL,1,=,docode
+ pop hl
+ or a
+ sbc hl,bc ; x1-x2 in HL, SZVC valid
+ jr z,tostrue
+tosfalse: ld bc,0
+ next
+
+;X <> x1 x2 -- flag test not eq (not ANSI)
+ head NOTEQUAL,2,<>,docolon
+ DW EQUAL,ZEROEQUAL,EXIT
+
+;C < n1 n2 -- flag test n1 n1 +ve, n2 -ve, rslt -ve, so n1>n2
+; if result positive & not OV, n1>=n2
+; pos. & OV => n1 -ve, n2 +ve, rslt +ve, so n1 n1 n2 -- flag test n1>n2, signed
+ head GREATER,1,>,docolon
+ DW SWOP,LESS,EXIT
+
+;C U< u1 u2 -- flag test u1 u1 u2 -- flag u1>u2 unsgd (not ANSI)
+ head UGREATER,2,U>,docolon
+ DW SWOP,ULESS,EXIT
+
+; LOOP AND BRANCH OPERATIONS ====================
+
+;Z branch -- branch always
+ head branch,6,branch,docode
+dobranch: ld a,(de) ; get inline value => IP
+ ld l,a
+ inc de
+ ld a,(de)
+ ld h,a
+ nexthl
+
+;Z ?branch x -- branch if TOS zero
+ head qbranch,7,?branch,docode
+ ld a,b
+ or c ; test old TOS
+ pop bc ; pop new TOS
+ jr z,dobranch ; if old TOS=0, branch
+ inc de ; else skip inline value
+ inc de
+ next
+
+;Z (do) n1|u1 n2|u2 -- R: -- sys1 sys2
+;Z run-time code for DO
+; '83 and ANSI standard loops terminate when the
+; boundary of limit-1 and limit is crossed, in
+; either direction. This can be conveniently
+; implemented by making the limit 8000h, so that
+; arithmetic overflow logic can detect crossing.
+; I learned this trick from Laxen & Perry F83.
+; fudge factor = 8000h-limit, to be added to
+; the start value.
+ head xdo,4,(do),docode
+ ex de,hl
+ ex (sp),hl ; IP on stack, limit in HL
+ ex de,hl
+ ld hl,8000h
+ or a
+ sbc hl,de ; 8000-limit in HL
+ dec ix ; push this fudge factor
+ ld (ix+0),h ; onto return stack
+ dec ix ; for later use by 'I'
+ ld (ix+0),l
+ add hl,bc ; add fudge to start value
+ dec ix ; push adjusted start value
+ ld (ix+0),h ; onto return stack
+ dec ix ; as the loop index.
+ ld (ix+0),l
+ pop de ; restore the saved IP
+ pop bc ; pop new TOS
+ next
+
+;Z (loop) R: sys1 sys2 -- | sys1 sys2
+;Z run-time code for LOOP
+; Add 1 to the loop index. If loop terminates,
+; clean up the return stack and skip the branch.
+; Else take the inline branch. Note that LOOP
+; terminates when index=8000h.
+ head xloop,6,(loop),docode
+ exx
+ ld bc,1
+looptst: ld l,(ix+0) ; get the loop index
+ ld h,(ix+1)
+ or a
+ adc hl,bc ; increment w/overflow test
+ jp pe,loopterm ; overflow=loop done
+ ; continue the loop
+ ld (ix+0),l ; save the updated index
+ ld (ix+1),h
+ exx
+ jr dobranch ; take the inline branch
+loopterm: ; terminate the loop
+ ld bc,4 ; discard the loop info
+ add ix,bc
+ exx
+ inc de ; skip the inline branch
+ inc de
+ next
+
+;Z (+loop) n -- R: sys1 sys2 -- | sys1 sys2
+;Z run-time code for +LOOP
+; Add n to the loop index. If loop terminates,
+; clean up the return stack and skip the branch.
+; Else take the inline branch.
+ head xplusloop,7,(+loop),docode
+ pop hl ; this will be the new TOS
+ push bc
+ ld b,h
+ ld c,l
+ exx
+ pop bc ; old TOS = loop increment
+ jr looptst
+
+;C I -- n R: sys1 sys2 -- sys1 sys2
+;C get the innermost loop index
+ head II,1,I,docode
+ push bc ; push old TOS
+ ld l,(ix+0) ; get current loop index
+ ld h,(ix+1)
+ ld c,(ix+2) ; get fudge factor
+ ld b,(ix+3)
+ or a
+ sbc hl,bc ; subtract fudge factor,
+ ld b,h ; returning true index
+ ld c,l
+ next
+
+;C J -- n R: 4*sys -- 4*sys
+;C get the second loop index
+ head JJ,1,J,docode
+ push bc ; push old TOS
+ ld l,(ix+4) ; get current loop index
+ ld h,(ix+5)
+ ld c,(ix+6) ; get fudge factor
+ ld b,(ix+7)
+ or a
+ sbc hl,bc ; subtract fudge factor,
+ ld b,h ; returning true index
+ ld c,l
+ next
+
+;C UNLOOP -- R: sys1 sys2 -- drop loop parms
+ head UNLOOP,6,UNLOOP,docode
+ inc ix
+ inc ix
+ inc ix
+ inc ix
+ next
+
+; MULTIPLY AND DIVIDE ===========================
+
+;C UM* u1 u2 -- ud unsigned 16x16->32 mult.
+ head UMSTAR,3,UM*,docode
+ push bc
+ exx
+ pop bc ; u2 in BC
+ pop de ; u1 in DE
+ ld hl,0 ; result will be in HLDE
+ ld a,17 ; loop counter
+ or a ; clear cy
+umloop: rr h
+ rr l
+ rr d
+ rr e
+ jr nc,noadd
+ add hl,bc
+noadd: dec a
+ jr nz,umloop
+ push de ; lo result
+ push hl ; hi result
+ exx
+ pop bc ; put TOS back in BC
+ next
+
+;C UM/MOD ud u1 -- u2 u3 unsigned 32/16->16
+ head UMSLASHMOD,6,UM/MOD,docode
+ push bc
+ exx
+ pop bc ; BC = divisor
+ pop hl ; HLDE = dividend
+ pop de
+ ld a,16 ; loop counter
+ sla e
+ rl d ; hi bit DE -> carry
+udloop: adc hl,hl ; rot left w/ carry
+ jr nc,udiv3
+ ; case 1: 17 bit, cy:HL = 1xxxx
+ or a ; we know we can subtract
+ sbc hl,bc
+ or a ; clear cy to indicate sub ok
+ jr udiv4
+ ; case 2: 16 bit, cy:HL = 0xxxx
+udiv3: sbc hl,bc ; try the subtract
+ jr nc,udiv4 ; if no cy, subtract ok
+ add hl,bc ; else cancel the subtract
+ scf ; and set cy to indicate
+udiv4: rl e ; rotate result bit into DE,
+ rl d ; and next bit of DE into cy
+ dec a
+ jr nz,udloop
+ ; now have complemented quotient in DE,
+ ; and remainder in HL
+ ld a,d
+ cpl
+ ld b,a
+ ld a,e
+ cpl
+ ld c,a
+ push hl ; push remainder
+ push bc
+ exx
+ pop bc ; quotient remains in TOS
+ next
+
+; BLOCK AND STRING OPERATIONS ===================
+
+;C FILL c-addr u char -- fill memory with char
+ head FILL,4,FILL,docode
+ ld a,c ; character in a
+ exx ; use alt. register set
+ pop bc ; count in bc
+ pop de ; address in de
+ or a ; clear carry flag
+ ld hl,0ffffh
+ adc hl,bc ; test for count=0 or 1
+ jr nc,filldone ; no cy: count=0, skip
+ ld (de),a ; fill first byte
+ jr z,filldone ; zero, count=1, done
+ dec bc ; else adjust count,
+ ld h,d ; let hl = start adrs,
+ ld l,e
+ inc de ; let de = start adrs+1
+ ldir ; copy (hl)->(de)
+filldone: exx ; back to main reg set
+ pop bc ; pop new TOS
+ next
+
+;X CMOVE c-addr1 c-addr2 u -- move from bottom
+; as defined in the ANSI optional String word set
+; On byte machines, CMOVE and CMOVE> are logical
+; factors of MOVE. They are easy to implement on
+; CPUs which have a block-move instruction.
+ head CMOVE,5,CMOVE,docode
+ push bc
+ exx
+ pop bc ; count
+ pop de ; destination adrs
+ pop hl ; source adrs
+ ld a,b ; test for count=0
+ or c
+ jr z,cmovedone
+ ldir ; move from bottom to top
+cmovedone: exx
+ pop bc ; pop new TOS
+ next
+
+;X CMOVE> c-addr1 c-addr2 u -- move from top
+; as defined in the ANSI optional String word set
+ head CMOVEUP,6,CMOVE>,docode
+ push bc
+ exx
+ pop bc ; count
+ pop hl ; destination adrs
+ pop de ; source adrs
+ ld a,b ; test for count=0
+ or c
+ jr z,umovedone
+ add hl,bc ; last byte in destination
+ dec hl
+ ex de,hl
+ add hl,bc ; last byte in source
+ dec hl
+ lddr ; move from top to bottom
+umovedone: exx
+ pop bc ; pop new TOS
+ next
+
+;Z SKIP c-addr u c -- c-addr' u'
+;Z skip matching chars
+; Although SKIP, SCAN, and S= are perhaps not the
+; ideal factors of WORD and FIND, they closely
+; follow the string operations available on many
+; CPUs, and so are easy to implement and fast.
+ head skip,4,SKIP,docode
+ ld a,c ; skip character
+ exx
+ pop bc ; count
+ pop hl ; address
+ ld e,a ; test for count=0
+ ld a,b
+ or c
+ jr z,skipdone
+ ld a,e
+skiploop: cpi
+ jr nz,skipmis ; char mismatch: exit
+ jp pe,skiploop ; count not exhausted
+ jr skipdone ; count 0, no mismatch
+skipmis: inc bc ; mismatch! undo last to
+ dec hl ; point at mismatch char
+skipdone: push hl ; updated address
+ push bc ; updated count
+ exx
+ pop bc ; TOS in bc
+ next
+
+;Z SCAN c-addr u c -- c-addr' u'
+;Z find matching char
+ head scan,4,SCAN,docode
+ ld a,c ; scan character
+ exx
+ pop bc ; count
+ pop hl ; address
+ ld e,a ; test for count=0
+ ld a,b
+ or c
+ jr z,scandone
+ ld a,e
+ cpir ; scan 'til match or count=0
+ jr nz,scandone ; no match, BC & HL ok
+ inc bc ; match! undo last to
+ dec hl ; point at match char
+scandone: push hl ; updated address
+ push bc ; updated count
+ exx
+ pop bc ; TOS in bc
+ next
+
+;Z S= c-addr1 c-addr2 u -- n string compare
+;Z n<0: s10: s1>s2
+ head sequal,2,S=,docode
+ push bc
+ exx
+ pop bc ; count
+ pop hl ; addr2
+ pop de ; addr1
+ ld a,b ; test for count=0
+ or c
+ jr z,smatch ; by definition, match!
+sloop: ld a,(de)
+ inc de
+ cpi
+ jr nz,sdiff ; char mismatch: exit
+ jp pe,sloop ; count not exhausted
+smatch: ; count exhausted & no mismatch found
+ exx
+ ld bc,0 ; bc=0000 (s1=s2)
+ jr snext
+sdiff: ; mismatch! undo last 'cpi' increment
+ dec hl ; point at mismatch char
+ cp (hl) ; set cy if char1 < char2
+ sbc a,a ; propagate cy thru A
+ exx
+ ld b,a ; bc=FFFF if cy (s1s2)
+ ld c,a
+snext: next
+
+*INCLUDE camel80d.azm ; CPU Dependencies
+*INCLUDE camel80h.azm ; High Level words
+lastword EQU link ; nfa of last word in dict.
+enddict EQU $ ; user's code starts here
+ END
+
diff --git a/Source/HBIOS/Forth/camel80.bin b/Source/HBIOS/Forth/camel80.bin
new file mode 100644
index 0000000000000000000000000000000000000000..6afdcbc6a5d7b4f24e30f3ec5cd212b918c99c39
GIT binary patch
literal 5632
zcmZu#3vg7|c|Pa9cJFGh_9dwbYc?w@6oCZN((yVlsQr0jlMAF>;-$PE5Ivb@pM(oBjAcyD*A$sMbj6SXnqrd{qbz!#)YZ!)ZEmB%CZ`ptCTAjs+y<4V5XB~Hq15lA-^aE
zxLsnlLUfb4(Y$ZsAZKj3#1xGC1k*gT7)PZQ(q%co*GNnz#sXgI^KVPKoe{
zzz2BMy`3;p$VJ9l80%ix#4ii5W$TVRHI**{$%CytRYU$xAT49%N)7p*%s6CD?`hp#
zgU-QXOkg$Smtcx)-LaTcw}>U;Kt5DGk`yNAVl9=K9W@!BKq51P3p^_n#@m-<-MtEv
z((N}cT+#bCc5(T_R8?03d}}JFX8ISF_8@dcGx5sEtBHNz&Q{s>Ks=kTjEpAsyj;5g=xtQwyrqRnb_A^gWm$2F%!|EX~A+;@4rHCsJ%A(51Os1tI|Hi
ztatrLw5DSg^L4AoTgKg028RlubG&W*V^zSfGA&gYOb!&I6{VT4a?dTSssp6_0!bNP
zKfc^OyFg7qQ+rFr@suPxzADwC`gx#TJtHSS;Kvg+C-xJzemuB{{DsPR4@I!84F{;|
z$+y6^z887;ih4i|@OQwoo_MZbQa^f4<@57ZzS-B*=38T+67RHh7Q9y=S`y5QHf|AS
zvHS)ss>Zbbd^8gqT(--%>=CPiHE7J%XQ3k}Pq$6^YNc&o6W77Le_n$?c`u)AKFk$X)+ZMX?1AOB
zb|FG%c=B}fk6+OkPmWo_<&0Dwke8;|JD_d=RVhELmNQy;z_yh7GdNJnkUAVr@xL0Z
zk2EHi(yPZNPhY@c?Dd=)ziWK?__A?-7uS1&AN_o4vbKgg8&sq_)7dzfD;Ij*doB7TH*RYMLu{4Slxl=pJwwdw6Q^!Ax|7v$fDmBPkk4pu4;
zg2B0e=37Da`n0WClG~Sf^9$mOMKd)%+y0r8!QW?Lb|w{iYL@h6K4{XfciJbBkInY>
zA0D4f{3ov^aI2lE(Nr>#sjfC>XErf6x^E}1er&V*cN>`ZQn4G4w_
zHjBHdqMXP5^i$v+0{6H+u#+&|zSr$cYl&r3*^CgFn{Rc6d4d1h9^g!8Y6rCdf)e28
zfcbT1>#$A%Omz}R+$XkB01Q1
zbrdJ?6^fYFvmb+VkT~7!7Z|2!=w(+hEC`GI*RYt2#sRnSJH$coA+9=bMF|ec?OIEn803b
z24A$lAow111o$rS#TWRdrFRtiq2_1F3BYEC+yf!H@4xZ`VjP5^iZZl_m6
zt>1Y}iOAE^V-EUp*@k2ypLH;;knYTz=>?WqDI!1Sh{)e}49V+l)6$UqAVlbQfL{gs
zfH>d6(TF_bpk;-$PuCGkH=Mkw__e;eA({Gu#yZBy_D>u%i`OxQN&|q1yb;>(stfQu
zSUQ1ht_va+AE{%q#j&}LL>{kW>golVpHyX@s$5;`J;{+fiMLzw%WXW`5D;R^}B
zPB>DB@G0Q$SMh&____$-QR$HVHbQb6mj8{w7J$>ztaM&JWT%sH6Xw@Z%LM$Q(5X0?
zvJPz(fLSmGc#{(>)I|X?eDA0p0^jEL#$7?5K3iK8*$t
zyYED+LCj%pps%ZScRRsc$VHLJ1wN!xzxNd<_KOfJQ$pIC&cjX$`O8jP@{4epsGi;ngak`tm;Zl_f$W)}B26-)!
zpEbff0fqqowt*`szK}E2T<=C68)9eZZ-BpR;695}VvZu$UABu7C9exKs+yPJ%V0J|
zX&Oeua7o{;Uea%)0}t>!2D*z@5a#qtIweR$J=1#Q$%H6{6f>PosbOwok1O3ctX-lE
zuc&97gpNYXj|@ZZsQ;Z2;2Y|h)JnUUs`ope70-f)>jQi%!PId$oMd%QpB1ruq8_&q
zE)NjsxcyCin6F`^=4;?Dtp)rCfEatI{>l1;aTtmAx3FsAqd4yt&5*yoK>w$D6c{s>
zOh;3Yri?o(mh`K7CJ&l)n!+fN7WUt;K4|7?Cr`qu0C&3RGD~IY1~`cT1^99o;~kiJ
zT<7J*CtRlsd2PX$1^l|$Hq(VHwkmXipVrH$1D|yIzkvw5q&KIA$A@1Ahct{QULMwQHvRr@Hi?>*N|h0Y*p
zJOYnH`0H`~rOV?QLWs8@;b?Ca4v^O;ng(12M$^LJvXiT76oMC=YY;b_rxzTl}
z(`KAremC(h3-A?g>S8kF(R=X5@0`U6KW6_!;l*d&7o|DZZ9L}a85nnyXHU9=nETw*
zQiuBhl83Wrq2`lrZo^~R%!}j$L6&X+xwMMi+w(>3W6|@@KIGiFJ$iXaa$grit=djtkdIj)1n^pasGhd
zwt|Uc?_->trlg?oqVe&eL?z=jLCS+LKZK(+Exy6L<-;@7++>Q=M7~%IbdD{C^FAaN
zo#dpoMoL`byD93zP1ySs>^1sEeaC$^J;03y&OZ(0=e`#GIbVQ(yn)LPtR$b_T@uL7
z25!$~3&mVEL!Mc?LWkel7b@lZ8ftN;qfNQFzkwEQHgG9vHR~bmUfqM#j=}Ds2Cftb
zO}Yp?u4yR?=&t~oDG{?U61>JcEq$W_O;7_@`^`i$bH?L3i!nNnq*d@qD`|WmXfzQO
zjglo#=ry352k~+^^XCoo4IIJCVfSGb9bN+|u4}|s0@5^WzlwT#6|tgy2m(&g{YAiS
zdDuRo5IMl_ZRAos3j!``?VQ~s@~5>iz;liGLYRruyAxFM=~In#c%N?kMuT4)0mqI;
zu2jikKBDabbfl51;^iw8z9FzlAkoNmjn+T6|*!IO>sJr_f!$H-A-Yx(CzyAaHMoCcs
literal 0
HcmV?d00001
diff --git a/Source/HBIOS/Forth/camel80.hex b/Source/HBIOS/Forth/camel80.hex
new file mode 100644
index 00000000..e7f60aa4
--- /dev/null
+++ b/Source/HBIOS/Forth/camel80.hex
@@ -0,0 +1,354 @@
+:100100002A06002E0025F924E5DDE12525E5FDE19F
+:10011000110100C3A9160000000445584954DD5ED2
+:1001200000DD23DD5600DD23EB5E235623EBE919CA
+:100130000100034C4954C51A4F131A4713EB5E23B1
+:100140005623EBE9320100074558454355544560B5
+:1001500069C1E9DD2BDD7200DD2BDD7300E15E237B
+:100160005623EBE9470100085641524941424C45AC
+:10017000CD53011513360101009208230F1E01E132
+:10018000C5444DEB5E235623EBE967010008434F5E
+:100190004E5354414E54CD53011513310F4713E1C3
+:1001A000C54E2346EB5E235623EBE98D0100045533
+:1001B000534552CD53011513310F4713E1C54E235B
+:1001C00046FDE5E109444DEB5E235623EBE9DD2BCB
+:1001D000DD7200DD2BDD7300D1E1C5444DEB5E2304
+:1001E0005623EBE9AE01000442444F53EBD1E5DD69
+:1001F000E5FDE5CD05004F0600FDE1DDE1D1EB5E5B
+:10020000235623EBE9E7010004454D4954CD530142
+:1002100036010600EC01D7021E0108020007534117
+:1002200056454B4559CD7F0100001D0200044B454A
+:10023000593FCD53013601FF0036010600EC01B4F1
+:10024000022502E2031E012D0200034B4559CD5346
+:1002500001250205047E05310663023202D7021B26
+:1002600006510225020504360100002502E2031EA4
+:10027000014A02000943504D414343455054CD5378
+:1002800001E7023601020061043103E203B40236E1
+:10029000010A00EC01D702E104050436010A000D51
+:1002A000021E0174020003425945C30000A6020069
+:1002B00003445550C5EB5E235623EBE9B00200041E
+:1002C0003F44555078B120ECEB5E235623EBE9BF59
+:1002D00002000444524F50C1EB5E235623EBE9D297
+:1002E00002000453574150E1C5444DEB5E235623B1
+:1002F000EBE9E20200044F564552E1E5C5444DEBFF
+:100300005E235623EBE9F5020003524F54E1E3C5A7
+:10031000444DEB5E235623EBE9090300034E49509D
+:10032000CD5301E702D7021E011C030004545543BC
+:100330004BCD5301E702FA021E012C0300023E528C
+:10034000DD2BDD7000DD2BDD7100C1EB5E2356235C
+:10035000EBE93D030002523EC5DD4E00DD23DD46E4
+:1003600000DD23EB5E235623EBE9550300025240E8
+:10037000C5DD4E00DD4601EB5E235623EBE96D0340
+:100380000003535040C521000039444DEB5E235615
+:1003900023EBE9810300035350216069F9C1EB5E4F
+:1003A000235623EBE996030003525040C5DDE5C117
+:1003B000EB5E235623EBE9A8030003525021C5DD71
+:1003C000E1C1EB5E235623EBE9BA0300012160692A
+:1003D000C1712370C1EB5E235623EBE9CC0300020D
+:1003E00043216069C171C1EB5E235623EBE9DF0352
+:1003F00000014060694E2346EB5E235623EBE9F192
+:1004000003000243400A4F0600EB5E235623EBE94C
+:1004100002040003504321E1ED69C1EB5E23562342
+:10042000EBE913040003504340ED480600EB5E2364
+:100430005623EBE9250400012BE109444DEB5E2333
+:100440005623EBE9370400024D2BEBD1E309424B75
+:10045000300103D1E5EB5E235623EBE947040001AD
+:100460002DE1B7ED42444DEB5E235623EBE95F04EB
+:100470000003414E44E178A44779A54FEB5E235633
+:1004800023EBE9710400024F52E178B44779B54F8C
+:10049000EB5E235623EBE986040003584F52E178C4
+:1004A000AC4779AD4FEB5E235623EBE99A04000687
+:1004B000494E56455254782F47792F4FEB5E2356BD
+:1004C00023EBE9AF0400064E4547415445782F47DA
+:1004D000792F4F03EB5E235623EBE9C6040002316C
+:1004E0002B03EB5E235623EBE9DE040002312D0BD8
+:1004F000EB5E235623EBE9EC0400023E3C78414FCF
+:10050000EB5E235623EBE9FA040002322ACB21CB1F
+:1005100010EB5E235623EBE90A050002322FCB28AD
+:10052000CB19EB5E235623EBE91B0500064C534821
+:1005300049465441E10418012910FD444DEB5E2366
+:100540005623EBE92C05000652534849465441E135
+:10055000041804CB3CCB1D10FA444DEB5E2356230C
+:10056000EBE9470500022B21E10A8502030A8C0210
+:10057000C1EB5E235623EBE965050002303D78B1FF
+:10058000D6019F474FEB5E235623EBE97B05000224
+:10059000303CCB209F474FEB5E235623EBE98F0582
+:1005A00000013DE1B7ED422828010000EB5E235633
+:1005B00023EBE9A10500023C3ECD5301A3057E05D6
+:1005C0001E01B60500013CE1B7ED42EADB05F2A9E8
+:1005D0000501FFFFEB5E235623EBE9FAA90518F1AD
+:1005E000C50500013ECD5301E702C7051E01E30525
+:1005F0000002553CE1B7ED429F474FEB5E23562387
+:10060000EBE9F1050002553ECD5301E702F4051E6A
+:1006100001050600064252414E43481A6F131A67FD
+:100620005E235623EBE9140600073F4252414E4336
+:100630004878B1C128E51313EB5E235623EBE92973
+:1006400006000428444F29EBE3EB210080B7ED526C
+:10065000DD2BDD7400DD2BDD750009DD2BDD740085
+:10066000DD2BDD7500D1C1EB5E235623EBE942069D
+:100670000006284C4F4F5029D9010100DD6E00DDE6
+:100680006601B7ED4AEA9106DD7500DD7401D918FF
+:100690008A010400DD09D91313EB5E235623EBE92D
+:1006A00071060007282B4C4F4F5029E1C5444DD906
+:1006B000C118C9A306000149C5DD6E00DD6601DD74
+:1006C0004E02DD4603B7ED42444DEB5E235623EB6D
+:1006D000E9B60600014AC5DD6E04DD6605DD4E069D
+:1006E000DD4607B7ED42444DEB5E235623EBE9D4DC
+:1006F000060006554E4C4F4F50DD23DD23DD23DD34
+:1007000023EB5E235623EBE9F2060003554D2AC581
+:10071000D9C1D12100003E11B7CB1CCB1DCB1ACBC8
+:100720001B3001093D20F2D5E5D9C1EB5E235623EC
+:10073000EBE90B070006554D2F4D4F44C5D9C1E1DC
+:10074000D13E10CB23CB12ED6A3006B7ED42B7187D
+:1007500006ED4230020937CB13CB123D20E97A2F48
+:10076000477B2F4FE5C5D9C1EB5E235623EBE93517
+:1007700007000446494C4C79D9C1D1B721FFFFEDA0
+:100780004A30091228060B626B13EDB0D9C1EB5E3B
+:10079000235623EBE972070005434D4F5645C5D953
+:1007A000C1D1E178B12802EDB0D9C1EB5E23562367
+:1007B000EBE998070006434D4F56453EC5D9C1E1C8
+:1007C000D178B12807092BEB092BEDB8D9C1EB5E25
+:1007D000235623EBE9B5070004534B495079D9C19F
+:1007E000E15F78B1280C7BEDA12005EAE70718024C
+:1007F000032BE5C5D9C1EB5E235623EBE9D80700EF
+:10080000045343414E79D9C1E15F78B128077BEDAC
+:10081000B12002032BE5C5D9C1EB5E235623EBE9DA
+:1008200000080002533DC5D9C1E1D178B128091AA9
+:1008300013EDA12009EA2F08D901000018082BBEEA
+:100840009FD947F6014FEB5E235623EBE9230800BF
+:1008500005414C49474EEB5E235623EBE950080017
+:1008600007414C49474E454418EC60080004434595
+:100870004C4CCD9F0102006D08000543454C4C2BAC
+:100880000303EB5E235623EBE97A08000543454C4E
+:100890004C53C30D058C080005434841522BC3E15E
+:1008A0000498080005434841525318AAA4080005BB
+:1008B0003E424F4459CD53013601030039041E0115
+:1008C000AF080008434F4D50494C452CC3310FC36E
+:1008D000080003214346CD53013601CD00FA02E260
+:1008E00003E104CE031E01D20800032C4346CD537E
+:1008F00001110FD60836010300230F1E01EA08007C
+:100900000621434F4C4F4ECD53013601FDFF230FBF
+:1009100036015301EE081E01000900052C45584917
+:1009200054CD530136011E01CC081E011B090007DE
+:100930002C4252414E4348C3310F2F0900052C442D
+:10094000455354C3310F3D0900052144455354C359
+:10095000CE0349090002424CCD9F012000550900F9
+:100960000754494253495A45CD9F017C0060090014
+:1009700003544942CD9F018200700900025530CDD9
+:10098000BC0100007C0900033E494ECDBC010200C1
+:100990008709000442415345CDBC0104009309007E
+:1009A000055354415445CDBC010600A00900024442
+:1009B00050CDBC010800AE09000727534F555243E4
+:1009C00045CDBC010A00B90900064C4154455354B9
+:1009D000CDBC010E00C90900024850CDBC01100079
+:1009E000D80900024C50CDBC011200E309000253AB
+:1009F00030CDBC010001EE090003504144CDBC01E3
+:100A00002801F90900024C30CDBC018001050A0023
+:100A1000025230CDBC010002100A000555494E4972
+:100A200054CD7F01000000000A000000E61600001F
+:100A30000000A41600001B0A000523494E4954CDAE
+:100A40009F011200390A0003533E44CD5301B40202
+:100A500092051E01470A00073F4E4547415445CDC8
+:100A60005301920531066A0ACD041E01570A00039C
+:100A7000414253CD5301B4025F0A1E016F0A0007C1
+:100A8000444E4547415445CD5301E702B604E702C1
+:100A9000B604360101004A041E017F0A00083F44E3
+:100AA0004E4547415445CD530192053106B10A8761
+:100AB0000A1E019D0A000444414253CD5301B40271
+:100AC000A60A1E01B60A00024D2ACD53011B0C9E38
+:100AD000044003E702730AE702730A0F075803A6EC
+:100AE0000A1E01C70A0006534D2F52454DCD530132
+:100AF0001B0C9E044003FA024003730A4003BB0A26
+:100B000058033C07E70258035F0AE70258035F0AED
+:100B10001E01E60A0006464D2F4D4F44CD5301B449
+:100B2000024003ED0AB402920531063B0BE702587E
+:100B3000033904E702EF041B063F0B5803D7021EDC
+:100B400001150B00012ACD5301CA0AD7021E014428
+:100B50000B00042F4D4F44CD530140034B0A580363
+:100B60001C0B1E01520B00012FCD5301570B20030C
+:100B70001E01670B00034D4F44CD5301570BD702A5
+:100B80001E01750B00052A2F4D4F44CD5301400324
+:100B9000CA0A58031C0B1E01850B00022A2FCD53D5
+:100BA000018B0B20031E019B0B00034D4158CD53BD
+:100BB000011B0CC7053106BB0BE702D7021E01AAB9
+:100BC0000B00034D494ECD53011B0CE5053106D3F7
+:100BD0000BE702D7021E01C20B00023240CD5301C7
+:100BE000B4028008F303E702F3031E01DA0B0002EC
+:100BF0003221CD5301E702FA02CE038008CE031E54
+:100C000001EF0B00053244524F50CD5301D702D7AC
+:100C1000021E01040C000432445550CD5301FA0267
+:100C2000FA021E01160C00053253574150CD5301F4
+:100C30000D0340030D0358031E01270C0005324F1E
+:100C4000564552CD5301400340031B0C5803580333
+:100C50002D0C1E013D0C0005434F554E54CD530144
+:100C6000B4029E08E70205041E01570C000243521D
+:100C7000CD530136010D000D0236010A000D021E92
+:100C8000016D0C00055350414345CD530158090DEA
+:100C9000021E01840C0006535041434553CD5301BD
+:100CA000B4023106AE0C8A0CEF041B06A00CD7026E
+:100CB0001E01960C0004554D494ECD53011B0C08E6
+:100CC000063106C70CE702D7021E01B50C00045519
+:100CD0004D4158CD53011B0CF4053106E00CE702E1
+:100CE000D7021E01CE0C0006414343455054CD535C
+:100CF00001FA023904EF04FA024E02B40236010D81
+:100D000000B9053106350DB4020D02B402360108F2
+:100D100000A3053106270DD702EF044003FA02585D
+:100D200003D30C1B06310DFA02E203E104FA02BA06
+:100D30000C1B06F90CD7022003E70261041E01E731
+:100D40000C000454595045CD5301C4023106660DC0
+:100D5000FA023904E7024706B80605040D027806D0
+:100D6000580D1B06680DD7021E01420D00042853C2
+:100D70002229CD530158035D0C1B0C39046808402F
+:100D8000031E016D0D01025322CD53013601720D78
+:100D9000CC0836012200AB0F0504E1046808230FDC
+:100DA0001E01860D01022E22CD5301890D36014709
+:100DB0000DCC081E01A50D000655442F4D4F44CD06
+:100DC000530140033601000070033C070D030D037F
+:100DD00058033C070D031E01B80D000355442ACDEE
+:100DE0005301B40240030F07D702E70258030F076D
+:100DF0000D0339041E01DB0D0004484F4C44CD5354
+:100E0000013601FFFFDB096805DB09F303E2031E7E
+:100E100001F90D00023C23CD5301FD09DB09CE038E
+:100E20001E01140E00063E4449474954CD5301B4F7
+:100E30000236010900E5053601070075043904365C
+:100E400001300039041E01250E000123CD53019805
+:100E500009F303BF0D0D032C0EFE0D1E014A0E00FB
+:100E6000022353CD53014C0E1B0C89047E05310621
+:100E7000660E1E01600E0002233ECD53010A0CDBFC
+:100E800009F303FD09FA0261041E01770E00045301
+:100E900049474ECD530192053106A20E36012D0071
+:100EA000FE0D1E018E0E0002552ECD5301170E367B
+:100EB000010000630E7A0E470D8A0C1E01A70E007A
+:100EC000012ECD5301170EB402730A3601000063E0
+:100ED0000E0D03930E7A0E470D8A0C1E01C00E00F4
+:100EE00007444543494D414CCD530136010A009812
+:100EF00009CE031E01E00E0003484558CD530136CC
+:100F00000110009809CE031E01F80E000448455256
+:100F100045CD5301B109F3031E010C0F0005414CEF
+:100F20004C4F54CD5301B10968051E011D0F00013E
+:100F30002CCD5301110FCE03360101009208230F6F
+:100F40001E012F0F0002432CCD5301110FE2033677
+:100F5000010100AA08230F1E01450F0006534F553B
+:100F6000524345CD5301C109DD0B1E015C0F000743
+:100F70002F535452494E47CD53010D03FA02390401
+:100F80000D030D0361041E016F0F00083E434F5512
+:100F90004E544544CD53011B0CE2039E08E7029ECC
+:100FA000071E018B0F0004574F5244CD5301B4026A
+:100FB000630F8B09F303770FB40240030D03DD07C2
+:100FC000FA0240030D030508B4023106D00FEF0406
+:100FD000580358030D0361048B096805310361044C
+:100FE000110F940F110F5809FA025D0C3904E20336
+:100FF0001E01A60F00074E46413E4C4641CD53010F
+:101000003601030061041E01F50F00074E46413E04
+:10101000434641CD53015D0C36017F007504390410
+:101020001E010B100006494D4D45443FCD5301EFC5
+:101030000405041E012510000446494E44CD530109
+:10104000D009F3031B0CFA0205049E082608B4021B
+:1010500031065C10D702FD0FF303B4027E053106A2
+:101060004410B40231067A102003B4021310E702D0
+:101070002C107E053601010089041E01381001077D
+:101080004C49544552414CCD5301A609F303310656
+:101090009A1036013601CC08310F1E017F10000670
+:1010A00044494749543FCD5301B40236013900E564
+:1010B000053601000175043904B40236014001E52A
+:1010C000053601070175046104360130006104B47E
+:1010D000029809F303F4051E019F1000053F5349D0
+:1010E000474ECD5301FA02050436012C006104B4C9
+:1010F00002730A36010100A3057504B40231060D1E
+:1011000011E104400336010100770F58031E01DC92
+:101110001000073E4E554D424552CD5301B40231A9
+:10112000064D11FA020504A6107E0531063311D7CB
+:10113000021E0140032D0C9809F303DF0D58034AEA
+:10114000042D0C36010100770F1B061D111E011224
+:101150001100073F4E554D424552CD5301B4023662
+:10116000010000B4020D035D0CE21040031A1131BE
+:1011700006811158030A0C0A0C360100001B069167
+:10118000110A0C2003580331068D11CD043601FFDE
+:10119000FF1E0152110009494E5445525052455408
+:1011A000CD5301C109F20B360100008B09CE035863
+:1011B00009AB0FB40205043106FB113D10C4023126
+:1011C00006DD11E104A609F3037E0589043106D783
+:1011D000114F011B06D911CC081B06F7115A11310A
+:1011E00006E91187101B06F7115D0C470D36013F0C
+:1011F000000D02700C78121B06AF11D7021E01966B
+:101200001100084556414C55415445CD5301C10983
+:10121000DD0B400340038B09F3034003A011580387
+:101220008B09CE0358035803C109F20B1E010212A9
+:10123000000451554954CD5301080AE609CE031361
+:101240000ABE0336010000A609CE037409B4026881
+:10125000097E028A0CA011A609F3037E0531066BF4
+:1012600012700C720D036F6B20470D1B064B123171
+:1012700012000541424F5254CD5301F1099A0336F1
+:1012800012721200063F41424F5254CD53010D03DA
+:1012900031069812470D78120A0C1E0184120106BD
+:1012A00041424F525422CD5301890D36018B12CC4D
+:1012B000081E019F12000127CD53015809AB0F3DB5
+:1012C000107E05720D013F8B121E01B61200044301
+:1012D000484152CD53015809AB0FE10405041E01EA
+:1012E000CE1201065B434841525DCD5301D3123605
+:1012F000013601CC08310F1E01E312010128CD5344
+:101300000136012900AB0FD7021E01FC1200064373
+:101310005245415445CD5301D009F303310F3601F5
+:101320000000480F110FD009CE035809AB0F050478
+:10133000E104230F36017F01EE081E010E130007A2
+:1013400028444F45533E29CD53015803D009F30398
+:101350001310D6081E013F130105444F45533ECDDF
+:10136000530136014713CC083601CE01EE081E01A9
+:101370005913010752454355525345CD5301D009E6
+:10138000F3031310CC081E01731301015BCD53014D
+:1013900036010000A609CE031E018B1300015DCDAE
+:1013A00053013601FFFFA609CE031E019D13000461
+:1013B00048494445CD5301D009F303B4020504362E
+:1013C0000180008904E702E2031E01AF1300065208
+:1013D000455645414CCD5301D009F303B4020504F1
+:1013E00036017F007504E702E2031E01CE130009F7
+:1013F000494D4D454449415445CD53013601010005
+:10140000D009F303EF04E2031E01EF1300013ACD0C
+:1014100053011513B4139F1307091E010D14010185
+:101420003BCD5301D51321098D131E011F14010358
+:101430005B275DCD5301B81236013601CC08310F60
+:101440001E012F140108504F5354504F4E45CD5399
+:10145000015809AB0F3D10B4027E05720D013F8BA0
+:101460001292053106791436013601CC08310F3657
+:1014700001CC08CC081B067B14CC081E01451401C6
+:10148000024946CD5301360131063709110FB40226
+:1014900043091E01801401045448454ECD530111E7
+:1014A0000FE7024F091E0197140104454C5345CD27
+:1014B000530136011B063709110FB4024309E70235
+:1014C0009C141E01AA140105424547494EC3110F41
+:1014D000C7140105554E54494CCD53013601310610
+:1014E000370943091E01D3140105414741494ECD37
+:1014F000530136011B06370943091E01E914010592
+:101500005748494C45C38314FF14010652455045C2
+:101510004154CD5301E702EF149C141E010B15003A
+:10152000023E4CCD53017208E6096805E609F30353
+:10153000CE031E01201500024C3ECD5301E609F3F7
+:1015400003F3037208CD04E60968051E013715018F
+:1015500002444FCD530136014706CC08110F360126
+:10156000000023151E0150150007454E444C4F4FF7
+:1015700050CD5301370943093A15C4023106861587
+:101580009C141B0678151E01691501044C4F4F5021
+:10159000CD53013601780671151E018B1501052BFF
+:1015A0004C4F4F50CD53013601AB0671151E019EB5
+:1015B0001501054C45415645CD53013601F906CC80
+:1015C0000836011B063709110FB402430923151E03
+:1015D00001B215000657495448494ECD5301FA024D
+:1015E0006104400361045803F4051E01D41500048E
+:1015F0004D4F5645CD530140031B0CE702B402701A
+:10160000033904DB15310611165803BC071B0615F8
+:101610001658039E071E01EF150005444550544817
+:10162000CD53018503F109E70261041E051E011A6D
+:1016300016000C454E5649524F4E4D454E543FCD27
+:1016400053010A0C360100001E0132160005574FE7
+:10165000524453CD5301D009F303B4025D0C470D3E
+:101660008A0CFD0FF303B4027E0531065A16D70229
+:101670001E014D1600022E53CD53018503F1096161
+:101680000431069F168503F1093601020061044703
+:1016900006B806F303AA0E3601FEFFAB0691161E2E
+:1016A0000175160004434F4C44CD5301210A7F09B4
+:1016B0003F0A9E07360180005D0CA011720D235A6F
+:1016C00038302043616D656C466F727468207631E6
+:1016D0002E303120203235204A616E2031393935A3
+:0616E0000D0A470D78120F
+:0000000000
+1016C00038302043616D656C466F727468207631E6
+:1016D0002E303120203235204A616E20313939
\ No newline at end of file
diff --git a/Source/HBIOS/Forth/camel80.prn b/Source/HBIOS/Forth/camel80.prn
new file mode 100644
index 00000000..5d3e9b2c
--- /dev/null
+++ b/Source/HBIOS/Forth/camel80.prn
@@ -0,0 +1,4464 @@
+ Z80MR VER 1.2 FILE CAMEL80
+
+
+ ; Listing 2.
+ ; ===============================================
+ ; CamelForth for the Zilog Z80
+ ; Copyright (c) 1994,1995 Bradford J. Rodriguez
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 3 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program. If not, see .
+
+ ; Commercial inquiries should be directed to the author at
+ ; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+ ; or via email to bj@camelforth.com
+ ;
+ ; ===============================================
+ ; CAMEL80.AZM: Code Primitives
+ ; Source code is for the Z80MR macro assembler.
+ ; Forth words are documented as follows:
+ ;x NAME stack -- stack description
+ ; where x=C for ANS Forth Core words, X for ANS
+ ; Extensions, Z for internal or private words.
+ ;
+ ; Direct-Threaded Forth model for Zilog Z80
+ ; 16 bit cell, 8 bit char, 8 bit (byte) adrs unit
+ ; Z80 BC = Forth TOS (top Param Stack item)
+ ; HL = W working register
+ ; DE = IP Interpreter Pointer
+ ; SP = PSP Param Stack Pointer
+ ; IX = RSP Return Stack Pointer
+ ; IY = UP User area Pointer
+ ; A, alternate register set = temporaries
+ ;
+ ; Revision history:
+ ; 19 Aug 94 v1.0
+ ; 25 Jan 95 v1.01 now using BDOS function 0Ah
+ ; for interpreter input; TIB at 82h.
+ ; 02 Mar 95 v1.02 changed ALIGN to ALIGNED in
+ ; S" (S"); changed ,BRANCH to ,XT in DO.
+ ; ===============================================
+ ; Macros to define Forth headers
+ ; HEAD label,length,name,action
+ ; IMMED label,length,name,action
+ ; label = assembler name for this word
+ ; (special characters not allowed)
+ ; length = length of name field
+ ; name = Forth's name for this word
+ ; action = code routine for this word, e.g.
+ ; DOCOLON, or DOCODE for code words
+ ; IMMED defines a header for an IMMEDIATE word.
+ ;
+ 0000 DOCODE EQU 0 ; flag to indicate CODE words
+ 0000 link DEFL 0 ; link to previous Forth word
+
+ head MACRO #label,#length,#name,#action
+ DW link
+ DB 0
+ link DEFL $
+ DB #length,'#name'
+ #label:
+ IF .NOT.(#action=DOCODE)
+ call #action
+ ENDIF
+ ENDM
+
+ immed MACRO #label,#length,#name,#action
+ DW link
+ DB 1
+ link DEFL $
+ DB #length,'#name'
+ #label:
+ IF .NOT.(#action=DOCODE)
+ call #action
+ ENDIF
+ ENDM
+
+ ; The NEXT macro (7 bytes) assembles the 'next'
+ ; code in-line in every Z80 CamelForth CODE word.
+ next MACRO
+ ex de,hl
+ ld e,(hl)
+ inc hl
+ ld d,(hl)
+ inc hl
+ ex de,hl
+ jp (hl)
+ ENDM
+
+ ; NEXTHL is used when the IP is already in HL.
+ nexthl MACRO
+ ld e,(hl)
+ inc hl
+ ld d,(hl)
+ inc hl
+ ex de,hl
+ jp (hl)
+ ENDM
+
+ ; RESET AND INTERRUPT VECTORS ===================
+ ; ...are not used in the CP/M implementation
+ ; Instead, we have the...
+
+ ; CP/M ENTRY POINT
+ 0100 org 100h
+ 0100 2A0600 reset: ld hl,(6h) ; BDOS address, rounded down
+ 0103 2E00 ld l,0 ; = end of avail.mem (EM)
+ 0105 25 dec h ; EM-100h
+ 0106 F9 ld sp,hl ; = top of param stack
+ 0107 24 inc h ; EM
+ 0108 E5 push hl
+ 0109 DDE1 pop ix ; = top of return stack
+ 010B 25 dec h ; EM-200h
+ 010C 25 dec h
+ 010D E5 push hl
+ 010E FDE1 pop iy ; = bottom of user area
+ 0110 110100 ld de,1 ; do reset if COLD returns
+ 0113 C3A916 jp COLD ; enter top-level Forth word
+
+ ; Memory map:
+ ; 0080h Terminal Input Buffer, 128 bytes
+ ; 0100h Forth kernel = start of CP/M TPA
+ ; ? h Forth dictionary (user RAM)
+ ; EM-200h User area, 128 bytes
+ ; EM-180h Parameter stack, 128B, grows down
+ ; EM-100h HOLD area, 40 bytes, grows down
+ ; EM-0D8h PAD buffer, 88 bytes
+ ; EM-80h Return stack, 128 B, grows down
+ ; EM End of RAM = start of CP/M BDOS
+ ; See also the definitions of U0, S0, and R0
+ ; in the "system variables & constants" area.
+ ; A task w/o terminal input requires 200h bytes.
+ ; Double all except TIB and PAD for 32-bit CPUs.
+
+ ; INTERPRETER LOGIC =============================
+ ; See also "defining words" at end of this file
+
+ ;C EXIT -- exit a colon definition
+ 0116 head EXIT,4,EXIT,docode
+ 0116 0000 + DW link
+ 0118 00 + DB 0
+ 0119 +link DEFL $
+ 0119 04455849 + DB 4,'EXIT'
+ 011E +EXIT:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 011E DD5E00 ld e,(ix+0) ; pop old IP from ret stk
+ 0121 DD23 inc ix
+ 0123 DD5600 ld d,(ix+0)
+ 0126 DD23 inc ix
+ 0128 next
+ 0128 EB + ex de,hl
+ 0129 5E + ld e,(hl)
+ 012A 23 + inc hl
+ 012B 56 + ld d,(hl)
+ 012C 23 + inc hl
+ 012D EB + ex de,hl
+ 012E E9 + jp (hl)
+
+ ;Z lit -- x fetch inline literal to stack
+ ; This is the primtive compiled by LITERAL.
+ 012F head lit,3,lit,docode
+ 012F 1901 + DW link
+ 0131 00 + DB 0
+ 0132 +link DEFL $
+ 0132 034C4954 + DB 3,'LIT'
+ 0136 +LIT:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0136 C5 push bc ; push old TOS
+ 0137 1A ld a,(de) ; fetch cell at IP to TOS,
+ 0138 4F ld c,a ; advancing IP
+ 0139 13 inc de
+ 013A 1A ld a,(de)
+ 013B 47 ld b,a
+ 013C 13 inc de
+ 013D next
+ 013D EB + ex de,hl
+ 013E 5E + ld e,(hl)
+ 013F 23 + inc hl
+ 0140 56 + ld d,(hl)
+ 0141 23 + inc hl
+ 0142 EB + ex de,hl
+ 0143 E9 + jp (hl)
+
+ ;C EXECUTE i*x xt -- j*x execute Forth word
+ ;C at 'xt'
+ 0144 head EXECUTE,7,EXECUTE,docode
+ 0144 3201 + DW link
+ 0146 00 + DB 0
+ 0147 +link DEFL $
+ 0147 07455845 + DB 7,'EXECUTE'
+ 014F +EXECUTE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 014F 60 ld h,b ; address of word -> HL
+ 0150 69 ld l,c
+ 0151 C1 pop bc ; get new TOS
+ 0152 E9 jp (hl) ; go do Forth word
+
+ ; DEFINING WORDS ================================
+
+ ; ENTER, a.k.a. DOCOLON, entered by CALL ENTER
+ ; to enter a new high-level thread (colon def'n.)
+ ; (internal code fragment, not a Forth word)
+ ; N.B.: DOCOLON must be defined before any
+ ; appearance of 'docolon' in a 'word' macro!
+ 0153 docolon: ; (alternate name)
+ 0153 DD2B enter: dec ix ; push old IP on ret stack
+ 0155 DD7200 ld (ix+0),d
+ 0158 DD2B dec ix
+ 015A DD7300 ld (ix+0),e
+ 015D E1 pop hl ; param field adrs -> IP
+ 015E nexthl ; use the faster 'nexthl'
+ 015E 5E + ld e,(hl)
+ 015F 23 + inc hl
+ 0160 56 + ld d,(hl)
+ 0161 23 + inc hl
+ 0162 EB + ex de,hl
+ 0163 E9 + jp (hl)
+
+ ;C VARIABLE -- define a Forth variable
+ ; CREATE 1 CELLS ALLOT ;
+ ; Action of RAM variable is identical to CREATE,
+ ; so we don't need a DOES> clause to change it.
+ 0164 head VARIABLE,8,VARIABLE,docolon
+ 0164 4701 + DW link
+ 0166 00 + DB 0
+ 0167 +link DEFL $
+ 0167 08564152 + DB 8,'VARIABLE'
+ 0170 +VARIABLE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0170 CD5301 + call DOCOLON
+ + ENDIF
+ 0173 15133601 DW CREATE,LIT,1,CELLS,ALLOT,EXIT
+ ; DOVAR, code action of VARIABLE, entered by CALL
+ ; DOCREATE, code action of newly created words
+ 017F docreate:
+ 017F dovar: ; -- a-addr
+ 017F E1 pop hl ; parameter field address
+ 0180 C5 push bc ; push old TOS
+ 0181 44 ld b,h ; pfa = variable's adrs -> TOS
+ 0182 4D ld c,l
+ 0183 next
+ 0183 EB + ex de,hl
+ 0184 5E + ld e,(hl)
+ 0185 23 + inc hl
+ 0186 56 + ld d,(hl)
+ 0187 23 + inc hl
+ 0188 EB + ex de,hl
+ 0189 E9 + jp (hl)
+
+ ;C CONSTANT n -- define a Forth constant
+ ; CREATE , DOES> (machine code fragment)
+ 018A head CONSTANT,8,CONSTANT,docolon
+ 018A 6701 + DW link
+ 018C 00 + DB 0
+ 018D +link DEFL $
+ 018D 08434F4E + DB 8,'CONSTANT'
+ 0196 +CONSTANT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0196 CD5301 + call DOCOLON
+ + ENDIF
+ 0199 1513310F DW CREATE,COMMA,XDOES
+ ; DOCON, code action of CONSTANT,
+ ; entered by CALL DOCON
+ 019F docon: ; -- x
+ 019F E1 pop hl ; parameter field address
+ 01A0 C5 push bc ; push old TOS
+ 01A1 4E ld c,(hl) ; fetch contents of parameter
+ 01A2 23 inc hl ; field -> TOS
+ 01A3 46 ld b,(hl)
+ 01A4 next
+ 01A4 EB + ex de,hl
+ 01A5 5E + ld e,(hl)
+ 01A6 23 + inc hl
+ 01A7 56 + ld d,(hl)
+ 01A8 23 + inc hl
+ 01A9 EB + ex de,hl
+ 01AA E9 + jp (hl)
+
+ ;Z USER n -- define user variable 'n'
+ ; CREATE , DOES> (machine code fragment)
+ 01AB head USER,4,USER,docolon
+ 01AB 8D01 + DW link
+ 01AD 00 + DB 0
+ 01AE +link DEFL $
+ 01AE 04555345 + DB 4,'USER'
+ 01B3 +USER:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 01B3 CD5301 + call DOCOLON
+ + ENDIF
+ 01B6 1513310F DW CREATE,COMMA,XDOES
+ ; DOUSER, code action of USER,
+ ; entered by CALL DOUSER
+ 01BC douser: ; -- a-addr
+ 01BC E1 pop hl ; parameter field address
+ 01BD C5 push bc ; push old TOS
+ 01BE 4E ld c,(hl) ; fetch contents of parameter
+ 01BF 23 inc hl ; field
+ 01C0 46 ld b,(hl)
+ 01C1 FDE5 push iy ; copy user base address to HL
+ 01C3 E1 pop hl
+ 01C4 09 add hl,bc ; and add offset
+ 01C5 44 ld b,h ; put result in TOS
+ 01C6 4D ld c,l
+ 01C7 next
+ 01C7 EB + ex de,hl
+ 01C8 5E + ld e,(hl)
+ 01C9 23 + inc hl
+ 01CA 56 + ld d,(hl)
+ 01CB 23 + inc hl
+ 01CC EB + ex de,hl
+ 01CD E9 + jp (hl)
+
+ ; DODOES, code action of DOES> clause
+ ; entered by CALL fragment
+ ; parameter field
+ ; ...
+ ; fragment: CALL DODOES
+ ; high-level thread
+ ; Enters high-level thread with address of
+ ; parameter field on top of stack.
+ ; (internal code fragment, not a Forth word)
+ 01CE dodoes: ; -- a-addr
+ 01CE DD2B dec ix ; push old IP on ret stk
+ 01D0 DD7200 ld (ix+0),d
+ 01D3 DD2B dec ix
+ 01D5 DD7300 ld (ix+0),e
+ 01D8 D1 pop de ; adrs of new thread -> IP
+ 01D9 E1 pop hl ; adrs of parameter field
+ 01DA C5 push bc ; push old TOS onto stack
+ 01DB 44 ld b,h ; pfa -> new TOS
+ 01DC 4D ld c,l
+ 01DD next
+ 01DD EB + ex de,hl
+ 01DE 5E + ld e,(hl)
+ 01DF 23 + inc hl
+ 01E0 56 + ld d,(hl)
+ 01E1 23 + inc hl
+ 01E2 EB + ex de,hl
+ 01E3 E9 + jp (hl)
+
+ ; CP/M TERMINAL I/O =============================
+ 0005 cpmbdos EQU 5h ; CP/M BDOS entry point
+
+ ;Z BDOS de c -- a call CP/M BDOS
+ 01E4 head BDOS,4,BDOS,docode
+ 01E4 AE01 + DW link
+ 01E6 00 + DB 0
+ 01E7 +link DEFL $
+ 01E7 0442444F + DB 4,'BDOS'
+ 01EC +BDOS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 01EC EB ex de,hl ; save important Forth regs
+ 01ED D1 pop de ; (DE,IX,IY) & pop DE value
+ 01EE E5 push hl
+ 01EF DDE5 push ix
+ 01F1 FDE5 push iy
+ 01F3 CD0500 call cpmbdos
+ 01F6 4F ld c,a ; result in TOS
+ 01F7 0600 ld b,0
+ 01F9 FDE1 pop iy ; restore Forth regs
+ 01FB DDE1 pop ix
+ 01FD D1 pop de
+ 01FE next
+ 01FE EB + ex de,hl
+ 01FF 5E + ld e,(hl)
+ 0200 23 + inc hl
+ 0201 56 + ld d,(hl)
+ 0202 23 + inc hl
+ 0203 EB + ex de,hl
+ 0204 E9 + jp (hl)
+
+ ;C EMIT c -- output character to console
+ ; 6 BDOS DROP ;
+ ; warning: if c=0ffh, will read one keypress
+ 0205 head EMIT,4,EMIT,docolon
+ 0205 E701 + DW link
+ 0207 00 + DB 0
+ 0208 +link DEFL $
+ 0208 04454D49 + DB 4,'EMIT'
+ 020D +EMIT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 020D CD5301 + call DOCOLON
+ + ENDIF
+ 0210 36010600 DW LIT,06H,BDOS,DROP,EXIT
+
+ ;Z SAVEKEY -- addr temporary storage for KEY?
+ 021A head savekey,7,SAVEKEY,dovar
+ 021A 0802 + DW link
+ 021C 00 + DB 0
+ 021D +link DEFL $
+ 021D 07534156 + DB 7,'SAVEKEY'
+ 0225 +SAVEKEY:
+ + IF .NOT.(DOVAR=DOCODE)
+ 0225 CD7F01 + call DOVAR
+ + ENDIF
+ 0228 0000 DW 0
+
+ ;X KEY? -- f return true if char waiting
+ ; 0FF 6 BDOS DUP SAVEKEY C! ; rtns 0 or key
+ ; must use BDOS function 6 to work with KEY
+ 022A head querykey,4,KEY?,docolon
+ 022A 1D02 + DW link
+ 022C 00 + DB 0
+ 022D +link DEFL $
+ 022D 044B4559 + DB 4,'KEY?'
+ 0232 +QUERYKEY:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0232 CD5301 + call DOCOLON
+ + ENDIF
+ 0235 3601FF00 DW LIT,0FFH,LIT,06H,BDOS
+ 023F B4022502 DW DUP,SAVEKEY,CSTORE,EXIT
+
+ ;C KEY -- c get character from keyboard
+ ; BEGIN SAVEKEY C@ 0= WHILE KEY? DROP REPEAT
+ ; SAVEKEY C@ 0 SAVEKEY C! ;
+ ; must use CP/M direct console I/O to avoid echo
+ ; (BDOS function 6, contained within KEY?)
+ 0247 head KEY,3,KEY,docolon
+ 0247 2D02 + DW link
+ 0249 00 + DB 0
+ 024A +link DEFL $
+ 024A 034B4559 + DB 3,'KEY'
+ 024E +KEY:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 024E CD5301 + call DOCOLON
+ + ENDIF
+ 0251 25020504 KEY1: DW SAVEKEY,CFETCH,ZEROEQUAL,qbranch,KEY2
+ 025B 3202D702 DW QUERYKEY,DROP,branch,KEY1
+ 0263 25020504 KEY2: DW SAVEKEY,CFETCH,LIT,0,SAVEKEY,CSTORE
+ 026F 1E01 DW EXIT
+
+ ;Z CPMACCEPT c-addr +n -- +n' get line of input
+ ; SWAP 2 - TUCK C! max # of characters
+ ; DUP 0A BDOS DROP CP/M Get Console Buffer
+ ; 1+ C@ 0A EMIT ; get returned count
+ ; Note: requires the two locations before c-addr
+ ; to be available for use.
+ 0271 head CPMACCEPT,9,CPMACCEPT,docolon
+ 0271 4A02 + DW link
+ 0273 00 + DB 0
+ 0274 +link DEFL $
+ 0274 0943504D + DB 9,'CPMACCEPT'
+ 027E +CPMACCEPT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 027E CD5301 + call DOCOLON
+ + ENDIF
+ 0281 E7023601 DW SWOP,LIT,2,MINUS,TUCK,CSTORE
+ 028D B4023601 DW DUP,LIT,0Ah,BDOS,DROP
+ 0297 E1040504 DW ONEPLUS,CFETCH,LIT,0Ah,EMIT,EXIT
+
+ ;X BYE i*x -- return to CP/M
+ 02A3 head bye,3,bye,docode
+ 02A3 7402 + DW link
+ 02A5 00 + DB 0
+ 02A6 +link DEFL $
+ 02A6 03425945 + DB 3,'BYE'
+ 02AA +BYE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 02AA C30000 jp 0
+
+ ; STACK OPERATIONS ==============================
+
+ ;C DUP x -- x x duplicate top of stack
+ 02AD head DUP,3,DUP,docode
+ 02AD A602 + DW link
+ 02AF 00 + DB 0
+ 02B0 +link DEFL $
+ 02B0 03445550 + DB 3,'DUP'
+ 02B4 +DUP:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 02B4 C5 pushtos: push bc
+ 02B5 next
+ 02B5 EB + ex de,hl
+ 02B6 5E + ld e,(hl)
+ 02B7 23 + inc hl
+ 02B8 56 + ld d,(hl)
+ 02B9 23 + inc hl
+ 02BA EB + ex de,hl
+ 02BB E9 + jp (hl)
+
+ ;C ?DUP x -- 0 | x x DUP if nonzero
+ 02BC head QDUP,4,?DUP,docode
+ 02BC B002 + DW link
+ 02BE 00 + DB 0
+ 02BF +link DEFL $
+ 02BF 043F4455 + DB 4,'?DUP'
+ 02C4 +QDUP:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 02C4 78 ld a,b
+ 02C5 B1 or c
+ 02C6 20EC jr nz,pushtos
+ 02C8 next
+ 02C8 EB + ex de,hl
+ 02C9 5E + ld e,(hl)
+ 02CA 23 + inc hl
+ 02CB 56 + ld d,(hl)
+ 02CC 23 + inc hl
+ 02CD EB + ex de,hl
+ 02CE E9 + jp (hl)
+
+ ;C DROP x -- drop top of stack
+ 02CF head DROP,4,DROP,docode
+ 02CF BF02 + DW link
+ 02D1 00 + DB 0
+ 02D2 +link DEFL $
+ 02D2 0444524F + DB 4,'DROP'
+ 02D7 +DROP:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 02D7 C1 poptos: pop bc
+ 02D8 next
+ 02D8 EB + ex de,hl
+ 02D9 5E + ld e,(hl)
+ 02DA 23 + inc hl
+ 02DB 56 + ld d,(hl)
+ 02DC 23 + inc hl
+ 02DD EB + ex de,hl
+ 02DE E9 + jp (hl)
+
+ ;C SWAP x1 x2 -- x2 x1 swap top two items
+ 02DF head SWOP,4,SWAP,docode
+ 02DF D202 + DW link
+ 02E1 00 + DB 0
+ 02E2 +link DEFL $
+ 02E2 04535741 + DB 4,'SWAP'
+ 02E7 +SWOP:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 02E7 E1 pop hl
+ 02E8 C5 push bc
+ 02E9 44 ld b,h
+ 02EA 4D ld c,l
+ 02EB next
+ 02EB EB + ex de,hl
+ 02EC 5E + ld e,(hl)
+ 02ED 23 + inc hl
+ 02EE 56 + ld d,(hl)
+ 02EF 23 + inc hl
+ 02F0 EB + ex de,hl
+ 02F1 E9 + jp (hl)
+
+ ;C OVER x1 x2 -- x1 x2 x1 per stack diagram
+ 02F2 head OVER,4,OVER,docode
+ 02F2 E202 + DW link
+ 02F4 00 + DB 0
+ 02F5 +link DEFL $
+ 02F5 044F5645 + DB 4,'OVER'
+ 02FA +OVER:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 02FA E1 pop hl
+ 02FB E5 push hl
+ 02FC C5 push bc
+ 02FD 44 ld b,h
+ 02FE 4D ld c,l
+ 02FF next
+ 02FF EB + ex de,hl
+ 0300 5E + ld e,(hl)
+ 0301 23 + inc hl
+ 0302 56 + ld d,(hl)
+ 0303 23 + inc hl
+ 0304 EB + ex de,hl
+ 0305 E9 + jp (hl)
+
+ ;C ROT x1 x2 x3 -- x2 x3 x1 per stack diagram
+ 0306 head ROT,3,ROT,docode
+ 0306 F502 + DW link
+ 0308 00 + DB 0
+ 0309 +link DEFL $
+ 0309 03524F54 + DB 3,'ROT'
+ 030D +ROT:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ ; x3 is in TOS
+ 030D E1 pop hl ; x2
+ 030E E3 ex (sp),hl ; x2 on stack, x1 in hl
+ 030F C5 push bc
+ 0310 44 ld b,h
+ 0311 4D ld c,l
+ 0312 next
+ 0312 EB + ex de,hl
+ 0313 5E + ld e,(hl)
+ 0314 23 + inc hl
+ 0315 56 + ld d,(hl)
+ 0316 23 + inc hl
+ 0317 EB + ex de,hl
+ 0318 E9 + jp (hl)
+
+ ;X NIP x1 x2 -- x2 per stack diagram
+ 0319 head NIP,3,NIP,docolon
+ 0319 0903 + DW link
+ 031B 00 + DB 0
+ 031C +link DEFL $
+ 031C 034E4950 + DB 3,'NIP'
+ 0320 +NIP:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0320 CD5301 + call DOCOLON
+ + ENDIF
+ 0323 E702D702 DW SWOP,DROP,EXIT
+
+ ;X TUCK x1 x2 -- x2 x1 x2 per stack diagram
+ 0329 head TUCK,4,TUCK,docolon
+ 0329 1C03 + DW link
+ 032B 00 + DB 0
+ 032C +link DEFL $
+ 032C 04545543 + DB 4,'TUCK'
+ 0331 +TUCK:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0331 CD5301 + call DOCOLON
+ + ENDIF
+ 0334 E702FA02 DW SWOP,OVER,EXIT
+
+ ;C >R x -- R: -- x push to return stack
+ 033A head TOR,2,>R,docode
+ 033A 2C03 + DW link
+ 033C 00 + DB 0
+ 033D +link DEFL $
+ 033D 023E52 + DB 2,'>R'
+ 0340 +TOR:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0340 DD2B dec ix ; push TOS onto rtn stk
+ 0342 DD7000 ld (ix+0),b
+ 0345 DD2B dec ix
+ 0347 DD7100 ld (ix+0),c
+ 034A C1 pop bc ; pop new TOS
+ 034B next
+ 034B EB + ex de,hl
+ 034C 5E + ld e,(hl)
+ 034D 23 + inc hl
+ 034E 56 + ld d,(hl)
+ 034F 23 + inc hl
+ 0350 EB + ex de,hl
+ 0351 E9 + jp (hl)
+
+ ;C R> -- x R: x -- pop from return stack
+ 0352 head RFROM,2,R>,docode
+ 0352 3D03 + DW link
+ 0354 00 + DB 0
+ 0355 +link DEFL $
+ 0355 02523E + DB 2,'R>'
+ 0358 +RFROM:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0358 C5 push bc ; push old TOS
+ 0359 DD4E00 ld c,(ix+0) ; pop top rtn stk item
+ 035C DD23 inc ix ; to TOS
+ 035E DD4600 ld b,(ix+0)
+ 0361 DD23 inc ix
+ 0363 next
+ 0363 EB + ex de,hl
+ 0364 5E + ld e,(hl)
+ 0365 23 + inc hl
+ 0366 56 + ld d,(hl)
+ 0367 23 + inc hl
+ 0368 EB + ex de,hl
+ 0369 E9 + jp (hl)
+
+ ;C R@ -- x R: x -- x fetch from rtn stk
+ 036A head RFETCH,2,R@,docode
+ 036A 5503 + DW link
+ 036C 00 + DB 0
+ 036D +link DEFL $
+ 036D 025240 + DB 2,'R@'
+ 0370 +RFETCH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0370 C5 push bc ; push old TOS
+ 0371 DD4E00 ld c,(ix+0) ; fetch top rtn stk item
+ 0374 DD4601 ld b,(ix+1) ; to TOS
+ 0377 next
+ 0377 EB + ex de,hl
+ 0378 5E + ld e,(hl)
+ 0379 23 + inc hl
+ 037A 56 + ld d,(hl)
+ 037B 23 + inc hl
+ 037C EB + ex de,hl
+ 037D E9 + jp (hl)
+
+ ;Z SP@ -- a-addr get data stack pointer
+ 037E head SPFETCH,3,SP@,docode
+ 037E 6D03 + DW link
+ 0380 00 + DB 0
+ 0381 +link DEFL $
+ 0381 03535040 + DB 3,'SP@'
+ 0385 +SPFETCH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0385 C5 push bc
+ 0386 210000 ld hl,0
+ 0389 39 add hl,sp
+ 038A 44 ld b,h
+ 038B 4D ld c,l
+ 038C next
+ 038C EB + ex de,hl
+ 038D 5E + ld e,(hl)
+ 038E 23 + inc hl
+ 038F 56 + ld d,(hl)
+ 0390 23 + inc hl
+ 0391 EB + ex de,hl
+ 0392 E9 + jp (hl)
+
+ ;Z SP! a-addr -- set data stack pointer
+ 0393 head SPSTORE,3,SP!,docode
+ 0393 8103 + DW link
+ 0395 00 + DB 0
+ 0396 +link DEFL $
+ 0396 03535021 + DB 3,'SP!'
+ 039A +SPSTORE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 039A 60 ld h,b
+ 039B 69 ld l,c
+ 039C F9 ld sp,hl
+ 039D C1 pop bc ; get new TOS
+ 039E next
+ 039E EB + ex de,hl
+ 039F 5E + ld e,(hl)
+ 03A0 23 + inc hl
+ 03A1 56 + ld d,(hl)
+ 03A2 23 + inc hl
+ 03A3 EB + ex de,hl
+ 03A4 E9 + jp (hl)
+
+ ;Z RP@ -- a-addr get return stack pointer
+ 03A5 head RPFETCH,3,RP@,docode
+ 03A5 9603 + DW link
+ 03A7 00 + DB 0
+ 03A8 +link DEFL $
+ 03A8 03525040 + DB 3,'RP@'
+ 03AC +RPFETCH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 03AC C5 push bc
+ 03AD DDE5 push ix
+ 03AF C1 pop bc
+ 03B0 next
+ 03B0 EB + ex de,hl
+ 03B1 5E + ld e,(hl)
+ 03B2 23 + inc hl
+ 03B3 56 + ld d,(hl)
+ 03B4 23 + inc hl
+ 03B5 EB + ex de,hl
+ 03B6 E9 + jp (hl)
+
+ ;Z RP! a-addr -- set return stack pointer
+ 03B7 head RPSTORE,3,RP!,docode
+ 03B7 A803 + DW link
+ 03B9 00 + DB 0
+ 03BA +link DEFL $
+ 03BA 03525021 + DB 3,'RP!'
+ 03BE +RPSTORE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 03BE C5 push bc
+ 03BF DDE1 pop ix
+ 03C1 C1 pop bc
+ 03C2 next
+ 03C2 EB + ex de,hl
+ 03C3 5E + ld e,(hl)
+ 03C4 23 + inc hl
+ 03C5 56 + ld d,(hl)
+ 03C6 23 + inc hl
+ 03C7 EB + ex de,hl
+ 03C8 E9 + jp (hl)
+
+ ; MEMORY AND I/O OPERATIONS =====================
+
+ ;C ! x a-addr -- store cell in memory
+ 03C9 head STORE,1,!,docode
+ 03C9 BA03 + DW link
+ 03CB 00 + DB 0
+ 03CC +link DEFL $
+ 03CC 0121 + DB 1,'!'
+ 03CE +STORE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 03CE 60 ld h,b ; address in hl
+ 03CF 69 ld l,c
+ 03D0 C1 pop bc ; data in bc
+ 03D1 71 ld (hl),c
+ 03D2 23 inc hl
+ 03D3 70 ld (hl),b
+ 03D4 C1 pop bc ; pop new TOS
+ 03D5 next
+ 03D5 EB + ex de,hl
+ 03D6 5E + ld e,(hl)
+ 03D7 23 + inc hl
+ 03D8 56 + ld d,(hl)
+ 03D9 23 + inc hl
+ 03DA EB + ex de,hl
+ 03DB E9 + jp (hl)
+
+ ;C C! char c-addr -- store char in memory
+ 03DC head CSTORE,2,C!,docode
+ 03DC CC03 + DW link
+ 03DE 00 + DB 0
+ 03DF +link DEFL $
+ 03DF 024321 + DB 2,'C!'
+ 03E2 +CSTORE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 03E2 60 ld h,b ; address in hl
+ 03E3 69 ld l,c
+ 03E4 C1 pop bc ; data in bc
+ 03E5 71 ld (hl),c
+ 03E6 C1 pop bc ; pop new TOS
+ 03E7 next
+ 03E7 EB + ex de,hl
+ 03E8 5E + ld e,(hl)
+ 03E9 23 + inc hl
+ 03EA 56 + ld d,(hl)
+ 03EB 23 + inc hl
+ 03EC EB + ex de,hl
+ 03ED E9 + jp (hl)
+
+ ;C @ a-addr -- x fetch cell from memory
+ 03EE head FETCH,1,@,docode
+ 03EE DF03 + DW link
+ 03F0 00 + DB 0
+ 03F1 +link DEFL $
+ 03F1 0140 + DB 1,'@'
+ 03F3 +FETCH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 03F3 60 ld h,b ; address in hl
+ 03F4 69 ld l,c
+ 03F5 4E ld c,(hl)
+ 03F6 23 inc hl
+ 03F7 46 ld b,(hl)
+ 03F8 next
+ 03F8 EB + ex de,hl
+ 03F9 5E + ld e,(hl)
+ 03FA 23 + inc hl
+ 03FB 56 + ld d,(hl)
+ 03FC 23 + inc hl
+ 03FD EB + ex de,hl
+ 03FE E9 + jp (hl)
+
+ ;C C@ c-addr -- char fetch char from memory
+ 03FF head CFETCH,2,C@,docode
+ 03FF F103 + DW link
+ 0401 00 + DB 0
+ 0402 +link DEFL $
+ 0402 024340 + DB 2,'C@'
+ 0405 +CFETCH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0405 0A ld a,(bc)
+ 0406 4F ld c,a
+ 0407 0600 ld b,0
+ 0409 next
+ 0409 EB + ex de,hl
+ 040A 5E + ld e,(hl)
+ 040B 23 + inc hl
+ 040C 56 + ld d,(hl)
+ 040D 23 + inc hl
+ 040E EB + ex de,hl
+ 040F E9 + jp (hl)
+
+ ;Z PC! char c-addr -- output char to port
+ 0410 head PCSTORE,3,PC!,docode
+ 0410 0204 + DW link
+ 0412 00 + DB 0
+ 0413 +link DEFL $
+ 0413 03504321 + DB 3,'PC!'
+ 0417 +PCSTORE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0417 E1 pop hl ; char in L
+ 0418 ED69 out (c),l ; to port (BC)
+ 041A C1 pop bc ; pop new TOS
+ 041B next
+ 041B EB + ex de,hl
+ 041C 5E + ld e,(hl)
+ 041D 23 + inc hl
+ 041E 56 + ld d,(hl)
+ 041F 23 + inc hl
+ 0420 EB + ex de,hl
+ 0421 E9 + jp (hl)
+
+ ;Z PC@ c-addr -- char input char from port
+ 0422 head PCFETCH,3,PC@,docode
+ 0422 1304 + DW link
+ 0424 00 + DB 0
+ 0425 +link DEFL $
+ 0425 03504340 + DB 3,'PC@'
+ 0429 +PCFETCH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0429 ED48 in c,(c) ; read port (BC) to C
+ 042B 0600 ld b,0
+ 042D next
+ 042D EB + ex de,hl
+ 042E 5E + ld e,(hl)
+ 042F 23 + inc hl
+ 0430 56 + ld d,(hl)
+ 0431 23 + inc hl
+ 0432 EB + ex de,hl
+ 0433 E9 + jp (hl)
+
+ ; ARITHMETIC AND LOGICAL OPERATIONS =============
+
+ ;C + n1/u1 n2/u2 -- n3/u3 add n1+n2
+ 0434 head PLUS,1,+,docode
+ 0434 2504 + DW link
+ 0436 00 + DB 0
+ 0437 +link DEFL $
+ 0437 012B + DB 1,'+'
+ 0439 +PLUS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0439 E1 pop hl
+ 043A 09 add hl,bc
+ 043B 44 ld b,h
+ 043C 4D ld c,l
+ 043D next
+ 043D EB + ex de,hl
+ 043E 5E + ld e,(hl)
+ 043F 23 + inc hl
+ 0440 56 + ld d,(hl)
+ 0441 23 + inc hl
+ 0442 EB + ex de,hl
+ 0443 E9 + jp (hl)
+
+ ;X M+ d n -- d add single to double
+ 0444 head MPLUS,2,M+,docode
+ 0444 3704 + DW link
+ 0446 00 + DB 0
+ 0447 +link DEFL $
+ 0447 024D2B + DB 2,'M+'
+ 044A +MPLUS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 044A EB ex de,hl
+ 044B D1 pop de ; hi cell
+ 044C E3 ex (sp),hl ; lo cell, save IP
+ 044D 09 add hl,bc
+ 044E 42 ld b,d ; hi result in BC (TOS)
+ 044F 4B ld c,e
+ 0450 3001 jr nc,mplus1
+ 0452 03 inc bc
+ 0453 D1 mplus1: pop de ; restore saved IP
+ 0454 E5 push hl ; push lo result
+ 0455 next
+ 0455 EB + ex de,hl
+ 0456 5E + ld e,(hl)
+ 0457 23 + inc hl
+ 0458 56 + ld d,(hl)
+ 0459 23 + inc hl
+ 045A EB + ex de,hl
+ 045B E9 + jp (hl)
+
+ ;C - n1/u1 n2/u2 -- n3/u3 subtract n1-n2
+ 045C head MINUS,1,-,docode
+ 045C 4704 + DW link
+ 045E 00 + DB 0
+ 045F +link DEFL $
+ 045F 012D + DB 1,'-'
+ 0461 +MINUS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0461 E1 pop hl
+ 0462 B7 or a
+ 0463 ED42 sbc hl,bc
+ 0465 44 ld b,h
+ 0466 4D ld c,l
+ 0467 next
+ 0467 EB + ex de,hl
+ 0468 5E + ld e,(hl)
+ 0469 23 + inc hl
+ 046A 56 + ld d,(hl)
+ 046B 23 + inc hl
+ 046C EB + ex de,hl
+ 046D E9 + jp (hl)
+
+ ;C AND x1 x2 -- x3 logical AND
+ 046E head AND,3,AND,docode
+ 046E 5F04 + DW link
+ 0470 00 + DB 0
+ 0471 +link DEFL $
+ 0471 03414E44 + DB 3,'AND'
+ 0475 +AND:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0475 E1 pop hl
+ 0476 78 ld a,b
+ 0477 A4 and h
+ 0478 47 ld b,a
+ 0479 79 ld a,c
+ 047A A5 and l
+ 047B 4F ld c,a
+ 047C next
+ 047C EB + ex de,hl
+ 047D 5E + ld e,(hl)
+ 047E 23 + inc hl
+ 047F 56 + ld d,(hl)
+ 0480 23 + inc hl
+ 0481 EB + ex de,hl
+ 0482 E9 + jp (hl)
+
+ ;C OR x1 x2 -- x3 logical OR
+ 0483 head OR,2,OR,docode
+ 0483 7104 + DW link
+ 0485 00 + DB 0
+ 0486 +link DEFL $
+ 0486 024F52 + DB 2,'OR'
+ 0489 +OR:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0489 E1 pop hl
+ 048A 78 ld a,b
+ 048B B4 or h
+ 048C 47 ld b,a
+ 048D 79 ld a,c
+ 048E B5 or l
+ 048F 4F ld c,a
+ 0490 next
+ 0490 EB + ex de,hl
+ 0491 5E + ld e,(hl)
+ 0492 23 + inc hl
+ 0493 56 + ld d,(hl)
+ 0494 23 + inc hl
+ 0495 EB + ex de,hl
+ 0496 E9 + jp (hl)
+
+ ;C XOR x1 x2 -- x3 logical XOR
+ 0497 head XOR,3,XOR,docode
+ 0497 8604 + DW link
+ 0499 00 + DB 0
+ 049A +link DEFL $
+ 049A 03584F52 + DB 3,'XOR'
+ 049E +XOR:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 049E E1 pop hl
+ 049F 78 ld a,b
+ 04A0 AC xor h
+ 04A1 47 ld b,a
+ 04A2 79 ld a,c
+ 04A3 AD xor l
+ 04A4 4F ld c,a
+ 04A5 next
+ 04A5 EB + ex de,hl
+ 04A6 5E + ld e,(hl)
+ 04A7 23 + inc hl
+ 04A8 56 + ld d,(hl)
+ 04A9 23 + inc hl
+ 04AA EB + ex de,hl
+ 04AB E9 + jp (hl)
+
+ ;C INVERT x1 -- x2 bitwise inversion
+ 04AC head INVERT,6,INVERT,docode
+ 04AC 9A04 + DW link
+ 04AE 00 + DB 0
+ 04AF +link DEFL $
+ 04AF 06494E56 + DB 6,'INVERT'
+ 04B6 +INVERT:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 04B6 78 ld a,b
+ 04B7 2F cpl
+ 04B8 47 ld b,a
+ 04B9 79 ld a,c
+ 04BA 2F cpl
+ 04BB 4F ld c,a
+ 04BC next
+ 04BC EB + ex de,hl
+ 04BD 5E + ld e,(hl)
+ 04BE 23 + inc hl
+ 04BF 56 + ld d,(hl)
+ 04C0 23 + inc hl
+ 04C1 EB + ex de,hl
+ 04C2 E9 + jp (hl)
+
+ ;C NEGATE x1 -- x2 two's complement
+ 04C3 head NEGATE,6,NEGATE,docode
+ 04C3 AF04 + DW link
+ 04C5 00 + DB 0
+ 04C6 +link DEFL $
+ 04C6 064E4547 + DB 6,'NEGATE'
+ 04CD +NEGATE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 04CD 78 ld a,b
+ 04CE 2F cpl
+ 04CF 47 ld b,a
+ 04D0 79 ld a,c
+ 04D1 2F cpl
+ 04D2 4F ld c,a
+ 04D3 03 inc bc
+ 04D4 next
+ 04D4 EB + ex de,hl
+ 04D5 5E + ld e,(hl)
+ 04D6 23 + inc hl
+ 04D7 56 + ld d,(hl)
+ 04D8 23 + inc hl
+ 04D9 EB + ex de,hl
+ 04DA E9 + jp (hl)
+
+ ;C 1+ n1/u1 -- n2/u2 add 1 to TOS
+ 04DB head ONEPLUS,2,1+,docode
+ 04DB C604 + DW link
+ 04DD 00 + DB 0
+ 04DE +link DEFL $
+ 04DE 02312B + DB 2,'1+'
+ 04E1 +ONEPLUS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 04E1 03 inc bc
+ 04E2 next
+ 04E2 EB + ex de,hl
+ 04E3 5E + ld e,(hl)
+ 04E4 23 + inc hl
+ 04E5 56 + ld d,(hl)
+ 04E6 23 + inc hl
+ 04E7 EB + ex de,hl
+ 04E8 E9 + jp (hl)
+
+ ;C 1- n1/u1 -- n2/u2 subtract 1 from TOS
+ 04E9 head ONEMINUS,2,1-,docode
+ 04E9 DE04 + DW link
+ 04EB 00 + DB 0
+ 04EC +link DEFL $
+ 04EC 02312D + DB 2,'1-'
+ 04EF +ONEMINUS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 04EF 0B dec bc
+ 04F0 next
+ 04F0 EB + ex de,hl
+ 04F1 5E + ld e,(hl)
+ 04F2 23 + inc hl
+ 04F3 56 + ld d,(hl)
+ 04F4 23 + inc hl
+ 04F5 EB + ex de,hl
+ 04F6 E9 + jp (hl)
+
+ ;Z >< x1 -- x2 swap bytes (not ANSI)
+ 04F7 head swapbytes,2,><,docode
+ 04F7 EC04 + DW link
+ 04F9 00 + DB 0
+ 04FA +link DEFL $
+ 04FA 023E3C + DB 2,'><'
+ 04FD +SWAPBYTES:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 04FD 78 ld a,b
+ 04FE 41 ld b,c
+ 04FF 4F ld c,a
+ 0500 next
+ 0500 EB + ex de,hl
+ 0501 5E + ld e,(hl)
+ 0502 23 + inc hl
+ 0503 56 + ld d,(hl)
+ 0504 23 + inc hl
+ 0505 EB + ex de,hl
+ 0506 E9 + jp (hl)
+
+ ;C 2* x1 -- x2 arithmetic left shift
+ 0507 head TWOSTAR,2,2*,docode
+ 0507 FA04 + DW link
+ 0509 00 + DB 0
+ 050A +link DEFL $
+ 050A 02322A + DB 2,'2*'
+ 050D +TWOSTAR:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 050D CB21 sla c
+ 050F CB10 rl b
+ 0511 next
+ 0511 EB + ex de,hl
+ 0512 5E + ld e,(hl)
+ 0513 23 + inc hl
+ 0514 56 + ld d,(hl)
+ 0515 23 + inc hl
+ 0516 EB + ex de,hl
+ 0517 E9 + jp (hl)
+
+ ;C 2/ x1 -- x2 arithmetic right shift
+ 0518 head TWOSLASH,2,2/,docode
+ 0518 0A05 + DW link
+ 051A 00 + DB 0
+ 051B +link DEFL $
+ 051B 02322F + DB 2,'2/'
+ 051E +TWOSLASH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 051E CB28 sra b
+ 0520 CB19 rr c
+ 0522 next
+ 0522 EB + ex de,hl
+ 0523 5E + ld e,(hl)
+ 0524 23 + inc hl
+ 0525 56 + ld d,(hl)
+ 0526 23 + inc hl
+ 0527 EB + ex de,hl
+ 0528 E9 + jp (hl)
+
+ ;C LSHIFT x1 u -- x2 logical L shift u places
+ 0529 head LSHIFT,6,LSHIFT,docode
+ 0529 1B05 + DW link
+ 052B 00 + DB 0
+ 052C +link DEFL $
+ 052C 064C5348 + DB 6,'LSHIFT'
+ 0533 +LSHIFT:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0533 41 ld b,c ; b = loop counter
+ 0534 E1 pop hl ; NB: hi 8 bits ignored!
+ 0535 04 inc b ; test for counter=0 case
+ 0536 1801 jr lsh2
+ 0538 29 lsh1: add hl,hl ; left shift HL, n times
+ 0539 10FD lsh2: djnz lsh1
+ 053B 44 ld b,h ; result is new TOS
+ 053C 4D ld c,l
+ 053D next
+ 053D EB + ex de,hl
+ 053E 5E + ld e,(hl)
+ 053F 23 + inc hl
+ 0540 56 + ld d,(hl)
+ 0541 23 + inc hl
+ 0542 EB + ex de,hl
+ 0543 E9 + jp (hl)
+
+ ;C RSHIFT x1 u -- x2 logical R shift u places
+ 0544 head RSHIFT,6,RSHIFT,docode
+ 0544 2C05 + DW link
+ 0546 00 + DB 0
+ 0547 +link DEFL $
+ 0547 06525348 + DB 6,'RSHIFT'
+ 054E +RSHIFT:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 054E 41 ld b,c ; b = loop counter
+ 054F E1 pop hl ; NB: hi 8 bits ignored!
+ 0550 04 inc b ; test for counter=0 case
+ 0551 1804 jr rsh2
+ 0553 CB3C rsh1: srl h ; right shift HL, n times
+ 0555 CB1D rr l
+ 0557 10FA rsh2: djnz rsh1
+ 0559 44 ld b,h ; result is new TOS
+ 055A 4D ld c,l
+ 055B next
+ 055B EB + ex de,hl
+ 055C 5E + ld e,(hl)
+ 055D 23 + inc hl
+ 055E 56 + ld d,(hl)
+ 055F 23 + inc hl
+ 0560 EB + ex de,hl
+ 0561 E9 + jp (hl)
+
+ ;C +! n/u a-addr -- add cell to memory
+ 0562 head PLUSSTORE,2,+!,docode
+ 0562 4705 + DW link
+ 0564 00 + DB 0
+ 0565 +link DEFL $
+ 0565 022B21 + DB 2,'+!'
+ 0568 +PLUSSTORE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0568 E1 pop hl
+ 0569 0A ld a,(bc) ; low byte
+ 056A 85 add a,l
+ 056B 02 ld (bc),a
+ 056C 03 inc bc
+ 056D 0A ld a,(bc) ; high byte
+ 056E 8C adc a,h
+ 056F 02 ld (bc),a
+ 0570 C1 pop bc ; pop new TOS
+ 0571 next
+ 0571 EB + ex de,hl
+ 0572 5E + ld e,(hl)
+ 0573 23 + inc hl
+ 0574 56 + ld d,(hl)
+ 0575 23 + inc hl
+ 0576 EB + ex de,hl
+ 0577 E9 + jp (hl)
+
+ ; COMPARISON OPERATIONS =========================
+
+ ;C 0= n/u -- flag return true if TOS=0
+ 0578 head ZEROEQUAL,2,0=,docode
+ 0578 6505 + DW link
+ 057A 00 + DB 0
+ 057B +link DEFL $
+ 057B 02303D + DB 2,'0='
+ 057E +ZEROEQUAL:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 057E 78 ld a,b
+ 057F B1 or c ; result=0 if bc was 0
+ 0580 D601 sub 1 ; cy set if bc was 0
+ 0582 9F sbc a,a ; propagate cy through A
+ 0583 47 ld b,a ; put 0000 or FFFF in TOS
+ 0584 4F ld c,a
+ 0585 next
+ 0585 EB + ex de,hl
+ 0586 5E + ld e,(hl)
+ 0587 23 + inc hl
+ 0588 56 + ld d,(hl)
+ 0589 23 + inc hl
+ 058A EB + ex de,hl
+ 058B E9 + jp (hl)
+
+ ;C 0< n -- flag true if TOS negative
+ 058C head ZEROLESS,2,0<,docode
+ 058C 7B05 + DW link
+ 058E 00 + DB 0
+ 058F +link DEFL $
+ 058F 02303C + DB 2,'0<'
+ 0592 +ZEROLESS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0592 CB20 sla b ; sign bit -> cy flag
+ 0594 9F sbc a,a ; propagate cy through A
+ 0595 47 ld b,a ; put 0000 or FFFF in TOS
+ 0596 4F ld c,a
+ 0597 next
+ 0597 EB + ex de,hl
+ 0598 5E + ld e,(hl)
+ 0599 23 + inc hl
+ 059A 56 + ld d,(hl)
+ 059B 23 + inc hl
+ 059C EB + ex de,hl
+ 059D E9 + jp (hl)
+
+ ;C = x1 x2 -- flag test x1=x2
+ 059E head EQUAL,1,=,docode
+ 059E 8F05 + DW link
+ 05A0 00 + DB 0
+ 05A1 +link DEFL $
+ 05A1 013D + DB 1,'='
+ 05A3 +EQUAL:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 05A3 E1 pop hl
+ 05A4 B7 or a
+ 05A5 ED42 sbc hl,bc ; x1-x2 in HL, SZVC valid
+ 05A7 2828 jr z,tostrue
+ 05A9 010000 tosfalse: ld bc,0
+ 05AC next
+ 05AC EB + ex de,hl
+ 05AD 5E + ld e,(hl)
+ 05AE 23 + inc hl
+ 05AF 56 + ld d,(hl)
+ 05B0 23 + inc hl
+ 05B1 EB + ex de,hl
+ 05B2 E9 + jp (hl)
+
+ ;X <> x1 x2 -- flag test not eq (not ANSI)
+ 05B3 head NOTEQUAL,2,<>,docolon
+ 05B3 A105 + DW link
+ 05B5 00 + DB 0
+ 05B6 +link DEFL $
+ 05B6 023C3E + DB 2,'<>'
+ 05B9 +NOTEQUAL:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 05B9 CD5301 + call DOCOLON
+ + ENDIF
+ 05BC A3057E05 DW EQUAL,ZEROEQUAL,EXIT
+
+ ;C < n1 n2 -- flag test n1 n1 +ve, n2 -ve, rslt -ve, so n1>n2
+ ; if result positive & not OV, n1>=n2
+ ; pos. & OV => n1 -ve, n2 +ve, rslt +ve, so n1 n1 n2 -- flag test n1>n2, signed
+ 05E0 head GREATER,1,>,docolon
+ 05E0 C505 + DW link
+ 05E2 00 + DB 0
+ 05E3 +link DEFL $
+ 05E3 013E + DB 1,'>'
+ 05E5 +GREATER:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 05E5 CD5301 + call DOCOLON
+ + ENDIF
+ 05E8 E702C705 DW SWOP,LESS,EXIT
+
+ ;C U< u1 u2 -- flag test u1 u1 u2 -- flag u1>u2 unsgd (not ANSI)
+ 0602 head UGREATER,2,U>,docolon
+ 0602 F105 + DW link
+ 0604 00 + DB 0
+ 0605 +link DEFL $
+ 0605 02553E + DB 2,'U>'
+ 0608 +UGREATER:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0608 CD5301 + call DOCOLON
+ + ENDIF
+ 060B E702F405 DW SWOP,ULESS,EXIT
+
+ ; LOOP AND BRANCH OPERATIONS ====================
+
+ ;Z branch -- branch always
+ 0611 head branch,6,branch,docode
+ 0611 0506 + DW link
+ 0613 00 + DB 0
+ 0614 +link DEFL $
+ 0614 06425241 + DB 6,'BRANCH'
+ 061B +BRANCH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 061B 1A dobranch: ld a,(de) ; get inline value => IP
+ 061C 6F ld l,a
+ 061D 13 inc de
+ 061E 1A ld a,(de)
+ 061F 67 ld h,a
+ 0620 nexthl
+ 0620 5E + ld e,(hl)
+ 0621 23 + inc hl
+ 0622 56 + ld d,(hl)
+ 0623 23 + inc hl
+ 0624 EB + ex de,hl
+ 0625 E9 + jp (hl)
+
+ ;Z ?branch x -- branch if TOS zero
+ 0626 head qbranch,7,?branch,docode
+ 0626 1406 + DW link
+ 0628 00 + DB 0
+ 0629 +link DEFL $
+ 0629 073F4252 + DB 7,'?BRANCH'
+ 0631 +QBRANCH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0631 78 ld a,b
+ 0632 B1 or c ; test old TOS
+ 0633 C1 pop bc ; pop new TOS
+ 0634 28E5 jr z,dobranch ; if old TOS=0, branch
+ 0636 13 inc de ; else skip inline value
+ 0637 13 inc de
+ 0638 next
+ 0638 EB + ex de,hl
+ 0639 5E + ld e,(hl)
+ 063A 23 + inc hl
+ 063B 56 + ld d,(hl)
+ 063C 23 + inc hl
+ 063D EB + ex de,hl
+ 063E E9 + jp (hl)
+
+ ;Z (do) n1|u1 n2|u2 -- R: -- sys1 sys2
+ ;Z run-time code for DO
+ ; '83 and ANSI standard loops terminate when the
+ ; boundary of limit-1 and limit is crossed, in
+ ; either direction. This can be conveniently
+ ; implemented by making the limit 8000h, so that
+ ; arithmetic overflow logic can detect crossing.
+ ; I learned this trick from Laxen & Perry F83.
+ ; fudge factor = 8000h-limit, to be added to
+ ; the start value.
+ 063F head xdo,4,(do),docode
+ 063F 2906 + DW link
+ 0641 00 + DB 0
+ 0642 +link DEFL $
+ 0642 0428444F + DB 4,'(DO)'
+ 0647 +XDO:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0647 EB ex de,hl
+ 0648 E3 ex (sp),hl ; IP on stack, limit in HL
+ 0649 EB ex de,hl
+ 064A 210080 ld hl,8000h
+ 064D B7 or a
+ 064E ED52 sbc hl,de ; 8000-limit in HL
+ 0650 DD2B dec ix ; push this fudge factor
+ 0652 DD7400 ld (ix+0),h ; onto return stack
+ 0655 DD2B dec ix ; for later use by 'I'
+ 0657 DD7500 ld (ix+0),l
+ 065A 09 add hl,bc ; add fudge to start value
+ 065B DD2B dec ix ; push adjusted start value
+ 065D DD7400 ld (ix+0),h ; onto return stack
+ 0660 DD2B dec ix ; as the loop index.
+ 0662 DD7500 ld (ix+0),l
+ 0665 D1 pop de ; restore the saved IP
+ 0666 C1 pop bc ; pop new TOS
+ 0667 next
+ 0667 EB + ex de,hl
+ 0668 5E + ld e,(hl)
+ 0669 23 + inc hl
+ 066A 56 + ld d,(hl)
+ 066B 23 + inc hl
+ 066C EB + ex de,hl
+ 066D E9 + jp (hl)
+
+ ;Z (loop) R: sys1 sys2 -- | sys1 sys2
+ ;Z run-time code for LOOP
+ ; Add 1 to the loop index. If loop terminates,
+ ; clean up the return stack and skip the branch.
+ ; Else take the inline branch. Note that LOOP
+ ; terminates when index=8000h.
+ 066E head xloop,6,(loop),docode
+ 066E 4206 + DW link
+ 0670 00 + DB 0
+ 0671 +link DEFL $
+ 0671 06284C4F + DB 6,'(LOOP)'
+ 0678 +XLOOP:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0678 D9 exx
+ 0679 010100 ld bc,1
+ 067C DD6E00 looptst: ld l,(ix+0) ; get the loop index
+ 067F DD6601 ld h,(ix+1)
+ 0682 B7 or a
+ 0683 ED4A adc hl,bc ; increment w/overflow test
+ 0685 EA9106 jp pe,loopterm ; overflow=loop done
+ ; continue the loop
+ 0688 DD7500 ld (ix+0),l ; save the updated index
+ 068B DD7401 ld (ix+1),h
+ 068E D9 exx
+ 068F 188A jr dobranch ; take the inline branch
+ 0691 loopterm: ; terminate the loop
+ 0691 010400 ld bc,4 ; discard the loop info
+ 0694 DD09 add ix,bc
+ 0696 D9 exx
+ 0697 13 inc de ; skip the inline branch
+ 0698 13 inc de
+ 0699 next
+ 0699 EB + ex de,hl
+ 069A 5E + ld e,(hl)
+ 069B 23 + inc hl
+ 069C 56 + ld d,(hl)
+ 069D 23 + inc hl
+ 069E EB + ex de,hl
+ 069F E9 + jp (hl)
+
+ ;Z (+loop) n -- R: sys1 sys2 -- | sys1 sys2
+ ;Z run-time code for +LOOP
+ ; Add n to the loop index. If loop terminates,
+ ; clean up the return stack and skip the branch.
+ ; Else take the inline branch.
+ 06A0 head xplusloop,7,(+loop),docode
+ 06A0 7106 + DW link
+ 06A2 00 + DB 0
+ 06A3 +link DEFL $
+ 06A3 07282B4C + DB 7,'(+LOOP)'
+ 06AB +XPLUSLOOP:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 06AB E1 pop hl ; this will be the new TOS
+ 06AC C5 push bc
+ 06AD 44 ld b,h
+ 06AE 4D ld c,l
+ 06AF D9 exx
+ 06B0 C1 pop bc ; old TOS = loop increment
+ 06B1 18C9 jr looptst
+
+ ;C I -- n R: sys1 sys2 -- sys1 sys2
+ ;C get the innermost loop index
+ 06B3 head II,1,I,docode
+ 06B3 A306 + DW link
+ 06B5 00 + DB 0
+ 06B6 +link DEFL $
+ 06B6 0149 + DB 1,'I'
+ 06B8 +II:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 06B8 C5 push bc ; push old TOS
+ 06B9 DD6E00 ld l,(ix+0) ; get current loop index
+ 06BC DD6601 ld h,(ix+1)
+ 06BF DD4E02 ld c,(ix+2) ; get fudge factor
+ 06C2 DD4603 ld b,(ix+3)
+ 06C5 B7 or a
+ 06C6 ED42 sbc hl,bc ; subtract fudge factor,
+ 06C8 44 ld b,h ; returning true index
+ 06C9 4D ld c,l
+ 06CA next
+ 06CA EB + ex de,hl
+ 06CB 5E + ld e,(hl)
+ 06CC 23 + inc hl
+ 06CD 56 + ld d,(hl)
+ 06CE 23 + inc hl
+ 06CF EB + ex de,hl
+ 06D0 E9 + jp (hl)
+
+ ;C J -- n R: 4*sys -- 4*sys
+ ;C get the second loop index
+ 06D1 head JJ,1,J,docode
+ 06D1 B606 + DW link
+ 06D3 00 + DB 0
+ 06D4 +link DEFL $
+ 06D4 014A + DB 1,'J'
+ 06D6 +JJ:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 06D6 C5 push bc ; push old TOS
+ 06D7 DD6E04 ld l,(ix+4) ; get current loop index
+ 06DA DD6605 ld h,(ix+5)
+ 06DD DD4E06 ld c,(ix+6) ; get fudge factor
+ 06E0 DD4607 ld b,(ix+7)
+ 06E3 B7 or a
+ 06E4 ED42 sbc hl,bc ; subtract fudge factor,
+ 06E6 44 ld b,h ; returning true index
+ 06E7 4D ld c,l
+ 06E8 next
+ 06E8 EB + ex de,hl
+ 06E9 5E + ld e,(hl)
+ 06EA 23 + inc hl
+ 06EB 56 + ld d,(hl)
+ 06EC 23 + inc hl
+ 06ED EB + ex de,hl
+ 06EE E9 + jp (hl)
+
+ ;C UNLOOP -- R: sys1 sys2 -- drop loop parms
+ 06EF head UNLOOP,6,UNLOOP,docode
+ 06EF D406 + DW link
+ 06F1 00 + DB 0
+ 06F2 +link DEFL $
+ 06F2 06554E4C + DB 6,'UNLOOP'
+ 06F9 +UNLOOP:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 06F9 DD23 inc ix
+ 06FB DD23 inc ix
+ 06FD DD23 inc ix
+ 06FF DD23 inc ix
+ 0701 next
+ 0701 EB + ex de,hl
+ 0702 5E + ld e,(hl)
+ 0703 23 + inc hl
+ 0704 56 + ld d,(hl)
+ 0705 23 + inc hl
+ 0706 EB + ex de,hl
+ 0707 E9 + jp (hl)
+
+ ; MULTIPLY AND DIVIDE ===========================
+
+ ;C UM* u1 u2 -- ud unsigned 16x16->32 mult.
+ 0708 head UMSTAR,3,UM*,docode
+ 0708 F206 + DW link
+ 070A 00 + DB 0
+ 070B +link DEFL $
+ 070B 03554D2A + DB 3,'UM*'
+ 070F +UMSTAR:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 070F C5 push bc
+ 0710 D9 exx
+ 0711 C1 pop bc ; u2 in BC
+ 0712 D1 pop de ; u1 in DE
+ 0713 210000 ld hl,0 ; result will be in HLDE
+ 0716 3E11 ld a,17 ; loop counter
+ 0718 B7 or a ; clear cy
+ 0719 CB1C umloop: rr h
+ 071B CB1D rr l
+ 071D CB1A rr d
+ 071F CB1B rr e
+ 0721 3001 jr nc,noadd
+ 0723 09 add hl,bc
+ 0724 3D noadd: dec a
+ 0725 20F2 jr nz,umloop
+ 0727 D5 push de ; lo result
+ 0728 E5 push hl ; hi result
+ 0729 D9 exx
+ 072A C1 pop bc ; put TOS back in BC
+ 072B next
+ 072B EB + ex de,hl
+ 072C 5E + ld e,(hl)
+ 072D 23 + inc hl
+ 072E 56 + ld d,(hl)
+ 072F 23 + inc hl
+ 0730 EB + ex de,hl
+ 0731 E9 + jp (hl)
+
+ ;C UM/MOD ud u1 -- u2 u3 unsigned 32/16->16
+ 0732 head UMSLASHMOD,6,UM/MOD,docode
+ 0732 0B07 + DW link
+ 0734 00 + DB 0
+ 0735 +link DEFL $
+ 0735 06554D2F + DB 6,'UM/MOD'
+ 073C +UMSLASHMOD:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 073C C5 push bc
+ 073D D9 exx
+ 073E C1 pop bc ; BC = divisor
+ 073F E1 pop hl ; HLDE = dividend
+ 0740 D1 pop de
+ 0741 3E10 ld a,16 ; loop counter
+ 0743 CB23 sla e
+ 0745 CB12 rl d ; hi bit DE -> carry
+ 0747 ED6A udloop: adc hl,hl ; rot left w/ carry
+ 0749 3006 jr nc,udiv3
+ ; case 1: 17 bit, cy:HL = 1xxxx
+ 074B B7 or a ; we know we can subtract
+ 074C ED42 sbc hl,bc
+ 074E B7 or a ; clear cy to indicate sub ok
+ 074F 1806 jr udiv4
+ ; case 2: 16 bit, cy:HL = 0xxxx
+ 0751 ED42 udiv3: sbc hl,bc ; try the subtract
+ 0753 3002 jr nc,udiv4 ; if no cy, subtract ok
+ 0755 09 add hl,bc ; else cancel the subtract
+ 0756 37 scf ; and set cy to indicate
+ 0757 CB13 udiv4: rl e ; rotate result bit into DE,
+ 0759 CB12 rl d ; and next bit of DE into cy
+ 075B 3D dec a
+ 075C 20E9 jr nz,udloop
+ ; now have complemented quotient in DE,
+ ; and remainder in HL
+ 075E 7A ld a,d
+ 075F 2F cpl
+ 0760 47 ld b,a
+ 0761 7B ld a,e
+ 0762 2F cpl
+ 0763 4F ld c,a
+ 0764 E5 push hl ; push remainder
+ 0765 C5 push bc
+ 0766 D9 exx
+ 0767 C1 pop bc ; quotient remains in TOS
+ 0768 next
+ 0768 EB + ex de,hl
+ 0769 5E + ld e,(hl)
+ 076A 23 + inc hl
+ 076B 56 + ld d,(hl)
+ 076C 23 + inc hl
+ 076D EB + ex de,hl
+ 076E E9 + jp (hl)
+
+ ; BLOCK AND STRING OPERATIONS ===================
+
+ ;C FILL c-addr u char -- fill memory with char
+ 076F head FILL,4,FILL,docode
+ 076F 3507 + DW link
+ 0771 00 + DB 0
+ 0772 +link DEFL $
+ 0772 0446494C + DB 4,'FILL'
+ 0777 +FILL:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0777 79 ld a,c ; character in a
+ 0778 D9 exx ; use alt. register set
+ 0779 C1 pop bc ; count in bc
+ 077A D1 pop de ; address in de
+ 077B B7 or a ; clear carry flag
+ 077C 21FFFF ld hl,0ffffh
+ 077F ED4A adc hl,bc ; test for count=0 or 1
+ 0781 3009 jr nc,filldone ; no cy: count=0, skip
+ 0783 12 ld (de),a ; fill first byte
+ 0784 2806 jr z,filldone ; zero, count=1, done
+ 0786 0B dec bc ; else adjust count,
+ 0787 62 ld h,d ; let hl = start adrs,
+ 0788 6B ld l,e
+ 0789 13 inc de ; let de = start adrs+1
+ 078A EDB0 ldir ; copy (hl)->(de)
+ 078C D9 filldone: exx ; back to main reg set
+ 078D C1 pop bc ; pop new TOS
+ 078E next
+ 078E EB + ex de,hl
+ 078F 5E + ld e,(hl)
+ 0790 23 + inc hl
+ 0791 56 + ld d,(hl)
+ 0792 23 + inc hl
+ 0793 EB + ex de,hl
+ 0794 E9 + jp (hl)
+
+ ;X CMOVE c-addr1 c-addr2 u -- move from bottom
+ ; as defined in the ANSI optional String word set
+ ; On byte machines, CMOVE and CMOVE> are logical
+ ; factors of MOVE. They are easy to implement on
+ ; CPUs which have a block-move instruction.
+ 0795 head CMOVE,5,CMOVE,docode
+ 0795 7207 + DW link
+ 0797 00 + DB 0
+ 0798 +link DEFL $
+ 0798 05434D4F + DB 5,'CMOVE'
+ 079E +CMOVE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 079E C5 push bc
+ 079F D9 exx
+ 07A0 C1 pop bc ; count
+ 07A1 D1 pop de ; destination adrs
+ 07A2 E1 pop hl ; source adrs
+ 07A3 78 ld a,b ; test for count=0
+ 07A4 B1 or c
+ 07A5 2802 jr z,cmovedone
+ 07A7 EDB0 ldir ; move from bottom to top
+ 07A9 D9 cmovedone: exx
+ 07AA C1 pop bc ; pop new TOS
+ 07AB next
+ 07AB EB + ex de,hl
+ 07AC 5E + ld e,(hl)
+ 07AD 23 + inc hl
+ 07AE 56 + ld d,(hl)
+ 07AF 23 + inc hl
+ 07B0 EB + ex de,hl
+ 07B1 E9 + jp (hl)
+
+ ;X CMOVE> c-addr1 c-addr2 u -- move from top
+ ; as defined in the ANSI optional String word set
+ 07B2 head CMOVEUP,6,CMOVE>,docode
+ 07B2 9807 + DW link
+ 07B4 00 + DB 0
+ 07B5 +link DEFL $
+ 07B5 06434D4F + DB 6,'CMOVE>'
+ 07BC +CMOVEUP:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 07BC C5 push bc
+ 07BD D9 exx
+ 07BE C1 pop bc ; count
+ 07BF E1 pop hl ; destination adrs
+ 07C0 D1 pop de ; source adrs
+ 07C1 78 ld a,b ; test for count=0
+ 07C2 B1 or c
+ 07C3 2807 jr z,umovedone
+ 07C5 09 add hl,bc ; last byte in destination
+ 07C6 2B dec hl
+ 07C7 EB ex de,hl
+ 07C8 09 add hl,bc ; last byte in source
+ 07C9 2B dec hl
+ 07CA EDB8 lddr ; move from top to bottom
+ 07CC D9 umovedone: exx
+ 07CD C1 pop bc ; pop new TOS
+ 07CE next
+ 07CE EB + ex de,hl
+ 07CF 5E + ld e,(hl)
+ 07D0 23 + inc hl
+ 07D1 56 + ld d,(hl)
+ 07D2 23 + inc hl
+ 07D3 EB + ex de,hl
+ 07D4 E9 + jp (hl)
+
+ ;Z SKIP c-addr u c -- c-addr' u'
+ ;Z skip matching chars
+ ; Although SKIP, SCAN, and S= are perhaps not the
+ ; ideal factors of WORD and FIND, they closely
+ ; follow the string operations available on many
+ ; CPUs, and so are easy to implement and fast.
+ 07D5 head skip,4,SKIP,docode
+ 07D5 B507 + DW link
+ 07D7 00 + DB 0
+ 07D8 +link DEFL $
+ 07D8 04534B49 + DB 4,'SKIP'
+ 07DD +SKIP:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 07DD 79 ld a,c ; skip character
+ 07DE D9 exx
+ 07DF C1 pop bc ; count
+ 07E0 E1 pop hl ; address
+ 07E1 5F ld e,a ; test for count=0
+ 07E2 78 ld a,b
+ 07E3 B1 or c
+ 07E4 280C jr z,skipdone
+ 07E6 7B ld a,e
+ 07E7 EDA1 skiploop: cpi
+ 07E9 2005 jr nz,skipmis ; char mismatch: exit
+ 07EB EAE707 jp pe,skiploop ; count not exhausted
+ 07EE 1802 jr skipdone ; count 0, no mismatch
+ 07F0 03 skipmis: inc bc ; mismatch! undo last to
+ 07F1 2B dec hl ; point at mismatch char
+ 07F2 E5 skipdone: push hl ; updated address
+ 07F3 C5 push bc ; updated count
+ 07F4 D9 exx
+ 07F5 C1 pop bc ; TOS in bc
+ 07F6 next
+ 07F6 EB + ex de,hl
+ 07F7 5E + ld e,(hl)
+ 07F8 23 + inc hl
+ 07F9 56 + ld d,(hl)
+ 07FA 23 + inc hl
+ 07FB EB + ex de,hl
+ 07FC E9 + jp (hl)
+
+ ;Z SCAN c-addr u c -- c-addr' u'
+ ;Z find matching char
+ 07FD head scan,4,SCAN,docode
+ 07FD D807 + DW link
+ 07FF 00 + DB 0
+ 0800 +link DEFL $
+ 0800 04534341 + DB 4,'SCAN'
+ 0805 +SCAN:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0805 79 ld a,c ; scan character
+ 0806 D9 exx
+ 0807 C1 pop bc ; count
+ 0808 E1 pop hl ; address
+ 0809 5F ld e,a ; test for count=0
+ 080A 78 ld a,b
+ 080B B1 or c
+ 080C 2807 jr z,scandone
+ 080E 7B ld a,e
+ 080F EDB1 cpir ; scan 'til match or count=0
+ 0811 2002 jr nz,scandone ; no match, BC & HL ok
+ 0813 03 inc bc ; match! undo last to
+ 0814 2B dec hl ; point at match char
+ 0815 E5 scandone: push hl ; updated address
+ 0816 C5 push bc ; updated count
+ 0817 D9 exx
+ 0818 C1 pop bc ; TOS in bc
+ 0819 next
+ 0819 EB + ex de,hl
+ 081A 5E + ld e,(hl)
+ 081B 23 + inc hl
+ 081C 56 + ld d,(hl)
+ 081D 23 + inc hl
+ 081E EB + ex de,hl
+ 081F E9 + jp (hl)
+
+ ;Z S= c-addr1 c-addr2 u -- n string compare
+ ;Z n<0: s10: s1>s2
+ 0820 head sequal,2,S=,docode
+ 0820 0008 + DW link
+ 0822 00 + DB 0
+ 0823 +link DEFL $
+ 0823 02533D + DB 2,'S='
+ 0826 +SEQUAL:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0826 C5 push bc
+ 0827 D9 exx
+ 0828 C1 pop bc ; count
+ 0829 E1 pop hl ; addr2
+ 082A D1 pop de ; addr1
+ 082B 78 ld a,b ; test for count=0
+ 082C B1 or c
+ 082D 2809 jr z,smatch ; by definition, match!
+ 082F 1A sloop: ld a,(de)
+ 0830 13 inc de
+ 0831 EDA1 cpi
+ 0833 2009 jr nz,sdiff ; char mismatch: exit
+ 0835 EA2F08 jp pe,sloop ; count not exhausted
+ 0838 smatch: ; count exhausted & no mismatch found
+ 0838 D9 exx
+ 0839 010000 ld bc,0 ; bc=0000 (s1=s2)
+ 083C 1808 jr snext
+ 083E sdiff: ; mismatch! undo last 'cpi' increment
+ 083E 2B dec hl ; point at mismatch char
+ 083F BE cp (hl) ; set cy if char1 < char2
+ 0840 9F sbc a,a ; propagate cy thru A
+ 0841 D9 exx
+ 0842 47 ld b,a ; bc=FFFF if cy (s1s2)
+ 0845 4F ld c,a
+ 0846 snext: next
+ 0846 EB + ex de,hl
+ 0847 5E + ld e,(hl)
+ 0848 23 + inc hl
+ 0849 56 + ld d,(hl)
+ 084A 23 + inc hl
+ 084B EB + ex de,hl
+ 084C E9 + jp (hl)
+
+ *INCLUDE camel80d.azm ; CPU Dependencies
+ ; LISTING 3.
+ ;
+ ; ===============================================
+ ; CamelForth for the Zilog Z80
+ ; Copyright (c) 1994,1995 Bradford J. Rodriguez
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 3 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program. If not, see .
+
+ ; Commercial inquiries should be directed to the author at
+ ; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+ ; or via email to bj@camelforth.com
+ ;
+ ; ===============================================
+ ; CAMEL80D.AZM: CPU and Model Dependencies
+ ; Source code is for the Z80MR macro assembler.
+ ; Forth words are documented as follows:
+ ;* NAME stack -- stack description
+ ; Word names in upper case are from the ANS
+ ; Forth Core word set. Names in lower case are
+ ; "internal" implementation words & extensions.
+ ;
+ ; Direct-Threaded Forth model for Zilog Z80
+ ; cell size is 16 bits (2 bytes)
+ ; char size is 8 bits (1 byte)
+ ; address unit is 8 bits (1 byte), i.e.,
+ ; addresses are byte-aligned.
+ ; ===============================================
+
+ ; ALIGNMENT AND PORTABILITY OPERATORS ===========
+ ; Many of these are synonyms for other words,
+ ; and so are defined as CODE words.
+
+ ;C ALIGN -- align HERE
+ 084D head ALIGN,5,ALIGN,docode
+ 084D 2308 + DW link
+ 084F 00 + DB 0
+ 0850 +link DEFL $
+ 0850 05414C49 + DB 5,'ALIGN'
+ 0856 +ALIGN:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0856 noop: next
+ 0856 EB + ex de,hl
+ 0857 5E + ld e,(hl)
+ 0858 23 + inc hl
+ 0859 56 + ld d,(hl)
+ 085A 23 + inc hl
+ 085B EB + ex de,hl
+ 085C E9 + jp (hl)
+
+ ;C ALIGNED addr -- a-addr align given addr
+ 085D head ALIGNED,7,ALIGNED,docode
+ 085D 5008 + DW link
+ 085F 00 + DB 0
+ 0860 +link DEFL $
+ 0860 07414C49 + DB 7,'ALIGNED'
+ 0868 +ALIGNED:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0868 18EC jr noop
+
+ ;Z CELL -- n size of one cell
+ 086A head CELL,4,CELL,docon
+ 086A 6008 + DW link
+ 086C 00 + DB 0
+ 086D +link DEFL $
+ 086D 0443454C + DB 4,'CELL'
+ 0872 +CELL:
+ + IF .NOT.(DOCON=DOCODE)
+ 0872 CD9F01 + call DOCON
+ + ENDIF
+ 0875 0200 dw 2
+
+ ;C CELL+ a-addr1 -- a-addr2 add cell size
+ ; 2 + ;
+ 0877 head CELLPLUS,5,CELL+,docode
+ 0877 6D08 + DW link
+ 0879 00 + DB 0
+ 087A +link DEFL $
+ 087A 0543454C + DB 5,'CELL+'
+ 0880 +CELLPLUS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0880 03 inc bc
+ 0881 03 inc bc
+ 0882 next
+ 0882 EB + ex de,hl
+ 0883 5E + ld e,(hl)
+ 0884 23 + inc hl
+ 0885 56 + ld d,(hl)
+ 0886 23 + inc hl
+ 0887 EB + ex de,hl
+ 0888 E9 + jp (hl)
+
+ ;C CELLS n1 -- n2 cells->adrs units
+ 0889 head CELLS,5,CELLS,docode
+ 0889 7A08 + DW link
+ 088B 00 + DB 0
+ 088C +link DEFL $
+ 088C 0543454C + DB 5,'CELLS'
+ 0892 +CELLS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0892 C30D05 jp twostar
+
+ ;C CHAR+ c-addr1 -- c-addr2 add char size
+ 0895 head CHARPLUS,5,CHAR+,docode
+ 0895 8C08 + DW link
+ 0897 00 + DB 0
+ 0898 +link DEFL $
+ 0898 05434841 + DB 5,'CHAR+'
+ 089E +CHARPLUS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 089E C3E104 jp oneplus
+
+ ;C CHARS n1 -- n2 chars->adrs units
+ 08A1 head CHARS,5,CHARS,docode
+ 08A1 9808 + DW link
+ 08A3 00 + DB 0
+ 08A4 +link DEFL $
+ 08A4 05434841 + DB 5,'CHARS'
+ 08AA +CHARS:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 08AA 18AA jr noop
+
+ ;C >BODY xt -- a-addr adrs of param field
+ ; 3 + ; Z80 (3 byte CALL)
+ 08AC head TOBODY,5,>BODY,docolon
+ 08AC A408 + DW link
+ 08AE 00 + DB 0
+ 08AF +link DEFL $
+ 08AF 053E424F + DB 5,'>BODY'
+ 08B5 +TOBODY:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 08B5 CD5301 + call DOCOLON
+ + ENDIF
+ 08B8 36010300 DW LIT,3,PLUS,EXIT
+
+ ;X COMPILE, xt -- append execution token
+ ; I called this word ,XT before I discovered that
+ ; it is defined in the ANSI standard as COMPILE,.
+ ; On a DTC Forth this simply appends xt (like , )
+ ; but on an STC Forth this must append 'CALL xt'.
+ 08C0 head COMMAXT,8,'COMPILE,',docode
+ 08C0 AF08 + DW link
+ 08C2 00 + DB 0
+ 08C3 +link DEFL $
+ 08C3 08434F4D + DB 8,'COMPILE,'
+ 08CC +COMMAXT:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 08CC C3310F jp COMMA
+
+ ;Z !CF adrs cfa -- set code action of a word
+ ; 0CD OVER C! store 'CALL adrs' instr
+ ; 1+ ! ; Z80 VERSION
+ ; Depending on the implementation this could
+ ; append CALL adrs or JUMP adrs.
+ 08CF head STORECF,3,!CF,docolon
+ 08CF C308 + DW link
+ 08D1 00 + DB 0
+ 08D2 +link DEFL $
+ 08D2 03214346 + DB 3,'!CF'
+ 08D6 +STORECF:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 08D6 CD5301 + call DOCOLON
+ + ENDIF
+ 08D9 3601CD00 DW LIT,0CDH,OVER,CSTORE
+ 08E1 E104CE03 DW ONEPLUS,STORE,EXIT
+
+ ;Z ,CF adrs -- append a code field
+ ; HERE !CF 3 ALLOT ; Z80 VERSION (3 bytes)
+ 08E7 head COMMACF,3,',CF',docolon
+ 08E7 D208 + DW link
+ 08E9 00 + DB 0
+ 08EA +link DEFL $
+ 08EA 032C4346 + DB 3,',CF'
+ 08EE +COMMACF:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 08EE CD5301 + call DOCOLON
+ + ENDIF
+ 08F1 110FD608 DW HERE,STORECF,LIT,3,ALLOT,EXIT
+
+ ;Z !COLON -- change code field to docolon
+ ; -3 ALLOT docolon-adrs ,CF ;
+ ; This should be used immediately after CREATE.
+ ; This is made a distinct word, because on an STC
+ ; Forth, colon definitions have no code field.
+ 08FD head STORCOLON,6,'!COLON',docolon
+ 08FD EA08 + DW link
+ 08FF 00 + DB 0
+ 0900 +link DEFL $
+ 0900 0621434F + DB 6,'!COLON'
+ 0907 +STORCOLON:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0907 CD5301 + call DOCOLON
+ + ENDIF
+ 090A 3601FDFF DW LIT,-3,ALLOT
+ 0910 36015301 DW LIT,docolon,COMMACF,EXIT
+
+ ;Z ,EXIT -- append hi-level EXIT action
+ ; ['] EXIT ,XT ;
+ ; This is made a distinct word, because on an STC
+ ; Forth, it appends a RET instruction, not an xt.
+ 0918 head CEXIT,5,',EXIT',docolon
+ 0918 0009 + DW link
+ 091A 00 + DB 0
+ 091B +link DEFL $
+ 091B 052C4558 + DB 5,',EXIT'
+ 0921 +CEXIT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0921 CD5301 + call DOCOLON
+ + ENDIF
+ 0924 36011E01 DW LIT,EXIT,COMMAXT,EXIT
+
+ ; CONTROL STRUCTURES ============================
+ ; These words allow Forth control structure words
+ ; to be defined portably.
+
+ ;Z ,BRANCH xt -- append a branch instruction
+ ; xt is the branch operator to use, e.g. qbranch
+ ; or (loop). It does NOT append the destination
+ ; address. On the Z80 this is equivalent to ,XT.
+ 092C head COMMABRANCH,7,',BRANCH',docode
+ 092C 1B09 + DW link
+ 092E 00 + DB 0
+ 092F +link DEFL $
+ 092F 072C4252 + DB 7,',BRANCH'
+ 0937 +COMMABRANCH:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0937 C3310F jp COMMA
+
+ ;Z ,DEST dest -- append a branch address
+ ; This appends the given destination address to
+ ; the branch instruction. On the Z80 this is ','
+ ; ...other CPUs may use relative addressing.
+ 093A head COMMADEST,5,',DEST',docode
+ 093A 2F09 + DW link
+ 093C 00 + DB 0
+ 093D +link DEFL $
+ 093D 052C4445 + DB 5,',DEST'
+ 0943 +COMMADEST:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 0943 C3310F jp COMMA
+
+ ;Z !DEST dest adrs -- change a branch dest'n
+ ; Changes the destination address found at 'adrs'
+ ; to the given 'dest'. On the Z80 this is '!'
+ ; ...other CPUs may need relative addressing.
+ 0946 head STOREDEST,5,'!DEST',docode
+ 0946 3D09 + DW link
+ 0948 00 + DB 0
+ 0949 +link DEFL $
+ 0949 05214445 + DB 5,'!DEST'
+ 094F +STOREDEST:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 094F C3CE03 jp STORE
+
+ ; HEADER STRUCTURE ==============================
+ ; The structure of the Forth dictionary headers
+ ; (name, link, immediate flag, and "smudge" bit)
+ ; does not necessarily differ across CPUs. This
+ ; structure is not easily factored into distinct
+ ; "portable" words; instead, it is implicit in
+ ; the definitions of FIND and CREATE, and also in
+ ; NFA>LFA, NFA>CFA, IMMED?, IMMEDIATE, HIDE, and
+ ; REVEAL. These words must be (substantially)
+ ; rewritten if either the header structure or its
+ ; inherent assumptions are changed.
+
+ *INCLUDE camel80h.azm ; High Level words
+ ; LISTING 2.
+ ;
+ ; ===============================================
+ ; CamelForth for the Zilog Z80
+ ; Copyright (c) 1994,1995 Bradford J. Rodriguez
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 3 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program. If not, see .
+
+ ; Commercial inquiries should be directed to the author at
+ ; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+ ; or via email to bj@camelforth.com
+ ;
+ ; ===============================================
+ ; CAMEL80H.AZM: High Level Words
+ ; Source code is for the Z80MR macro assembler.
+ ; Forth words are documented as follows:
+ ;* NAME stack -- stack description
+ ; Word names in upper case are from the ANS
+ ; Forth Core word set. Names in lower case are
+ ; "internal" implementation words & extensions.
+ ; ===============================================
+
+ ; SYSTEM VARIABLES & CONSTANTS ==================
+
+ ;C BL -- char an ASCII space
+ 0952 head BL,2,BL,docon
+ 0952 4909 + DW link
+ 0954 00 + DB 0
+ 0955 +link DEFL $
+ 0955 02424C + DB 2,'BL'
+ 0958 +BL:
+ + IF .NOT.(DOCON=DOCODE)
+ 0958 CD9F01 + call DOCON
+ + ENDIF
+ 095B 2000 dw 20h
+
+ ;Z tibsize -- n size of TIB
+ 095D head TIBSIZE,7,TIBSIZE,docon
+ 095D 5509 + DW link
+ 095F 00 + DB 0
+ 0960 +link DEFL $
+ 0960 07544942 + DB 7,'TIBSIZE'
+ 0968 +TIBSIZE:
+ + IF .NOT.(DOCON=DOCODE)
+ 0968 CD9F01 + call DOCON
+ + ENDIF
+ 096B 7C00 dw 124 ; 2 chars safety zone
+
+ ;X tib -- a-addr Terminal Input Buffer
+ ; HEX 82 CONSTANT TIB CP/M systems: 126 bytes
+ ; HEX -80 USER TIB others: below user area
+ 096D head TIB,3,TIB,docon
+ 096D 6009 + DW link
+ 096F 00 + DB 0
+ 0970 +link DEFL $
+ 0970 03544942 + DB 3,'TIB'
+ 0974 +TIB:
+ + IF .NOT.(DOCON=DOCODE)
+ 0974 CD9F01 + call DOCON
+ + ENDIF
+ 0977 8200 dw 82h
+
+ ;Z u0 -- a-addr current user area adrs
+ ; 0 USER U0
+ 0979 head U0,2,U0,douser
+ 0979 7009 + DW link
+ 097B 00 + DB 0
+ 097C +link DEFL $
+ 097C 025530 + DB 2,'U0'
+ 097F +U0:
+ + IF .NOT.(DOUSER=DOCODE)
+ 097F CDBC01 + call DOUSER
+ + ENDIF
+ 0982 0000 dw 0
+
+ ;C >IN -- a-addr holds offset into TIB
+ ; 2 USER >IN
+ 0984 head TOIN,3,>IN,douser
+ 0984 7C09 + DW link
+ 0986 00 + DB 0
+ 0987 +link DEFL $
+ 0987 033E494E + DB 3,'>IN'
+ 098B +TOIN:
+ + IF .NOT.(DOUSER=DOCODE)
+ 098B CDBC01 + call DOUSER
+ + ENDIF
+ 098E 0200 dw 2
+
+ ;C BASE -- a-addr holds conversion radix
+ ; 4 USER BASE
+ 0990 head BASE,4,BASE,douser
+ 0990 8709 + DW link
+ 0992 00 + DB 0
+ 0993 +link DEFL $
+ 0993 04424153 + DB 4,'BASE'
+ 0998 +BASE:
+ + IF .NOT.(DOUSER=DOCODE)
+ 0998 CDBC01 + call DOUSER
+ + ENDIF
+ 099B 0400 dw 4
+
+ ;C STATE -- a-addr holds compiler state
+ ; 6 USER STATE
+ 099D head STATE,5,STATE,douser
+ 099D 9309 + DW link
+ 099F 00 + DB 0
+ 09A0 +link DEFL $
+ 09A0 05535441 + DB 5,'STATE'
+ 09A6 +STATE:
+ + IF .NOT.(DOUSER=DOCODE)
+ 09A6 CDBC01 + call DOUSER
+ + ENDIF
+ 09A9 0600 dw 6
+
+ ;Z dp -- a-addr holds dictionary ptr
+ ; 8 USER DP
+ 09AB head DP,2,DP,douser
+ 09AB A009 + DW link
+ 09AD 00 + DB 0
+ 09AE +link DEFL $
+ 09AE 024450 + DB 2,'DP'
+ 09B1 +DP:
+ + IF .NOT.(DOUSER=DOCODE)
+ 09B1 CDBC01 + call DOUSER
+ + ENDIF
+ 09B4 0800 dw 8
+
+ ;Z 'source -- a-addr two cells: len, adrs
+ ; 10 USER 'SOURCE
+ ; head TICKSOURCE,7,'SOURCE,douser
+ 09B6 AE09 DW link ; must expand
+ 09B8 00 DB 0 ; manually
+ 09B9 link DEFL $ ; because of
+ 09B9 0727534F DB 7,27h,'SOURCE' ; tick character
+ 09C1 CDBC01 TICKSOURCE: call douser ; in name!
+ 09C4 0A00 dw 10
+
+ ;Z latest -- a-addr last word in dict.
+ ; 14 USER LATEST
+ 09C6 head LATEST,6,LATEST,douser
+ 09C6 B909 + DW link
+ 09C8 00 + DB 0
+ 09C9 +link DEFL $
+ 09C9 064C4154 + DB 6,'LATEST'
+ 09D0 +LATEST:
+ + IF .NOT.(DOUSER=DOCODE)
+ 09D0 CDBC01 + call DOUSER
+ + ENDIF
+ 09D3 0E00 dw 14
+
+ ;Z hp -- a-addr HOLD pointer
+ ; 16 USER HP
+ 09D5 head HP,2,HP,douser
+ 09D5 C909 + DW link
+ 09D7 00 + DB 0
+ 09D8 +link DEFL $
+ 09D8 024850 + DB 2,'HP'
+ 09DB +HP:
+ + IF .NOT.(DOUSER=DOCODE)
+ 09DB CDBC01 + call DOUSER
+ + ENDIF
+ 09DE 1000 dw 16
+
+ ;Z LP -- a-addr Leave-stack pointer
+ ; 18 USER LP
+ 09E0 head LP,2,LP,douser
+ 09E0 D809 + DW link
+ 09E2 00 + DB 0
+ 09E3 +link DEFL $
+ 09E3 024C50 + DB 2,'LP'
+ 09E6 +LP:
+ + IF .NOT.(DOUSER=DOCODE)
+ 09E6 CDBC01 + call DOUSER
+ + ENDIF
+ 09E9 1200 dw 18
+
+ ;Z s0 -- a-addr end of parameter stack
+ 09EB head S0,2,S0,douser
+ 09EB E309 + DW link
+ 09ED 00 + DB 0
+ 09EE +link DEFL $
+ 09EE 025330 + DB 2,'S0'
+ 09F1 +S0:
+ + IF .NOT.(DOUSER=DOCODE)
+ 09F1 CDBC01 + call DOUSER
+ + ENDIF
+ 09F4 0001 dw 100h
+
+ ;X PAD -- a-addr user PAD buffer
+ ; = end of hold area!
+ 09F6 head PAD,3,PAD,douser
+ 09F6 EE09 + DW link
+ 09F8 00 + DB 0
+ 09F9 +link DEFL $
+ 09F9 03504144 + DB 3,'PAD'
+ 09FD +PAD:
+ + IF .NOT.(DOUSER=DOCODE)
+ 09FD CDBC01 + call DOUSER
+ + ENDIF
+ 0A00 2801 dw 128h
+
+ ;Z l0 -- a-addr bottom of Leave stack
+ 0A02 head L0,2,L0,douser
+ 0A02 F909 + DW link
+ 0A04 00 + DB 0
+ 0A05 +link DEFL $
+ 0A05 024C30 + DB 2,'L0'
+ 0A08 +L0:
+ + IF .NOT.(DOUSER=DOCODE)
+ 0A08 CDBC01 + call DOUSER
+ + ENDIF
+ 0A0B 8001 dw 180h
+
+ ;Z r0 -- a-addr end of return stack
+ 0A0D head R0,2,R0,douser
+ 0A0D 050A + DW link
+ 0A0F 00 + DB 0
+ 0A10 +link DEFL $
+ 0A10 025230 + DB 2,'R0'
+ 0A13 +R0:
+ + IF .NOT.(DOUSER=DOCODE)
+ 0A13 CDBC01 + call DOUSER
+ + ENDIF
+ 0A16 0002 dw 200h
+
+ ;Z uinit -- addr initial values for user area
+ 0A18 head UINIT,5,UINIT,docreate
+ 0A18 100A + DW link
+ 0A1A 00 + DB 0
+ 0A1B +link DEFL $
+ 0A1B 0555494E + DB 5,'UINIT'
+ 0A21 +UINIT:
+ + IF .NOT.(DOCREATE=DOCODE)
+ 0A21 CD7F01 + call DOCREATE
+ + ENDIF
+ 0A24 00000000 DW 0,0,10,0 ; reserved,>IN,BASE,STATE
+ 0A2C E616 DW enddict ; DP
+ 0A2E 00000000 DW 0,0 ; SOURCE init'd elsewhere
+ 0A32 A416 DW lastword ; LATEST
+ 0A34 0000 DW 0 ; HP init'd elsewhere
+
+ ;Z #init -- n #bytes of user area init data
+ 0A36 head NINIT,5,#INIT,docon
+ 0A36 1B0A + DW link
+ 0A38 00 + DB 0
+ 0A39 +link DEFL $
+ 0A39 0523494E + DB 5,'#INIT'
+ 0A3F +NINIT:
+ + IF .NOT.(DOCON=DOCODE)
+ 0A3F CD9F01 + call DOCON
+ + ENDIF
+ 0A42 1200 DW 18
+
+ ; ARITHMETIC OPERATORS ==========================
+
+ ;C S>D n -- d single -> double prec.
+ ; DUP 0< ;
+ 0A44 head STOD,3,S>D,docolon
+ 0A44 390A + DW link
+ 0A46 00 + DB 0
+ 0A47 +link DEFL $
+ 0A47 03533E44 + DB 3,'S>D'
+ 0A4B +STOD:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0A4B CD5301 + call DOCOLON
+ + ENDIF
+ 0A4E B4029205 dw DUP,ZEROLESS,EXIT
+
+ ;Z ?NEGATE n1 n2 -- n3 negate n1 if n2 negative
+ ; 0< IF NEGATE THEN ; ...a common factor
+ 0A54 head QNEGATE,7,?NEGATE,docolon
+ 0A54 470A + DW link
+ 0A56 00 + DB 0
+ 0A57 +link DEFL $
+ 0A57 073F4E45 + DB 7,'?NEGATE'
+ 0A5F +QNEGATE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0A5F CD5301 + call DOCOLON
+ + ENDIF
+ 0A62 92053106 DW ZEROLESS,qbranch,QNEG1,NEGATE
+ 0A6A 1E01 QNEG1: DW EXIT
+
+ ;C ABS n1 -- +n2 absolute value
+ ; DUP ?NEGATE ;
+ 0A6C head ABS,3,ABS,docolon
+ 0A6C 570A + DW link
+ 0A6E 00 + DB 0
+ 0A6F +link DEFL $
+ 0A6F 03414253 + DB 3,'ABS'
+ 0A73 +ABS:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0A73 CD5301 + call DOCOLON
+ + ENDIF
+ 0A76 B4025F0A DW DUP,QNEGATE,EXIT
+
+ ;X DNEGATE d1 -- d2 negate double precision
+ ; SWAP INVERT SWAP INVERT 1 M+ ;
+ 0A7C head DNEGATE,7,DNEGATE,docolon
+ 0A7C 6F0A + DW link
+ 0A7E 00 + DB 0
+ 0A7F +link DEFL $
+ 0A7F 07444E45 + DB 7,'DNEGATE'
+ 0A87 +DNEGATE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0A87 CD5301 + call DOCOLON
+ + ENDIF
+ 0A8A E702B604 DW SWOP,INVERT,SWOP,INVERT,LIT,1,MPLUS
+ 0A98 1E01 DW EXIT
+
+ ;Z ?DNEGATE d1 n -- d2 negate d1 if n negative
+ ; 0< IF DNEGATE THEN ; ...a common factor
+ 0A9A head QDNEGATE,8,?DNEGATE,docolon
+ 0A9A 7F0A + DW link
+ 0A9C 00 + DB 0
+ 0A9D +link DEFL $
+ 0A9D 083F444E + DB 8,'?DNEGATE'
+ 0AA6 +QDNEGATE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0AA6 CD5301 + call DOCOLON
+ + ENDIF
+ 0AA9 92053106 DW ZEROLESS,qbranch,DNEG1,DNEGATE
+ 0AB1 1E01 DNEG1: DW EXIT
+
+ ;X DABS d1 -- +d2 absolute value dbl.prec.
+ ; DUP ?DNEGATE ;
+ 0AB3 head DABS,4,DABS,docolon
+ 0AB3 9D0A + DW link
+ 0AB5 00 + DB 0
+ 0AB6 +link DEFL $
+ 0AB6 04444142 + DB 4,'DABS'
+ 0ABB +DABS:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0ABB CD5301 + call DOCOLON
+ + ENDIF
+ 0ABE B402A60A DW DUP,QDNEGATE,EXIT
+
+ ;C M* n1 n2 -- d signed 16*16->32 multiply
+ ; 2DUP XOR >R carries sign of the result
+ ; SWAP ABS SWAP ABS UM*
+ ; R> ?DNEGATE ;
+ 0AC4 head MSTAR,2,M*,docolon
+ 0AC4 B60A + DW link
+ 0AC6 00 + DB 0
+ 0AC7 +link DEFL $
+ 0AC7 024D2A + DB 2,'M*'
+ 0ACA +MSTAR:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0ACA CD5301 + call DOCOLON
+ + ENDIF
+ 0ACD 1B0C9E04 DW TWODUP,XOR,TOR
+ 0AD3 E702730A DW SWOP,ABS,SWOP,ABS,UMSTAR
+ 0ADD 5803A60A DW RFROM,QDNEGATE,EXIT
+
+ ;C SM/REM d1 n1 -- n2 n3 symmetric signed div
+ ; 2DUP XOR >R sign of quotient
+ ; OVER >R sign of remainder
+ ; ABS >R DABS R> UM/MOD
+ ; SWAP R> ?NEGATE
+ ; SWAP R> ?NEGATE ;
+ ; Ref. dpANS-6 section 3.2.2.1.
+ 0AE3 head SMSLASHREM,6,SM/REM,docolon
+ 0AE3 C70A + DW link
+ 0AE5 00 + DB 0
+ 0AE6 +link DEFL $
+ 0AE6 06534D2F + DB 6,'SM/REM'
+ 0AED +SMSLASHREM:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0AED CD5301 + call DOCOLON
+ + ENDIF
+ 0AF0 1B0C9E04 DW TWODUP,XOR,TOR,OVER,TOR
+ 0AFA 730A4003 DW ABS,TOR,DABS,RFROM,UMSLASHMOD
+ 0B04 E7025803 DW SWOP,RFROM,QNEGATE,SWOP,RFROM,QNEGATE
+ 0B10 1E01 DW EXIT
+
+ ;C FM/MOD d1 n1 -- n2 n3 floored signed div'n
+ ; DUP >R save divisor
+ ; SM/REM
+ ; DUP 0< IF if quotient negative,
+ ; SWAP R> + add divisor to rem'dr
+ ; SWAP 1- decrement quotient
+ ; ELSE R> DROP THEN ;
+ ; Ref. dpANS-6 section 3.2.2.1.
+ 0B12 head FMSLASHMOD,6,FM/MOD,docolon
+ 0B12 E60A + DW link
+ 0B14 00 + DB 0
+ 0B15 +link DEFL $
+ 0B15 06464D2F + DB 6,'FM/MOD'
+ 0B1C +FMSLASHMOD:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0B1C CD5301 + call DOCOLON
+ + ENDIF
+ 0B1F B4024003 DW DUP,TOR,SMSLASHREM
+ 0B25 B4029205 DW DUP,ZEROLESS,qbranch,FMMOD1
+ 0B2D E7025803 DW SWOP,RFROM,PLUS,SWOP,ONEMINUS
+ 0B37 1B063F0B DW branch,FMMOD2
+ 0B3B 5803D702 FMMOD1: DW RFROM,DROP
+ 0B3F 1E01 FMMOD2: DW EXIT
+
+ ;C * n1 n2 -- n3 signed multiply
+ ; M* DROP ;
+ 0B41 head STAR,1,*,docolon
+ 0B41 150B + DW link
+ 0B43 00 + DB 0
+ 0B44 +link DEFL $
+ 0B44 012A + DB 1,'*'
+ 0B46 +STAR:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0B46 CD5301 + call DOCOLON
+ + ENDIF
+ 0B49 CA0AD702 dw MSTAR,DROP,EXIT
+
+ ;C /MOD n1 n2 -- n3 n4 signed divide/rem'dr
+ ; >R S>D R> FM/MOD ;
+ 0B4F head SLASHMOD,4,/MOD,docolon
+ 0B4F 440B + DW link
+ 0B51 00 + DB 0
+ 0B52 +link DEFL $
+ 0B52 042F4D4F + DB 4,'/MOD'
+ 0B57 +SLASHMOD:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0B57 CD5301 + call DOCOLON
+ + ENDIF
+ 0B5A 40034B0A dw TOR,STOD,RFROM,FMSLASHMOD,EXIT
+
+ ;C / n1 n2 -- n3 signed divide
+ ; /MOD nip ;
+ 0B64 head SLASH,1,/,docolon
+ 0B64 520B + DW link
+ 0B66 00 + DB 0
+ 0B67 +link DEFL $
+ 0B67 012F + DB 1,'/'
+ 0B69 +SLASH:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0B69 CD5301 + call DOCOLON
+ + ENDIF
+ 0B6C 570B2003 dw SLASHMOD,NIP,EXIT
+
+ ;C MOD n1 n2 -- n3 signed remainder
+ ; /MOD DROP ;
+ 0B72 head MOD,3,MOD,docolon
+ 0B72 670B + DW link
+ 0B74 00 + DB 0
+ 0B75 +link DEFL $
+ 0B75 034D4F44 + DB 3,'MOD'
+ 0B79 +MOD:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0B79 CD5301 + call DOCOLON
+ + ENDIF
+ 0B7C 570BD702 dw SLASHMOD,DROP,EXIT
+
+ ;C */MOD n1 n2 n3 -- n4 n5 n1*n2/n3, rem"
+ ; >R M* R> FM/MOD ;
+ 0B82 head SSMOD,5,*/MOD,docolon
+ 0B82 750B + DW link
+ 0B84 00 + DB 0
+ 0B85 +link DEFL $
+ 0B85 052A2F4D + DB 5,'*/MOD'
+ 0B8B +SSMOD:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0B8B CD5301 + call DOCOLON
+ + ENDIF
+ 0B8E 4003CA0A dw TOR,MSTAR,RFROM,FMSLASHMOD,EXIT
+
+ ;C */ n1 n2 n3 -- n4 n1*n2/n3
+ ; */MOD nip ;
+ 0B98 head STARSLASH,2,*/,docolon
+ 0B98 850B + DW link
+ 0B9A 00 + DB 0
+ 0B9B +link DEFL $
+ 0B9B 022A2F + DB 2,'*/'
+ 0B9E +STARSLASH:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0B9E CD5301 + call DOCOLON
+ + ENDIF
+ 0BA1 8B0B2003 dw SSMOD,NIP,EXIT
+
+ ;C MAX n1 n2 -- n3 signed maximum
+ ; 2DUP < IF SWAP THEN DROP ;
+ 0BA7 head MAX,3,MAX,docolon
+ 0BA7 9B0B + DW link
+ 0BA9 00 + DB 0
+ 0BAA +link DEFL $
+ 0BAA 034D4158 + DB 3,'MAX'
+ 0BAE +MAX:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0BAE CD5301 + call DOCOLON
+ + ENDIF
+ 0BB1 1B0CC705 dw TWODUP,LESS,qbranch,MAX1,SWOP
+ 0BBB D7021E01 MAX1: dw DROP,EXIT
+
+ ;C MIN n1 n2 -- n3 signed minimum
+ ; 2DUP > IF SWAP THEN DROP ;
+ 0BBF head MIN,3,MIN,docolon
+ 0BBF AA0B + DW link
+ 0BC1 00 + DB 0
+ 0BC2 +link DEFL $
+ 0BC2 034D494E + DB 3,'MIN'
+ 0BC6 +MIN:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0BC6 CD5301 + call DOCOLON
+ + ENDIF
+ 0BC9 1B0CE505 dw TWODUP,GREATER,qbranch,MIN1,SWOP
+ 0BD3 D7021E01 MIN1: dw DROP,EXIT
+
+ ; DOUBLE OPERATORS ==============================
+
+ ;C 2@ a-addr -- x1 x2 fetch 2 cells
+ ; DUP CELL+ @ SWAP @ ;
+ ; the lower address will appear on top of stack
+ 0BD7 head TWOFETCH,2,2@,docolon
+ 0BD7 C20B + DW link
+ 0BD9 00 + DB 0
+ 0BDA +link DEFL $
+ 0BDA 023240 + DB 2,'2@'
+ 0BDD +TWOFETCH:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0BDD CD5301 + call DOCOLON
+ + ENDIF
+ 0BE0 B4028008 dw DUP,CELLPLUS,FETCH,SWOP,FETCH,EXIT
+
+ ;C 2! x1 x2 a-addr -- store 2 cells
+ ; SWAP OVER ! CELL+ ! ;
+ ; the top of stack is stored at the lower adrs
+ 0BEC head TWOSTORE,2,2!,docolon
+ 0BEC DA0B + DW link
+ 0BEE 00 + DB 0
+ 0BEF +link DEFL $
+ 0BEF 023221 + DB 2,'2!'
+ 0BF2 +TWOSTORE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0BF2 CD5301 + call DOCOLON
+ + ENDIF
+ 0BF5 E702FA02 dw SWOP,OVER,STORE,CELLPLUS,STORE,EXIT
+
+ ;C 2DROP x1 x2 -- drop 2 cells
+ ; DROP DROP ;
+ 0C01 head TWODROP,5,2DROP,docolon
+ 0C01 EF0B + DW link
+ 0C03 00 + DB 0
+ 0C04 +link DEFL $
+ 0C04 05324452 + DB 5,'2DROP'
+ 0C0A +TWODROP:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0C0A CD5301 + call DOCOLON
+ + ENDIF
+ 0C0D D702D702 dw DROP,DROP,EXIT
+
+ ;C 2DUP x1 x2 -- x1 x2 x1 x2 dup top 2 cells
+ ; OVER OVER ;
+ 0C13 head TWODUP,4,2DUP,docolon
+ 0C13 040C + DW link
+ 0C15 00 + DB 0
+ 0C16 +link DEFL $
+ 0C16 04324455 + DB 4,'2DUP'
+ 0C1B +TWODUP:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0C1B CD5301 + call DOCOLON
+ + ENDIF
+ 0C1E FA02FA02 dw OVER,OVER,EXIT
+
+ ;C 2SWAP x1 x2 x3 x4 -- x3 x4 x1 x2 per diagram
+ ; ROT >R ROT R> ;
+ 0C24 head TWOSWAP,5,2SWAP,docolon
+ 0C24 160C + DW link
+ 0C26 00 + DB 0
+ 0C27 +link DEFL $
+ 0C27 05325357 + DB 5,'2SWAP'
+ 0C2D +TWOSWAP:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0C2D CD5301 + call DOCOLON
+ + ENDIF
+ 0C30 0D034003 dw ROT,TOR,ROT,RFROM,EXIT
+
+ ;C 2OVER x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2
+ ; >R >R 2DUP R> R> 2SWAP ;
+ 0C3A head TWOOVER,5,2OVER,docolon
+ 0C3A 270C + DW link
+ 0C3C 00 + DB 0
+ 0C3D +link DEFL $
+ 0C3D 05324F56 + DB 5,'2OVER'
+ 0C43 +TWOOVER:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0C43 CD5301 + call DOCOLON
+ + ENDIF
+ 0C46 40034003 dw TOR,TOR,TWODUP,RFROM,RFROM
+ 0C50 2D0C1E01 dw TWOSWAP,EXIT
+
+ ; INPUT/OUTPUT ==================================
+
+ ;C COUNT c-addr1 -- c-addr2 u counted->adr/len
+ ; DUP CHAR+ SWAP C@ ;
+ 0C54 head COUNT,5,COUNT,docolon
+ 0C54 3D0C + DW link
+ 0C56 00 + DB 0
+ 0C57 +link DEFL $
+ 0C57 05434F55 + DB 5,'COUNT'
+ 0C5D +COUNT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0C5D CD5301 + call DOCOLON
+ + ENDIF
+ 0C60 B4029E08 dw DUP,CHARPLUS,SWOP,CFETCH,EXIT
+
+ ;C CR -- output newline
+ ; 0D EMIT 0A EMIT ;
+ 0C6A head CR,2,CR,docolon
+ 0C6A 570C + DW link
+ 0C6C 00 + DB 0
+ 0C6D +link DEFL $
+ 0C6D 024352 + DB 2,'CR'
+ 0C70 +CR:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0C70 CD5301 + call DOCOLON
+ + ENDIF
+ 0C73 36010D00 dw lit,0dh,EMIT,lit,0ah,EMIT,EXIT
+
+ ;C SPACE -- output a space
+ ; BL EMIT ;
+ 0C81 head SPACE,5,SPACE,docolon
+ 0C81 6D0C + DW link
+ 0C83 00 + DB 0
+ 0C84 +link DEFL $
+ 0C84 05535041 + DB 5,'SPACE'
+ 0C8A +SPACE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0C8A CD5301 + call DOCOLON
+ + ENDIF
+ 0C8D 58090D02 dw BL,EMIT,EXIT
+
+ ;C SPACES n -- output n spaces
+ ; BEGIN DUP WHILE SPACE 1- REPEAT DROP ;
+ 0C93 head SPACES,6,SPACES,docolon
+ 0C93 840C + DW link
+ 0C95 00 + DB 0
+ 0C96 +link DEFL $
+ 0C96 06535041 + DB 6,'SPACES'
+ 0C9D +SPACES:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0C9D CD5301 + call DOCOLON
+ + ENDIF
+ 0CA0 B4023106 SPCS1: DW DUP,qbranch,SPCS2
+ 0CA6 8A0CEF04 DW SPACE,ONEMINUS,branch,SPCS1
+ 0CAE D7021E01 SPCS2: DW DROP,EXIT
+
+ ;Z umin u1 u2 -- u unsigned minimum
+ ; 2DUP U> IF SWAP THEN DROP ;
+ 0CB2 head UMIN,4,UMIN,docolon
+ 0CB2 960C + DW link
+ 0CB4 00 + DB 0
+ 0CB5 +link DEFL $
+ 0CB5 04554D49 + DB 4,'UMIN'
+ 0CBA +UMIN:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0CBA CD5301 + call DOCOLON
+ + ENDIF
+ 0CBD 1B0C0806 DW TWODUP,UGREATER,QBRANCH,UMIN1,SWOP
+ 0CC7 D7021E01 UMIN1: DW DROP,EXIT
+
+ ;Z umax u1 u2 -- u unsigned maximum
+ ; 2DUP U< IF SWAP THEN DROP ;
+ 0CCB head UMAX,4,UMAX,docolon
+ 0CCB B50C + DW link
+ 0CCD 00 + DB 0
+ 0CCE +link DEFL $
+ 0CCE 04554D41 + DB 4,'UMAX'
+ 0CD3 +UMAX:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0CD3 CD5301 + call DOCOLON
+ + ENDIF
+ 0CD6 1B0CF405 DW TWODUP,ULESS,QBRANCH,UMAX1,SWOP
+ 0CE0 D7021E01 UMAX1: DW DROP,EXIT
+
+ ;C ACCEPT c-addr +n -- +n' get line from term'l
+ ; OVER + 1- OVER -- sa ea a
+ ; BEGIN KEY -- sa ea a c
+ ; DUP 0D <> WHILE
+ ; DUP EMIT -- sa ea a c
+ ; DUP 8 = IF DROP 1- >R OVER R> UMAX
+ ; ELSE OVER C! 1+ OVER UMIN
+ ; THEN -- sa ea a
+ ; REPEAT -- sa ea a c
+ ; DROP NIP SWAP - ;
+ 0CE4 head ACCEPT,6,ACCEPT,docolon
+ 0CE4 CE0C + DW link
+ 0CE6 00 + DB 0
+ 0CE7 +link DEFL $
+ 0CE7 06414343 + DB 6,'ACCEPT'
+ 0CEE +ACCEPT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0CEE CD5301 + call DOCOLON
+ + ENDIF
+ 0CF1 FA023904 DW OVER,PLUS,ONEMINUS,OVER
+ 0CF9 4E02B402 ACC1: DW KEY,DUP,LIT,0DH,NOTEQUAL,QBRANCH,ACC5
+ 0D07 B4020D02 DW DUP,EMIT,DUP,LIT,8,EQUAL,QBRANCH,ACC3
+ 0D17 D702EF04 DW DROP,ONEMINUS,TOR,OVER,RFROM,UMAX
+ 0D23 1B06310D DW BRANCH,ACC4
+ 0D27 FA02E203 ACC3: DW OVER,CSTORE,ONEPLUS,OVER,UMIN
+ 0D31 1B06F90C ACC4: DW BRANCH,ACC1
+ 0D35 D7022003 ACC5: DW DROP,NIP,SWOP,MINUS,EXIT
+
+ ;C TYPE c-addr +n -- type line to term'l
+ ; ?DUP IF
+ ; OVER + SWAP DO I C@ EMIT LOOP
+ ; ELSE DROP THEN ;
+ 0D3F head TYPE,4,TYPE,docolon
+ 0D3F E70C + DW link
+ 0D41 00 + DB 0
+ 0D42 +link DEFL $
+ 0D42 04545950 + DB 4,'TYPE'
+ 0D47 +TYPE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0D47 CD5301 + call DOCOLON
+ + ENDIF
+ 0D4A C4023106 DW QDUP,QBRANCH,TYP4
+ 0D50 FA023904 DW OVER,PLUS,SWOP,XDO
+ 0D58 B8060504 TYP3: DW II,CFETCH,EMIT,XLOOP,TYP3
+ 0D62 1B06680D DW BRANCH,TYP5
+ 0D66 D702 TYP4: DW DROP
+ 0D68 1E01 TYP5: DW EXIT
+
+ ;Z (S") -- c-addr u run-time code for S"
+ ; R> COUNT 2DUP + ALIGNED >R ;
+ 0D6A head XSQUOTE,4,(S"),docolon
+ 0D6A 420D + DW link
+ 0D6C 00 + DB 0
+ 0D6D +link DEFL $
+ 0D6D 04285322 + DB 4,'(S")'
+ 0D72 +XSQUOTE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0D72 CD5301 + call DOCOLON
+ + ENDIF
+ 0D75 58035D0C DW RFROM,COUNT,TWODUP,PLUS,ALIGNED,TOR
+ 0D81 1E01 DW EXIT
+
+ ;C S" -- compile in-line string
+ ; COMPILE (S") [ HEX ]
+ ; 22 WORD C@ 1+ ALIGNED ALLOT ; IMMEDIATE
+ 0D83 immed SQUOTE,2,S",docolon
+ 0D83 6D0D + DW link
+ 0D85 01 + DB 1
+ 0D86 +link DEFL $
+ 0D86 025322 + DB 2,'S"'
+ 0D89 +SQUOTE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0D89 CD5301 + call DOCOLON
+ + ENDIF
+ 0D8C 3601720D DW LIT,XSQUOTE,COMMAXT
+ 0D92 36012200 DW LIT,22H,WORD,CFETCH,ONEPLUS
+ 0D9C 6808230F DW ALIGNED,ALLOT,EXIT
+
+ ;C ." -- compile string to print
+ ; POSTPONE S" POSTPONE TYPE ; IMMEDIATE
+ 0DA2 immed DOTQUOTE,2,.",docolon
+ 0DA2 860D + DW link
+ 0DA4 01 + DB 1
+ 0DA5 +link DEFL $
+ 0DA5 022E22 + DB 2,'."'
+ 0DA8 +DOTQUOTE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0DA8 CD5301 + call DOCOLON
+ + ENDIF
+ 0DAB 890D DW SQUOTE
+ 0DAD 3601470D DW LIT,TYPE,COMMAXT
+ 0DB3 1E01 DW EXIT
+
+ ; NUMERIC OUTPUT ================================
+ ; Numeric conversion is done l.s.digit first, so
+ ; the output buffer is built backwards in memory.
+
+ ; Some double-precision arithmetic operators are
+ ; needed to implement ANSI numeric conversion.
+
+ ;Z UD/MOD ud1 u2 -- u3 ud4 32/16->32 divide
+ ; >R 0 R@ UM/MOD ROT ROT R> UM/MOD ROT ;
+ 0DB5 head UDSLASHMOD,6,UD/MOD,docolon
+ 0DB5 A50D + DW link
+ 0DB7 00 + DB 0
+ 0DB8 +link DEFL $
+ 0DB8 0655442F + DB 6,'UD/MOD'
+ 0DBF +UDSLASHMOD:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0DBF CD5301 + call DOCOLON
+ + ENDIF
+ 0DC2 40033601 DW TOR,LIT,0,RFETCH,UMSLASHMOD,ROT,ROT
+ 0DD0 58033C07 DW RFROM,UMSLASHMOD,ROT,EXIT
+
+ ;Z UD* ud1 d2 -- ud3 32*16->32 multiply
+ ; DUP >R UM* DROP SWAP R> UM* ROT + ;
+ 0DD8 head UDSTAR,3,UD*,docolon
+ 0DD8 B80D + DW link
+ 0DDA 00 + DB 0
+ 0DDB +link DEFL $
+ 0DDB 0355442A + DB 3,'UD*'
+ 0DDF +UDSTAR:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0DDF CD5301 + call DOCOLON
+ + ENDIF
+ 0DE2 B4024003 DW DUP,TOR,UMSTAR,DROP
+ 0DEA E7025803 DW SWOP,RFROM,UMSTAR,ROT,PLUS,EXIT
+
+ ;C HOLD char -- add char to output string
+ ; -1 HP +! HP @ C! ;
+ 0DF6 head HOLD,4,HOLD,docolon
+ 0DF6 DB0D + DW link
+ 0DF8 00 + DB 0
+ 0DF9 +link DEFL $
+ 0DF9 04484F4C + DB 4,'HOLD'
+ 0DFE +HOLD:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0DFE CD5301 + call DOCOLON
+ + ENDIF
+ 0E01 3601FFFF DW LIT,-1,HP,PLUSSTORE
+ 0E09 DB09F303 DW HP,FETCH,CSTORE,EXIT
+
+ ;C <# -- begin numeric conversion
+ ; PAD HP ! ; (initialize Hold Pointer)
+ 0E11 head LESSNUM,2,<#,docolon
+ 0E11 F90D + DW link
+ 0E13 00 + DB 0
+ 0E14 +link DEFL $
+ 0E14 023C23 + DB 2,'<#'
+ 0E17 +LESSNUM:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0E17 CD5301 + call DOCOLON
+ + ENDIF
+ 0E1A FD09DB09 DW PAD,HP,STORE,EXIT
+
+ ;Z >digit n -- c convert to 0..9A..Z
+ ; [ HEX ] DUP 9 > 7 AND + 30 + ;
+ 0E22 head TODIGIT,6,>DIGIT,docolon
+ 0E22 140E + DW link
+ 0E24 00 + DB 0
+ 0E25 +link DEFL $
+ 0E25 063E4449 + DB 6,'>DIGIT'
+ 0E2C +TODIGIT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0E2C CD5301 + call DOCOLON
+ + ENDIF
+ 0E2F B4023601 DW DUP,LIT,9,GREATER,LIT,7,AND,PLUS
+ 0E3F 36013000 DW LIT,30H,PLUS,EXIT
+
+ ;C # ud1 -- ud2 convert 1 digit of output
+ ; BASE @ UD/MOD ROT >digit HOLD ;
+ 0E47 head NUM,1,#,docolon
+ 0E47 250E + DW link
+ 0E49 00 + DB 0
+ 0E4A +link DEFL $
+ 0E4A 0123 + DB 1,'#'
+ 0E4C +NUM:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0E4C CD5301 + call DOCOLON
+ + ENDIF
+ 0E4F 9809F303 DW BASE,FETCH,UDSLASHMOD,ROT,TODIGIT
+ 0E59 FE0D1E01 DW HOLD,EXIT
+
+ ;C #S ud1 -- ud2 convert remaining digits
+ ; BEGIN # 2DUP OR 0= UNTIL ;
+ 0E5D head NUMS,2,#S,docolon
+ 0E5D 4A0E + DW link
+ 0E5F 00 + DB 0
+ 0E60 +link DEFL $
+ 0E60 022353 + DB 2,'#S'
+ 0E63 +NUMS:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0E63 CD5301 + call DOCOLON
+ + ENDIF
+ 0E66 4C0E1B0C NUMS1: DW NUM,TWODUP,OR,ZEROEQUAL,qbranch,NUMS1
+ 0E72 1E01 DW EXIT
+
+ ;C #> ud1 -- c-addr u end conv., get string
+ ; 2DROP HP @ PAD OVER - ;
+ 0E74 head NUMGREATER,2,#>,docolon
+ 0E74 600E + DW link
+ 0E76 00 + DB 0
+ 0E77 +link DEFL $
+ 0E77 02233E + DB 2,'#>'
+ 0E7A +NUMGREATER:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0E7A CD5301 + call DOCOLON
+ + ENDIF
+ 0E7D 0A0CDB09 DW TWODROP,HP,FETCH,PAD,OVER,MINUS,EXIT
+
+ ;C SIGN n -- add minus sign if n<0
+ ; 0< IF 2D HOLD THEN ;
+ 0E8B head SIGN,4,SIGN,docolon
+ 0E8B 770E + DW link
+ 0E8D 00 + DB 0
+ 0E8E +link DEFL $
+ 0E8E 04534947 + DB 4,'SIGN'
+ 0E93 +SIGN:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0E93 CD5301 + call DOCOLON
+ + ENDIF
+ 0E96 92053106 DW ZEROLESS,qbranch,SIGN1,LIT,2DH,HOLD
+ 0EA2 1E01 SIGN1: DW EXIT
+
+ ;C U. u -- display u unsigned
+ ; <# 0 #S #> TYPE SPACE ;
+ 0EA4 head UDOT,2,U.,docolon
+ 0EA4 8E0E + DW link
+ 0EA6 00 + DB 0
+ 0EA7 +link DEFL $
+ 0EA7 02552E + DB 2,'U.'
+ 0EAA +UDOT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0EAA CD5301 + call DOCOLON
+ + ENDIF
+ 0EAD 170E3601 DW LESSNUM,LIT,0,NUMS,NUMGREATER,TYPE
+ 0EB9 8A0C1E01 DW SPACE,EXIT
+
+ ;C . n -- display n signed
+ ; <# DUP ABS 0 #S ROT SIGN #> TYPE SPACE ;
+ 0EBD head DOT,1,'.',docolon
+ 0EBD A70E + DW link
+ 0EBF 00 + DB 0
+ 0EC0 +link DEFL $
+ 0EC0 012E + DB 1,'.'
+ 0EC2 +DOT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0EC2 CD5301 + call DOCOLON
+ + ENDIF
+ 0EC5 170EB402 DW LESSNUM,DUP,ABS,LIT,0,NUMS
+ 0ED1 0D03930E DW ROT,SIGN,NUMGREATER,TYPE,SPACE,EXIT
+
+ ;C DECIMAL -- set number base to decimal
+ ; 10 BASE ! ;
+ 0EDD head DECIMAL,7,DECIMAL,docolon
+ 0EDD C00E + DW link
+ 0EDF 00 + DB 0
+ 0EE0 +link DEFL $
+ 0EE0 07444543 + DB 7,'DECIMAL'
+ 0EE8 +DECIMAL:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0EE8 CD5301 + call DOCOLON
+ + ENDIF
+ 0EEB 36010A00 DW LIT,10,BASE,STORE,EXIT
+
+ ;X HEX -- set number base to hex
+ ; 16 BASE ! ;
+ 0EF5 head HEX,3,HEX,docolon
+ 0EF5 E00E + DW link
+ 0EF7 00 + DB 0
+ 0EF8 +link DEFL $
+ 0EF8 03484558 + DB 3,'HEX'
+ 0EFC +HEX:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0EFC CD5301 + call DOCOLON
+ + ENDIF
+ 0EFF 36011000 DW LIT,16,BASE,STORE,EXIT
+
+ ; DICTIONARY MANAGEMENT =========================
+
+ ;C HERE -- addr returns dictionary ptr
+ ; DP @ ;
+ 0F09 head HERE,4,HERE,docolon
+ 0F09 F80E + DW link
+ 0F0B 00 + DB 0
+ 0F0C +link DEFL $
+ 0F0C 04484552 + DB 4,'HERE'
+ 0F11 +HERE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0F11 CD5301 + call DOCOLON
+ + ENDIF
+ 0F14 B109F303 dw DP,FETCH,EXIT
+
+ ;C ALLOT n -- allocate n bytes in dict
+ ; DP +! ;
+ 0F1A head ALLOT,5,ALLOT,docolon
+ 0F1A 0C0F + DW link
+ 0F1C 00 + DB 0
+ 0F1D +link DEFL $
+ 0F1D 05414C4C + DB 5,'ALLOT'
+ 0F23 +ALLOT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0F23 CD5301 + call DOCOLON
+ + ENDIF
+ 0F26 B1096805 dw DP,PLUSSTORE,EXIT
+
+ ; Note: , and C, are only valid for combined
+ ; Code and Data spaces.
+
+ ;C , x -- append cell to dict
+ ; HERE ! 1 CELLS ALLOT ;
+ 0F2C head COMMA,1,',',docolon
+ 0F2C 1D0F + DW link
+ 0F2E 00 + DB 0
+ 0F2F +link DEFL $
+ 0F2F 012C + DB 1,','
+ 0F31 +COMMA:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0F31 CD5301 + call DOCOLON
+ + ENDIF
+ 0F34 110FCE03 dw HERE,STORE,lit,1,CELLS,ALLOT,EXIT
+
+ ;C C, char -- append char to dict
+ ; HERE C! 1 CHARS ALLOT ;
+ 0F42 head CCOMMA,2,'C,',docolon
+ 0F42 2F0F + DW link
+ 0F44 00 + DB 0
+ 0F45 +link DEFL $
+ 0F45 02432C + DB 2,'C,'
+ 0F48 +CCOMMA:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0F48 CD5301 + call DOCOLON
+ + ENDIF
+ 0F4B 110FE203 dw HERE,CSTORE,lit,1,CHARS,ALLOT,EXIT
+
+ ; INTERPRETER ===================================
+ ; Note that NFA>LFA, NFA>CFA, IMMED?, and FIND
+ ; are dependent on the structure of the Forth
+ ; header. This may be common across many CPUs,
+ ; or it may be different.
+
+ ;C SOURCE -- adr n current input buffer
+ ; 'SOURCE 2@ ; length is at lower adrs
+ 0F59 head SOURCE,6,SOURCE,docolon
+ 0F59 450F + DW link
+ 0F5B 00 + DB 0
+ 0F5C +link DEFL $
+ 0F5C 06534F55 + DB 6,'SOURCE'
+ 0F63 +SOURCE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0F63 CD5301 + call DOCOLON
+ + ENDIF
+ 0F66 C109DD0B DW TICKSOURCE,TWOFETCH,EXIT
+
+ ;X /STRING a u n -- a+n u-n trim string
+ ; ROT OVER + ROT ROT - ;
+ 0F6C head SLASHSTRING,7,/STRING,docolon
+ 0F6C 5C0F + DW link
+ 0F6E 00 + DB 0
+ 0F6F +link DEFL $
+ 0F6F 072F5354 + DB 7,'/STRING'
+ 0F77 +SLASHSTRING:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0F77 CD5301 + call DOCOLON
+ + ENDIF
+ 0F7A 0D03FA02 DW ROT,OVER,PLUS,ROT,ROT,MINUS,EXIT
+
+ ;Z >counted src n dst -- copy to counted str
+ ; 2DUP C! CHAR+ SWAP CMOVE ;
+ 0F88 head TOCOUNTED,8,>COUNTED,docolon
+ 0F88 6F0F + DW link
+ 0F8A 00 + DB 0
+ 0F8B +link DEFL $
+ 0F8B 083E434F + DB 8,'>COUNTED'
+ 0F94 +TOCOUNTED:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0F94 CD5301 + call DOCOLON
+ + ENDIF
+ 0F97 1B0CE203 DW TWODUP,CSTORE,CHARPLUS,SWOP,CMOVE,EXIT
+
+ ;C WORD char -- c-addr n word delim'd by char
+ ; DUP SOURCE >IN @ /STRING -- c c adr n
+ ; DUP >R ROT SKIP -- c adr' n'
+ ; OVER >R ROT SCAN -- adr" n"
+ ; DUP IF CHAR- THEN skip trailing delim.
+ ; R> R> ROT - >IN +! update >IN offset
+ ; TUCK - -- adr' N
+ ; HERE >counted --
+ ; HERE -- a
+ ; BL OVER COUNT + C! ; append trailing blank
+ 0FA3 head WORD,4,WORD,docolon
+ 0FA3 8B0F + DW link
+ 0FA5 00 + DB 0
+ 0FA6 +link DEFL $
+ 0FA6 04574F52 + DB 4,'WORD'
+ 0FAB +WORD:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0FAB CD5301 + call DOCOLON
+ + ENDIF
+ 0FAE B402630F DW DUP,SOURCE,TOIN,FETCH,SLASHSTRING
+ 0FB8 B4024003 DW DUP,TOR,ROT,SKIP
+ 0FC0 FA024003 DW OVER,TOR,ROT,SCAN
+ 0FC8 B4023106 DW DUP,qbranch,WORD1,ONEMINUS ; char-
+ 0FD0 58035803 WORD1: DW RFROM,RFROM,ROT,MINUS,TOIN,PLUSSTORE
+ 0FDC 31036104 DW TUCK,MINUS
+ 0FE0 110F940F DW HERE,TOCOUNTED,HERE
+ 0FE6 5809FA02 DW BL,OVER,COUNT,PLUS,CSTORE,EXIT
+
+ ;Z NFA>LFA nfa -- lfa name adr -> link field
+ ; 3 - ;
+ 0FF2 head NFATOLFA,7,NFA>LFA,docolon
+ 0FF2 A60F + DW link
+ 0FF4 00 + DB 0
+ 0FF5 +link DEFL $
+ 0FF5 074E4641 + DB 7,'NFA>LFA'
+ 0FFD +NFATOLFA:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 0FFD CD5301 + call DOCOLON
+ + ENDIF
+ 1000 36010300 DW LIT,3,MINUS,EXIT
+
+ ;Z NFA>CFA nfa -- cfa name adr -> code field
+ ; COUNT 7F AND + ; mask off 'smudge' bit
+ 1008 head NFATOCFA,7,NFA>CFA,docolon
+ 1008 F50F + DW link
+ 100A 00 + DB 0
+ 100B +link DEFL $
+ 100B 074E4641 + DB 7,'NFA>CFA'
+ 1013 +NFATOCFA:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1013 CD5301 + call DOCOLON
+ + ENDIF
+ 1016 5D0C3601 DW COUNT,LIT,07FH,AND,PLUS,EXIT
+
+ ;Z IMMED? nfa -- f fetch immediate flag
+ ; 1- C@ ; nonzero if immed
+ 1022 head IMMEDQ,6,IMMED?,docolon
+ 1022 0B10 + DW link
+ 1024 00 + DB 0
+ 1025 +link DEFL $
+ 1025 06494D4D + DB 6,'IMMED?'
+ 102C +IMMEDQ:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 102C CD5301 + call DOCOLON
+ + ENDIF
+ 102F EF040504 DW ONEMINUS,CFETCH,EXIT
+
+ ;C FIND c-addr -- c-addr 0 if not found
+ ;C xt 1 if immediate
+ ;C xt -1 if "normal"
+ ; LATEST @ BEGIN -- a nfa
+ ; 2DUP OVER C@ CHAR+ -- a nfa a nfa n+1
+ ; S= -- a nfa f
+ ; DUP IF
+ ; DROP
+ ; NFA>LFA @ DUP -- a link link
+ ; THEN
+ ; 0= UNTIL -- a nfa OR a 0
+ ; DUP IF
+ ; NIP DUP NFA>CFA -- nfa xt
+ ; SWAP IMMED? -- xt iflag
+ ; 0= 1 OR -- xt 1/-1
+ ; THEN ;
+ 1035 head FIND,4,FIND,docolon
+ 1035 2510 + DW link
+ 1037 00 + DB 0
+ 1038 +link DEFL $
+ 1038 0446494E + DB 4,'FIND'
+ 103D +FIND:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 103D CD5301 + call DOCOLON
+ + ENDIF
+ 1040 D009F303 DW LATEST,FETCH
+ 1044 1B0CFA02 FIND1: DW TWODUP,OVER,CFETCH,CHARPLUS
+ 104C 2608B402 DW SEQUAL,DUP,qbranch,FIND2
+ 1054 D702FD0F DW DROP,NFATOLFA,FETCH,DUP
+ 105C 7E053106 FIND2: DW ZEROEQUAL,qbranch,FIND1
+ 1062 B4023106 DW DUP,qbranch,FIND3
+ 1068 2003B402 DW NIP,DUP,NFATOCFA
+ 106E E7022C10 DW SWOP,IMMEDQ,ZEROEQUAL,LIT,1,OR
+ 107A 1E01 FIND3: DW EXIT
+
+ ;C LITERAL x -- append numeric literal
+ ; STATE @ IF ['] LIT ,XT , THEN ; IMMEDIATE
+ ; This tests STATE so that it can also be used
+ ; interpretively. (ANSI doesn't require this.)
+ 107C immed LITERAL,7,LITERAL,docolon
+ 107C 3810 + DW link
+ 107E 01 + DB 1
+ 107F +link DEFL $
+ 107F 074C4954 + DB 7,'LITERAL'
+ 1087 +LITERAL:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1087 CD5301 + call DOCOLON
+ + ENDIF
+ 108A A609F303 DW STATE,FETCH,qbranch,LITER1
+ 1092 36013601 DW LIT,LIT,COMMAXT,COMMA
+ 109A 1E01 LITER1: DW EXIT
+
+ ;Z DIGIT? c -- n -1 if c is a valid digit
+ ;Z -- x 0 otherwise
+ ; [ HEX ] DUP 39 > 100 AND + silly looking
+ ; DUP 140 > 107 AND - 30 - but it works!
+ ; DUP BASE @ U< ;
+ 109C head DIGITQ,6,DIGIT?,docolon
+ 109C 7F10 + DW link
+ 109E 00 + DB 0
+ 109F +link DEFL $
+ 109F 06444947 + DB 6,'DIGIT?'
+ 10A6 +DIGITQ:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 10A6 CD5301 + call DOCOLON
+ + ENDIF
+ 10A9 B4023601 DW DUP,LIT,39H,GREATER,LIT,100H,AND,PLUS
+ 10B9 B4023601 DW DUP,LIT,140H,GREATER,LIT,107H,AND
+ 10C7 61043601 DW MINUS,LIT,30H,MINUS
+ 10CF B4029809 DW DUP,BASE,FETCH,ULESS,EXIT
+
+ ;Z ?SIGN adr n -- adr' n' f get optional sign
+ ;Z advance adr/n if sign; return NZ if negative
+ ; OVER C@ -- adr n c
+ ; 2C - DUP ABS 1 = AND -- +=-1, -=+1, else 0
+ ; DUP IF 1+ -- +=0, -=+2
+ ; >R 1 /STRING R> -- adr' n' f
+ ; THEN ;
+ 10D9 head QSIGN,5,?SIGN,docolon
+ 10D9 9F10 + DW link
+ 10DB 00 + DB 0
+ 10DC +link DEFL $
+ 10DC 053F5349 + DB 5,'?SIGN'
+ 10E2 +QSIGN:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 10E2 CD5301 + call DOCOLON
+ + ENDIF
+ 10E5 FA020504 DW OVER,CFETCH,LIT,2CH,MINUS,DUP,ABS
+ 10F3 36010100 DW LIT,1,EQUAL,AND,DUP,qbranch,QSIGN1
+ 1101 E1044003 DW ONEPLUS,TOR,LIT,1,SLASHSTRING,RFROM
+ 110D 1E01 QSIGN1: DW EXIT
+
+ ;C >NUMBER ud adr u -- ud' adr' u'
+ ;C convert string to number
+ ; BEGIN
+ ; DUP WHILE
+ ; OVER C@ DIGIT?
+ ; 0= IF DROP EXIT THEN
+ ; >R 2SWAP BASE @ UD*
+ ; R> M+ 2SWAP
+ ; 1 /STRING
+ ; REPEAT ;
+ 110F head TONUMBER,7,>NUMBER,docolon
+ 110F DC10 + DW link
+ 1111 00 + DB 0
+ 1112 +link DEFL $
+ 1112 073E4E55 + DB 7,'>NUMBER'
+ 111A +TONUMBER:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 111A CD5301 + call DOCOLON
+ + ENDIF
+ 111D B4023106 TONUM1: DW DUP,qbranch,TONUM3
+ 1123 FA020504 DW OVER,CFETCH,DIGITQ
+ 1129 7E053106 DW ZEROEQUAL,qbranch,TONUM2,DROP,EXIT
+ 1133 40032D0C TONUM2: DW TOR,TWOSWAP,BASE,FETCH,UDSTAR
+ 113D 58034A04 DW RFROM,MPLUS,TWOSWAP
+ 1143 36010100 DW LIT,1,SLASHSTRING,branch,TONUM1
+ 114D 1E01 TONUM3: DW EXIT
+
+ ;Z ?NUMBER c-addr -- n -1 string->number
+ ;Z -- c-addr 0 if convert error
+ ; DUP 0 0 ROT COUNT -- ca ud adr n
+ ; ?SIGN >R >NUMBER -- ca ud adr' n'
+ ; IF R> 2DROP 2DROP 0 -- ca 0 (error)
+ ; ELSE 2DROP NIP R>
+ ; IF NEGATE THEN -1 -- n -1 (ok)
+ ; THEN ;
+ 114F head QNUMBER,7,?NUMBER,docolon
+ 114F 1211 + DW link
+ 1151 00 + DB 0
+ 1152 +link DEFL $
+ 1152 073F4E55 + DB 7,'?NUMBER'
+ 115A +QNUMBER:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 115A CD5301 + call DOCOLON
+ + ENDIF
+ 115D B4023601 DW DUP,LIT,0,DUP,ROT,COUNT
+ 1169 E2104003 DW QSIGN,TOR,TONUMBER,qbranch,QNUM1
+ 1173 58030A0C DW RFROM,TWODROP,TWODROP,LIT,0
+ 117D 1B069111 DW branch,QNUM3
+ 1181 0A0C2003 QNUM1: DW TWODROP,NIP,RFROM,qbranch,QNUM2,NEGATE
+ 118D 3601FFFF QNUM2: DW LIT,-1
+ 1191 1E01 QNUM3: DW EXIT
+
+ ;Z INTERPRET i*x c-addr u -- j*x
+ ;Z interpret given buffer
+ ; This is a common factor of EVALUATE and QUIT.
+ ; ref. dpANS-6, 3.4 The Forth Text Interpreter
+ ; 'SOURCE 2! 0 >IN !
+ ; BEGIN
+ ; BL WORD DUP C@ WHILE -- textadr
+ ; FIND -- a 0/1/-1
+ ; ?DUP IF -- xt 1/-1
+ ; 1+ STATE @ 0= OR immed or interp?
+ ; IF EXECUTE ELSE ,XT THEN
+ ; ELSE -- textadr
+ ; ?NUMBER
+ ; IF POSTPONE LITERAL converted ok
+ ; ELSE COUNT TYPE 3F EMIT CR ABORT err
+ ; THEN
+ ; THEN
+ ; REPEAT DROP ;
+ 1193 head INTERPRET,9,INTERPRET,docolon
+ 1193 5211 + DW link
+ 1195 00 + DB 0
+ 1196 +link DEFL $
+ 1196 09494E54 + DB 9,'INTERPRET'
+ 11A0 +INTERPRET:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 11A0 CD5301 + call DOCOLON
+ + ENDIF
+ 11A3 C109F20B DW TICKSOURCE,TWOSTORE,LIT,0,TOIN,STORE
+ 11AF 5809AB0F INTER1: DW BL,WORD,DUP,CFETCH,qbranch,INTER9
+ 11BB 3D10C402 DW FIND,QDUP,qbranch,INTER4
+ 11C3 E104A609 DW ONEPLUS,STATE,FETCH,ZEROEQUAL,OR
+ 11CD 3106D711 DW qbranch,INTER2
+ 11D1 4F011B06 DW EXECUTE,branch,INTER3
+ 11D7 CC08 INTER2: DW COMMAXT
+ 11D9 1B06F711 INTER3: DW branch,INTER8
+ 11DD 5A113106 INTER4: DW QNUMBER,qbranch,INTER5
+ 11E3 87101B06 DW LITERAL,branch,INTER6
+ 11E9 5D0C470D INTER5: DW COUNT,TYPE,LIT,3FH,EMIT,CR,ABORT
+ 11F7 INTER6:
+ 11F7 1B06AF11 INTER8: DW branch,INTER1
+ 11FB D7021E01 INTER9: DW DROP,EXIT
+
+ ;C EVALUATE i*x c-addr u -- j*x interprt string
+ ; 'SOURCE 2@ >R >R >IN @ >R
+ ; INTERPRET
+ ; R> >IN ! R> R> 'SOURCE 2! ;
+ 11FF head EVALUATE,8,EVALUATE,docolon
+ 11FF 9611 + DW link
+ 1201 00 + DB 0
+ 1202 +link DEFL $
+ 1202 08455641 + DB 8,'EVALUATE'
+ 120B +EVALUATE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 120B CD5301 + call DOCOLON
+ + ENDIF
+ 120E C109DD0B DW TICKSOURCE,TWOFETCH,TOR,TOR
+ 1216 8B09F303 DW TOIN,FETCH,TOR,INTERPRET
+ 121E 58038B09 DW RFROM,TOIN,STORE,RFROM,RFROM
+ 1228 C109F20B DW TICKSOURCE,TWOSTORE,EXIT
+
+ ;C QUIT -- R: i*x -- interpret from kbd
+ ; L0 LP ! R0 RP! 0 STATE !
+ ; BEGIN
+ ; TIB DUP TIBSIZE ACCEPT SPACE
+ ; INTERPRET
+ ; STATE @ 0= IF CR ." OK" THEN
+ ; AGAIN ;
+ 122E head QUIT,4,QUIT,docolon
+ 122E 0212 + DW link
+ 1230 00 + DB 0
+ 1231 +link DEFL $
+ 1231 04515549 + DB 4,'QUIT'
+ 1236 +QUIT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1236 CD5301 + call DOCOLON
+ + ENDIF
+ 1239 080AE609 DW L0,LP,STORE
+ 123F 130ABE03 DW R0,RPSTORE,LIT,0,STATE,STORE
+ 124B 7409B402 QUIT1: DW TIB,DUP,TIBSIZE,CPMACCEPT,SPACE
+ 1255 A011 DW INTERPRET
+ 1257 A609F303 DW STATE,FETCH,ZEROEQUAL,qbranch,QUIT2
+ 1261 700C720D DW CR,XSQUOTE
+ 1265 036F6B20 DB 3,'ok '
+ 1269 470D DW TYPE
+ 126B 1B064B12 QUIT2: DW branch,QUIT1
+
+ ;C ABORT i*x -- R: j*x -- clear stk & QUIT
+ ; S0 SP! QUIT ;
+ 126F head ABORT,5,ABORT,docolon
+ 126F 3112 + DW link
+ 1271 00 + DB 0
+ 1272 +link DEFL $
+ 1272 0541424F + DB 5,'ABORT'
+ 1278 +ABORT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1278 CD5301 + call DOCOLON
+ + ENDIF
+ 127B F1099A03 DW S0,SPSTORE,QUIT ; QUIT never returns
+
+ ;Z ?ABORT f c-addr u -- abort & print msg
+ ; ROT IF TYPE ABORT THEN 2DROP ;
+ 1281 head QABORT,6,?ABORT,docolon
+ 1281 7212 + DW link
+ 1283 00 + DB 0
+ 1284 +link DEFL $
+ 1284 063F4142 + DB 6,'?ABORT'
+ 128B +QABORT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 128B CD5301 + call DOCOLON
+ + ENDIF
+ 128E 0D033106 DW ROT,qbranch,QABO1,TYPE,ABORT
+ 1298 0A0C1E01 QABO1: DW TWODROP,EXIT
+
+ ;C ABORT" i*x 0 -- i*x R: j*x -- j*x x1=0
+ ;C i*x x1 -- R: j*x -- x1<>0
+ ; POSTPONE S" POSTPONE ?ABORT ; IMMEDIATE
+ 129C immed ABORTQUOTE,6,ABORT",docolon
+ 129C 8412 + DW link
+ 129E 01 + DB 1
+ 129F +link DEFL $
+ 129F 0641424F + DB 6,'ABORT"'
+ 12A6 +ABORTQUOTE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 12A6 CD5301 + call DOCOLON
+ + ENDIF
+ 12A9 890D DW SQUOTE
+ 12AB 36018B12 DW LIT,QABORT,COMMAXT
+ 12B1 1E01 DW EXIT
+
+ ;C ' -- xt find word in dictionary
+ ; BL WORD FIND
+ ; 0= ABORT" ?" ;
+ ; head TICK,1,',docolon
+ 12B3 9F12 DW link ; must expand
+ 12B5 00 DB 0 ; manually
+ 12B6 link DEFL $ ; because of
+ 12B6 0127 DB 1,27h ; tick character
+ 12B8 CD5301 TICK: call docolon
+ 12BB 5809AB0F DW BL,WORD,FIND,ZEROEQUAL,XSQUOTE
+ 12C5 013F DB 1,'?'
+ 12C7 8B121E01 DW QABORT,EXIT
+
+ ;C CHAR -- char parse ASCII character
+ ; BL WORD 1+ C@ ;
+ 12CB head CHAR,4,CHAR,docolon
+ 12CB B612 + DW link
+ 12CD 00 + DB 0
+ 12CE +link DEFL $
+ 12CE 04434841 + DB 4,'CHAR'
+ 12D3 +CHAR:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 12D3 CD5301 + call DOCOLON
+ + ENDIF
+ 12D6 5809AB0F DW BL,WORD,ONEPLUS,CFETCH,EXIT
+
+ ;C [CHAR] -- compile character literal
+ ; CHAR ['] LIT ,XT , ; IMMEDIATE
+ 12E0 immed BRACCHAR,6,[CHAR],docolon
+ 12E0 CE12 + DW link
+ 12E2 01 + DB 1
+ 12E3 +link DEFL $
+ 12E3 065B4348 + DB 6,'[CHAR]'
+ 12EA +BRACCHAR:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 12EA CD5301 + call DOCOLON
+ + ENDIF
+ 12ED D312 DW CHAR
+ 12EF 36013601 DW LIT,LIT,COMMAXT
+ 12F5 310F1E01 DW COMMA,EXIT
+
+ ;C ( -- skip input until )
+ ; [ HEX ] 29 WORD DROP ; IMMEDIATE
+ 12F9 immed PAREN,1,(,docolon
+ 12F9 E312 + DW link
+ 12FB 01 + DB 1
+ 12FC +link DEFL $
+ 12FC 0128 + DB 1,'('
+ 12FE +PAREN:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 12FE CD5301 + call DOCOLON
+ + ENDIF
+ 1301 36012900 DW LIT,29H,WORD,DROP,EXIT
+
+ ; COMPILER ======================================
+
+ ;C CREATE -- create an empty definition
+ ; LATEST @ , 0 C, link & immed field
+ ; HERE LATEST ! new "latest" link
+ ; BL WORD C@ 1+ ALLOT name field
+ ; docreate ,CF code field
+ 130B head CREATE,6,CREATE,docolon
+ 130B FC12 + DW link
+ 130D 00 + DB 0
+ 130E +link DEFL $
+ 130E 06435245 + DB 6,'CREATE'
+ 1315 +CREATE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1315 CD5301 + call DOCOLON
+ + ENDIF
+ 1318 D009F303 DW LATEST,FETCH,COMMA,LIT,0,CCOMMA
+ 1324 110FD009 DW HERE,LATEST,STORE
+ 132A 5809AB0F DW BL,WORD,CFETCH,ONEPLUS,ALLOT
+ 1334 36017F01 DW LIT,docreate,COMMACF,EXIT
+
+ ;Z (DOES>) -- run-time action of DOES>
+ ; R> adrs of headless DOES> def'n
+ ; LATEST @ NFA>CFA code field to fix up
+ ; !CF ;
+ 133C head XDOES,7,(DOES>),docolon
+ 133C 0E13 + DW link
+ 133E 00 + DB 0
+ 133F +link DEFL $
+ 133F 0728444F + DB 7,'(DOES>)'
+ 1347 +XDOES:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1347 CD5301 + call DOCOLON
+ + ENDIF
+ 134A 5803D009 DW RFROM,LATEST,FETCH,NFATOCFA,STORECF
+ 1354 1E01 DW EXIT
+
+ ;C DOES> -- change action of latest def'n
+ ; COMPILE (DOES>)
+ ; dodoes ,CF ; IMMEDIATE
+ 1356 immed DOES,5,DOES>,docolon
+ 1356 3F13 + DW link
+ 1358 01 + DB 1
+ 1359 +link DEFL $
+ 1359 05444F45 + DB 5,'DOES>'
+ 135F +DOES:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 135F CD5301 + call DOCOLON
+ + ENDIF
+ 1362 36014713 DW LIT,XDOES,COMMAXT
+ 1368 3601CE01 DW LIT,dodoes,COMMACF,EXIT
+
+ ;C RECURSE -- recurse current definition
+ ; LATEST @ NFA>CFA ,XT ; IMMEDIATE
+ 1370 immed RECURSE,7,RECURSE,docolon
+ 1370 5913 + DW link
+ 1372 01 + DB 1
+ 1373 +link DEFL $
+ 1373 07524543 + DB 7,'RECURSE'
+ 137B +RECURSE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 137B CD5301 + call DOCOLON
+ + ENDIF
+ 137E D009F303 DW LATEST,FETCH,NFATOCFA,COMMAXT,EXIT
+
+ ;C [ -- enter interpretive state
+ ; 0 STATE ! ; IMMEDIATE
+ 1388 immed LEFTBRACKET,1,[,docolon
+ 1388 7313 + DW link
+ 138A 01 + DB 1
+ 138B +link DEFL $
+ 138B 015B + DB 1,'['
+ 138D +LEFTBRACKET:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 138D CD5301 + call DOCOLON
+ + ENDIF
+ 1390 36010000 DW LIT,0,STATE,STORE,EXIT
+
+ ;C ] -- enter compiling state
+ ; -1 STATE ! ;
+ 139A head RIGHTBRACKET,1,],docolon
+ 139A 8B13 + DW link
+ 139C 00 + DB 0
+ 139D +link DEFL $
+ 139D 015D + DB 1,']'
+ 139F +RIGHTBRACKET:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 139F CD5301 + call DOCOLON
+ + ENDIF
+ 13A2 3601FFFF DW LIT,-1,STATE,STORE,EXIT
+
+ ;Z HIDE -- "hide" latest definition
+ ; LATEST @ DUP C@ 80 OR SWAP C! ;
+ 13AC head HIDE,4,HIDE,docolon
+ 13AC 9D13 + DW link
+ 13AE 00 + DB 0
+ 13AF +link DEFL $
+ 13AF 04484944 + DB 4,'HIDE'
+ 13B4 +HIDE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 13B4 CD5301 + call DOCOLON
+ + ENDIF
+ 13B7 D009F303 DW LATEST,FETCH,DUP,CFETCH,LIT,80H,OR
+ 13C5 E702E203 DW SWOP,CSTORE,EXIT
+
+ ;Z REVEAL -- "reveal" latest definition
+ ; LATEST @ DUP C@ 7F AND SWAP C! ;
+ 13CB head REVEAL,6,REVEAL,docolon
+ 13CB AF13 + DW link
+ 13CD 00 + DB 0
+ 13CE +link DEFL $
+ 13CE 06524556 + DB 6,'REVEAL'
+ 13D5 +REVEAL:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 13D5 CD5301 + call DOCOLON
+ + ENDIF
+ 13D8 D009F303 DW LATEST,FETCH,DUP,CFETCH,LIT,7FH,AND
+ 13E6 E702E203 DW SWOP,CSTORE,EXIT
+
+ ;C IMMEDIATE -- make last def'n immediate
+ ; 1 LATEST @ 1- C! ; set immediate flag
+ 13EC head IMMEDIATE,9,IMMEDIATE,docolon
+ 13EC CE13 + DW link
+ 13EE 00 + DB 0
+ 13EF +link DEFL $
+ 13EF 09494D4D + DB 9,'IMMEDIATE'
+ 13F9 +IMMEDIATE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 13F9 CD5301 + call DOCOLON
+ + ENDIF
+ 13FC 36010100 DW LIT,1,LATEST,FETCH,ONEMINUS,CSTORE
+ 1408 1E01 DW EXIT
+
+ ;C : -- begin a colon definition
+ ; CREATE HIDE ] !COLON ;
+ 140A head COLON,1,:,docode
+ 140A EF13 + DW link
+ 140C 00 + DB 0
+ 140D +link DEFL $
+ 140D 013A + DB 1,':'
+ 140F +COLON:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 140F CD5301 CALL docolon ; code fwd ref explicitly
+ 1412 1513B413 DW CREATE,HIDE,RIGHTBRACKET,STORCOLON
+ 141A 1E01 DW EXIT
+
+ ;C ;
+ ; REVEAL ,EXIT
+ ; POSTPONE [ ; IMMEDIATE
+ 141C immed SEMICOLON,1,';',docolon
+ 141C 0D14 + DW link
+ 141E 01 + DB 1
+ 141F +link DEFL $
+ 141F 013B + DB 1,';'
+ 1421 +SEMICOLON:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1421 CD5301 + call DOCOLON
+ + ENDIF
+ 1424 D5132109 DW REVEAL,CEXIT
+ 1428 8D131E01 DW LEFTBRACKET,EXIT
+
+ ;C ['] -- find word & compile as literal
+ ; ' ['] LIT ,XT , ; IMMEDIATE
+ ; When encountered in a colon definition, the
+ ; phrase ['] xxx will cause LIT,xxt to be
+ ; compiled into the colon definition (where
+ ; (where xxt is the execution token of word xxx).
+ ; When the colon definition executes, xxt will
+ ; be put on the stack. (All xt's are one cell.)
+ ; immed BRACTICK,3,['],docolon
+ 142C 1F14 DW link ; must expand
+ 142E 01 DB 1 ; manually
+ 142F link DEFL $ ; because of
+ 142F 035B275D DB 3,5Bh,27h,5Dh ; tick character
+ 1433 CD5301 BRACTICK: call docolon
+ 1436 B812 DW TICK ; get xt of 'xxx'
+ 1438 36013601 DW LIT,LIT,COMMAXT ; append LIT action
+ 143E 310F1E01 DW COMMA,EXIT ; append xt literal
+
+ ;C POSTPONE -- postpone compile action of word
+ ; BL WORD FIND
+ ; DUP 0= ABORT" ?"
+ ; 0< IF -- xt non immed: add code to current
+ ; def'n to compile xt later.
+ ; ['] LIT ,XT , add "LIT,xt,COMMAXT"
+ ; ['] ,XT ,XT to current definition
+ ; ELSE ,XT immed: compile into cur. def'n
+ ; THEN ; IMMEDIATE
+ 1442 immed POSTPONE,8,POSTPONE,docolon
+ 1442 2F14 + DW link
+ 1444 01 + DB 1
+ 1445 +link DEFL $
+ 1445 08504F53 + DB 8,'POSTPONE'
+ 144E +POSTPONE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 144E CD5301 + call DOCOLON
+ + ENDIF
+ 1451 5809AB0F DW BL,WORD,FIND,DUP,ZEROEQUAL,XSQUOTE
+ 145D 013F DB 1,'?'
+ 145F 8B129205 DW QABORT,ZEROLESS,qbranch,POST1
+ 1467 36013601 DW LIT,LIT,COMMAXT,COMMA
+ 146F 3601CC08 DW LIT,COMMAXT,COMMAXT,branch,POST2
+ 1479 CC08 POST1: DW COMMAXT
+ 147B 1E01 POST2: DW EXIT
+
+ ;Z COMPILE -- append inline execution token
+ ; R> DUP CELL+ >R @ ,XT ;
+ ; The phrase ['] xxx ,XT appears so often that
+ ; this word was created to combine the actions
+ ; of LIT and ,XT. It takes an inline literal
+ ; execution token and appends it to the dict.
+ ; head COMPILE,7,COMPILE,docolon
+ ; DW RFROM,DUP,CELLPLUS,TOR
+ ; DW FETCH,COMMAXT,EXIT
+ ; N.B.: not used in the current implementation
+
+ ; CONTROL STRUCTURES ============================
+
+ ;C IF -- adrs conditional forward branch
+ ; ['] qbranch ,BRANCH HERE DUP ,DEST ;
+ ; IMMEDIATE
+ 147D immed IF,2,IF,docolon
+ 147D 4514 + DW link
+ 147F 01 + DB 1
+ 1480 +link DEFL $
+ 1480 024946 + DB 2,'IF'
+ 1483 +IF:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1483 CD5301 + call DOCOLON
+ + ENDIF
+ 1486 36013106 DW LIT,qbranch,COMMABRANCH
+ 148C 110FB402 DW HERE,DUP,COMMADEST,EXIT
+
+ ;C THEN adrs -- resolve forward branch
+ ; HERE SWAP !DEST ; IMMEDIATE
+ 1494 immed THEN,4,THEN,docolon
+ 1494 8014 + DW link
+ 1496 01 + DB 1
+ 1497 +link DEFL $
+ 1497 04544845 + DB 4,'THEN'
+ 149C +THEN:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 149C CD5301 + call DOCOLON
+ + ENDIF
+ 149F 110FE702 DW HERE,SWOP,STOREDEST,EXIT
+
+ ;C ELSE adrs1 -- adrs2 branch for IF..ELSE
+ ; ['] branch ,BRANCH HERE DUP ,DEST
+ ; SWAP POSTPONE THEN ; IMMEDIATE
+ 14A7 immed ELSE,4,ELSE,docolon
+ 14A7 9714 + DW link
+ 14A9 01 + DB 1
+ 14AA +link DEFL $
+ 14AA 04454C53 + DB 4,'ELSE'
+ 14AF +ELSE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 14AF CD5301 + call DOCOLON
+ + ENDIF
+ 14B2 36011B06 DW LIT,branch,COMMABRANCH
+ 14B8 110FB402 DW HERE,DUP,COMMADEST
+ 14BE E7029C14 DW SWOP,THEN,EXIT
+
+ ;C BEGIN -- adrs target for bwd. branch
+ ; HERE ; IMMEDIATE
+ 14C4 immed BEGIN,5,BEGIN,docode
+ 14C4 AA14 + DW link
+ 14C6 01 + DB 1
+ 14C7 +link DEFL $
+ 14C7 05424547 + DB 5,'BEGIN'
+ 14CD +BEGIN:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 14CD C3110F jp HERE
+
+ ;C UNTIL adrs -- conditional backward branch
+ ; ['] qbranch ,BRANCH ,DEST ; IMMEDIATE
+ ; conditional backward branch
+ 14D0 immed UNTIL,5,UNTIL,docolon
+ 14D0 C714 + DW link
+ 14D2 01 + DB 1
+ 14D3 +link DEFL $
+ 14D3 05554E54 + DB 5,'UNTIL'
+ 14D9 +UNTIL:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 14D9 CD5301 + call DOCOLON
+ + ENDIF
+ 14DC 36013106 DW LIT,qbranch,COMMABRANCH
+ 14E2 43091E01 DW COMMADEST,EXIT
+
+ ;X AGAIN adrs -- uncond'l backward branch
+ ; ['] branch ,BRANCH ,DEST ; IMMEDIATE
+ ; unconditional backward branch
+ 14E6 immed AGAIN,5,AGAIN,docolon
+ 14E6 D314 + DW link
+ 14E8 01 + DB 1
+ 14E9 +link DEFL $
+ 14E9 05414741 + DB 5,'AGAIN'
+ 14EF +AGAIN:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 14EF CD5301 + call DOCOLON
+ + ENDIF
+ 14F2 36011B06 DW LIT,branch,COMMABRANCH
+ 14F8 43091E01 DW COMMADEST,EXIT
+
+ ;C WHILE -- adrs branch for WHILE loop
+ ; POSTPONE IF ; IMMEDIATE
+ 14FC immed WHILE,5,WHILE,docode
+ 14FC E914 + DW link
+ 14FE 01 + DB 1
+ 14FF +link DEFL $
+ 14FF 05574849 + DB 5,'WHILE'
+ 1505 +WHILE:
+ + IF .NOT.(DOCODE=DOCODE)
+ + call DOCODE
+ + ENDIF
+ 1505 C38314 jp IF
+
+ ;C REPEAT adrs1 adrs2 -- resolve WHILE loop
+ ; SWAP POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE
+ 1508 immed REPEAT,6,REPEAT,docolon
+ 1508 FF14 + DW link
+ 150A 01 + DB 1
+ 150B +link DEFL $
+ 150B 06524550 + DB 6,'REPEAT'
+ 1512 +REPEAT:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1512 CD5301 + call DOCOLON
+ + ENDIF
+ 1515 E702EF14 DW SWOP,AGAIN,THEN,EXIT
+
+ ;Z >L x -- L: -- x move to leave stack
+ ; CELL LP +! LP @ ! ; (L stack grows up)
+ 151D head TOL,2,>L,docolon
+ 151D 0B15 + DW link
+ 151F 00 + DB 0
+ 1520 +link DEFL $
+ 1520 023E4C + DB 2,'>L'
+ 1523 +TOL:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1523 CD5301 + call DOCOLON
+ + ENDIF
+ 1526 7208E609 DW CELL,LP,PLUSSTORE,LP,FETCH,STORE,EXIT
+
+ ;Z L> -- x L: x -- move from leave stack
+ ; LP @ @ CELL NEGATE LP +! ;
+ 1534 head LFROM,2,L>,docolon
+ 1534 2015 + DW link
+ 1536 00 + DB 0
+ 1537 +link DEFL $
+ 1537 024C3E + DB 2,'L>'
+ 153A +LFROM:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 153A CD5301 + call DOCOLON
+ + ENDIF
+ 153D E609F303 DW LP,FETCH,FETCH
+ 1543 7208CD04 DW CELL,NEGATE,LP,PLUSSTORE,EXIT
+
+ ;C DO -- adrs L: -- 0
+ ; ['] xdo ,XT HERE target for bwd branch
+ ; 0 >L ; IMMEDIATE marker for LEAVEs
+ 154D immed DO,2,DO,docolon
+ 154D 3715 + DW link
+ 154F 01 + DB 1
+ 1550 +link DEFL $
+ 1550 02444F + DB 2,'DO'
+ 1553 +DO:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1553 CD5301 + call DOCOLON
+ + ENDIF
+ 1556 36014706 DW LIT,xdo,COMMAXT,HERE
+ 155E 36010000 DW LIT,0,TOL,EXIT
+
+ ;Z ENDLOOP adrs xt -- L: 0 a1 a2 .. aN --
+ ; ,BRANCH ,DEST backward loop
+ ; BEGIN L> ?DUP WHILE POSTPONE THEN REPEAT ;
+ ; resolve LEAVEs
+ ; This is a common factor of LOOP and +LOOP.
+ 1566 head ENDLOOP,7,ENDLOOP,docolon
+ 1566 5015 + DW link
+ 1568 00 + DB 0
+ 1569 +link DEFL $
+ 1569 07454E44 + DB 7,'ENDLOOP'
+ 1571 +ENDLOOP:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1571 CD5301 + call DOCOLON
+ + ENDIF
+ 1574 37094309 DW COMMABRANCH,COMMADEST
+ 1578 3A15C402 LOOP1: DW LFROM,QDUP,qbranch,LOOP2
+ 1580 9C141B06 DW THEN,branch,LOOP1
+ 1586 1E01 LOOP2: DW EXIT
+
+ ;C LOOP adrs -- L: 0 a1 a2 .. aN --
+ ; ['] xloop ENDLOOP ; IMMEDIATE
+ 1588 immed LOOP,4,LOOP,docolon
+ 1588 6915 + DW link
+ 158A 01 + DB 1
+ 158B +link DEFL $
+ 158B 044C4F4F + DB 4,'LOOP'
+ 1590 +LOOP:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1590 CD5301 + call DOCOLON
+ + ENDIF
+ 1593 36017806 DW LIT,xloop,ENDLOOP,EXIT
+
+ ;C +LOOP adrs -- L: 0 a1 a2 .. aN --
+ ; ['] xplusloop ENDLOOP ; IMMEDIATE
+ 159B immed PLUSLOOP,5,+LOOP,docolon
+ 159B 8B15 + DW link
+ 159D 01 + DB 1
+ 159E +link DEFL $
+ 159E 052B4C4F + DB 5,'+LOOP'
+ 15A4 +PLUSLOOP:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 15A4 CD5301 + call DOCOLON
+ + ENDIF
+ 15A7 3601AB06 DW LIT,xplusloop,ENDLOOP,EXIT
+
+ ;C LEAVE -- L: -- adrs
+ ; ['] UNLOOP ,XT
+ ; ['] branch ,BRANCH HERE DUP ,DEST >L
+ ; ; IMMEDIATE unconditional forward branch
+ 15AF immed LEAVE,5,LEAVE,docolon
+ 15AF 9E15 + DW link
+ 15B1 01 + DB 1
+ 15B2 +link DEFL $
+ 15B2 054C4541 + DB 5,'LEAVE'
+ 15B8 +LEAVE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 15B8 CD5301 + call DOCOLON
+ + ENDIF
+ 15BB 3601F906 DW LIT,unloop,COMMAXT
+ 15C1 36011B06 DW LIT,branch,COMMABRANCH
+ 15C7 110FB402 DW HERE,DUP,COMMADEST,TOL,EXIT
+
+ ; OTHER OPERATIONS ==============================
+
+ ;X WITHIN n1|u1 n2|u2 n3|u3 -- f n2<=n1R - R> U< ; per ANS document
+ 15D1 head WITHIN,6,WITHIN,docolon
+ 15D1 B215 + DW link
+ 15D3 00 + DB 0
+ 15D4 +link DEFL $
+ 15D4 06574954 + DB 6,'WITHIN'
+ 15DB +WITHIN:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 15DB CD5301 + call DOCOLON
+ + ENDIF
+ 15DE FA026104 DW OVER,MINUS,TOR,MINUS,RFROM,ULESS,EXIT
+
+ ;C MOVE addr1 addr2 u -- smart move
+ ; VERSION FOR 1 ADDRESS UNIT = 1 CHAR
+ ; >R 2DUP SWAP DUP R@ + -- ... dst src src+n
+ ; WITHIN IF R> CMOVE> src <= dst < src+n
+ ; ELSE R> CMOVE THEN ; otherwise
+ 15EC head MOVE,4,MOVE,docolon
+ 15EC D415 + DW link
+ 15EE 00 + DB 0
+ 15EF +link DEFL $
+ 15EF 044D4F56 + DB 4,'MOVE'
+ 15F4 +MOVE:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 15F4 CD5301 + call DOCOLON
+ + ENDIF
+ 15F7 40031B0C DW TOR,TWODUP,SWOP,DUP,RFETCH,PLUS
+ 1603 DB153106 DW WITHIN,qbranch,MOVE1
+ 1609 5803BC07 DW RFROM,CMOVEUP,branch,MOVE2
+ 1611 58039E07 MOVE1: DW RFROM,CMOVE
+ 1615 1E01 MOVE2: DW EXIT
+
+ ;C DEPTH -- +n number of items on stack
+ ; SP@ S0 SWAP - 2/ ; 16-BIT VERSION!
+ 1617 head DEPTH,5,DEPTH,docolon
+ 1617 EF15 + DW link
+ 1619 00 + DB 0
+ 161A +link DEFL $
+ 161A 05444550 + DB 5,'DEPTH'
+ 1620 +DEPTH:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1620 CD5301 + call DOCOLON
+ + ENDIF
+ 1623 8503F109 DW SPFETCH,S0,SWOP,MINUS,TWOSLASH,EXIT
+
+ ;C ENVIRONMENT? c-addr u -- false system query
+ ; -- i*x true
+ ; 2DROP 0 ; the minimal definition!
+ 162F head ENVIRONMENTQ,12,ENVIRONMENT?,docolon
+ 162F 1A16 + DW link
+ 1631 00 + DB 0
+ 1632 +link DEFL $
+ 1632 0C454E56 + DB 12,'ENVIRONMENT?'
+ 163F +ENVIRONMENTQ:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 163F CD5301 + call DOCOLON
+ + ENDIF
+ 1642 0A0C3601 DW TWODROP,LIT,0,EXIT
+
+ ; UTILITY WORDS AND STARTUP =====================
+
+ ;X WORDS -- list all words in dict.
+ ; LATEST @ BEGIN
+ ; DUP COUNT TYPE SPACE
+ ; NFA>LFA @
+ ; DUP 0= UNTIL
+ ; DROP ;
+ 164A head WORDS,5,WORDS,docolon
+ 164A 3216 + DW link
+ 164C 00 + DB 0
+ 164D +link DEFL $
+ 164D 05574F52 + DB 5,'WORDS'
+ 1653 +WORDS:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1653 CD5301 + call DOCOLON
+ + ENDIF
+ 1656 D009F303 DW LATEST,FETCH
+ 165A B4025D0C WDS1: DW DUP,COUNT,TYPE,SPACE,NFATOLFA,FETCH
+ 1666 B4027E05 DW DUP,ZEROEQUAL,qbranch,WDS1
+ 166E D7021E01 DW DROP,EXIT
+
+ ;X .S -- print stack contents
+ ; SP@ S0 - IF
+ ; SP@ S0 2 - DO I @ U. -2 +LOOP
+ ; THEN ;
+ 1672 head DOTS,2,.S,docolon
+ 1672 4D16 + DW link
+ 1674 00 + DB 0
+ 1675 +link DEFL $
+ 1675 022E53 + DB 2,'.S'
+ 1678 +DOTS:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 1678 CD5301 + call DOCOLON
+ + ENDIF
+ 167B 8503F109 DW SPFETCH,S0,MINUS,qbranch,DOTS2
+ 1685 8503F109 DW SPFETCH,S0,LIT,2,MINUS,XDO
+ 1691 B806F303 DOTS1: DW II,FETCH,UDOT,LIT,-2,XPLUSLOOP,DOTS1
+ 169F 1E01 DOTS2: DW EXIT
+
+ ;Z COLD -- cold start Forth system
+ ; UINIT U0 #INIT CMOVE init user area
+ ; 80 COUNT INTERPRET interpret CP/M cmd
+ ; ." Z80 CamelForth etc."
+ ; ABORT ;
+ 16A1 head COLD,4,COLD,docolon
+ 16A1 7516 + DW link
+ 16A3 00 + DB 0
+ 16A4 +link DEFL $
+ 16A4 04434F4C + DB 4,'COLD'
+ 16A9 +COLD:
+ + IF .NOT.(DOCOLON=DOCODE)
+ 16A9 CD5301 + call DOCOLON
+ + ENDIF
+ 16AC 210A7F09 DW UINIT,U0,NINIT,CMOVE
+ 16B4 36018000 DW LIT,80h,COUNT,INTERPRET
+ 16BC 720D DW XSQUOTE
+ 16BE 235A3830 DB 35,'Z80 CamelForth v1.01 25 Jan 1995'
+ 16E0 0D0A DB 0dh,0ah
+ 16E2 470D7812 DW TYPE,ABORT ; ABORT never returns
+
+ 16A4 lastword EQU link ; nfa of last word in dict.
+ 16E6 enddict EQU $ ; user's code starts here
+ 16E6 END
+
+
+REDEFINED SYMBOLS
+
+LINK 16A4
+
+ASEG SYMBOLS
+
+ABORT 1278 ABORTQ 12A6 ABS 0A73 ACC1 0CF9 ACC3 0D27
+ACC4 0D31 ACC5 0D35 ACCEPT 0CEE AGAIN 14EF ALIGN 0856
+ALIGNE 0868 ALLOT 0F23 AND 0475 BASE 0998 BDOS 01EC
+BEGIN 14CD BL 0958 BRACCH 12EA BRACTI 1433 BRANCH 061B
+BYE 02AA CCOMMA 0F48 CELL 0872 CELLPL 0880 CELLS 0892
+CEXIT 0921 CFETCH 0405 CHAR 12D3 CHARPL 089E CHARS 08AA
+CMOVE 079E CMOVED 07A9 CMOVEU 07BC COLD 16A9 COLON 140F
+COMMA 0F31 COMMAB 0937 COMMAC 08EE COMMAD 0943 COMMAX 08CC
+CONSTA 0196 COUNT 0C5D CPMACC 027E CPMBDO 0005 CR 0C70
+CREATE 1315 CSTORE 03E2 DABS 0ABB DECIMA 0EE8 DEPTH 1620
+DIGITQ 10A6 DNEG1 0AB1 DNEGAT 0A87 DO 1553 DOBRAN 061B
+DOCODE 0000 DOCOLO 0153 DOCON 019F DOCREA 017F DODOES 01CE
+DOES 135F DOT 0EC2 DOTQUO 0DA8 DOTS 1678 DOTS1 1691
+DOTS2 169F DOUSER 01BC DOVAR 017F DP 09B1 DROP 02D7
+DUP 02B4 ELSE 14AF EMIT 020D ENDDIC 16E6 ENDLOO 1571
+ENTER 0153 ENVIRO 163F EQUAL 05A3 EVALUA 120B EXECUT 014F
+EXIT 011E FETCH 03F3 FILL 0777 FILLDO 078C FIND 103D
+FIND1 1044 FIND2 105C FIND3 107A FMMOD1 0B3B FMMOD2 0B3F
+FMSLAS 0B1C GREATE 05E5 HERE 0F11 HEX 0EFC HIDE 13B4
+HOLD 0DFE HP 09DB IF 1483 II 06B8 IMMEDI 13F9
+IMMEDQ 102C INTER1 11AF INTER2 11D7 INTER3 11D9 INTER4 11DD
+INTER5 11E9 INTER6 11F7 INTER8 11F7 INTER9 11FB INTERP 11A0
+INVERT 04B6 JJ 06D6 KEY 024E KEY1 0251 KEY2 0263
+L0 0A08 LASTWO 16A4 LATEST 09D0 LEAVE 15B8 LEFTBR 138D
+LESS 05C7 LESSNU 0E17 LFROM 153A LINK 16A4 LIT 0136
+LITER1 109A LITERA 1087 LOOP 1590 LOOP1 1578 LOOP2 1586
+LOOPTE 0691 LOOPTS 067C LP 09E6 LSH1 0538 LSH2 0539
+LSHIFT 0533 MAX 0BAE MAX1 0BBB MIN 0BC6 MIN1 0BD3
+MINUS 0461 MOD 0B79 MOVE 15F4 MOVE1 1611 MOVE2 1615
+MPLUS 044A MPLUS1 0453 MSTAR 0ACA NEGATE 04CD NFATOC 1013
+NFATOL 0FFD NINIT 0A3F NIP 0320 NOADD 0724 NOOP 0856
+NOTEQU 05B9 NUM 0E4C NUMGRE 0E7A NUMS 0E63 NUMS1 0E66
+ONEMIN 04EF ONEPLU 04E1 OR 0489 OVER 02FA PAD 09FD
+PAREN 12FE PCFETC 0429 PCSTOR 0417 PLUS 0439 PLUSLO 15A4
+PLUSST 0568 POPTOS 02D7 POST1 1479 POST2 147B POSTPO 144E
+PUSHTO 02B4 QABO1 1298 QABORT 128B QBRANC 0631 QDNEGA 0AA6
+QDUP 02C4 QNEG1 0A6A QNEGAT 0A5F QNUM1 1181 QNUM2 118D
+QNUM3 1191 QNUMBE 115A QSIGN 10E2 QSIGN1 110D QUERYK 0232
+QUIT 1236 QUIT1 124B QUIT2 126B R0 0A13 RECURS 137B
+REPEAT 1512 RESET 0100 REVEAL 13D5 REVSEN 05DB RFETCH 0370
+RFROM 0358 RIGHTB 139F ROT 030D RPFETC 03AC RPSTOR 03BE
+RSH1 0553 RSH2 0557 RSHIFT 054E S0 09F1 SAVEKE 0225
+SCAN 0805 SCANDO 0815 SDIFF 083E SEMICO 1421 SEQUAL 0826
+SIGN 0E93 SIGN1 0EA2 SKIP 07DD SKIPDO 07F2 SKIPLO 07E7
+SKIPMI 07F0 SLASH 0B69 SLASHM 0B57 SLASHS 0F77 SLOOP 082F
+SMATCH 0838 SMSLAS 0AED SNEXT 0846 SOURCE 0F63 SPACE 0C8A
+SPACES 0C9D SPCS1 0CA0 SPCS2 0CAE SPFETC 0385 SPSTOR 039A
+SQUOTE 0D89 SSMOD 0B8B STAR 0B46 STARSL 0B9E STATE 09A6
+STOD 0A4B STORCO 0907 STORE 03CE STOREC 08D6 STORED 094F
+SWAPBY 04FD SWOP 02E7 THEN 149C TIB 0974 TIBSIZ 0968
+TICK 12B8 TICKSO 09C1 TOBODY 08B5 TOCOUN 0F94 TODIGI 0E2C
+TOIN 098B TOL 1523 TONUM1 111D TONUM2 1133 TONUM3 114D
+TONUMB 111A TOR 0340 TOSFAL 05A9 TOSTRU 05D1 TUCK 0331
+TWODRO 0C0A TWODUP 0C1B TWOFET 0BDD TWOOVE 0C43 TWOSLA 051E
+TWOSTA 050D TWOSTO 0BF2 TWOSWA 0C2D TYP3 0D58 TYP4 0D66
+TYP5 0D68 TYPE 0D47 U0 097F UDIV3 0751 UDIV4 0757
+UDLOOP 0747 UDOT 0EAA UDSLAS 0DBF UDSTAR 0DDF UGREAT 0608
+UINIT 0A21 ULESS 05F4 UMAX 0CD3 UMAX1 0CE0 UMIN 0CBA
+UMIN1 0CC7 UMLOOP 0719 UMOVED 07CC UMSLAS 073C UMSTAR 070F
+UNLOOP 06F9 UNTIL 14D9 USER 01B3 VARIAB 0170 WDS1 165A
+WHILE 1505 WITHIN 15DB WORD 0FAB WORD1 0FD0 WORDS 1653
+XDO 0647 XDOES 1347 XLOOP 0678 XOR 049E XPLUSL 06AB
+XSQUOT 0D72 ZEROEQ 057E ZEROLE 0592
+
+ 0000 ERROR(S) ASSEMBLY COMPLETE
+47 XDOES 1347 XLOOP 0678 XOR 049E XPLUSL 06AB
+XSQUOT 0D72 ZEROEQ 057E ZEROLE 0592
+
+
\ No newline at end of file
diff --git a/Source/HBIOS/Forth/camel80d.azm b/Source/HBIOS/Forth/camel80d.azm
new file mode 100644
index 00000000..0dd13e3e
--- /dev/null
+++ b/Source/HBIOS/Forth/camel80d.azm
@@ -0,0 +1,154 @@
+; LISTING 3.
+;
+; ===============================================
+; CamelForth for the Zilog Z80
+; Copyright (c) 1994,1995 Bradford J. Rodriguez
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 3 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program. If not, see .
+
+; Commercial inquiries should be directed to the author at
+; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+; or via email to bj@camelforth.com
+;
+; ===============================================
+; CAMEL80D.AZM: CPU and Model Dependencies
+; Source code is for the Z80MR macro assembler.
+; Forth words are documented as follows:
+;* NAME stack -- stack description
+; Word names in upper case are from the ANS
+; Forth Core word set. Names in lower case are
+; "internal" implementation words & extensions.
+;
+; Direct-Threaded Forth model for Zilog Z80
+; cell size is 16 bits (2 bytes)
+; char size is 8 bits (1 byte)
+; address unit is 8 bits (1 byte), i.e.,
+; addresses are byte-aligned.
+; ===============================================
+
+; ALIGNMENT AND PORTABILITY OPERATORS ===========
+; Many of these are synonyms for other words,
+; and so are defined as CODE words.
+
+;C ALIGN -- align HERE
+ head ALIGN,5,ALIGN,docode
+noop: next
+
+;C ALIGNED addr -- a-addr align given addr
+ head ALIGNED,7,ALIGNED,docode
+ jr noop
+
+;Z CELL -- n size of one cell
+ head CELL,4,CELL,docon
+ dw 2
+
+;C CELL+ a-addr1 -- a-addr2 add cell size
+; 2 + ;
+ head CELLPLUS,5,CELL+,docode
+ inc bc
+ inc bc
+ next
+
+;C CELLS n1 -- n2 cells->adrs units
+ head CELLS,5,CELLS,docode
+ jp twostar
+
+;C CHAR+ c-addr1 -- c-addr2 add char size
+ head CHARPLUS,5,CHAR+,docode
+ jp oneplus
+
+;C CHARS n1 -- n2 chars->adrs units
+ head CHARS,5,CHARS,docode
+ jr noop
+
+;C >BODY xt -- a-addr adrs of param field
+; 3 + ; Z80 (3 byte CALL)
+ head TOBODY,5,>BODY,docolon
+ DW LIT,3,PLUS,EXIT
+
+;X COMPILE, xt -- append execution token
+; I called this word ,XT before I discovered that
+; it is defined in the ANSI standard as COMPILE,.
+; On a DTC Forth this simply appends xt (like , )
+; but on an STC Forth this must append 'CALL xt'.
+ head COMMAXT,8,'COMPILE,',docode
+ jp COMMA
+
+;Z !CF adrs cfa -- set code action of a word
+; 0CD OVER C! store 'CALL adrs' instr
+; 1+ ! ; Z80 VERSION
+; Depending on the implementation this could
+; append CALL adrs or JUMP adrs.
+ head STORECF,3,!CF,docolon
+ DW LIT,0CDH,OVER,CSTORE
+ DW ONEPLUS,STORE,EXIT
+
+;Z ,CF adrs -- append a code field
+; HERE !CF 3 ALLOT ; Z80 VERSION (3 bytes)
+ head COMMACF,3,',CF',docolon
+ DW HERE,STORECF,LIT,3,ALLOT,EXIT
+
+;Z !COLON -- change code field to docolon
+; -3 ALLOT docolon-adrs ,CF ;
+; This should be used immediately after CREATE.
+; This is made a distinct word, because on an STC
+; Forth, colon definitions have no code field.
+ head STORCOLON,6,'!COLON',docolon
+ DW LIT,-3,ALLOT
+ DW LIT,docolon,COMMACF,EXIT
+
+;Z ,EXIT -- append hi-level EXIT action
+; ['] EXIT ,XT ;
+; This is made a distinct word, because on an STC
+; Forth, it appends a RET instruction, not an xt.
+ head CEXIT,5,',EXIT',docolon
+ DW LIT,EXIT,COMMAXT,EXIT
+
+; CONTROL STRUCTURES ============================
+; These words allow Forth control structure words
+; to be defined portably.
+
+;Z ,BRANCH xt -- append a branch instruction
+; xt is the branch operator to use, e.g. qbranch
+; or (loop). It does NOT append the destination
+; address. On the Z80 this is equivalent to ,XT.
+ head COMMABRANCH,7,',BRANCH',docode
+ jp COMMA
+
+;Z ,DEST dest -- append a branch address
+; This appends the given destination address to
+; the branch instruction. On the Z80 this is ','
+; ...other CPUs may use relative addressing.
+ head COMMADEST,5,',DEST',docode
+ jp COMMA
+
+;Z !DEST dest adrs -- change a branch dest'n
+; Changes the destination address found at 'adrs'
+; to the given 'dest'. On the Z80 this is '!'
+; ...other CPUs may need relative addressing.
+ head STOREDEST,5,'!DEST',docode
+ jp STORE
+
+; HEADER STRUCTURE ==============================
+; The structure of the Forth dictionary headers
+; (name, link, immediate flag, and "smudge" bit)
+; does not necessarily differ across CPUs. This
+; structure is not easily factored into distinct
+; "portable" words; instead, it is implicit in
+; the definitions of FIND and CREATE, and also in
+; NFA>LFA, NFA>CFA, IMMED?, IMMEDIATE, HIDE, and
+; REVEAL. These words must be (substantially)
+; rewritten if either the header structure or its
+; inherent assumptions are changed.
+
diff --git a/Source/HBIOS/Forth/camel80h.azm b/Source/HBIOS/Forth/camel80h.azm
new file mode 100644
index 00000000..5744c024
--- /dev/null
+++ b/Source/HBIOS/Forth/camel80h.azm
@@ -0,0 +1,1024 @@
+; LISTING 2.
+;
+; ===============================================
+; CamelForth for the Zilog Z80
+; Copyright (c) 1994,1995 Bradford J. Rodriguez
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 3 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program. If not, see .
+
+; Commercial inquiries should be directed to the author at
+; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+; or via email to bj@camelforth.com
+;
+; ===============================================
+; CAMEL80H.AZM: High Level Words
+; Source code is for the Z80MR macro assembler.
+; Forth words are documented as follows:
+;* NAME stack -- stack description
+; Word names in upper case are from the ANS
+; Forth Core word set. Names in lower case are
+; "internal" implementation words & extensions.
+; ===============================================
+
+; SYSTEM VARIABLES & CONSTANTS ==================
+
+;C BL -- char an ASCII space
+ head BL,2,BL,docon
+ dw 20h
+
+;Z tibsize -- n size of TIB
+ head TIBSIZE,7,TIBSIZE,docon
+ dw 124 ; 2 chars safety zone
+
+;X tib -- a-addr Terminal Input Buffer
+; HEX 82 CONSTANT TIB CP/M systems: 126 bytes
+; HEX -80 USER TIB others: below user area
+ head TIB,3,TIB,docon
+ dw 82h
+
+;Z u0 -- a-addr current user area adrs
+; 0 USER U0
+ head U0,2,U0,douser
+ dw 0
+
+;C >IN -- a-addr holds offset into TIB
+; 2 USER >IN
+ head TOIN,3,>IN,douser
+ dw 2
+
+;C BASE -- a-addr holds conversion radix
+; 4 USER BASE
+ head BASE,4,BASE,douser
+ dw 4
+
+;C STATE -- a-addr holds compiler state
+; 6 USER STATE
+ head STATE,5,STATE,douser
+ dw 6
+
+;Z dp -- a-addr holds dictionary ptr
+; 8 USER DP
+ head DP,2,DP,douser
+ dw 8
+
+;Z 'source -- a-addr two cells: len, adrs
+; 10 USER 'SOURCE
+; head TICKSOURCE,7,'SOURCE,douser
+ DW link ; must expand
+ DB 0 ; manually
+link DEFL $ ; because of
+ DB 7,27h,'SOURCE' ; tick character
+TICKSOURCE: call douser ; in name!
+ dw 10
+
+;Z latest -- a-addr last word in dict.
+; 14 USER LATEST
+ head LATEST,6,LATEST,douser
+ dw 14
+
+;Z hp -- a-addr HOLD pointer
+; 16 USER HP
+ head HP,2,HP,douser
+ dw 16
+
+;Z LP -- a-addr Leave-stack pointer
+; 18 USER LP
+ head LP,2,LP,douser
+ dw 18
+
+;Z s0 -- a-addr end of parameter stack
+ head S0,2,S0,douser
+ dw 100h
+
+;X PAD -- a-addr user PAD buffer
+; = end of hold area!
+ head PAD,3,PAD,douser
+ dw 128h
+
+;Z l0 -- a-addr bottom of Leave stack
+ head L0,2,L0,douser
+ dw 180h
+
+;Z r0 -- a-addr end of return stack
+ head R0,2,R0,douser
+ dw 200h
+
+;Z uinit -- addr initial values for user area
+ head UINIT,5,UINIT,docreate
+ DW 0,0,10,0 ; reserved,>IN,BASE,STATE
+ DW enddict ; DP
+ DW 0,0 ; SOURCE init'd elsewhere
+ DW lastword ; LATEST
+ DW 0 ; HP init'd elsewhere
+
+;Z #init -- n #bytes of user area init data
+ head NINIT,5,#INIT,docon
+ DW 18
+
+; ARITHMETIC OPERATORS ==========================
+
+;C S>D n -- d single -> double prec.
+; DUP 0< ;
+ head STOD,3,S>D,docolon
+ dw DUP,ZEROLESS,EXIT
+
+;Z ?NEGATE n1 n2 -- n3 negate n1 if n2 negative
+; 0< IF NEGATE THEN ; ...a common factor
+ head QNEGATE,7,?NEGATE,docolon
+ DW ZEROLESS,qbranch,QNEG1,NEGATE
+QNEG1: DW EXIT
+
+;C ABS n1 -- +n2 absolute value
+; DUP ?NEGATE ;
+ head ABS,3,ABS,docolon
+ DW DUP,QNEGATE,EXIT
+
+;X DNEGATE d1 -- d2 negate double precision
+; SWAP INVERT SWAP INVERT 1 M+ ;
+ head DNEGATE,7,DNEGATE,docolon
+ DW SWOP,INVERT,SWOP,INVERT,LIT,1,MPLUS
+ DW EXIT
+
+;Z ?DNEGATE d1 n -- d2 negate d1 if n negative
+; 0< IF DNEGATE THEN ; ...a common factor
+ head QDNEGATE,8,?DNEGATE,docolon
+ DW ZEROLESS,qbranch,DNEG1,DNEGATE
+DNEG1: DW EXIT
+
+;X DABS d1 -- +d2 absolute value dbl.prec.
+; DUP ?DNEGATE ;
+ head DABS,4,DABS,docolon
+ DW DUP,QDNEGATE,EXIT
+
+;C M* n1 n2 -- d signed 16*16->32 multiply
+; 2DUP XOR >R carries sign of the result
+; SWAP ABS SWAP ABS UM*
+; R> ?DNEGATE ;
+ head MSTAR,2,M*,docolon
+ DW TWODUP,XOR,TOR
+ DW SWOP,ABS,SWOP,ABS,UMSTAR
+ DW RFROM,QDNEGATE,EXIT
+
+;C SM/REM d1 n1 -- n2 n3 symmetric signed div
+; 2DUP XOR >R sign of quotient
+; OVER >R sign of remainder
+; ABS >R DABS R> UM/MOD
+; SWAP R> ?NEGATE
+; SWAP R> ?NEGATE ;
+; Ref. dpANS-6 section 3.2.2.1.
+ head SMSLASHREM,6,SM/REM,docolon
+ DW TWODUP,XOR,TOR,OVER,TOR
+ DW ABS,TOR,DABS,RFROM,UMSLASHMOD
+ DW SWOP,RFROM,QNEGATE,SWOP,RFROM,QNEGATE
+ DW EXIT
+
+;C FM/MOD d1 n1 -- n2 n3 floored signed div'n
+; DUP >R save divisor
+; SM/REM
+; DUP 0< IF if quotient negative,
+; SWAP R> + add divisor to rem'dr
+; SWAP 1- decrement quotient
+; ELSE R> DROP THEN ;
+; Ref. dpANS-6 section 3.2.2.1.
+ head FMSLASHMOD,6,FM/MOD,docolon
+ DW DUP,TOR,SMSLASHREM
+ DW DUP,ZEROLESS,qbranch,FMMOD1
+ DW SWOP,RFROM,PLUS,SWOP,ONEMINUS
+ DW branch,FMMOD2
+FMMOD1: DW RFROM,DROP
+FMMOD2: DW EXIT
+
+;C * n1 n2 -- n3 signed multiply
+; M* DROP ;
+ head STAR,1,*,docolon
+ dw MSTAR,DROP,EXIT
+
+;C /MOD n1 n2 -- n3 n4 signed divide/rem'dr
+; >R S>D R> FM/MOD ;
+ head SLASHMOD,4,/MOD,docolon
+ dw TOR,STOD,RFROM,FMSLASHMOD,EXIT
+
+;C / n1 n2 -- n3 signed divide
+; /MOD nip ;
+ head SLASH,1,/,docolon
+ dw SLASHMOD,NIP,EXIT
+
+;C MOD n1 n2 -- n3 signed remainder
+; /MOD DROP ;
+ head MOD,3,MOD,docolon
+ dw SLASHMOD,DROP,EXIT
+
+;C */MOD n1 n2 n3 -- n4 n5 n1*n2/n3, rem"
+; >R M* R> FM/MOD ;
+ head SSMOD,5,*/MOD,docolon
+ dw TOR,MSTAR,RFROM,FMSLASHMOD,EXIT
+
+;C */ n1 n2 n3 -- n4 n1*n2/n3
+; */MOD nip ;
+ head STARSLASH,2,*/,docolon
+ dw SSMOD,NIP,EXIT
+
+;C MAX n1 n2 -- n3 signed maximum
+; 2DUP < IF SWAP THEN DROP ;
+ head MAX,3,MAX,docolon
+ dw TWODUP,LESS,qbranch,MAX1,SWOP
+MAX1: dw DROP,EXIT
+
+;C MIN n1 n2 -- n3 signed minimum
+; 2DUP > IF SWAP THEN DROP ;
+ head MIN,3,MIN,docolon
+ dw TWODUP,GREATER,qbranch,MIN1,SWOP
+MIN1: dw DROP,EXIT
+
+; DOUBLE OPERATORS ==============================
+
+;C 2@ a-addr -- x1 x2 fetch 2 cells
+; DUP CELL+ @ SWAP @ ;
+; the lower address will appear on top of stack
+ head TWOFETCH,2,2@,docolon
+ dw DUP,CELLPLUS,FETCH,SWOP,FETCH,EXIT
+
+;C 2! x1 x2 a-addr -- store 2 cells
+; SWAP OVER ! CELL+ ! ;
+; the top of stack is stored at the lower adrs
+ head TWOSTORE,2,2!,docolon
+ dw SWOP,OVER,STORE,CELLPLUS,STORE,EXIT
+
+;C 2DROP x1 x2 -- drop 2 cells
+; DROP DROP ;
+ head TWODROP,5,2DROP,docolon
+ dw DROP,DROP,EXIT
+
+;C 2DUP x1 x2 -- x1 x2 x1 x2 dup top 2 cells
+; OVER OVER ;
+ head TWODUP,4,2DUP,docolon
+ dw OVER,OVER,EXIT
+
+;C 2SWAP x1 x2 x3 x4 -- x3 x4 x1 x2 per diagram
+; ROT >R ROT R> ;
+ head TWOSWAP,5,2SWAP,docolon
+ dw ROT,TOR,ROT,RFROM,EXIT
+
+;C 2OVER x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2
+; >R >R 2DUP R> R> 2SWAP ;
+ head TWOOVER,5,2OVER,docolon
+ dw TOR,TOR,TWODUP,RFROM,RFROM
+ dw TWOSWAP,EXIT
+
+; INPUT/OUTPUT ==================================
+
+;C COUNT c-addr1 -- c-addr2 u counted->adr/len
+; DUP CHAR+ SWAP C@ ;
+ head COUNT,5,COUNT,docolon
+ dw DUP,CHARPLUS,SWOP,CFETCH,EXIT
+
+;C CR -- output newline
+; 0D EMIT 0A EMIT ;
+ head CR,2,CR,docolon
+ dw lit,0dh,EMIT,lit,0ah,EMIT,EXIT
+
+;C SPACE -- output a space
+; BL EMIT ;
+ head SPACE,5,SPACE,docolon
+ dw BL,EMIT,EXIT
+
+;C SPACES n -- output n spaces
+; BEGIN DUP WHILE SPACE 1- REPEAT DROP ;
+ head SPACES,6,SPACES,docolon
+SPCS1: DW DUP,qbranch,SPCS2
+ DW SPACE,ONEMINUS,branch,SPCS1
+SPCS2: DW DROP,EXIT
+
+;Z umin u1 u2 -- u unsigned minimum
+; 2DUP U> IF SWAP THEN DROP ;
+ head UMIN,4,UMIN,docolon
+ DW TWODUP,UGREATER,QBRANCH,UMIN1,SWOP
+UMIN1: DW DROP,EXIT
+
+;Z umax u1 u2 -- u unsigned maximum
+; 2DUP U< IF SWAP THEN DROP ;
+ head UMAX,4,UMAX,docolon
+ DW TWODUP,ULESS,QBRANCH,UMAX1,SWOP
+UMAX1: DW DROP,EXIT
+
+;C ACCEPT c-addr +n -- +n' get line from term'l
+; OVER + 1- OVER -- sa ea a
+; BEGIN KEY -- sa ea a c
+; DUP 0D <> WHILE
+; DUP EMIT -- sa ea a c
+; DUP 8 = IF DROP 1- >R OVER R> UMAX
+; ELSE OVER C! 1+ OVER UMIN
+; THEN -- sa ea a
+; REPEAT -- sa ea a c
+; DROP NIP SWAP - ;
+ head ACCEPT,6,ACCEPT,docolon
+ DW OVER,PLUS,ONEMINUS,OVER
+ACC1: DW KEY,DUP,LIT,0DH,NOTEQUAL,QBRANCH,ACC5
+ DW DUP,EMIT,DUP,LIT,8,EQUAL,QBRANCH,ACC3
+ DW DROP,ONEMINUS,TOR,OVER,RFROM,UMAX
+ DW BRANCH,ACC4
+ACC3: DW OVER,CSTORE,ONEPLUS,OVER,UMIN
+ACC4: DW BRANCH,ACC1
+ACC5: DW DROP,NIP,SWOP,MINUS,EXIT
+
+;C TYPE c-addr +n -- type line to term'l
+; ?DUP IF
+; OVER + SWAP DO I C@ EMIT LOOP
+; ELSE DROP THEN ;
+ head TYPE,4,TYPE,docolon
+ DW QDUP,QBRANCH,TYP4
+ DW OVER,PLUS,SWOP,XDO
+TYP3: DW II,CFETCH,EMIT,XLOOP,TYP3
+ DW BRANCH,TYP5
+TYP4: DW DROP
+TYP5: DW EXIT
+
+;Z (S") -- c-addr u run-time code for S"
+; R> COUNT 2DUP + ALIGNED >R ;
+ head XSQUOTE,4,(S"),docolon
+ DW RFROM,COUNT,TWODUP,PLUS,ALIGNED,TOR
+ DW EXIT
+
+;C S" -- compile in-line string
+; COMPILE (S") [ HEX ]
+; 22 WORD C@ 1+ ALIGNED ALLOT ; IMMEDIATE
+ immed SQUOTE,2,S",docolon
+ DW LIT,XSQUOTE,COMMAXT
+ DW LIT,22H,WORD,CFETCH,ONEPLUS
+ DW ALIGNED,ALLOT,EXIT
+
+;C ." -- compile string to print
+; POSTPONE S" POSTPONE TYPE ; IMMEDIATE
+ immed DOTQUOTE,2,.",docolon
+ DW SQUOTE
+ DW LIT,TYPE,COMMAXT
+ DW EXIT
+
+; NUMERIC OUTPUT ================================
+; Numeric conversion is done l.s.digit first, so
+; the output buffer is built backwards in memory.
+
+; Some double-precision arithmetic operators are
+; needed to implement ANSI numeric conversion.
+
+;Z UD/MOD ud1 u2 -- u3 ud4 32/16->32 divide
+; >R 0 R@ UM/MOD ROT ROT R> UM/MOD ROT ;
+ head UDSLASHMOD,6,UD/MOD,docolon
+ DW TOR,LIT,0,RFETCH,UMSLASHMOD,ROT,ROT
+ DW RFROM,UMSLASHMOD,ROT,EXIT
+
+;Z UD* ud1 d2 -- ud3 32*16->32 multiply
+; DUP >R UM* DROP SWAP R> UM* ROT + ;
+ head UDSTAR,3,UD*,docolon
+ DW DUP,TOR,UMSTAR,DROP
+ DW SWOP,RFROM,UMSTAR,ROT,PLUS,EXIT
+
+;C HOLD char -- add char to output string
+; -1 HP +! HP @ C! ;
+ head HOLD,4,HOLD,docolon
+ DW LIT,-1,HP,PLUSSTORE
+ DW HP,FETCH,CSTORE,EXIT
+
+;C <# -- begin numeric conversion
+; PAD HP ! ; (initialize Hold Pointer)
+ head LESSNUM,2,<#,docolon
+ DW PAD,HP,STORE,EXIT
+
+;Z >digit n -- c convert to 0..9A..Z
+; [ HEX ] DUP 9 > 7 AND + 30 + ;
+ head TODIGIT,6,>DIGIT,docolon
+ DW DUP,LIT,9,GREATER,LIT,7,AND,PLUS
+ DW LIT,30H,PLUS,EXIT
+
+;C # ud1 -- ud2 convert 1 digit of output
+; BASE @ UD/MOD ROT >digit HOLD ;
+ head NUM,1,#,docolon
+ DW BASE,FETCH,UDSLASHMOD,ROT,TODIGIT
+ DW HOLD,EXIT
+
+;C #S ud1 -- ud2 convert remaining digits
+; BEGIN # 2DUP OR 0= UNTIL ;
+ head NUMS,2,#S,docolon
+NUMS1: DW NUM,TWODUP,OR,ZEROEQUAL,qbranch,NUMS1
+ DW EXIT
+
+;C #> ud1 -- c-addr u end conv., get string
+; 2DROP HP @ PAD OVER - ;
+ head NUMGREATER,2,#>,docolon
+ DW TWODROP,HP,FETCH,PAD,OVER,MINUS,EXIT
+
+;C SIGN n -- add minus sign if n<0
+; 0< IF 2D HOLD THEN ;
+ head SIGN,4,SIGN,docolon
+ DW ZEROLESS,qbranch,SIGN1,LIT,2DH,HOLD
+SIGN1: DW EXIT
+
+;C U. u -- display u unsigned
+; <# 0 #S #> TYPE SPACE ;
+ head UDOT,2,U.,docolon
+ DW LESSNUM,LIT,0,NUMS,NUMGREATER,TYPE
+ DW SPACE,EXIT
+
+;C . n -- display n signed
+; <# DUP ABS 0 #S ROT SIGN #> TYPE SPACE ;
+ head DOT,1,'.',docolon
+ DW LESSNUM,DUP,ABS,LIT,0,NUMS
+ DW ROT,SIGN,NUMGREATER,TYPE,SPACE,EXIT
+
+;C DECIMAL -- set number base to decimal
+; 10 BASE ! ;
+ head DECIMAL,7,DECIMAL,docolon
+ DW LIT,10,BASE,STORE,EXIT
+
+;X HEX -- set number base to hex
+; 16 BASE ! ;
+ head HEX,3,HEX,docolon
+ DW LIT,16,BASE,STORE,EXIT
+
+; DICTIONARY MANAGEMENT =========================
+
+;C HERE -- addr returns dictionary ptr
+; DP @ ;
+ head HERE,4,HERE,docolon
+ dw DP,FETCH,EXIT
+
+;C ALLOT n -- allocate n bytes in dict
+; DP +! ;
+ head ALLOT,5,ALLOT,docolon
+ dw DP,PLUSSTORE,EXIT
+
+; Note: , and C, are only valid for combined
+; Code and Data spaces.
+
+;C , x -- append cell to dict
+; HERE ! 1 CELLS ALLOT ;
+ head COMMA,1,',',docolon
+ dw HERE,STORE,lit,1,CELLS,ALLOT,EXIT
+
+;C C, char -- append char to dict
+; HERE C! 1 CHARS ALLOT ;
+ head CCOMMA,2,'C,',docolon
+ dw HERE,CSTORE,lit,1,CHARS,ALLOT,EXIT
+
+; INTERPRETER ===================================
+; Note that NFA>LFA, NFA>CFA, IMMED?, and FIND
+; are dependent on the structure of the Forth
+; header. This may be common across many CPUs,
+; or it may be different.
+
+;C SOURCE -- adr n current input buffer
+; 'SOURCE 2@ ; length is at lower adrs
+ head SOURCE,6,SOURCE,docolon
+ DW TICKSOURCE,TWOFETCH,EXIT
+
+;X /STRING a u n -- a+n u-n trim string
+; ROT OVER + ROT ROT - ;
+ head SLASHSTRING,7,/STRING,docolon
+ DW ROT,OVER,PLUS,ROT,ROT,MINUS,EXIT
+
+;Z >counted src n dst -- copy to counted str
+; 2DUP C! CHAR+ SWAP CMOVE ;
+ head TOCOUNTED,8,>COUNTED,docolon
+ DW TWODUP,CSTORE,CHARPLUS,SWOP,CMOVE,EXIT
+
+;C WORD char -- c-addr n word delim'd by char
+; DUP SOURCE >IN @ /STRING -- c c adr n
+; DUP >R ROT SKIP -- c adr' n'
+; OVER >R ROT SCAN -- adr" n"
+; DUP IF CHAR- THEN skip trailing delim.
+; R> R> ROT - >IN +! update >IN offset
+; TUCK - -- adr' N
+; HERE >counted --
+; HERE -- a
+; BL OVER COUNT + C! ; append trailing blank
+ head WORD,4,WORD,docolon
+ DW DUP,SOURCE,TOIN,FETCH,SLASHSTRING
+ DW DUP,TOR,ROT,SKIP
+ DW OVER,TOR,ROT,SCAN
+ DW DUP,qbranch,WORD1,ONEMINUS ; char-
+WORD1: DW RFROM,RFROM,ROT,MINUS,TOIN,PLUSSTORE
+ DW TUCK,MINUS
+ DW HERE,TOCOUNTED,HERE
+ DW BL,OVER,COUNT,PLUS,CSTORE,EXIT
+
+;Z NFA>LFA nfa -- lfa name adr -> link field
+; 3 - ;
+ head NFATOLFA,7,NFA>LFA,docolon
+ DW LIT,3,MINUS,EXIT
+
+;Z NFA>CFA nfa -- cfa name adr -> code field
+; COUNT 7F AND + ; mask off 'smudge' bit
+ head NFATOCFA,7,NFA>CFA,docolon
+ DW COUNT,LIT,07FH,AND,PLUS,EXIT
+
+;Z IMMED? nfa -- f fetch immediate flag
+; 1- C@ ; nonzero if immed
+ head IMMEDQ,6,IMMED?,docolon
+ DW ONEMINUS,CFETCH,EXIT
+
+;C FIND c-addr -- c-addr 0 if not found
+;C xt 1 if immediate
+;C xt -1 if "normal"
+; LATEST @ BEGIN -- a nfa
+; 2DUP OVER C@ CHAR+ -- a nfa a nfa n+1
+; S= -- a nfa f
+; DUP IF
+; DROP
+; NFA>LFA @ DUP -- a link link
+; THEN
+; 0= UNTIL -- a nfa OR a 0
+; DUP IF
+; NIP DUP NFA>CFA -- nfa xt
+; SWAP IMMED? -- xt iflag
+; 0= 1 OR -- xt 1/-1
+; THEN ;
+ head FIND,4,FIND,docolon
+ DW LATEST,FETCH
+FIND1: DW TWODUP,OVER,CFETCH,CHARPLUS
+ DW SEQUAL,DUP,qbranch,FIND2
+ DW DROP,NFATOLFA,FETCH,DUP
+FIND2: DW ZEROEQUAL,qbranch,FIND1
+ DW DUP,qbranch,FIND3
+ DW NIP,DUP,NFATOCFA
+ DW SWOP,IMMEDQ,ZEROEQUAL,LIT,1,OR
+FIND3: DW EXIT
+
+;C LITERAL x -- append numeric literal
+; STATE @ IF ['] LIT ,XT , THEN ; IMMEDIATE
+; This tests STATE so that it can also be used
+; interpretively. (ANSI doesn't require this.)
+ immed LITERAL,7,LITERAL,docolon
+ DW STATE,FETCH,qbranch,LITER1
+ DW LIT,LIT,COMMAXT,COMMA
+LITER1: DW EXIT
+
+;Z DIGIT? c -- n -1 if c is a valid digit
+;Z -- x 0 otherwise
+; [ HEX ] DUP 39 > 100 AND + silly looking
+; DUP 140 > 107 AND - 30 - but it works!
+; DUP BASE @ U< ;
+ head DIGITQ,6,DIGIT?,docolon
+ DW DUP,LIT,39H,GREATER,LIT,100H,AND,PLUS
+ DW DUP,LIT,140H,GREATER,LIT,107H,AND
+ DW MINUS,LIT,30H,MINUS
+ DW DUP,BASE,FETCH,ULESS,EXIT
+
+;Z ?SIGN adr n -- adr' n' f get optional sign
+;Z advance adr/n if sign; return NZ if negative
+; OVER C@ -- adr n c
+; 2C - DUP ABS 1 = AND -- +=-1, -=+1, else 0
+; DUP IF 1+ -- +=0, -=+2
+; >R 1 /STRING R> -- adr' n' f
+; THEN ;
+ head QSIGN,5,?SIGN,docolon
+ DW OVER,CFETCH,LIT,2CH,MINUS,DUP,ABS
+ DW LIT,1,EQUAL,AND,DUP,qbranch,QSIGN1
+ DW ONEPLUS,TOR,LIT,1,SLASHSTRING,RFROM
+QSIGN1: DW EXIT
+
+;C >NUMBER ud adr u -- ud' adr' u'
+;C convert string to number
+; BEGIN
+; DUP WHILE
+; OVER C@ DIGIT?
+; 0= IF DROP EXIT THEN
+; >R 2SWAP BASE @ UD*
+; R> M+ 2SWAP
+; 1 /STRING
+; REPEAT ;
+ head TONUMBER,7,>NUMBER,docolon
+TONUM1: DW DUP,qbranch,TONUM3
+ DW OVER,CFETCH,DIGITQ
+ DW ZEROEQUAL,qbranch,TONUM2,DROP,EXIT
+TONUM2: DW TOR,TWOSWAP,BASE,FETCH,UDSTAR
+ DW RFROM,MPLUS,TWOSWAP
+ DW LIT,1,SLASHSTRING,branch,TONUM1
+TONUM3: DW EXIT
+
+;Z ?NUMBER c-addr -- n -1 string->number
+;Z -- c-addr 0 if convert error
+; DUP 0 0 ROT COUNT -- ca ud adr n
+; ?SIGN >R >NUMBER -- ca ud adr' n'
+; IF R> 2DROP 2DROP 0 -- ca 0 (error)
+; ELSE 2DROP NIP R>
+; IF NEGATE THEN -1 -- n -1 (ok)
+; THEN ;
+ head QNUMBER,7,?NUMBER,docolon
+ DW DUP,LIT,0,DUP,ROT,COUNT
+ DW QSIGN,TOR,TONUMBER,qbranch,QNUM1
+ DW RFROM,TWODROP,TWODROP,LIT,0
+ DW branch,QNUM3
+QNUM1: DW TWODROP,NIP,RFROM,qbranch,QNUM2,NEGATE
+QNUM2: DW LIT,-1
+QNUM3: DW EXIT
+
+;Z INTERPRET i*x c-addr u -- j*x
+;Z interpret given buffer
+; This is a common factor of EVALUATE and QUIT.
+; ref. dpANS-6, 3.4 The Forth Text Interpreter
+; 'SOURCE 2! 0 >IN !
+; BEGIN
+; BL WORD DUP C@ WHILE -- textadr
+; FIND -- a 0/1/-1
+; ?DUP IF -- xt 1/-1
+; 1+ STATE @ 0= OR immed or interp?
+; IF EXECUTE ELSE ,XT THEN
+; ELSE -- textadr
+; ?NUMBER
+; IF POSTPONE LITERAL converted ok
+; ELSE COUNT TYPE 3F EMIT CR ABORT err
+; THEN
+; THEN
+; REPEAT DROP ;
+ head INTERPRET,9,INTERPRET,docolon
+ DW TICKSOURCE,TWOSTORE,LIT,0,TOIN,STORE
+INTER1: DW BL,WORD,DUP,CFETCH,qbranch,INTER9
+ DW FIND,QDUP,qbranch,INTER4
+ DW ONEPLUS,STATE,FETCH,ZEROEQUAL,OR
+ DW qbranch,INTER2
+ DW EXECUTE,branch,INTER3
+INTER2: DW COMMAXT
+INTER3: DW branch,INTER8
+INTER4: DW QNUMBER,qbranch,INTER5
+ DW LITERAL,branch,INTER6
+INTER5: DW COUNT,TYPE,LIT,3FH,EMIT,CR,ABORT
+INTER6:
+INTER8: DW branch,INTER1
+INTER9: DW DROP,EXIT
+
+;C EVALUATE i*x c-addr u -- j*x interprt string
+; 'SOURCE 2@ >R >R >IN @ >R
+; INTERPRET
+; R> >IN ! R> R> 'SOURCE 2! ;
+ head EVALUATE,8,EVALUATE,docolon
+ DW TICKSOURCE,TWOFETCH,TOR,TOR
+ DW TOIN,FETCH,TOR,INTERPRET
+ DW RFROM,TOIN,STORE,RFROM,RFROM
+ DW TICKSOURCE,TWOSTORE,EXIT
+
+;C QUIT -- R: i*x -- interpret from kbd
+; L0 LP ! R0 RP! 0 STATE !
+; BEGIN
+; TIB DUP TIBSIZE ACCEPT SPACE
+; INTERPRET
+; STATE @ 0= IF CR ." OK" THEN
+; AGAIN ;
+ head QUIT,4,QUIT,docolon
+ DW L0,LP,STORE
+ DW R0,RPSTORE,LIT,0,STATE,STORE
+QUIT1: DW TIB,DUP,TIBSIZE,CPMACCEPT,SPACE
+ DW INTERPRET
+ DW STATE,FETCH,ZEROEQUAL,qbranch,QUIT2
+ DW CR,XSQUOTE
+ DB 3,'ok '
+ DW TYPE
+QUIT2: DW branch,QUIT1
+
+;C ABORT i*x -- R: j*x -- clear stk & QUIT
+; S0 SP! QUIT ;
+ head ABORT,5,ABORT,docolon
+ DW S0,SPSTORE,QUIT ; QUIT never returns
+
+;Z ?ABORT f c-addr u -- abort & print msg
+; ROT IF TYPE ABORT THEN 2DROP ;
+ head QABORT,6,?ABORT,docolon
+ DW ROT,qbranch,QABO1,TYPE,ABORT
+QABO1: DW TWODROP,EXIT
+
+;C ABORT" i*x 0 -- i*x R: j*x -- j*x x1=0
+;C i*x x1 -- R: j*x -- x1<>0
+; POSTPONE S" POSTPONE ?ABORT ; IMMEDIATE
+ immed ABORTQUOTE,6,ABORT",docolon
+ DW SQUOTE
+ DW LIT,QABORT,COMMAXT
+ DW EXIT
+
+;C ' -- xt find word in dictionary
+; BL WORD FIND
+; 0= ABORT" ?" ;
+; head TICK,1,',docolon
+ DW link ; must expand
+ DB 0 ; manually
+link DEFL $ ; because of
+ DB 1,27h ; tick character
+TICK: call docolon
+ DW BL,WORD,FIND,ZEROEQUAL,XSQUOTE
+ DB 1,'?'
+ DW QABORT,EXIT
+
+;C CHAR -- char parse ASCII character
+; BL WORD 1+ C@ ;
+ head CHAR,4,CHAR,docolon
+ DW BL,WORD,ONEPLUS,CFETCH,EXIT
+
+;C [CHAR] -- compile character literal
+; CHAR ['] LIT ,XT , ; IMMEDIATE
+ immed BRACCHAR,6,[CHAR],docolon
+ DW CHAR
+ DW LIT,LIT,COMMAXT
+ DW COMMA,EXIT
+
+;C ( -- skip input until )
+; [ HEX ] 29 WORD DROP ; IMMEDIATE
+ immed PAREN,1,(,docolon
+ DW LIT,29H,WORD,DROP,EXIT
+
+; COMPILER ======================================
+
+;C CREATE -- create an empty definition
+; LATEST @ , 0 C, link & immed field
+; HERE LATEST ! new "latest" link
+; BL WORD C@ 1+ ALLOT name field
+; docreate ,CF code field
+ head CREATE,6,CREATE,docolon
+ DW LATEST,FETCH,COMMA,LIT,0,CCOMMA
+ DW HERE,LATEST,STORE
+ DW BL,WORD,CFETCH,ONEPLUS,ALLOT
+ DW LIT,docreate,COMMACF,EXIT
+
+;Z (DOES>) -- run-time action of DOES>
+; R> adrs of headless DOES> def'n
+; LATEST @ NFA>CFA code field to fix up
+; !CF ;
+ head XDOES,7,(DOES>),docolon
+ DW RFROM,LATEST,FETCH,NFATOCFA,STORECF
+ DW EXIT
+
+;C DOES> -- change action of latest def'n
+; COMPILE (DOES>)
+; dodoes ,CF ; IMMEDIATE
+ immed DOES,5,DOES>,docolon
+ DW LIT,XDOES,COMMAXT
+ DW LIT,dodoes,COMMACF,EXIT
+
+;C RECURSE -- recurse current definition
+; LATEST @ NFA>CFA ,XT ; IMMEDIATE
+ immed RECURSE,7,RECURSE,docolon
+ DW LATEST,FETCH,NFATOCFA,COMMAXT,EXIT
+
+;C [ -- enter interpretive state
+; 0 STATE ! ; IMMEDIATE
+ immed LEFTBRACKET,1,[,docolon
+ DW LIT,0,STATE,STORE,EXIT
+
+;C ] -- enter compiling state
+; -1 STATE ! ;
+ head RIGHTBRACKET,1,],docolon
+ DW LIT,-1,STATE,STORE,EXIT
+
+;Z HIDE -- "hide" latest definition
+; LATEST @ DUP C@ 80 OR SWAP C! ;
+ head HIDE,4,HIDE,docolon
+ DW LATEST,FETCH,DUP,CFETCH,LIT,80H,OR
+ DW SWOP,CSTORE,EXIT
+
+;Z REVEAL -- "reveal" latest definition
+; LATEST @ DUP C@ 7F AND SWAP C! ;
+ head REVEAL,6,REVEAL,docolon
+ DW LATEST,FETCH,DUP,CFETCH,LIT,7FH,AND
+ DW SWOP,CSTORE,EXIT
+
+;C IMMEDIATE -- make last def'n immediate
+; 1 LATEST @ 1- C! ; set immediate flag
+ head IMMEDIATE,9,IMMEDIATE,docolon
+ DW LIT,1,LATEST,FETCH,ONEMINUS,CSTORE
+ DW EXIT
+
+;C : -- begin a colon definition
+; CREATE HIDE ] !COLON ;
+ head COLON,1,:,docode
+ CALL docolon ; code fwd ref explicitly
+ DW CREATE,HIDE,RIGHTBRACKET,STORCOLON
+ DW EXIT
+
+;C ;
+; REVEAL ,EXIT
+; POSTPONE [ ; IMMEDIATE
+ immed SEMICOLON,1,';',docolon
+ DW REVEAL,CEXIT
+ DW LEFTBRACKET,EXIT
+
+;C ['] -- find word & compile as literal
+; ' ['] LIT ,XT , ; IMMEDIATE
+; When encountered in a colon definition, the
+; phrase ['] xxx will cause LIT,xxt to be
+; compiled into the colon definition (where
+; (where xxt is the execution token of word xxx).
+; When the colon definition executes, xxt will
+; be put on the stack. (All xt's are one cell.)
+; immed BRACTICK,3,['],docolon
+ DW link ; must expand
+ DB 1 ; manually
+link DEFL $ ; because of
+ DB 3,5Bh,27h,5Dh ; tick character
+BRACTICK: call docolon
+ DW TICK ; get xt of 'xxx'
+ DW LIT,LIT,COMMAXT ; append LIT action
+ DW COMMA,EXIT ; append xt literal
+
+;C POSTPONE -- postpone compile action of word
+; BL WORD FIND
+; DUP 0= ABORT" ?"
+; 0< IF -- xt non immed: add code to current
+; def'n to compile xt later.
+; ['] LIT ,XT , add "LIT,xt,COMMAXT"
+; ['] ,XT ,XT to current definition
+; ELSE ,XT immed: compile into cur. def'n
+; THEN ; IMMEDIATE
+ immed POSTPONE,8,POSTPONE,docolon
+ DW BL,WORD,FIND,DUP,ZEROEQUAL,XSQUOTE
+ DB 1,'?'
+ DW QABORT,ZEROLESS,qbranch,POST1
+ DW LIT,LIT,COMMAXT,COMMA
+ DW LIT,COMMAXT,COMMAXT,branch,POST2
+POST1: DW COMMAXT
+POST2: DW EXIT
+
+;Z COMPILE -- append inline execution token
+; R> DUP CELL+ >R @ ,XT ;
+; The phrase ['] xxx ,XT appears so often that
+; this word was created to combine the actions
+; of LIT and ,XT. It takes an inline literal
+; execution token and appends it to the dict.
+; head COMPILE,7,COMPILE,docolon
+; DW RFROM,DUP,CELLPLUS,TOR
+; DW FETCH,COMMAXT,EXIT
+; N.B.: not used in the current implementation
+
+; CONTROL STRUCTURES ============================
+
+;C IF -- adrs conditional forward branch
+; ['] qbranch ,BRANCH HERE DUP ,DEST ;
+; IMMEDIATE
+ immed IF,2,IF,docolon
+ DW LIT,qbranch,COMMABRANCH
+ DW HERE,DUP,COMMADEST,EXIT
+
+;C THEN adrs -- resolve forward branch
+; HERE SWAP !DEST ; IMMEDIATE
+ immed THEN,4,THEN,docolon
+ DW HERE,SWOP,STOREDEST,EXIT
+
+;C ELSE adrs1 -- adrs2 branch for IF..ELSE
+; ['] branch ,BRANCH HERE DUP ,DEST
+; SWAP POSTPONE THEN ; IMMEDIATE
+ immed ELSE,4,ELSE,docolon
+ DW LIT,branch,COMMABRANCH
+ DW HERE,DUP,COMMADEST
+ DW SWOP,THEN,EXIT
+
+;C BEGIN -- adrs target for bwd. branch
+; HERE ; IMMEDIATE
+ immed BEGIN,5,BEGIN,docode
+ jp HERE
+
+;C UNTIL adrs -- conditional backward branch
+; ['] qbranch ,BRANCH ,DEST ; IMMEDIATE
+; conditional backward branch
+ immed UNTIL,5,UNTIL,docolon
+ DW LIT,qbranch,COMMABRANCH
+ DW COMMADEST,EXIT
+
+;X AGAIN adrs -- uncond'l backward branch
+; ['] branch ,BRANCH ,DEST ; IMMEDIATE
+; unconditional backward branch
+ immed AGAIN,5,AGAIN,docolon
+ DW LIT,branch,COMMABRANCH
+ DW COMMADEST,EXIT
+
+;C WHILE -- adrs branch for WHILE loop
+; POSTPONE IF ; IMMEDIATE
+ immed WHILE,5,WHILE,docode
+ jp IF
+
+;C REPEAT adrs1 adrs2 -- resolve WHILE loop
+; SWAP POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE
+ immed REPEAT,6,REPEAT,docolon
+ DW SWOP,AGAIN,THEN,EXIT
+
+;Z >L x -- L: -- x move to leave stack
+; CELL LP +! LP @ ! ; (L stack grows up)
+ head TOL,2,>L,docolon
+ DW CELL,LP,PLUSSTORE,LP,FETCH,STORE,EXIT
+
+;Z L> -- x L: x -- move from leave stack
+; LP @ @ CELL NEGATE LP +! ;
+ head LFROM,2,L>,docolon
+ DW LP,FETCH,FETCH
+ DW CELL,NEGATE,LP,PLUSSTORE,EXIT
+
+;C DO -- adrs L: -- 0
+; ['] xdo ,XT HERE target for bwd branch
+; 0 >L ; IMMEDIATE marker for LEAVEs
+ immed DO,2,DO,docolon
+ DW LIT,xdo,COMMAXT,HERE
+ DW LIT,0,TOL,EXIT
+
+;Z ENDLOOP adrs xt -- L: 0 a1 a2 .. aN --
+; ,BRANCH ,DEST backward loop
+; BEGIN L> ?DUP WHILE POSTPONE THEN REPEAT ;
+; resolve LEAVEs
+; This is a common factor of LOOP and +LOOP.
+ head ENDLOOP,7,ENDLOOP,docolon
+ DW COMMABRANCH,COMMADEST
+LOOP1: DW LFROM,QDUP,qbranch,LOOP2
+ DW THEN,branch,LOOP1
+LOOP2: DW EXIT
+
+;C LOOP adrs -- L: 0 a1 a2 .. aN --
+; ['] xloop ENDLOOP ; IMMEDIATE
+ immed LOOP,4,LOOP,docolon
+ DW LIT,xloop,ENDLOOP,EXIT
+
+;C +LOOP adrs -- L: 0 a1 a2 .. aN --
+; ['] xplusloop ENDLOOP ; IMMEDIATE
+ immed PLUSLOOP,5,+LOOP,docolon
+ DW LIT,xplusloop,ENDLOOP,EXIT
+
+;C LEAVE -- L: -- adrs
+; ['] UNLOOP ,XT
+; ['] branch ,BRANCH HERE DUP ,DEST >L
+; ; IMMEDIATE unconditional forward branch
+ immed LEAVE,5,LEAVE,docolon
+ DW LIT,unloop,COMMAXT
+ DW LIT,branch,COMMABRANCH
+ DW HERE,DUP,COMMADEST,TOL,EXIT
+
+; OTHER OPERATIONS ==============================
+
+;X WITHIN n1|u1 n2|u2 n3|u3 -- f n2<=n1R - R> U< ; per ANS document
+ head WITHIN,6,WITHIN,docolon
+ DW OVER,MINUS,TOR,MINUS,RFROM,ULESS,EXIT
+
+;C MOVE addr1 addr2 u -- smart move
+; VERSION FOR 1 ADDRESS UNIT = 1 CHAR
+; >R 2DUP SWAP DUP R@ + -- ... dst src src+n
+; WITHIN IF R> CMOVE> src <= dst < src+n
+; ELSE R> CMOVE THEN ; otherwise
+ head MOVE,4,MOVE,docolon
+ DW TOR,TWODUP,SWOP,DUP,RFETCH,PLUS
+ DW WITHIN,qbranch,MOVE1
+ DW RFROM,CMOVEUP,branch,MOVE2
+MOVE1: DW RFROM,CMOVE
+MOVE2: DW EXIT
+
+;C DEPTH -- +n number of items on stack
+; SP@ S0 SWAP - 2/ ; 16-BIT VERSION!
+ head DEPTH,5,DEPTH,docolon
+ DW SPFETCH,S0,SWOP,MINUS,TWOSLASH,EXIT
+
+;C ENVIRONMENT? c-addr u -- false system query
+; -- i*x true
+; 2DROP 0 ; the minimal definition!
+ head ENVIRONMENTQ,12,ENVIRONMENT?,docolon
+ DW TWODROP,LIT,0,EXIT
+
+; UTILITY WORDS AND STARTUP =====================
+
+;X WORDS -- list all words in dict.
+; LATEST @ BEGIN
+; DUP COUNT TYPE SPACE
+; NFA>LFA @
+; DUP 0= UNTIL
+; DROP ;
+ head WORDS,5,WORDS,docolon
+ DW LATEST,FETCH
+WDS1: DW DUP,COUNT,TYPE,SPACE,NFATOLFA,FETCH
+ DW DUP,ZEROEQUAL,qbranch,WDS1
+ DW DROP,EXIT
+
+;X .S -- print stack contents
+; SP@ S0 - IF
+; SP@ S0 2 - DO I @ U. -2 +LOOP
+; THEN ;
+ head DOTS,2,.S,docolon
+ DW SPFETCH,S0,MINUS,qbranch,DOTS2
+ DW SPFETCH,S0,LIT,2,MINUS,XDO
+DOTS1: DW II,FETCH,UDOT,LIT,-2,XPLUSLOOP,DOTS1
+DOTS2: DW EXIT
+
+;Z COLD -- cold start Forth system
+; UINIT U0 #INIT CMOVE init user area
+; 80 COUNT INTERPRET interpret CP/M cmd
+; ." Z80 CamelForth etc."
+; ABORT ;
+ head COLD,4,COLD,docolon
+ DW UINIT,U0,NINIT,CMOVE
+ DW LIT,80h,COUNT,INTERPRET
+ DW XSQUOTE
+ DB 35,'Z80 CamelForth v1.01 25 Jan 1995'
+ DB 0dh,0ah
+ DW TYPE,ABORT ; ABORT never returns
+
diff --git a/Source/HBIOS/Forth/cameltst.azm b/Source/HBIOS/Forth/cameltst.azm
new file mode 100644
index 00000000..ad480ed2
--- /dev/null
+++ b/Source/HBIOS/Forth/cameltst.azm
@@ -0,0 +1,93 @@
+; Listing 1.
+; ===============================================
+; CamelForth for the Zilog Z80
+; Primitive testing code
+;
+; This is the "minimal" test of the CamelForth
+; kernel. It verifies the threading and nesting
+; mechanisms, the stacks, and the primitives
+; DUP EMIT EXIT lit branch ONEPLUS.
+; It is particularly useful because it does not
+; use the DO..LOOP, multiply, or divide words,
+; and because it can be used on embedded CPUs.
+; The numeric display word .A is also useful
+; for testing the rest of the Core wordset.
+;
+; The required macros and CPU initialization
+; are in file CAMEL80.AZM.
+; ===============================================
+
+;Z >< u1 -- u2 swap the bytes of TOS
+ head SWAB,2,><,docode
+ ld a,b
+ ld b,c
+ ld c,a
+ next
+
+;Z LO c1 -- c2 return low nybble of TOS
+ head LO,2,LO,docode
+ ld a,c
+ and 0fh
+ ld c,a
+ ld b,0
+ next
+
+;Z HI c1 -- c2 return high nybble of TOS
+ head HI,2,HI,docode
+ ld a,c
+ and 0f0h
+ rrca
+ rrca
+ rrca
+ rrca
+ ld c,a
+ ld b,0
+ next
+
+;Z >HEX c1 -- c2 convert nybble to hex char
+ head TOHEX,4,>HEX,docode
+ ld a,c
+ sub 0ah
+ jr c,numeric
+ add a,7
+numeric: add a,3ah
+ ld c,a
+ next
+
+;Z .HH c -- print byte as 2 hex digits
+; DUP HI >HEX EMIT LO >HEX EMIT ;
+ head DOTHH,3,.HH,docolon
+ DW DUP,HI,TOHEX,EMIT,LO,TOHEX,EMIT,EXIT
+
+;Z .B a -- a+1 fetch & print byte, advancing
+; DUP C@ .HH 20 EMIT 1+ ;
+ head DOTB,2,.B,docolon
+ DW DUP,CFETCH,DOTHH,lit,20h,EMIT,ONEPLUS,EXIT
+
+;Z .A u -- print unsigned as 4 hex digits
+; DUP >< .HH .HH 20 EMIT ;
+ head DOTA,2,.A,docolon
+ DW DUP,SWAB,DOTHH,DOTHH,lit,20h,EMIT,EXIT
+
+;X DUMP addr u -- dump u locations at addr
+; 0 DO
+; I 15 AND 0= IF CR DUP .A THEN
+; .B
+; LOOP DROP ;
+ head DUMP,4,DUMP,docolon
+ DW LIT,0,XDO
+DUMP2: DW II,LIT,15,AND,ZEROEQUAL,qbranch,DUMP1
+ DW CR,DUP,DOTA
+DUMP1: DW DOTB,XLOOP,DUMP2,DROP,EXIT
+
+;Z ZQUIT -- endless dump for testing
+; 0 BEGIN 0D EMIT 0A EMIT DUP .A
+; .B .B .B .B .B .B .B .B
+; .B .B .B .B .B .B .B .B
+; AGAIN ;
+ head ZQUIT,5,ZQUIT,docolon
+ DW lit,0
+zquit1: DW lit,0dh,EMIT,lit,0ah,EMIT,DUP,DOTA
+ DW DOTB,DOTB,DOTB,DOTB,DOTB,DOTB,DOTB,DOTB
+ DW DOTB,DOTB,DOTB,DOTB,DOTB,DOTB,DOTB,DOTB
+ DW branch,zquit1
diff --git a/Source/HBIOS/Forth/camldump.azm b/Source/HBIOS/Forth/camldump.azm
new file mode 100644
index 00000000..7be431d5
--- /dev/null
+++ b/Source/HBIOS/Forth/camldump.azm
@@ -0,0 +1,7 @@
+;Z DUMP adr n -- +++TEMP+++
+; 1 UMAX 0 DO .B LOOP DROP ;
+ head DUMP,4,DUMP,docolon
+ DW LIT,1,UMAX,LIT,0,XDO
+DUMP1: DW DOTB,XLOOP,DUMP1
+ DW DROP,EXIT
+
diff --git a/Source/HBIOS/Forth/copying b/Source/HBIOS/Forth/copying
new file mode 100644
index 00000000..94a9ed02
--- /dev/null
+++ b/Source/HBIOS/Forth/copying
@@ -0,0 +1,674 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+
+ Copyright (C)
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ Copyright (C)
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+.
diff --git a/Source/HBIOS/Forth/glosshi.txt b/Source/HBIOS/Forth/glosshi.txt
new file mode 100644
index 00000000..0c83f8fa
--- /dev/null
+++ b/Source/HBIOS/Forth/glosshi.txt
@@ -0,0 +1,184 @@
+ TABLE 1. GLOSSARY OF "HIGH LEVEL" WORDS
+ (files CAMEL80D.AZM and CAMEL80H.AZM)
+
+NAME stack in -- stack out description
+
+ Guide to stack diagrams: R: = return stack,
+ c = 8-bit character, flag = boolean (0 or -1),
+ n = signed 16-bit, u = unsigned 16-bit,
+ d = signed 32-bit, ud = unsigned 32-bit,
+ +n = unsigned 15-bit, x = any cell value,
+ i*x j*x = any number of cell values,
+ a-addr = aligned adrs, c-addr = character adrs
+ p-addr = I/O port adrs, sys = system-specific.
+ Refer to ANS Forth document for more details.
+
+ ANS Forth Core words
+These are required words whose definitions are
+specified by the ANS Forth document.
+
+# ud1 -- ud2 convert 1 digit of output
+#S ud1 -- ud2 convert remaining digits
+#> ud1 -- c-addr u end conv., get string
+' -- xt find word in dictionary
+( -- skip input until )
+* n1 n2 -- n3 signed multiply
+*/ n1 n2 n3 -- n4 n1*n2/n3
+*/MOD n1 n2 n3 -- n4 n5 n1*n2/n3, rem & quot
++LOOP adrs -- L: 0 a1 a2 .. aN --
+, x -- append cell to dict
+/ n1 n2 -- n3 signed divide
+/MOD n1 n2 -- n3 n4 signed divide, rem & quot
+: -- begin a colon definition
+; end a colon definition
+<# -- begin numeric conversion
+>BODY xt -- a-addr adrs of param field
+>IN -- a-addr holds offset into TIB
+>NUMBER ud adr u -- ud' adr' u'
+ convert string to number
+2DROP x1 x2 -- drop 2 cells
+2DUP x1 x2 -- x1 x2 x1 x2 dup top 2 cells
+2OVER x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 per diag
+2SWAP x1 x2 x3 x4 -- x3 x4 x1 x2 per diagram
+2! x1 x2 a-addr -- store 2 cells
+2@ a-addr -- x1 x2 fetch 2 cells
+ABORT i*x -- R: j*x -- clear stack & QUIT
+ABORT" i*x 0 -- i*x R: j*x -- j*x print msg &
+ i*x x1 -- R: j*x -- abort,x1<>0
+ABS n1 -- +n2 absolute value
+ACCEPT c-addr +n -- +n' get line from terminal
+ALIGN -- align HERE
+ALIGNED addr -- a-addr align given addr
+ALLOT n -- allocate n bytes in dict
+BASE -- a-addr holds conversion radix
+BEGIN -- adrs target for backward branch
+BL -- char an ASCII space
+C, char -- append char to dict
+CELLS n1 -- n2 cells->adrs units
+CELL+ a-addr1 -- a-addr2 add cell size to adrs
+CHAR -- char parse ASCII character
+CHARS n1 -- n2 chars->adrs units
+CHAR+ c-addr1 -- c-addr2 add char size to adrs
+COUNT c-addr1 -- c-addr2 u counted->adr/len
+CR -- output newline
+CREATE -- create an empty definition
+DECIMAL -- set number base to decimal
+DEPTH -- +n number of items on stack
+DO -- adrs L: -- 0 start of DO..LOOP
+DOES> -- change action of latest def'n
+ELSE adrs1 -- adrs2 branch for IF..ELSE
+ENVIRONMENT? c-addr u -- false system query
+EVALUATE i*x c-addr u -- j*x interpret string
+FIND c-addr -- c-addr 0 ..if name not found
+ xt 1 ..if immediate
+ xt -1 ..if "normal"
+FM/MOD d1 n1 -- n2 n3 floored signed division
+HERE -- addr returns dictionary pointer
+HOLD char -- add char to output string
+IF -- adrs conditional forward branch
+IMMEDIATE -- make last def'n immediate
+LEAVE -- L: -- adrs exit DO..LOOP
+LITERAL x -- append numeric literal to dict.
+LOOP adrs -- L: 0 a1 a2 .. aN --
+MAX n1 n2 -- n3 signed maximum
+MIN n1 n2 -- n3 signed minimum
+MOD n1 n2 -- n3 signed remainder
+MOVE addr1 addr2 u -- smart move
+M* n1 n2 -- d signed 16*16->32 multiply
+POSTPONE -- postpone compile action of word
+QUIT -- R: i*x -- interpret from keyboard
+RECURSE -- recurse current definition
+REPEAT adrs1 adrs2 -- resolve WHILE loop
+SIGN n -- add minus sign if n<0
+SM/REM d1 n1 -- n2 n3 symmetric signed division
+SOURCE -- adr n current input buffer
+SPACE -- output a space
+SPACES n -- output n spaces
+STATE -- a-addr holds compiler state
+S" -- compile in-line string
+." -- compile string to print
+S>D n -- d single -> double precision
+THEN adrs -- resolve forward branch
+TYPE c-addr +n -- type line to terminal
+UNTIL adrs -- conditional backward branch
+U. u -- display u unsigned
+. n -- display n signed
+WHILE -- adrs branch for WHILE loop
+WORD char -- c-addr n parse word delim by char
+[ -- enter interpretive state
+[CHAR] -- compile character literal
+['] -- find word & compile as literal
+] -- enter compiling state
+
+ ANS Forth Extensions
+These are optional words whose definitions are
+specified by the ANS Forth document.
+
+.S -- print stack contents
+/STRING a u n -- a+n u-n trim string
+AGAIN adrs -- uncond'l backward branch
+COMPILE, xt -- append execution token
+DABS d1 -- +d2 absolute value, dbl.prec.
+DNEGATE d1 -- d2 negate, double precision
+HEX -- set number base to hex
+PAD -- a-addr user PAD buffer
+TIB -- a-addr Terminal Input Buffer
+WITHIN n1|u1 n2|u2 n3|u3 -- f test n2<=n1) -- run-time action of DOES>
+(S") -- c-addr u run-time code for S"
+,BRANCH xt -- append a branch instruction
+,CF adrs -- append a code field
+,DEST dest -- append a branch address
+,EXIT -- append hi-level EXIT action
+>COUNTED src n dst -- copy to counted str
+>DIGIT n -- c convert to 0..9A..Z
+>L x -- L: -- x move to Leave stack
+?ABORT f c-addr u -- abort & print msg
+?DNEGATE d1 n -- d2 negate d1 if n negative
+?NEGATE n1 n2 -- n3 negate n1 if n2 negative
+?NUMBER c-addr -- n -1 convert string->number
+ -- c-addr 0 if convert error
+?SIGN adr n -- adr' n' f get optional sign
+ advance adr/n if sign; return NZ if negative
+CELL -- n size of one cell
+COLD -- cold start Forth system
+COMPILE -- append inline execution token
+DIGIT? c -- n -1 ..if c is a valid digit
+ -- x 0 ..otherwise
+DP -- a-addr holds dictionary ptr
+ENDLOOP adrs xt -- L: 0 a1 a2 .. aN --
+HIDE -- "hide" latest definition
+HP -- a-addr HOLD pointer
+IMMED? nfa -- f fetch immediate flag
+INTERPRET i*x c-addr u -- j*x
+ interpret given buffer
+L0 -- a-addr bottom of Leave stack
+LATEST -- a-addr last word in dictionary
+LP -- a-addr Leave-stack pointer
+L> -- x L: x -- move from Leave stack
+NFA>CFA nfa -- cfa name adr -> code field
+NFA>LFA nfa -- lfa name adr -> link field
+R0 -- a-addr end of return stack
+REVEAL -- "reveal" latest definition
+S0 -- a-addr end of parameter stack
+TIBSIZE -- n size of TIB
+U0 -- a-addr current user area adrs
+UD* ud1 d2 -- ud3 32*16->32 multiply
+UD/MOD ud1 u2 -- u3 ud4 32/16->32 divide
+UINIT -- addr initial values for user area
+UMAX u1 u2 -- u unsigned maximum
+UMIN u1 u2 -- u unsigned minimum
+
diff --git a/Source/HBIOS/Forth/glosslo.txt b/Source/HBIOS/Forth/glosslo.txt
new file mode 100644
index 00000000..c46a5498
--- /dev/null
+++ b/Source/HBIOS/Forth/glosslo.txt
@@ -0,0 +1,112 @@
+ TABLE 1. GLOSSARY OF WORDS IN CAMEL80.AZM
+ Words which are (usually) written in CODE.
+
+NAME stack in -- stack out description
+
+ Guide to stack diagrams: R: = return stack,
+ c = 8-bit character, flag = boolean (0 or -1),
+ n = signed 16-bit, u = unsigned 16-bit,
+ d = signed 32-bit, ud = unsigned 32-bit,
+ +n = unsigned 15-bit, x = any cell value,
+ i*x j*x = any number of cell values,
+ a-addr = aligned adrs, c-addr = character adrs
+ p-addr = I/O port adrs, sys = system-specific.
+ Refer to ANS Forth document for more details.
+
+ ANS Forth Core words
+These are required words whose definitions are
+specified by the ANS Forth document.
+
+! x a-addr -- store cell in memory
++ n1/u1 n2/u2 -- n3/u3 add n1+n2
++! n/u a-addr -- add cell to memory
+- n1/u1 n2/u2 -- n3/u3 subtract n1-n2
+< n1 n2 -- flag test n1 n1 n2 -- flag test n1>n2, signed
+>R x -- R: -- x push to return stack
+?DUP x -- 0 | x x DUP if nonzero
+@ a-addr -- x fetch cell from memory
+0< n -- flag true if TOS negative
+0= n/u -- flag return true if TOS=0
+1+ n1/u1 -- n2/u2 add 1 to TOS
+1- n1/u1 -- n2/u2 subtract 1 from TOS
+2* x1 -- x2 arithmetic left shift
+2/ x1 -- x2 arithmetic right shift
+AND x1 x2 -- x3 logical AND
+CONSTANT n -- define a Forth constant
+C! c c-addr -- store char in memory
+C@ c-addr -- c fetch char from memory
+DROP x -- drop top of stack
+DUP x -- x x duplicate top of stack
+EMIT c -- output character to console
+EXECUTE i*x xt -- j*x execute Forth word 'xt'
+EXIT -- exit a colon definition
+FILL c-addr u c -- fill memory with char
+I -- n R: sys1 sys2 -- sys1 sys2
+ get the innermost loop index
+INVERT x1 -- x2 bitwise inversion
+J -- n R: 4*sys -- 4*sys
+ get the second loop index
+KEY -- c get character from keyboard
+LSHIFT x1 u -- x2 logical L shift u places
+NEGATE x1 -- x2 two's complement
+OR x1 x2 -- x3 logical OR
+OVER x1 x2 -- x1 x2 x1 per stack diagram
+ROT x1 x2 x3 -- x2 x3 x1 per stack diagram
+RSHIFT x1 u -- x2 logical R shift u places
+R> -- x R: x -- pop from return stack
+R@ -- x R: x -- x fetch from rtn stk
+SWAP x1 x2 -- x2 x1 swap top two items
+UM* u1 u2 -- ud unsigned 16x16->32 mult.
+UM/MOD ud u1 -- u2 u3 unsigned 32/16->16 div.
+UNLOOP -- R: sys1 sys2 -- drop loop parms
+U< u1 u2 -- flag test u1 x1 x2 -- flag test not equal
+BYE i*x -- return to CP/M
+CMOVE c-addr1 c-addr2 u -- move from bottom
+CMOVE> c-addr1 c-addr2 u -- move from top
+KEY? -- flag return true if char waiting
+M+ d1 n -- d2 add single to double
+NIP x1 x2 -- x2 per stack diagram
+TUCK x1 x2 -- x2 x1 x2 per stack diagram
+U> u1 u2 -- flag test u1>u2, unsigned
+
+ Private Extensions
+These are words which are unique to CamelForth.
+Many of these are necessary to implement ANS
+Forth words, but are not specified by the ANS
+document. Others are functions I find useful.
+
+(do) n1|u1 n2|u2 -- R: -- sys1 sys2
+ run-time code for DO
+(loop) R: sys1 sys2 -- | sys1 sys2
+ run-time code for LOOP
+(+loop) n -- R: sys1 sys2 -- | sys1 sys2
+ run-time code for +LOOP
+>< x1 -- x2 swap bytes
+?branch x -- branch if TOS zero
+BDOS DE C -- A call CP/M BDOS
+branch -- branch always
+lit -- x fetch inline literal to stack
+PC! c p-addr -- output char to port
+PC@ p-addr -- c input char from port
+RP! a-addr -- set return stack pointer
+RP@ -- a-addr get return stack pointer
+SCAN c-addr1 u1 c -- c-addr2 u2
+ find matching char
+SKIP c-addr1 u1 c -- c-addr2 u2
+ skip matching chars
+SP! a-addr -- set data stack pointer
+SP@ -- a-addr get data stack pointer
+S= c-addr1 c-addr2 u -- n string compare
+ n<0: s10: s1>s2
+USER n -- define user variable 'n'
+
\ No newline at end of file
diff --git a/Source/HBIOS/Forth/readme.z80 b/Source/HBIOS/Forth/readme.z80
index 8b137891..a4b64040 100644
--- a/Source/HBIOS/Forth/readme.z80
+++ b/Source/HBIOS/Forth/readme.z80
@@ -1 +1,166 @@
-
+ CAMELFORTH FOR THE Z80 - BETA TEST VERSION - 16 APRIL 1995
+ ==========================================================
+
+This is a BETA TEST version of CamelForth/80, an ANSI Standard Forth for
+the Zilog Z80 microprocessor and the CP/M operating system. This means
+that, although I have tested the bulk of this code for correct
+functioning, and have fixed several bugs, you may discover new bugs.
+I'd appreciate hearing of any such, either
+
+ by Internet: bj@camelforth.com
+
+I'll also answer questions and try to solve problems.
+
+ * * *
+
+As distributed, CamelForth will assemble to run under CP/M 2.x. It
+determines the highest available RAM location from CP/M, and places its
+data areas (stacks, user area, etc.) immediately below that. The
+CamelForth program resides in the bottom of the CP/M program area
+(100h), and any user definitions are added immediately after. CP/M's
+default command buffer at 80h is used for the Terminal Input Buffer.
+
+To start CamelForth under CP/M, type the command
+
+ CAMEL80 ...any Forth commands...
+
+CamelForth will execute the rest of the CP/M command line as a Forth
+statement, and then enter the Forth interpreter. To return to CP/M, use
+the command
+
+ BYE
+
+Note that CamelForth is CASE SENSITIVE, and all Forth words are in UPPER
+CASE.
+
+ MODIFICATION FOR STANDALONE USE
+
+CamelForth can be easily assembled for a standalone or embedded Z80.
+About 6K of PROM and 640 bytes of RAM are used by CamelForth, plus
+whatever additional PROM and RAM is needed by your program. You will
+probably need to provide the Z80 reset vector, e.g.
+
+ org 0
+ jp reset
+
+You must also add any required hardware initialization, and the Forth
+words KEY KEY? and EMIT for your hardware. You should modify the
+'reset' routine to use an equate for end of RAM, e.g.
+
+reset: ld hl,ramend ; end of available memory (EM)
+ dec h ; EM-100h
+ ld sp,hl ; = top of param stack
+ inc h ; EM
+ etc.
+
+If you are putting CamelForth in PROM, but want to have a Forth
+dictionary in RAM (so you can add new definitions), you'll have to
+change the 'enddict' equate (at the end of camel80.azm) to the your
+starting RAM address. Do NOT change the 'lastword' equate.
+
+The Terminal Input Buffer must be moved to a new location in RAM. The
+usual CamelForth usage is 80h bytes below the user area. TIB can be
+redefined as
+
+;X tib -- a-addr Terminal Input Buffer
+; HEX -80 USER TIB below user area
+ head TIB,3,TIB,douser
+ dw -80h
+
+You should also delete the line
+
+ DW LIT,80h,COUNT,INTERPRET
+
+from the routine COLD. This line causes the CP/M command "tail" to be
+executed as a Forth command...inapplicable in a standalone system.
+
+ * * *
+
+This program was written using the Z80MR macro assembler under CP/M.
+Z80MR is a freeware assembler, available from GEnie and several other
+CP/M archives. Assemble the CamelForth source files with the commands
+
+ z80mr camel80
+ load camel80
+
+Z80MR produces an Intel hex file camel80.hex, and LOAD generates the
+file camel80.com. (Note: do NOT use the version of Z80MR that directly
+outputs a .COM file; that version of the assembler has bugs.) For
+embedded applications you probably can skip the LOAD, since most PROM
+programmers, PROM emulators, and debug programs will accept Intel hex
+files.
+
+If you don't have CP/M, you can use the MYZ80 emulator on an IBM PC, or
+you can rewrite the source code for your Z80 macro assembler.
+
+There are TWO WAYS to write embedded programs in CamelForth:
+
+1. If you have CamelForth running on an embedded Z80, you can download
+Forth code directly to CamelForth. This lets you type new words from
+the keyboard, test them as they are defined, and re-define them to make
+changes. Or you can edit an ASCII text file, and use a program such as
+Procomm to send this file over the serial port to your Z80. It can take
+a few seconds to compile each line, so be sure to leave plenty of delay
+after the line. (I'm working on handshaking to improve this.) Also be
+sure that no line exceeds 80 characters.
+
+2. If you you want to burn your program into PROM, you can add your code
+to the file CAMEL80.ASM. (I recommend creating a separate file and
+using the *INCLUDE directive.) This requires you to convert your Forth
+code to assembler code. To show how this is done, every high-level
+Forth word in the file is shown with its equivalent Forth code in a
+comment. Be especially careful with control structures (IF..ELSE..THEN,
+BEGIN..UNTIL, DO..LOOP, and the like), and with the Forth word headers.
+Reassemble CAMEL80.AZM and burn a PROM (or download to a PROM emulator
+or debug monitor), then test. This is a much slower process, and is
+best saved for the final stage when you have a tested & debugged program
+that you want to put in PROM.
+
+Disk I/O is not yet supported under CP/M. However, CamelForth v1.2 will
+accept commands from a CP/M SUBMIT file using the XSUB utility. The
+SUBMIT file should contain the commands
+
+ XSUB
+ CAMEL80
+ ...Forth source code...
+
+This will run CamelForth/80 under XSUB, which will feed the rest of the
+file to CamelForth as terminal input. You can automatically return to
+CP/M by putting the CamelForth BYE command in the file. Then you can
+save the modified CamelForth image with the CP/M command
+
+ SAVE nn CAMELNEW.COM
+
+'nn' is the decimal number of pages occupied by the CamelForth
+dictionary. You can determine this value while in CamelForth with the
+statement
+
+ DECIMAL HERE 0 256 UM/MOD NIP .
+
+Unfortunately, at the moment there's no way to totally automate this as
+part of the SUBMIT file. And I'm reluctant to add SAVE to CamelForth
+when CP/M has a perfectly good SAVE command.
+
+ * * *
+
+--------------------------- LICENSE TERMS ------------------------------
+CamelForth for the Zilog Z80 Copyright 1994,1995 Bradford J. Rodriguez.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program. If not, see .
+
+Commercial inquiries should be directed to the author at
+115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
+or via email to bj@camelforth.com
+------------------------------------------------------------------------
+