From f2892e592762939c8777c4d797d2eafee00d0026 Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Sun, 4 Nov 2018 11:07:49 +0800
Subject: [PATCH 01/16] Create readme.z80
---
Source/HBIOS/Forth/readme.z80 | 1 +
1 file changed, 1 insertion(+)
create mode 100644 Source/HBIOS/Forth/readme.z80
diff --git a/Source/HBIOS/Forth/readme.z80 b/Source/HBIOS/Forth/readme.z80
new file mode 100644
index 00000000..8b137891
--- /dev/null
+++ b/Source/HBIOS/Forth/readme.z80
@@ -0,0 +1 @@
+
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 02/16] 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
+------------------------------------------------------------------------
+
From 22f30c06f7fe66d22d5d12bb902ffffe31c4e661 Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Sun, 4 Nov 2018 11:10:47 +0800
Subject: [PATCH 03/16] Delete camel80.prn
---
Source/HBIOS/Forth/camel80.prn | 4464 --------------------------------
1 file changed, 4464 deletions(-)
delete mode 100644 Source/HBIOS/Forth/camel80.prn
diff --git a/Source/HBIOS/Forth/camel80.prn b/Source/HBIOS/Forth/camel80.prn
deleted file mode 100644
index 5d3e9b2c..00000000
--- a/Source/HBIOS/Forth/camel80.prn
+++ /dev/null
@@ -1,4464 +0,0 @@
- 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
From 6703f3b74ca67052fb327b02b249edf5ea74d2c6 Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Sun, 4 Nov 2018 11:11:18 +0800
Subject: [PATCH 04/16] Delete camel80.bin
---
Source/HBIOS/Forth/camel80.bin | Bin 5632 -> 0 bytes
1 file changed, 0 insertions(+), 0 deletions(-)
delete mode 100644 Source/HBIOS/Forth/camel80.bin
diff --git a/Source/HBIOS/Forth/camel80.bin b/Source/HBIOS/Forth/camel80.bin
deleted file mode 100644
index 6afdcbc6a5d7b4f24e30f3ec5cd212b918c99c39..0000000000000000000000000000000000000000
GIT binary patch
literal 0
HcmV?d00001
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
From a97284c18d57aca1df39fc683bf3c431908fe9c8 Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Sun, 4 Nov 2018 11:11:32 +0800
Subject: [PATCH 05/16] Delete camel80.hex
---
Source/HBIOS/Forth/camel80.hex | 354 ---------------------------------
1 file changed, 354 deletions(-)
delete mode 100644 Source/HBIOS/Forth/camel80.hex
diff --git a/Source/HBIOS/Forth/camel80.hex b/Source/HBIOS/Forth/camel80.hex
deleted file mode 100644
index e7f60aa4..00000000
--- a/Source/HBIOS/Forth/camel80.hex
+++ /dev/null
@@ -1,354 +0,0 @@
-: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
From b5703e8177f7cf28feb65e4c2ba5f9f8024fc28e Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Sun, 4 Nov 2018 11:36:10 +0800
Subject: [PATCH 06/16] First build with Forth to ROM (still CP/M version)
---
Source/HBIOS/Build.ps1 | 7 +++++--
Source/HBIOS/imgpad0.asm | 2 +-
Source/HBIOS/romldr.asm | 1 +
Source/HBIOS/std.asm | 4 ++++
4 files changed, 11 insertions(+), 3 deletions(-)
diff --git a/Source/HBIOS/Build.ps1 b/Source/HBIOS/Build.ps1
index 716caf7d..f02989dc 100644
--- a/Source/HBIOS/Build.ps1
+++ b/Source/HBIOS/Build.ps1
@@ -119,7 +119,10 @@ Function Asm($Component, $Opt, $Architecture=$CPUType, $Output="${Component}.bin
$Cmd = "tasm -t${Architecture} -g3 ${Opt} ${Component}.asm ${Output} ${List}"
$Cmd | write-host
Invoke-Expression $Cmd | write-host
- if ($LASTEXITCODE -gt 0) {throw "TASM returned exit code $LASTEXITCODE"}
+ if ($LASTEXITCODE -gt 0)
+ {
+ throw "TASM returned exit code" + $LASTEXITCODE
+ }
}
# Function to concatenate two binary files.
@@ -191,7 +194,7 @@ Concat 'prefix.bin','zsys.bin' 'zsys.sys'
# Build 32K OS chunk containing the loader, debug monitor, and OS images
Concat 'romldr.bin', 'dbgmon.bin','cpm.bin','zsys.bin', 'eastaegg.bin', 'imgpad.bin' osimg.bin
-Concat 'nascom.bin', 'tastybasic.bin', 'imgpad0.bin' osimg1.bin
+Concat 'nascom.bin', 'tastybasic.bin', 'camel80.bin', 'imgpad0.bin' osimg1.bin
#
# Now the ROM disk image is created. This is done by starting with a
diff --git a/Source/HBIOS/imgpad0.asm b/Source/HBIOS/imgpad0.asm
index 31ef6b96..e2822918 100644
--- a/Source/HBIOS/imgpad0.asm
+++ b/Source/HBIOS/imgpad0.asm
@@ -1,6 +1,6 @@
#INCLUDE "std.asm"
;
-SLACK .EQU ($8000-BAS_SIZ-TBC_SIZ)
+SLACK .EQU ($8000-BAS_SIZ-TBC_SIZ-FTH_SIZ)
.FILL SLACK,00H
;
MON_STACK .EQU $
diff --git a/Source/HBIOS/romldr.asm b/Source/HBIOS/romldr.asm
index 175bc4fc..d3e6c624 100644
--- a/Source/HBIOS/romldr.asm
+++ b/Source/HBIOS/romldr.asm
@@ -19,6 +19,7 @@ EGGIMG .EQU $7A00 ;SIZE 0200 > 7A00-7C00
;
BASIMG .EQU $0000 ;SIZE 2000 > 0000-2000
TBCIMG .EQU $2000 ;SIZE 0900 > 2000-2900
+FTHIMG .EQU $2900 ;SIZE 1600 > 2900-3F00
;
INT_IM1 .EQU $FF00
;
diff --git a/Source/HBIOS/std.asm b/Source/HBIOS/std.asm
index 8b388074..519f30cb 100644
--- a/Source/HBIOS/std.asm
+++ b/Source/HBIOS/std.asm
@@ -382,6 +382,10 @@ EGG_LOC .EQU $0A00 ; EASTER EGG
EGG_SIZ .EQU $0200
EGG_END .EQU EGG_LOC + EGG_SIZ
+FTH_LOC .EQU $0A00 ; CAMEL FORTH
+FTH_SIZ .EQU $1600
+FTH_END .EQU FTH_LOC + FTH_SIZ
+
MON_DSKY .EQU MON_LOC + (0 * 3) ; MONITOR ENTRY (DSKY)
MON_SERIAL .EQU MON_LOC + (1 * 3) ; MONITOR ENTRY (SERIAL PORT)
;
From f77eedf4b41e847d5ab1e405ab79a156d4206210 Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Sun, 4 Nov 2018 11:38:05 +0800
Subject: [PATCH 07/16] Forth BIN file gets copied to HBIOS directory for
assembly into ROM
---
Source/HBIOS/Forth/Build.cmd | 2 ++
1 file changed, 2 insertions(+)
diff --git a/Source/HBIOS/Forth/Build.cmd b/Source/HBIOS/Forth/Build.cmd
index a332af02..1833c745 100644
--- a/Source/HBIOS/Forth/Build.cmd
+++ b/Source/HBIOS/Forth/Build.cmd
@@ -14,4 +14,6 @@ set ZXINCDIR=%TOOLS%/cpm/include/
zx z80mr camel80
zx MLOAD25 -camel80.bin=camel80.hex
+copy camel80.bin ..\
+
goto :eof
From 518478c793728f10cc9aea23401cc5509af48cab Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Sun, 4 Nov 2018 11:42:44 +0800
Subject: [PATCH 08/16] Fix some mangling I did t- returned to original
---
Source/HBIOS/Build.ps1 | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/Source/HBIOS/Build.ps1 b/Source/HBIOS/Build.ps1
index f02989dc..8bba4131 100644
--- a/Source/HBIOS/Build.ps1
+++ b/Source/HBIOS/Build.ps1
@@ -119,10 +119,7 @@ Function Asm($Component, $Opt, $Architecture=$CPUType, $Output="${Component}.bin
$Cmd = "tasm -t${Architecture} -g3 ${Opt} ${Component}.asm ${Output} ${List}"
$Cmd | write-host
Invoke-Expression $Cmd | write-host
- if ($LASTEXITCODE -gt 0)
- {
- throw "TASM returned exit code" + $LASTEXITCODE
- }
+ if ($LASTEXITCODE -gt 0) {throw "TASM returned exit code $LASTEXITCODE"}
}
# Function to concatenate two binary files.
From e95eb28fe68bc1d05d664134eb0c7089566f7aff Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Mon, 5 Nov 2018 13:31:13 +0800
Subject: [PATCH 09/16] First version with HBIOS Character IO (but not working)
---
Source/HBIOS/Forth/camel80.azm | 117 ++++++++++++++++++++------------
Source/HBIOS/Forth/camel80h.azm | 12 ++--
2 files changed, 80 insertions(+), 49 deletions(-)
diff --git a/Source/HBIOS/Forth/camel80.azm b/Source/HBIOS/Forth/camel80.azm
index 07ae6330..d094953d 100644
--- a/Source/HBIOS/Forth/camel80.azm
+++ b/Source/HBIOS/Forth/camel80.azm
@@ -1,3 +1,9 @@
+CIODEV_CONSOLE EQU 0D0h
+CIOOUT EQU 01h ; CHARACTER OUTPUT
+CIOIST EQU 02h
+CIOIN EQU 00h
+BID_BOOT EQU 00h
+HB_BNKCALL EQU 0fff9h
; Listing 2.
; ===============================================
@@ -109,8 +115,8 @@ nexthl MACRO
; Instead, we have the...
; CP/M ENTRY POINT
- org 100h
-reset: ld hl,(6h) ; BDOS address, rounded down
+ org 0A00h ; Execute address
+reset: ld hl,0FDFFh ; HBIOS address, rounded down
ld l,0 ; = end of avail.mem (EM)
dec h ; EM-100h
ld sp,hl ; = top of param stack
@@ -122,18 +128,19 @@ reset: ld hl,(6h) ; BDOS address, rounded down
push hl
pop iy ; = bottom of user area
ld de,1 ; do reset if COLD returns
+; jp tst
jp COLD ; enter top-level Forth word
; Memory map:
; 0080h Terminal Input Buffer, 128 bytes
-; 0100h Forth kernel = start of CP/M TPA
+; 0A00h Forth kernel = starts after ROMLDR
; ? 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
+; EM End of RAM = start of HBIOS
; See also the definitions of U0, S0, and R0
; in the "system variables & constants" area.
; A task w/o terminal input requires 200h bytes.
@@ -256,39 +263,69 @@ dodoes: ; -- a-addr
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
-
+ head EMIT,4,EMIT,docode
+ push AF
+ PUSH BC
+ PUSH DE
+ PUSH HL ; OUTPUT CHARACTER TO CONSOLE VIA HBIOS
+ LD E,C ; OUTPUT CHAR TO E
+ LD C,CIODEV_CONSOLE ; CONSOLE UNIT TO C
+ LD B,CIOOUT ; HBIOS FUNC: OUTPUT CHAR
+ RST 08 ; HBIOS OUTPUTS CHARACTER
+ POP HL
+ POP DE
+ POP BC
+ POP AF
+ pop BC
+ next
+;
;Z SAVEKEY -- addr temporary storage for KEY?
head savekey,7,SAVEKEY,dovar
- DW 0
+SVKY: DW 0
+
+DBG:
+ push AF
+ PUSH BC
+ PUSH DE
+ PUSH HL ; OUTPUT CHARACTER TO CONSOLE VIA HBIOS
+; LD E,'1' ; OUTPUT CHAR TO E
+ LD C,CIODEV_CONSOLE ; CONSOLE UNIT TO C
+ LD B,CIOOUT ; HBIOS FUNC: OUTPUT CHAR
+ RST 08 ; HBIOS OUTPUTS CHARACTER
+ POP HL
+ POP DE
+ POP BC
+ POP AF
+ ret
;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
+ head querykey,4,KEY?,docode
+; DW LIT,0FFH,LIT,06H,BDOS
+; DW DUP,SAVEKEY,CSTORE,EXIT
+ PUSH DE
+ PUSH HL ; GET CONSOLE INPUT STATUS VIA HBIOS
+ LD C,CIODEV_CONSOLE ; CONSOLE UNIT TO C
+ LD B,CIOIST ; HBIOS FUNC: INPUT STATUS
+ RST 08 ; HBIOS RETURNS STATUS IN A
+ LD BC,0000h
+ OR A
+ JR Z,key3
+ ; INPUT CHARACTER FROM CONSOLE VIA HBIOS
+ LD C,CIODEV_CONSOLE ; CONSOLE UNIT TO C
+ LD B,CIOIN ; HBIOS FUNC: INPUT CHAR
+ RST 08 ; HBIOS READS CHARACTDR
+ LD B,E
+ LD C,0
+key3: LD HL,SVKY
+ LD (HL),B
+ INC HL
+ LD (HL),C
+ POP HL ; RESTORE REGISTERS (AF IS OUTPUT)
+ POP DE
+ PUSH BC
+ next
;C KEY -- c get character from keyboard
; BEGIN SAVEKEY C@ 0= WHILE KEY? DROP REPEAT
@@ -301,20 +338,12 @@ KEY1: DW SAVEKEY,CFETCH,ZEROEQUAL,qbranch,KEY2
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
+ LD A,BID_BOOT ; BOOT BANK
+ LD HL,0 ; ADDRESS ZERO
+ CALL HB_BNKCALL ; DOES NOT RETURN
+ HALT
; STACK OPERATIONS ==============================
diff --git a/Source/HBIOS/Forth/camel80h.azm b/Source/HBIOS/Forth/camel80h.azm
index 5744c024..db393f9d 100644
--- a/Source/HBIOS/Forth/camel80h.azm
+++ b/Source/HBIOS/Forth/camel80h.azm
@@ -44,9 +44,11 @@
;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
-
+; head TIB,3,TIB,docon
+; dw 82h
+ head TIB,3,TIB,douser
+ dw -80h
+
;Z u0 -- a-addr current user area adrs
; 0 USER U0
head U0,2,U0,douser
@@ -677,7 +679,7 @@ INTER9: DW DROP,EXIT
head QUIT,4,QUIT,docolon
DW L0,LP,STORE
DW R0,RPSTORE,LIT,0,STATE,STORE
-QUIT1: DW TIB,DUP,TIBSIZE,CPMACCEPT,SPACE
+QUIT1: DW TIB,DUP,TIBSIZE,ACCEPT,SPACE ;CPMACCEPT
DW INTERPRET
DW STATE,FETCH,ZEROEQUAL,qbranch,QUIT2
DW CR,XSQUOTE
@@ -1016,7 +1018,7 @@ DOTS2: DW EXIT
; ABORT ;
head COLD,4,COLD,docolon
DW UINIT,U0,NINIT,CMOVE
- DW LIT,80h,COUNT,INTERPRET
+; DW LIT,80h,COUNT,INTERPRET
DW XSQUOTE
DB 35,'Z80 CamelForth v1.01 25 Jan 1995'
DB 0dh,0ah
From 9bc2cb5328a9d29e19257b9b3ba3caa1c855db1e Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Mon, 5 Nov 2018 14:43:38 +0800
Subject: [PATCH 10/16] CamelForth ROMWBW first working version
---
Source/HBIOS/Forth/camel80.azm | 47 +++++++++------------------------
Source/HBIOS/Forth/camel80h.azm | 2 +-
2 files changed, 13 insertions(+), 36 deletions(-)
diff --git a/Source/HBIOS/Forth/camel80.azm b/Source/HBIOS/Forth/camel80.azm
index d094953d..f8ee415a 100644
--- a/Source/HBIOS/Forth/camel80.azm
+++ b/Source/HBIOS/Forth/camel80.azm
@@ -1,7 +1,7 @@
CIODEV_CONSOLE EQU 0D0h
+CIOIN EQU 00h ; CHARACTER INPPUT
CIOOUT EQU 01h ; CHARACTER OUTPUT
-CIOIST EQU 02h
-CIOIN EQU 00h
+CIOIST EQU 02h ; CHARACTER INPUT STATUS
BID_BOOT EQU 00h
HB_BNKCALL EQU 0fff9h
@@ -51,6 +51,8 @@ HB_BNKCALL EQU 0fff9h
; for interpreter input; TIB at 82h.
; 02 Mar 95 v1.02 changed ALIGN to ALIGNED in
; S" (S"); changed ,BRANCH to ,XT in DO.
+; 05 Nov 18 v1.02 Initial ROMWBW HBIOS version.
+; b1ackmai1er difficultylevelhigh@gmail.com
; ===============================================
; Macros to define Forth headers
; HEAD label,length,name,action
@@ -128,11 +130,10 @@ reset: ld hl,0FDFFh ; HBIOS address, rounded down
push hl
pop iy ; = bottom of user area
ld de,1 ; do reset if COLD returns
-; jp tst
jp COLD ; enter top-level Forth word
; Memory map:
-; 0080h Terminal Input Buffer, 128 bytes
+; Terminal Input Buffer, 128 bytes
; 0A00h Forth kernel = starts after ROMLDR
; ? h Forth dictionary (user RAM)
; EM-200h User area, 128 bytes
@@ -266,8 +267,6 @@ dodoes: ; -- a-addr
;C EMIT c -- output character to console
head EMIT,4,EMIT,docode
- push AF
- PUSH BC
PUSH DE
PUSH HL ; OUTPUT CHARACTER TO CONSOLE VIA HBIOS
LD E,C ; OUTPUT CHAR TO E
@@ -276,62 +275,40 @@ dodoes: ; -- a-addr
RST 08 ; HBIOS OUTPUTS CHARACTER
POP HL
POP DE
- POP BC
- POP AF
- pop BC
+ pop BC ; PUT TOP OF STACK IN BC
next
;
;Z SAVEKEY -- addr temporary storage for KEY?
head savekey,7,SAVEKEY,dovar
SVKY: DW 0
-DBG:
- push AF
- PUSH BC
- PUSH DE
- PUSH HL ; OUTPUT CHARACTER TO CONSOLE VIA HBIOS
-; LD E,'1' ; OUTPUT CHAR TO E
- LD C,CIODEV_CONSOLE ; CONSOLE UNIT TO C
- LD B,CIOOUT ; HBIOS FUNC: OUTPUT CHAR
- RST 08 ; HBIOS OUTPUTS CHARACTER
- POP HL
- POP DE
- POP BC
- POP AF
- ret
-
;X KEY? -- f return true if char waiting
head querykey,4,KEY?,docode
-; DW LIT,0FFH,LIT,06H,BDOS
-; DW DUP,SAVEKEY,CSTORE,EXIT
+ PUSH BC ; SAVE TOP OF STACK
PUSH DE
PUSH HL ; GET CONSOLE INPUT STATUS VIA HBIOS
LD C,CIODEV_CONSOLE ; CONSOLE UNIT TO C
LD B,CIOIST ; HBIOS FUNC: INPUT STATUS
RST 08 ; HBIOS RETURNS STATUS IN A
- LD BC,0000h
+ LD B,A
OR A
- JR Z,key3
- ; INPUT CHARACTER FROM CONSOLE VIA HBIOS
+ JR Z,key3 ; INPUT CHARACTER FROM CONSOLE VIA HBIOS
LD C,CIODEV_CONSOLE ; CONSOLE UNIT TO C
LD B,CIOIN ; HBIOS FUNC: INPUT CHAR
RST 08 ; HBIOS READS CHARACTDR
LD B,E
- LD C,0
-key3: LD HL,SVKY
+key3: LD C,0
+ LD HL,SVKY
LD (HL),B
INC HL
LD (HL),C
- POP HL ; RESTORE REGISTERS (AF IS OUTPUT)
+ POP HL
POP DE
- PUSH BC
next
;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
diff --git a/Source/HBIOS/Forth/camel80h.azm b/Source/HBIOS/Forth/camel80h.azm
index db393f9d..90ed8559 100644
--- a/Source/HBIOS/Forth/camel80h.azm
+++ b/Source/HBIOS/Forth/camel80h.azm
@@ -1020,7 +1020,7 @@ DOTS2: DW EXIT
DW UINIT,U0,NINIT,CMOVE
; DW LIT,80h,COUNT,INTERPRET
DW XSQUOTE
- DB 35,'Z80 CamelForth v1.01 25 Jan 1995'
+ DB 54,'Z80 CamelForth v1.02 25 Jan 1995, ROMWBW 5 Nov 2018'
DB 0dh,0ah
DW TYPE,ABORT ; ABORT never returns
From 5f7f902ba195e94ced6682bf6affca87d3353943 Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Mon, 5 Nov 2018 16:31:07 +0800
Subject: [PATCH 11/16] CamelForth ROMWBW in OSIMG1
---
Source/HBIOS/Build.ps1 | 5 ++--
Source/HBIOS/imgpad.asm | 2 +-
Source/HBIOS/romldr.asm | 49 ++++++++++++++++++++++++++++++++-----
Source/HBIOS/std.asm | 2 +-
Source/HBIOS/tastybasic.asm | 2 +-
5 files changed, 48 insertions(+), 12 deletions(-)
diff --git a/Source/HBIOS/Build.ps1 b/Source/HBIOS/Build.ps1
index 8bba4131..23f3fe2a 100644
--- a/Source/HBIOS/Build.ps1
+++ b/Source/HBIOS/Build.ps1
@@ -190,9 +190,8 @@ Concat 'prefix.bin','cpm.bin' 'cpm.sys'
Concat 'prefix.bin','zsys.bin' 'zsys.sys'
# Build 32K OS chunk containing the loader, debug monitor, and OS images
-Concat 'romldr.bin', 'dbgmon.bin','cpm.bin','zsys.bin', 'eastaegg.bin', 'imgpad.bin' osimg.bin
-Concat 'nascom.bin', 'tastybasic.bin', 'camel80.bin', 'imgpad0.bin' osimg1.bin
-
+Concat 'romldr.bin', 'dbgmon.bin', 'cpm.bin', 'zsys.bin', 'eastaegg.bin', 'imgpad.bin' osimg.bin
+Concat 'camel80.bin', 'nascom.bin', 'tastybasic.bin', 'imgpad0.bin' osimg1.bin
#
# Now the ROM disk image is created. This is done by starting with a
# blank ROM disk image of the correct size, then cpmtools is used to
diff --git a/Source/HBIOS/imgpad.asm b/Source/HBIOS/imgpad.asm
index 3846a294..8ca47e5d 100644
--- a/Source/HBIOS/imgpad.asm
+++ b/Source/HBIOS/imgpad.asm
@@ -9,4 +9,4 @@ MON_STACK .EQU $
.ECHO SLACK
.ECHO " bytes.\n"
- .END
\ No newline at end of file
+ .END
diff --git a/Source/HBIOS/romldr.asm b/Source/HBIOS/romldr.asm
index d3e6c624..ea01c3d9 100644
--- a/Source/HBIOS/romldr.asm
+++ b/Source/HBIOS/romldr.asm
@@ -17,9 +17,9 @@ EGGIMG .EQU $7A00 ;SIZE 0200 > 7A00-7C00
;
; osimg1.bin
;
-BASIMG .EQU $0000 ;SIZE 2000 > 0000-2000
-TBCIMG .EQU $2000 ;SIZE 0900 > 2000-2900
-FTHIMG .EQU $2900 ;SIZE 1600 > 2900-3F00
+FTHIMG .EQU $0000 ;SIZE 1700 > 0000-1700
+BASIMG .EQU $1700 ;SIZE 2000 > 1700-3700
+TBCIMG .EQU $3700 ;SIZE 0900 > 3700-4000
;
INT_IM1 .EQU $FF00
;
@@ -164,6 +164,8 @@ DB_BOOTLOOP:
JP Z,GOCPM
CP 'E' ; CP/M BOOT FROM ROM
JP Z,GOEASTA
+ CP 'F' ; FORTH
+ JP Z,GOFORTH
CP 'M' ; MONITOR
JP Z,GOMONSER
; CP 'L' ; LIST DRIVES
@@ -228,6 +230,8 @@ DB_DSKYEND:
JP Z,GOCPM
CP 'E' ; CP/M BOOT FROM ROM
JP Z,GOEASTA
+ CP 'F' ; FORTH
+ JP Z,GOFORTH
CP 'M' ; MONITOR
JP Z,GOMONSER
; CP 'L' ; LIST DRIVES
@@ -297,12 +301,12 @@ GOEASTA:
LD BC,EGG_SIZ ; BC := BASIC SIZE
LDIR ; COPY BASIC CODE TO EXEC ADDRESS
POP HL ; RECOVER ENTRY ADDRESS
- JR CHAIN ; AND CHAIN TO IT
+ JP CHAIN ; AND CHAIN TO IT
GOTBAS:
LD DE,STR_BOOTTBC ; DE POINTS TO MESSAGE
CALL WRITESTR ; WRITE IT TO CONSOLE
- ; COPY BASIC FROM BASIC FROM OSIMG0 IN ROM BANK TO THIS RAM BANKS
+ ; COPY BASIC FROM OSIMG0 IN ROM BANK TO THIS RAM BANKS
LD B,BF_SYSSETCPY ; HBIOS FUNC: SETUP BANK COPY
LD D,BID_USR ; D = DEST BANK = USER BANK
LD E,BID_OSIMG ; E = SRC BANK = BIOS BANK
@@ -330,6 +334,38 @@ GOTBAS:
; LDIR ; COPY BASIC CODE TO EXEC ADDRESS
; POP HL ; RECOVER ENTRY ADDRESS
; JR CHAIN ; AND CHAIN TO IT
+
+GOFORTH:
+ LD DE,STR_BOOTFTH ; DE POINTS TO MESSAGE
+ CALL WRITESTR ; WRITE IT TO CONSOLE
+ ; COPY FORTH FROM OSIMG0 IN ROM BANK TO THIS RAM BANKS
+ LD B,BF_SYSSETCPY ; HBIOS FUNC: SETUP BANK COPY
+ LD D,BID_USR ; D = DEST BANK = USER BANK
+ LD E,BID_OSIMG ; E = SRC BANK = BIOS BANK
+ LD HL,FTH_SIZ ; HL = COPY LEN = 1 PAGE = 256 BYTES
+ RST 08 ; DO IT
+ LD DE,STR_LOADING
+ CALL WRITESTR ; WRITE IT TO CONSOLE
+ LD B,BF_SYSBNKCPY ; HBIOS FUNC: PERFORM BANK COPY
+ LD HL,FTHIMG ; COPY FROM
+ LD DE,FTH_LOC ; COPY TO
+ RST 08 ; DO IT
+ LD DE,STR_LAUNCH
+ CALL WRITESTR
+ LD HL,FTH_LOC
+ JP CHAIN
+
+; LD HL,FTH_LOC ; FIRST BANK CODE
+; PUSH HL
+; LD DE,STR_BOOTFTH ; DE POINTS TO MESSAGE
+; CALL WRITESTR ; WRITE IT TO CONSOLE
+; ; COPY IMAGE TO EXEC ADDRESS
+; LD HL,FTHIMG ; HL := BASIC IMAGE ADDRESS
+; LD DE,FTH_LOC ; DE := BASIC EXEC ADDRESS
+; LD BC,FTH_SIZ ; BC := BASIC SIZE
+; LDIR ; COPY BASIC CODE TO EXEC ADDRESS
+; POP HL ; RECOVER ENTRY ADDRESS
+; JR CHAIN ; AND CHAIN TO IT
GOMONSER:
LD HL,MON_SERIAL ; MONITOR SERIAL INTERFACE ENTRY ADDRESS TO HL
@@ -852,6 +888,7 @@ STR_BOOTDISK .DB "BOOT FROM DISK\r\n$"
STR_BOOTDISK1 .DB "\r\nReading disk information...$"
STR_BOOTMON .DB "START MONITOR FROM ROM\r\n$"
STR_BOOTBAS .DB "START BASIC FROM ROM\r\n$"
+STR_BOOTFTH .DB "START FORTH FROM ROM\r\n$"
STR_BOOTTBC .DB "START TASTYBASIC FROM ROM\r\n$"
STR_BOOTCPM .DB "BOOT CPM FROM ROM\r\n$"
STR_BOOTZSYS .DB "BOOT ZSYSTEM FROM ROM\r\n$"
@@ -875,7 +912,7 @@ STR_LAUNCH .DB "\r\nLaunching ...$"
;
STR_BANNER .DB "\r\n", PLATFORM_NAME, " Boot Loader$"
STR_BOOTMENU .DB "\r\n"
- .DB "\r\nROM Boot: (B)ASIC, (C)PM, (M)onitor, (T)ASTYBASIC, (Z)System.\r\n"
+ .DB "\r\nROM Boot: (B)ASIC, (C)PM, (F)ORTH, (M)onitor, (T)ASTYBASIC, (Z)System.\r\n"
.DB "Disk Boot: $"
;
.IF DSKYENABLE
diff --git a/Source/HBIOS/std.asm b/Source/HBIOS/std.asm
index 519f30cb..1cd38747 100644
--- a/Source/HBIOS/std.asm
+++ b/Source/HBIOS/std.asm
@@ -383,7 +383,7 @@ EGG_SIZ .EQU $0200
EGG_END .EQU EGG_LOC + EGG_SIZ
FTH_LOC .EQU $0A00 ; CAMEL FORTH
-FTH_SIZ .EQU $1600
+FTH_SIZ .EQU $1700
FTH_END .EQU FTH_LOC + FTH_SIZ
MON_DSKY .EQU MON_LOC + (0 * 3) ; MONITOR ENTRY (DSKY)
diff --git a/Source/HBIOS/tastybasic.asm b/Source/HBIOS/tastybasic.asm
index 07e3516a..b38b87e2 100644
--- a/Source/HBIOS/tastybasic.asm
+++ b/Source/HBIOS/tastybasic.asm
@@ -1539,7 +1539,7 @@ chkio:
POP HL
POP DE
POP BC
- ret z ; no, return
+ RET Z ; no, return
PUSH BC
PUSH DE
PUSH HL
From 9fad7db460c1da017aa91fb9b0bd7a52ecd0123f Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Mon, 5 Nov 2018 16:33:58 +0800
Subject: [PATCH 12/16] CamelForth ROMWBW updated to finish on page ending
---
Source/HBIOS/Forth/camel80.azm | 7 +++++++
1 file changed, 7 insertions(+)
diff --git a/Source/HBIOS/Forth/camel80.azm b/Source/HBIOS/Forth/camel80.azm
index f8ee415a..e9c97241 100644
--- a/Source/HBIOS/Forth/camel80.azm
+++ b/Source/HBIOS/Forth/camel80.azm
@@ -4,6 +4,7 @@ CIOOUT EQU 01h ; CHARACTER OUTPUT
CIOIST EQU 02h ; CHARACTER INPUT STATUS
BID_BOOT EQU 00h
HB_BNKCALL EQU 0fff9h
+FTH_SIZ EQU 1700h
; Listing 2.
; ===============================================
@@ -1045,5 +1046,11 @@ snext: next
*INCLUDE camel80h.azm ; High Level words
lastword EQU link ; nfa of last word in dict.
enddict EQU $ ; user's code starts here
+
+ ; force padding to page boundary
+
+ ds (FTH_SIZ-(enddict-reset)-1)
+ nop
+
END
From 0838624a79feab2361daa67a42ea59f011cec53a Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Mon, 5 Nov 2018 16:51:06 +0800
Subject: [PATCH 13/16] Assembler for Camel Forth
---
Tools/cpm/bin/Z80MR.COM | Bin 0 -> 14336 bytes
1 file changed, 0 insertions(+), 0 deletions(-)
create mode 100644 Tools/cpm/bin/Z80MR.COM
diff --git a/Tools/cpm/bin/Z80MR.COM b/Tools/cpm/bin/Z80MR.COM
new file mode 100644
index 0000000000000000000000000000000000000000..0bdda14d84493edbdc214f536a50275b23098c5e
GIT binary patch
literal 14336
zcmeHu4RjM%mS)-dvjmncgpDm*s7fWvAcHJRvH+PV$d>#=Y|F7t2S`rnp6xW7&W{P4
zZsTAZGuZ%>)1eb4-OQZH=?>}6IU&>O2?-hHha|QN6PKFmASY&tLuT5`$lZyXBxVC7
z{FL{5uVh1JvL|QG*`3`zo06$_->rM^yZ63V_q}&tQN^gZI~Y^8A&XwTtTUP=Fgo);2a)|9=+FEA?0zyIR=*>8??Z!#Js4I}dXGMjv5{y&Aq
zpg&vem;TAv&&#=qqw_-sz@q66Myt2THz!}u?dHvz#OQpHdn!*lI$yXs*O&(Z^2{Lj
zDn&4iF+YP?nolTzFbf*SSeU_{%#a1Ev!#Rc#b6*?E*_B=5rEcLWJ^{5pW82}RSbL}
zRjQ?So%AbBaHBe&G^n^ny}w`1O5CjCR0h*tRaOoe9j2`+sUb)DR3%07q{kf?4APfn
zuIJqLEzaN}_oT|Z)hWqk!8&XF*zIagQU$|$sazkdC3n*Z;T8Tt&u(1lX=!J_6K!X!
z++LPt>zkURY?asNuMVtO$>thz4a~p4{|OuG!No?~+hgrZI+n8Gj*e(cZSw}UF4of4
z9PNxkFvl=@{S_s5TE)ts#AJCgWRB~EdArno;ok{+|XY37sp>eR%zR*iAk+TF9j
z%xe;h)nF6msihwpq}>J5WXXZeUEYmq@3hWar?*G+_IkZNtoNRE+S5+^AD#A(oFc=0cdG08R^I+gb?CE$UXvy?<2|T`CR46osx9#mP74j5Iy5$X;%W6z
zis&;XJfvnACU{W28kC68$}}eXa2>!qwafu;lU{1lior&Gd}NHgA#FJ+QMya(t+mo(wN<1vA9`sEy`%-{
ziZe7L#_H=a{2$fET2Zi%X_*is0v(*z#Smg9;|2f8u%p3-u>E^8h$X0n*@7N&yP
z25+&6vzW}55;>SSt(8{!PKC!+I$1rc(yhibvss%XnRK!{aY4)3O(C|M$Iq-)p#nVh
zNN!T6gIjb&8F5UK@>ATj&M!iiRNxz=u@{u9d?HbfT+L0jCZjD&%UIq_H0sQJZo;p-
zlmE^H@%=}qG1T=uFSvDDhC8p526eI}c~A$JKcwsCWqqPc7t+1Zpx!RGjo)^|MWfBLxf0!X}Ig(^`G73B!bpmE?&W*IPw>M?w|Jzsm7$&Jq^a)X)
zqLy-51`N7S^ay+J>H8;ji9hItt9m~c8W;5eW|J`+O9X20H`|{cbG>H>eg5m@9fo1k
zC4)9+Y}jZ4yXlm{xDaK0D3y#ELY4)>dIL9rxUEU}4MT8j8q~%86TJOB16;^4Y5-ie
z0es40i~DCoAj}6g@`08E-iwCdJj1Cq`8FrlSVo75$iL
zfT2yNjCok+G_|&^>r|%CSX;DJnfWluG3wz9-`f9e|9?CFzkUDzC-IL=2B87h*}P|t
zEzC1%^QY6r-3U}?^T-^4x)R{hdBy?+IE1qJh^aCU5hzwm*G0FrH+4qm;!Q~OM)HF5
z4f4js#ynIm8NH)5@@`Rp2MvL(EYB
zHva!#WH5|8K|t|6A{W
zCWJ05eCF6~1*R2+nJHvpA)P{26e?3lVc`u^$kqY`ptkm=)=u`{%pki9=mui^$pXwE
z!2++Ukj@~5g_#+|Rv2jG1MS%V9qj>XaDjws9i<>Dx*vd2kT$Ffh8
zvZ)>=Zn*APOcO6GyVXiEFD%<_jf6YHEc?DSQcDO>Qee?ycY)z
zaWV2J?J@S%MXli$81l2yR!Wd-jkQBfcD+@}AU#vs(H4f>d8M6Aoya<^FJ6acV5f&728`Xa4k`v4U3lA*K
zU6GvCv5QVI%?%ax$1TY>ipI=ow0fqbKR$8!#iA6Fi02O#2~QMVu*lBjYegl~KHmh^
zHjWJ~12X%+)_!Ow!oR&Q6R~h0akE+R9|5_9MKYE^|B65spKZUKgvXpxrLH}P+$KcpIZ
zfZu{-#*@X6FkyewBJt(iV5VvNQA=Qe52A_$^ANckcS$LW(j5GZzJvw5{jDOTl_1gB
zhEoPha-$`Fd51;Tj~}xjHT6r_mNZzTmo37_#bZ-wdQsMKRoeJFya{NJD_IN$zU1gc*mz{}^i+PAig?L3Cq=i%!^%bqdHzhV%GA2ww
zZ|GG4y~K0_Nc#C#lKU+2!~k0OxEP&$`4J4L@kglOeU?z}0&~c)zq
zICuUC@N=n`1}ySlwrCQ=#Eb{{`4+i6`I!YBLq>KAIYREVTr+~CsxWRbL;9J|oTovO
zU4jn#j9|(W;}#0@{m4CaSM($C)GfMpAWJ?nOo#r^$S{ro^h3hp62v{zLfVaqdrCl)
z9wJF>?u(gX$S`kzEzw-k^Ez%>U(Dcv9*0IC(&I>J3hyVfhggTAcc-@TThUEqu1E(5
z{HsBFbhO%!#r~?Yi9yqoC73C44N7!~wX@OnZSB#HjwYl^TcaJF(Fofaiy`?OZCl>a
z8Lqp9jp00@eO)WEAL-#Syfvwz3DNTAAj#dIDM9XqfyeEG7JI_t>hqJAjv5Db$Oy%s
zaHT{#X_eaDG!Hk}6F>H;bFla2L|G}9l}St^8BK!1L_a}c;swC@j6MIVo
zjL1DxD*e%m;hyPYK*-tuFi-jyZ_ww%+y0qzM7r#Ab^D0{{TJ2US7)4)?6C_@+Ua=J
zo-h3-9@Tldw0o9(qSQDe7{a!6dt8`syuks`D${rb$%|q8IvA!5|cuV&~FW8ky|znOybGCR$>}oj;t?D
z;g66!`4smntCA=ek>(0FL|?U%JIfxiGR7?7b*nKO!s92dAk0fvM2X|p2Z*=mY(N4j
z1k(4wN)+1dP$JM7>jCfIyS<0p)a$v6<*YMToTt6dxj`X(W~Es5V&P9#Zi6GhrX|PX
zi9kLPMTDH;6(Qw|6$Hk}6{nFIn?l007{;YUi_AfuTm!8zl0;WT4}bDF9-=1|I3og<
zj;y{Tg9uRQ(>i^Is_)2&FP$TJm+JL>uMYOUG6%+D@?zmRE4J_7}E_61g(D!zKp@`w^9pwLc(&zcTr^
zHcSVQ2SH{G0O^pe4}x%VllWVkaHq}9NWZnAHex>I!MW5?+bP{rTrYQt(sRp$&$=-w
zI&70`5)Ke8OI)>?fs=CCQ!7c2g*EV@^07hrH2GEDVp(WuAFLQ&T
z8X}K~2(n)hp(Y|!5OJI(+)vUrDR&sT^bQuspg04K3HPuV4uB3#=3&qqnc#EopLGTQ
z-u>j}ii+Onum0KDg9m?h_O4F$vo`_gONR!$&$^wA{W*6pdQVXX<8i_OH1BRKNW46MX19N!;!fp5Ubimj_>TOKR@;8fXmm
zNj6!)5i#F`(TdDm8zFp%Cr;90*it8np$~{Zb~}g!co7o9M8b@HrcLm(c8V
zD4u|b(eDx2((U$fhYdy?cY#Hy<}*$oAnj16P5$ANj2UnQwWDwH?IXmnT-(EQYQt1?
z%u8<2TyeUNxcer*I6}16Jp+MVgp`OExVh%X|Cx&cy$k5j?})poX}Dhq4Fe}t^V7$*
z8S&H=_u3VM-XtaTANSfx?`C{O3_5JT(I9yX`~!ms4%7}Cq!LbQu+rf1E%J}ayAM-$
zIz*gH-FI5qFgQ`uLqI9F%h0fcnD
zzCRs5_5?q{_mlVuF--8>E$41$T<3Ot=(^^j(L9SWF&tC%A$JXPC*wU=cdmo6pWF7K
z{hA#?mi9Bo4Ag=;*Hu+Im`!}2qU$pjWIR^QQ{At3ae1djF8#&(ZrepvfeV
z=3a6Of8f*HAvZbn+Te)wPv#wtkvPZO`y68v(iTUEJ($dP?AUl)NOdq_050S?m?&^8
zEWk+Y$;+F}OLH3?4|nzcp4nVK0h*-8@dDnoNn1E3wU+IWKF*Q;i!w-CWsDvX~F%n6bmxbHm9L}R`B;$
zm*kYJWtdyvvAW)I?%A{J_)qXr2fpvXOd^+wPy#Sy9v=WYr1f?=(e9i^${~0#WF=ox
z4EMwnub1^*2zFtPKUgN`j~*=BRLEe~ZU}C5zLGdt=Gx*cCX?rbM^V}F25yk#>T)`n
z;^}T!=cfmfUzUM{w3>z1deH2&cbhZw#JyOS67x@t78?Un$=&CotmRD5tpPHJqA>Oamlk;7E`m89K^>kG=BKfec
zd$b(O4C%S@kuj+K-+iR%#J%NY6kt!+6F$K3KZObr*gG6$KTJisp(@
z{5CIp?km4=q%PRlysWmaG8*xRYckbH6xHgvYGX61fw^i&8>%ZvHIm_7H4B5WYOVq{
z?_32;KBdyMo-`MUc;>3$ibOJec-pic)eI-9;EY6Oc{dQ=`Z?YW%fMSd$Gc%!(*{&$
zc{dQ=dcs>*S6}I?uc>Q`K=m-{ZIO0BwFGJ+s44`iA3vyXtS0A
z#6ATg#wn1ZZU&~!D=@JbP*Y{SuO^CnZB2B2a7jno(q+V-z-4Nb|He9zq140m%fj{L
zl`9EtBue>+6!>RVO=GyZvvNhC2B#ZDKOY5%ehNhNQy@jZ3{3S?V4@#^s7t~Gp!O4p
zy2MKWit^U1Z3`}GY+hO!T}8pB^-Iwwvy}}?iNdRDnj^s_wRKCE!EF?dL}gtlM3+Fw8h$j;rhz@
zDhk2%bqYjAu>z6)RUoBrGcfH}!0S31seoz)BoZ2+@2CE65+{XwuszmR7B}x
zy5+hj5nmp1V#h?5*U9&m%lG3(R@P4;EAq)xCoVX##!?OT{RWG*Ub?G_kF3U;j^uz^
zqS$2FpLJX0B?+V399jc0lF^Or=h6|
z-4ng9B|`4L*OT?+5jK<0lCmMQ0Ti`)!$@pxzaTB~PB&nVJm%g$H2liw1MYOgu&~Z;
zPq@89?x6{?Q}_9x57{+}L%|{UE6M%t(Vgz$bOt%>O1RU&Q#LY(EA|seu|JD|xbSsk
zVw|KjTqUG5YqPny2gwL`@|ruw)m8StnmF$^^Ywf`|AQ_uuH8Ap;}ZVGJ!U5Mu0Td9
zadRc;%_z8gE5}SepH^*T`s2w^rRBF+IHPMyD^rJ)fl9)-uyQCPE0xmj6z|Bo>T#+5
zx~fw3MpcD+!n0icvB#-dSaqk?UUif14o^t;BhPBxZV%HM>tsPo24j}Z(-MoYs*$RW
z#&%X!@9Ai4W>szv8B|~;qY2z({AfK@(OX#-avJdAB}6roVz*}7RQy3wzvON2Df1YK7=J
zjUt7xNDo&HrH3bmw#P4j;MsmSxyLBQkCqj!W)OX&{Z{yz)pi!u*OSJ;PB*CxK<=R
zK_Tf=C#}S0u_$BMB|!#tG7N!ySjI5h;}@>3@%6lre5q<)v2dtrIz5E?Fcy>w|giiX07d~I(8#B$!=*KSvfem$18hAn|#6^FJ3@wVat=7
zyk!myy1TlBTL`W^xy~z^gS)*qUEbyO?)D;rpt2g!^|)ied#FkLoMv|&$&{1E9o9E$wX}s+fIg1U+W2D#2A`Llz#
zS$0x(oRm57Em5)GB7gVvDHhq>$73PpZyFFf|ItU%#Er?lK7`4Gv=T!_zE#2OqnKKy
za*9?WsFXmN6W6f7_xYeO(#S|Zdrr&QCz0AS3y%}8XHYpO%{1XB{Q3r@Vf=*elukCB
zmh(?4`9QPq>W$A&8VzGp$XFKVCO-0|%)ELv&YOpzV737_Q)YQL$*kK+jv&Z4ccbq$SdOSC1{z5$01L>$?A(dS7m=4U*xaKoW>nV`SG;N@O
zk!hkOo5vvHk}IES-AI8VMk(212J<$#EKFOB0;Now(u9>!1hb17tU<_SV;l;wh|Wyk
ze5)4zR4qv>O}UJe&PtrAc4hD5)6$Y)O1fzk;IvDlbM~1Sb+LW^KD0(O
zkRPSPh4PbDh%G4X1>{kHArrul15=!uS@q@Akl23L_rA~GwRLOPRu+Hvcd^k}Ju}Q*
zm|68@q(yo%h^F$=(qp?*Q{TNC8*1}|FC|_h$_s~AlBfH5B1uoq(jLoFlO1?qhCsvu
z@_$?~E@%cSBc+Q`(zwyzgCNfiGksnmo
z>3w>0->
Date: Mon, 5 Nov 2018 16:53:18 +0800
Subject: [PATCH 14/16] Update to build CamelForth
---
Source/HBIOS/Build.cmd | 5 +++++
1 file changed, 5 insertions(+)
diff --git a/Source/HBIOS/Build.cmd b/Source/HBIOS/Build.cmd
index 52660c54..d315afa8 100644
--- a/Source/HBIOS/Build.cmd
+++ b/Source/HBIOS/Build.cmd
@@ -1,4 +1,9 @@
@echo off
+
+set TOOLS=../../Tools
+
+setlocal & cd .\Forth && call Build || exit /b 1 & endlocal
+
setlocal
PowerShell .\Build.ps1 %*
From 42cf223f4e9db16c11aa6999399f12feb7710120 Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Tue, 6 Nov 2018 16:01:14 +0800
Subject: [PATCH 15/16] Unified Menu structure for romldr to ease intergration
of ROMs
---
Source/HBIOS/romldr.asm | 391 ++++++++++++++++------------------------
1 file changed, 156 insertions(+), 235 deletions(-)
diff --git a/Source/HBIOS/romldr.asm b/Source/HBIOS/romldr.asm
index ea01c3d9..fda7d702 100644
--- a/Source/HBIOS/romldr.asm
+++ b/Source/HBIOS/romldr.asm
@@ -7,23 +7,8 @@
;
#INCLUDE "std.asm"
;
-; osimg.bin
-;
-;LDRIMG .EQU $0000 ;SIZE 0A00 > 0000-0A00
-MONIMG .EQU $0A00 ;SIZE 1000 > 0A00-1A00
-CPMIMG .EQU $1A00 ;SIZE 3000 > 1A00-4A00
-ZSYSIMG .EQU $4A00 ;SIZE 3000 > 4A00-7A00
-EGGIMG .EQU $7A00 ;SIZE 0200 > 7A00-7C00
-;
-; osimg1.bin
-;
-FTHIMG .EQU $0000 ;SIZE 1700 > 0000-1700
-BASIMG .EQU $1700 ;SIZE 2000 > 1700-3700
-TBCIMG .EQU $3700 ;SIZE 0900 > 3700-4000
-;
INT_IM1 .EQU $FF00
;
-
.ORG 0
;
;==================================================================================================
@@ -134,52 +119,86 @@ INT_IM1 .EQU $FF00
;________________________________________________________________________________________________________________________________
;
DOBOOTMENU:
-; CALL NEWLINE
- LD DE,STR_BOOTMENU
- CALL WRITESTR
- CALL PRTALL
- CALL PC_COLON
-
+;
#IF (DSKYENABLE)
- LD HL,BOOT ; POINT TO BOOT MESSAGE
- CALL SEGDISPLAY ; DISPLAY MESSAGE
+ LD HL,BOOT ; POINT TO BOOT MESSAGE
+ CALL SEGDISPLAY ; DISPLAY MESSAGE
#ENDIF
#IF (BOOTTYPE == BT_AUTO)
- LD BC,100 * BOOT_TIMEOUT
- LD (BL_TIMEOUT),BC
+ LD BC,100 * BOOT_TIMEOUT
+ LD (BL_TIMEOUT),BC
#ENDIF
-DB_BOOTLOOP:
-;
-; CHECK FOR CONSOLE BOOT KEYPRESS
-;
- CALL CST
- OR A
- JP Z,DB_CONEND
- CALL CINUC
- CP 'B' ; NASCOM BASIC
- JP Z,GOBASIC
- CP 'C' ; CP/M BOOT FROM ROM
- JP Z,GOCPM
- CP 'E' ; CP/M BOOT FROM ROM
- JP Z,GOEASTA
- CP 'F' ; FORTH
- JP Z,GOFORTH
- CP 'M' ; MONITOR
- JP Z,GOMONSER
-; CP 'L' ; LIST DRIVES
-; JP Z,GOLIST
- CP 'T' ; TASTY BASIC
- JP Z,GOTBAS
- CP 'Z' ; ZSYSTEM BOOT FROM ROM
- JP Z,GOZSYS
- CP '0' ; 0-9, DISK DEVICE
- JP C,DB_INVALID
- CP '9' + 1
- JP NC,DB_INVALID
- SUB '0'
- JP GOBOOTDISK
+DB_BOOTLOOP: ; OUTPUT A '$' TERMINATED MENU TEXT WITH HIGHLIGHT
+ LD B,MENU_N
+ LD DE,MENU_S
+ LD HL,MENU_V
+MENU_L: PUSH DE
+WRITE_M:PUSH BC
+ PUSH HL
+ PUSH DE
+ POP HL
+ LD BC,10
+ ADD HL,BC ; HL POINTS TO MENU KEY
+WRITEM1:LD A,(DE)
+ CP '$' ; TEST FOR STRING TERMINATOR
+ JP Z,WRITEM2
+ CP (HL)
+ JR NZ,WRITEM3
+ LD A,'('
+ CALL COUT
+ LD A,(DE)
+ CALL COUT
+ LD A,')'
+WRITEM3:CALL COUT
+ INC DE
+ JR WRITEM1
+WRITEM2:POP HL
+ POP BC
+
+ POP DE
+ EX DE,HL
+ ADD HL,DE
+ EX DE,HL
+ DJNZ MENU_L ; NEXT MENU ITEM
+
+ CALL NEWLINE ; DISPLAY AVAILABLE DRIVES
+ CALL PRTALL
+ CALL PC_COLON
+
+MENU_W: CALL CST ; INPUT A MENU SELECTION
+ OR A
+ JP Z,MENU_W
+ CALL CINUC
+
+ LD B,MENU_N
+ LD DE,MENU_S+10-MENU_V
+ LD HL,MENU_V
+MENU_C: EX DE,HL
+ ADD HL,DE
+ CP (HL)
+ EX DE,HL
+ JR Z,MENU_X
+ DJNZ MENU_C ; FALL THRU IF IT DOES NOT MATCH ROM MENU
+
+; CHECK FOR DRIVE EXECUTION
+
+ CP '0' ; 0-9, DISK DEVICE
+ JP C,DB_INVALID
+ CP '9' + 1
+ JP NC,DB_INVALID
+ SUB '0'
+ JP GOBOOTDISK
+
+MENU_X: EX DE,HL ; WE HAVE A VALID ROM MENU OPTION
+ INC HL
+ LD E,(HL)
+ INC HL
+ LD D,(HL)
+ EX DE,HL
+ JP (HL) ;; JUMP TO THE ROUTINE TO EXECUTE IT
+
DB_CONEND:
;
; CHECK FOR DSKY BOOT KEYPRESS
@@ -249,170 +268,92 @@ DB_DSKYEND:
#ENDIF
JP DB_BOOTLOOP
-;
+
+#DEFINE MENU_L(M1,M2,M3,M4,M5,M6,M7,M8,M9,M10) \
+#DEFCONT \ .DB M1
+#DEFCONT \ .DB M2
+#DEFCONT \ .DW M3
+#DEFCONT \ .DB M4
+#DEFCONT \ .DW M5
+#DEFCONT \ .DW M6
+#DEFCONT \ .DW M7
+#DEFCONT \ .DW M8
+#DEFCONT \ .DB M9
+#DEFCONT \ .DB M10
+;
+; name menu exec source-bank dest-exec source-addr dest-addr img-size dest-bank desc
+; DB DB DW DB DW DW DW DW DB DB
+MENU_S: MENU_L("MONITOR $$", "M", GOROM, BID_BIOSIMG, MON_SERIAL, 0A00h, MON_LOC, MON_SIZ, BID_USR, "Monitor$12345")
+MENU_1: MENU_L("CPM $ $", "C", GOROM, BID_BIOSIMG, CPM_ENT, 1A00h, CPM_LOC, CPM_SIZ, BID_USR, "CP/M$ ")
+ MENU_L("Z-SYSTEM $", "Z", GOROM, BID_BIOSIMG, CPM_ENT, 4A00h, CPM_LOC, CPM_SIZ, BID_USR, "Z-System$ ")
+ MENU_L("$ $", "E", GOROM, BID_BIOSIMG, EGG_LOC, 7A00h, EGG_LOC, EGG_SIZ, BID_USR, "$ ")
+ MENU_L("FORTH $ $", "R", GOROMB, BID_OSIMG, FTH_LOC, 0000h, FTH_LOC, FTH_SIZ, BID_USR, "Camel Forth$ ")
+ MENU_L("BASIC $ $", "B", GOROMB, BID_OSIMG, BAS_LOC, 1700h, BAS_LOC, BAS_SIZ, BID_USR, "Nascom BASIC$")
+ MENU_L("T-BASIC $$", "T", GOROMB, BID_OSIMG, TBC_LOC, 3700h, TBC_LOC, TBC_SIZ, BID_USR, "Tasty BASIC$ ")
+
+#IF (DSKYENABLE)
+ MENU_L("DSKY-MON $", "D", GOROM, BID_BIOSIMG, MON_DSKY, 0A00h, MON_LOC, MON_SIZ, BID_USR, DSKY Monitor$")
+#ENDIF
+
+MENU_E:
+
+MENU_V .EQU MENU_1-MENU_S ; LENGTH OF EACH MENU RECORD
+MENU_N .EQU (MENU_E-MENU_S)/MENU_V ; NUMBER OF MENU ITEMS
+ ;
; BOOT OPTION PROCESSING
;
DB_INVALID:
- LD DE,STR_INVALID
- CALL WRITESTR
- JP DOBOOTMENU
-;
-GOBASIC:
- LD DE,STR_BOOTBAS ; DE POINTS TO MESSAGE
- CALL WRITESTR ; WRITE IT TO CONSOLE
- ; COPY BASIC FROM BASIC FROM OSIMG0 IN ROM BANK TO THIS RAM BANKS
- LD B,BF_SYSSETCPY ; HBIOS FUNC: SETUP BANK COPY
- LD D,BID_USR ; D = DEST BANK = USER BANK
- LD E,BID_OSIMG ; E = SRC BANK = BIOS BANK
- LD HL,BAS_SIZ ; HL = COPY LEN = 1 PAGE = 256 BYTES
- RST 08 ; DO IT
- LD DE,STR_LOADING
- CALL WRITESTR ; WRITE IT TO CONSOLE
- LD B,BF_SYSBNKCPY ; HBIOS FUNC: PERFORM BANK COPY
- LD HL,BASIMG ; COPY FROM
- LD DE,BAS_LOC ; COPY TO
- RST 08 ; DO IT
- LD DE,STR_LAUNCH
- CALL WRITESTR
- LD HL,BAS_LOC
- JP CHAIN
-
-; LD HL,BAS_LOC ; FIRST BANK CODE
-; PUSH HL
-; LD DE,STR_BOOTBAS ; DE POINTS TO MESSAGE
-; CALL WRITESTR ; WRITE IT TO CONSOLE
-; ; COPY IMAGE TO EXEC ADDRESS
-; LD HL,BASIMG ; HL := BASIC IMAGE ADDRESS
-; LD DE,BAS_LOC ; DE := BASIC EXEC ADDRESS
-; LD BC,BAS_SIZ ; BC := BASIC SIZE
-; LDIR ; COPY BASIC CODE TO EXEC ADDRESS
-; POP HL ; RECOVER ENTRY ADDRESS
-; JR CHAIN ; AND CHAIN TO IT
+ LD DE,STR_INVALID
+ CALL WRITESTR
+ JP DOBOOTMENU
+;
+GOROM: EX DE,HL
+ INC HL ; HL POINTS TO source-bank
+; LD A,(HL)
+; CP BID_BIOSIMG
+; JP Z,DOBOOTMENU; ONLY CURRENT BANK SUPPORTED
-GOEASTA:
-
- LD HL,EGG_LOC
- PUSH HL
- LD DE,STR_LAUNCH ; DE POINTS TO MESSAGE
- CALL WRITESTR ; WRITE IT TO CONSOLE
- ; COPY IMAGE TO EXEC ADDRESS
- LD HL,EGGIMG ; HL := BASIC IMAGE ADDRESS
- LD DE,EGG_LOC ; DE := BASIC EXEC ADDRESS
- LD BC,EGG_SIZ ; BC := BASIC SIZE
- LDIR ; COPY BASIC CODE TO EXEC ADDRESS
- POP HL ; RECOVER ENTRY ADDRESS
- JP CHAIN ; AND CHAIN TO IT
+ LD B,4 ;
+GOROM_1:INC HL
+ LD E,(HL)
+ INC HL
+ LD D,(HL)
+ PUSH DE
+ DJNZ GOROM_1
+
+ POP BC ; SIZE
+ POP DE ; DEST
+ POP HL ; SOURCE
+ LDIR
+ JR CHAIN
-GOTBAS:
- LD DE,STR_BOOTTBC ; DE POINTS TO MESSAGE
- CALL WRITESTR ; WRITE IT TO CONSOLE
- ; COPY BASIC FROM OSIMG0 IN ROM BANK TO THIS RAM BANKS
- LD B,BF_SYSSETCPY ; HBIOS FUNC: SETUP BANK COPY
- LD D,BID_USR ; D = DEST BANK = USER BANK
- LD E,BID_OSIMG ; E = SRC BANK = BIOS BANK
- LD HL,TBC_SIZ ; HL = COPY LEN = 1 PAGE = 256 BYTES
- RST 08 ; DO IT
- LD DE,STR_LOADING
- CALL WRITESTR ; WRITE IT TO CONSOLE
- LD B,BF_SYSBNKCPY ; HBIOS FUNC: PERFORM BANK COPY
- LD HL,TBCIMG ; COPY FROM
- LD DE,TBC_LOC ; COPY TO
- RST 08 ; DO IT
- LD DE,STR_LAUNCH
- CALL WRITESTR
- LD HL,TBC_LOC
- JP CHAIN
-
-; LD HL,TBC_LOC ; FIRST BANK CODE
-; PUSH HL
-; LD DE,STR_BOOTTBC ; DE POINTS TO MESSAGE
-; CALL WRITESTR ; WRITE IT TO CONSOLE
-; ; COPY IMAGE TO EXEC ADDRESS
-; LD HL,TBCIMG ; HL := BASIC IMAGE ADDRESS
-; LD DE,TBC_LOC ; DE := BASIC EXEC ADDRESS
-; LD BC,TBC_SIZ ; BC := BASIC SIZE
-; LDIR ; COPY BASIC CODE TO EXEC ADDRESS
-; POP HL ; RECOVER ENTRY ADDRESS
-; JR CHAIN ; AND CHAIN TO IT
+GOROMB: EX DE,HL
+ INC HL ; HL POINTS TO source-bank
+; LD A,(HL)
+; CP BID_BIOSIMG
+; JP Z,DOBOOTMENU; ONLY CURRENT BANK SUPPORTED
-GOFORTH:
- LD DE,STR_BOOTFTH ; DE POINTS TO MESSAGE
- CALL WRITESTR ; WRITE IT TO CONSOLE
- ; COPY FORTH FROM OSIMG0 IN ROM BANK TO THIS RAM BANKS
- LD B,BF_SYSSETCPY ; HBIOS FUNC: SETUP BANK COPY
- LD D,BID_USR ; D = DEST BANK = USER BANK
- LD E,BID_OSIMG ; E = SRC BANK = BIOS BANK
- LD HL,FTH_SIZ ; HL = COPY LEN = 1 PAGE = 256 BYTES
- RST 08 ; DO IT
- LD DE,STR_LOADING
- CALL WRITESTR ; WRITE IT TO CONSOLE
- LD B,BF_SYSBNKCPY ; HBIOS FUNC: PERFORM BANK COPY
- LD HL,FTHIMG ; COPY FROM
- LD DE,FTH_LOC ; COPY TO
- RST 08 ; DO IT
- LD DE,STR_LAUNCH
- CALL WRITESTR
- LD HL,FTH_LOC
- JP CHAIN
+ LD B,4
+GOROMB1:INC HL
+ LD E,(HL)
+ INC HL
+ LD D,(HL)
+ PUSH DE
+ DJNZ GOROMB1
+
+ POP HL ; SIZE
+ LD B,BF_SYSSETCPY ; HBIOS FUNC: SETUP BANK COPY
+ LD D,BID_USR ; D = DEST BANK = USER BANK
+ LD E,BID_OSIMG ; E = SRC BANK = BIOS BANK
+ RST 08
+
+ POP DE ; DEST
+ POP HL ; SOURCE
+ LD B,BF_SYSBNKCPY ; HBIOS FUNC: PERFORM BANK COPY
+ RST 08 ; DO IT
-; LD HL,FTH_LOC ; FIRST BANK CODE
-; PUSH HL
-; LD DE,STR_BOOTFTH ; DE POINTS TO MESSAGE
-; CALL WRITESTR ; WRITE IT TO CONSOLE
-; ; COPY IMAGE TO EXEC ADDRESS
-; LD HL,FTHIMG ; HL := BASIC IMAGE ADDRESS
-; LD DE,FTH_LOC ; DE := BASIC EXEC ADDRESS
-; LD BC,FTH_SIZ ; BC := BASIC SIZE
-; LDIR ; COPY BASIC CODE TO EXEC ADDRESS
-; POP HL ; RECOVER ENTRY ADDRESS
-; JR CHAIN ; AND CHAIN TO IT
-
-GOMONSER:
- LD HL,MON_SERIAL ; MONITOR SERIAL INTERFACE ENTRY ADDRESS TO HL
- JR GOMON ; LOAD AND RUN MONITOR
-;
-GOMONDSKY:
- LD HL,MON_DSKY ; MONITOR DSKY INTERFACE ENTRY ADDRESS TO HL
- JR GOMON ; LOAD AND RUN MONITOR
-;
-GOMON:
- LD DE,STR_BOOTMON ; DE POINTS TO MESSAGE
- CALL WRITESTR ; WRITE IT TO CONSOLE
-;
- PUSH HL ; SAVE DESIRED MONITOR ENTRY ADDRESS
-;
- ; COPY MONITOR IMAGE TO EXEC ADDRESS
- LD HL,MONIMG ; HL := MONITOR IMAGE ADDRESS
- LD DE,MON_LOC ; DE := MONITOR EXEC ADDRESS
- LD BC,MON_SIZ ; BC := MONITOR SIZE
- LDIR ; COPY MONITOR CODE TO EXEC ADDRESS
-;
- POP HL ; RECOVER ENTRY ADDRESS
- JR CHAIN ; AND CHAIN TO IT
-;
-GOCPM:
- LD DE,STR_BOOTCPM ; DE POINTS TO MESSAGE
- CALL WRITESTR ; WRITE IT TO CONSOLE
- LD HL,CPMIMG ; SET HL TO CPM IMAGE ADDRESS
- JR GOOS ; LOAD AND RUN OS
-;
-GOZSYS:
- LD DE,STR_BOOTZSYS ; DE POINTS TO MESSAGE
- CALL WRITESTR ; WRITE IT TO CONSOLE
- LD HL,ZSYSIMG ; SET HL TO ZSYS IMAGE ADDRESS
- JR GOOS ; LOAD AND RUN OS
-;
-GOOS:
- ; COPY OS IMAGE TO EXEC ADDRESS
- LD DE,CPM_LOC ; DE := MONITOR EXEC ADDRESS
- LD BC,CPM_SIZ ; BC := MONITOR SIZE
- LDIR ; COPY MONITOR CODE TO EXEC ADDRESS
-;
- LD HL,CPM_ENT
- ;JR CHAIN ; CHAIN TO ENTRY ADDRESS IN USER BANK
-;
CHAIN:
- PUSH HL ; SAVE ENTRY ADDRESS
+; PUSH HL ; SAVE ENTRY ADDRESS
;
#IF (PLATFORM == PLT_UNA)
LD BC,$00FB ; GET LOWER PAGE ID
@@ -440,15 +381,6 @@ CHAIN:
CALL HB_BNKCALL ; AND GO
HALT ; WE SHOULD NEVER RETURN!!!
#ENDIF
-
-;
-GOLIST:
- LD DE,STR_LIST
- CALL WRITESTR
- LD DE,STR_DRVLIST
- CALL WRITESTR
- CALL PRTALL
- JP DOBOOTMENU
;
GOBOOTDISK:
LD (BL_BOOTID),A
@@ -886,13 +818,7 @@ DEV15 .EQU DEVUNK
;
STR_BOOTDISK .DB "BOOT FROM DISK\r\n$"
STR_BOOTDISK1 .DB "\r\nReading disk information...$"
-STR_BOOTMON .DB "START MONITOR FROM ROM\r\n$"
-STR_BOOTBAS .DB "START BASIC FROM ROM\r\n$"
-STR_BOOTFTH .DB "START FORTH FROM ROM\r\n$"
-STR_BOOTTBC .DB "START TASTYBASIC FROM ROM\r\n$"
-STR_BOOTCPM .DB "BOOT CPM FROM ROM\r\n$"
-STR_BOOTZSYS .DB "BOOT ZSYSTEM FROM ROM\r\n$"
-STR_LIST .DB "LIST DEVICES\r\n$"
+;STR_LIST .DB "LIST DEVICES\r\n$"
STR_INVALID .DB "INVALID SELECTION\r\n$"
STR_SETUP .DB "SYSTEM SETUP\r\n$"
STR_SIG .DB "SIGNATURE=$"
@@ -902,18 +828,13 @@ STR_CPMENT .DB "ENT=$"
STR_LABEL .DB "LABEL=$"
STR_DRVLIST .DB "\r\nDisk Devices:\r\n$"
STR_PREFIX .DB "($"
-;STR_PREFIX .DB "\r\n $"
STR_LOADING .DB "\r\nLoading...$"
STR_NODISK .DB "\r\nNo disk!$"
STR_NOBOOT .DB "\r\nDisk not bootable!$"
STR_BOOTERR .DB "\r\nBoot failure!$"
-STR_ITSRAM .DB "\r\n\RAM$"
-STR_LAUNCH .DB "\r\nLaunching ...$"
-;
-STR_BANNER .DB "\r\n", PLATFORM_NAME, " Boot Loader$"
-STR_BOOTMENU .DB "\r\n"
- .DB "\r\nROM Boot: (B)ASIC, (C)PM, (F)ORTH, (M)onitor, (T)ASTYBASIC, (Z)System.\r\n"
- .DB "Disk Boot: $"
+;STR_LAUNCH .DB "\r\nLaunching ...$"
+STR_BANNER .DB "\r\n", PLATFORM_NAME, " Boot Loader"
+STR_NL .DB "\r\n$"
;
.IF DSKYENABLE
BOOT:
From e2400a535ce99368fab0946eadfe5bea4f43dafb Mon Sep 17 00:00:00 2001
From: b1ackmai1er <39449559+b1ackmai1er@users.noreply.github.com>
Date: Tue, 6 Nov 2018 21:16:03 +0800
Subject: [PATCH 16/16] Updated to DSKY and BootAuto in romldr
Still more work to be done. Enabling DSKY make the bin file to large for the allocated ROM space.
---
Source/HBIOS/romldr.asm | 141 ++++++++++++++--------------------------
1 file changed, 50 insertions(+), 91 deletions(-)
diff --git a/Source/HBIOS/romldr.asm b/Source/HBIOS/romldr.asm
index fda7d702..04e7c208 100644
--- a/Source/HBIOS/romldr.asm
+++ b/Source/HBIOS/romldr.asm
@@ -56,7 +56,7 @@ INT_IM1 .EQU $FF00
LD SP,BL_STACK ; SETUP STACK
;
; BANNER
- LD DE,STR_BANNER
+ LD DE,STR_BANNER
CALL WRITESTR
;
@@ -119,19 +119,19 @@ INT_IM1 .EQU $FF00
;________________________________________________________________________________________________________________________________
;
DOBOOTMENU:
+ CALL NEWLINE
;
#IF (DSKYENABLE)
LD HL,BOOT ; POINT TO BOOT MESSAGE
CALL SEGDISPLAY ; DISPLAY MESSAGE
#ENDIF
-
+;
#IF (BOOTTYPE == BT_AUTO)
LD BC,100 * BOOT_TIMEOUT
LD (BL_TIMEOUT),BC
#ENDIF
-
-DB_BOOTLOOP: ; OUTPUT A '$' TERMINATED MENU TEXT WITH HIGHLIGHT
- LD B,MENU_N
+;
+ LD B,MENU_N ; DISPLAY ALL ROM MENU ENTRIES
LD DE,MENU_S
LD HL,MENU_V
MENU_L: PUSH DE
@@ -166,13 +166,42 @@ WRITEM2:POP HL
CALL NEWLINE ; DISPLAY AVAILABLE DRIVES
CALL PRTALL
CALL PC_COLON
+
+DB_BOOTLOOP:
-MENU_W: CALL CST ; INPUT A MENU SELECTION
+ CALL CST ; CHECK CONSOLE INPUT
OR A
- JP Z,MENU_W
- CALL CINUC
+ JR NZ,GOTK1
+
+#IF (DSKYENABLE)
+ CALL KY_STAT ; CHECK DSKY INPUR
+ OR A
+ JR Z,GOTNK
+
+ CALL KY_GET
+ JR MENU_A
+#ENDIF
+
+GOTNK: ; CHECK AUTOBOOT TIMEOUT
+
+#IF (BOOTTYPE == BT_AUTO)
+ LD DE,625 ; DELAY FOR 10MS TO MAKE TIMEOUT CALC EASY
+ CALL VDELAY ; 16US * 625 = 10MS
+ LD BC,(BL_TIMEOUT) ; CHECK/INCREMENT TIMEOUT
+ DEC BC
+ LD (BL_TIMEOUT),BC
+ LD A,B
+ OR C
+ JP NZ,DB_BOOTLOOP
+
+ LD A,BOOT_DEFAULT ; TIMEOUT EXPIRED,
+ JR MENU_A ; PERFORM DEFAULT BOOT ACTION
+#ENDIF
+ JR DB_BOOTLOOP
- LD B,MENU_N
+GOTK1: CALL CINUC
+
+MENU_A: LD B,MENU_N
LD DE,MENU_S+10-MENU_V
LD HL,MENU_V
MENU_C: EX DE,HL
@@ -191,84 +220,15 @@ MENU_C: EX DE,HL
SUB '0'
JP GOBOOTDISK
-MENU_X: EX DE,HL ; WE HAVE A VALID ROM MENU OPTION
+MENU_X: CALL NEWLINE
+ EX DE,HL ; WE HAVE A VALID ROM MENU OPTION
INC HL
LD E,(HL)
INC HL
LD D,(HL)
EX DE,HL
- JP (HL) ;; JUMP TO THE ROUTINE TO EXECUTE IT
+ JP (HL) ; JUMP TO THE ROUTINE TO EXECUTE IT
-DB_CONEND:
-;
-; CHECK FOR DSKY BOOT KEYPRESS
-;
-#IF (DSKYENABLE)
- CALL KY_STAT ; GET KEY FROM KB INTO A
- OR A
- JP Z,DB_DSKYEND
- CALL KY_GET
- CP KY_GO ; GO = MONITOR
- JP Z,GOMONDSKY
- CP KY_BO ; BO = BOOT ROM
- JP Z,GOCPM
-; CP 0AH ; A-F, DISK BOOT
-; JP C,DB_INVALID
- CP 0FH + 1 ; 0-F, DISK BOOT
-; JP NC,DB_INVALID
-; SUB 0AH
- JP GOBOOTDISK
-; LD HL,BOOT ; POINT TO BOOT MESSAGE
-; LD A,00H ; BLANK OUT SELECTION,IT WAS INVALID
-; LD (HL),A ; STORE IT IN DISPLAY BUFFER
-; CALL SEGDISPLAY ; DISPLAY THE BUFFER
-DB_DSKYEND:
-#ENDIF
-;
-; IF CONFIGURED, CHECK FOR AUTOBOOT TIMEOUT
-;
-#IF (BOOTTYPE == BT_AUTO)
-
- ; DELAY FOR 10MS TO MAKE TIMEOUT CALC EASY
- LD DE,625 ; 16US * 625 = 10MS
- CALL VDELAY
-
- ; CHECK/INCREMENT TIMEOUT
- LD BC,(BL_TIMEOUT)
- DEC BC
- LD (BL_TIMEOUT),BC
- LD A,B
- OR C
- JP NZ,DB_BOOTLOOP
-
- ; TIMEOUT EXPIRED, PERFORM DEFAULT BOOT ACTION
- LD A,BOOT_DEFAULT
- CP 'B' ; NASCOM BASIC
- JP Z,GOBASIC
- CP 'C' ; CP/M BOOT FROM ROM
- JP Z,GOCPM
- CP 'E' ; CP/M BOOT FROM ROM
- JP Z,GOEASTA
- CP 'F' ; FORTH
- JP Z,GOFORTH
- CP 'M' ; MONITOR
- JP Z,GOMONSER
-; CP 'L' ; LIST DRIVES
-; JP Z,GOLIST
- CP 'T' ; TASTY BASIC
- JP Z,GOTBAS
- CP 'Z' ; ZSYSTEM BOOT FROM ROM
- JP Z,GOZSYS
- CP '0' ; 0-9, DISK DEVICE
- JP C,DB_INVALID
- CP '9' + 1
- JP NC,DB_INVALID
- SUB '0'
- JP GOBOOTDISK
-#ENDIF
-
- JP DB_BOOTLOOP
-
#DEFINE MENU_L(M1,M2,M3,M4,M5,M6,M7,M8,M9,M10) \
#DEFCONT \ .DB M1
#DEFCONT \ .DB M2
@@ -284,9 +244,9 @@ DB_DSKYEND:
; name menu exec source-bank dest-exec source-addr dest-addr img-size dest-bank desc
; DB DB DW DB DW DW DW DW DB DB
MENU_S: MENU_L("MONITOR $$", "M", GOROM, BID_BIOSIMG, MON_SERIAL, 0A00h, MON_LOC, MON_SIZ, BID_USR, "Monitor$12345")
-MENU_1: MENU_L("CPM $ $", "C", GOROM, BID_BIOSIMG, CPM_ENT, 1A00h, CPM_LOC, CPM_SIZ, BID_USR, "CP/M$ ")
- MENU_L("Z-SYSTEM $", "Z", GOROM, BID_BIOSIMG, CPM_ENT, 4A00h, CPM_LOC, CPM_SIZ, BID_USR, "Z-System$ ")
- MENU_L("$ $", "E", GOROM, BID_BIOSIMG, EGG_LOC, 7A00h, EGG_LOC, EGG_SIZ, BID_USR, "$ ")
+MENU_1: MENU_L("CP/M $ $", "C", GOROM, BID_BIOSIMG, CPM_ENT, 1A00h, CPM_LOC, CPM_SIZ, BID_USR, "CP/M 80 2.2$ ")
+ MENU_L("Z-SYSTEM $", "Z", GOROM, BID_BIOSIMG, CPM_ENT, 4A00h, CPM_LOC, CPM_SIZ, BID_USR, "ZSDOS V1.1 $ ")
+ MENU_L("$ $", "E", GOROM, BID_BIOSIMG, EGG_LOC, 7A00h, EGG_LOC, EGG_SIZ, BID_USR, "Easter Egg $ ")
MENU_L("FORTH $ $", "R", GOROMB, BID_OSIMG, FTH_LOC, 0000h, FTH_LOC, FTH_SIZ, BID_USR, "Camel Forth$ ")
MENU_L("BASIC $ $", "B", GOROMB, BID_OSIMG, BAS_LOC, 1700h, BAS_LOC, BAS_SIZ, BID_USR, "Nascom BASIC$")
MENU_L("T-BASIC $$", "T", GOROMB, BID_OSIMG, TBC_LOC, 3700h, TBC_LOC, TBC_SIZ, BID_USR, "Tasty BASIC$ ")
@@ -346,15 +306,14 @@ GOROMB1:INC HL
LD D,BID_USR ; D = DEST BANK = USER BANK
LD E,BID_OSIMG ; E = SRC BANK = BIOS BANK
RST 08
-
+
POP DE ; DEST
POP HL ; SOURCE
LD B,BF_SYSBNKCPY ; HBIOS FUNC: PERFORM BANK COPY
- RST 08 ; DO IT
+ RST 08 ; DO IT
+
+CHAIN: ; EXPECT EXEC ADDRESS ON TOP OF STACK
-CHAIN:
-; PUSH HL ; SAVE ENTRY ADDRESS
-;
#IF (PLATFORM == PLT_UNA)
LD BC,$00FB ; GET LOWER PAGE ID
RST 08 ; DE := LOWER PAGE ID == BOOT ROM PAGE
@@ -386,7 +345,7 @@ GOBOOTDISK:
LD (BL_BOOTID),A
LD DE,STR_BOOTDISK
CALL WRITESTR
- JP BOOTDISK
+; JP BOOTDISK
;
; BOOT FROM DISK DRIVE
;
@@ -826,7 +785,7 @@ STR_CPMLOC .DB "LOC=$"
STR_CPMEND .DB "END=$"
STR_CPMENT .DB "ENT=$"
STR_LABEL .DB "LABEL=$"
-STR_DRVLIST .DB "\r\nDisk Devices:\r\n$"
+;STR_DRVLIST .DB "\r\nDisk Devices:\r\n$"
STR_PREFIX .DB "($"
STR_LOADING .DB "\r\nLoading...$"
STR_NODISK .DB "\r\nNo disk!$"