#define db .byte      ; TASM cross-assembler definitions
#define dw .word
#define defb .byte
#define defw .word
#define ds .block
#define org .org
#define equ .equ
#define end .end


	org	$2200

START_CODE:
; ----------------------------------------------------------------------
;			< Zx81 fig-FORTH 1.1 H >
;			Adaptive version by KAM
;
; Modified frm DLW version by Kelly A. Murta 2009
; Modified frm FIG document keyed by Dennis L. Wilson 800907
; Converted frm "8080 FIG-FORTH VERSION A0 15SEP79"
;
; fig-FORTH release 1.1 for the 8080 processor.
;
; ALL PUBLICATIONS OF THE FORTH INTEREST GROUP
; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER
; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT NOTICE:
;
; This publication has been made available by the
;	Forth Interest Group
;	P.O.Box 1105
;	San Carlos, CA 94070
;	U.S.A.
;
; Implementation on 8080 by:
;	John Cassady
;	339 15th Street
;	Oakland, CA 94612
;	U.S.A
;	on 790528
; Modified by:
;	Kim Harris
; Acknowledgements:
;	George Flammer
;	Robt. D. Villwock
; ----------------------------------------------------------------------
; Z80 Version for Cromemco CDOS & Digital Research CP/M by:
;	Dennis Lee Wilson c/o
;	Aristotelian Logicians
;	2631 East Pinchot Avenue
;	Phoenix, AZ 85016
;	U.S.A.
; ----------------------------------------------------------------------
; The 2 byte Z80 code for Jump Relative (JR) has been substituted for
; the 3 byte Jump (JP) wherever practical. The port I/O words P@ & P!
; have been made ROMable by use of Z80 instructions.
; ----------------------------------------------------------------------
; Further modifications (marked ;/) by:
;	Edmund Ramm
;	Anderheitsallee 24
;	2000 Hamburg 71
;	Fed. Rep. of Germany	840418
; ----------------------------------------------------------------------
; Disc I/O has been modified a la Albert van der Horst (HCCH) to employ
; CP/M 2.x's random access feature.
; ----------------------------------------------------------------------
;
;	Release & Version numbers
;
FIGREL	equ	1		;FIG RELEASE #
FIGREV	equ	1		;FIG REVISION #
USRVER	equ	$48		;USER VERSION # H by KAM
;
;	ASCII characters used
;
ABL	equ	20H		;BLANK
ACR	equ	0DH		;CR
ADOT	equ	2EH		;.
BELL	equ	07H		;^G
BSIN	equ	08H		;backspace chr = ^H
BSOUT	equ	08H
DLE	equ	10H		;^P
LF	equ	0AH		;^J
FF	equ	0CH		;^L
;
;	Memory allocation
;
NSCR	equ	4		;  # of 1024 byte screens
KBBUF	equ	128		;  bytes/disc buffer
US	equ	40H		;  user variables space
RTS	equ	400H		;  Return Stack & term buff space
CO	equ	KBBUF+4		;  Disc buff + 2 header + 2 tail
NBUF	equ	NSCR*400H/KBBUF	;  # of buffers
BUFSIZ	equ	CO*NBUF		;/ total disc buffer size
;

;SYSTEM:					;Start of scratch pad area
;		ds	6		;User bytes
;S0:		ds	2		;Initial value of the data stack pointer
;R0:		ds	2		;Initial value of the return stack pointer
;TIB:		ds	2		;Address of the terminal input buffer
;WIDTH:		ds	2		;Number of letters saved in names
;WARNING:	ds	2		;Error message control number
;FENCE:		ds	2		;Dictionary FORGET protection point
;DP:		ds	2		;The dictionary pointer
;VOC_LINK:	ds	2		;Most recently created vocabulary
;BLK:		ds	2		;Current block number under interpretation
;IN:		ds	2		;Offset in the current input text buffer
;OUT:		ds	2		;Offset in the current output text buffer
;SCR:		ds	2		;Screen number last referenced by LIST
;OFFSET:		ds	2		;Block offset for disk drives
;CONTEXT:	ds	2		;Pointer to the vocabulary within which
;					;dictionary search will first begin
;CURRENT:	ds	2		;Pointer to the vocabulary within which
;					;new definitions are to be created
;STATE:		ds	2		;Contains state of compillation
;BASE:		ds	2		;Current I/O base address
;DPL:		ds	2		;Number of digits to the right of the
;					;decimal point on double integer input
;FLD:		ds	2		;Field width for formatted number output
;CSP:		ds	2		;Check stack pointer
;RHASH:		ds	2		;Location of editor cursor in a text block
;HLD:		ds	2		;Address of current output
;USE:		DS	2		;Mass storage buffer address to use
;PREV:		DS	2		;Mass storage buffer address just used
;


; ------------------
; char-set (symbols)
; ------------------

SET0:

; $20 - Character: ' '          CHR$(32)

        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000

; $21 - Character: '!'          CHR$(33)

        defb    %00000000
        defb    %00010000
        defb    %00010000
        defb    %00010000
        defb    %00010000
        defb    %00000000
        defb    %00010000
        defb    %00000000

; $22 - Character: '"'          CHR$(34)

        defb    %00000000
        defb    %00100100
        defb    %00100100
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000

; $23 - Character: '#'          CHR$(35)

        defb    %00000000
        defb    %00001001
        defb    %00010010
        defb    %01111111
        defb    %00100100
        defb    %11111110
        defb    %01001000
        defb    %10010000

; $24 - Character: '$'          CHR$(36)

        defb    %00000000
        defb    %00001000
        defb    %00111110
        defb    %00101000
        defb    %00111110
        defb    %00001010
        defb    %00111110
        defb    %00001000

; $25 - Character: '%'          CHR$(37)

        defb    %00000000
        defb    %01100010
        defb    %01100100
        defb    %00001000
        defb    %00010000
        defb    %00100110
        defb    %01000110
        defb    %00000000

; $26 - Character: '&'          CHR$(38)

        defb    %00000000
        defb    %00010000
        defb    %00101000
        defb    %00010000
        defb    %00101010
        defb    %01000100
        defb    %00111010
        defb    %00000000

; $27 - Character: '''          CHR$(39)

        defb    %00000000
        defb    %00010000
        defb    %00010000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000

; $28 - Character: '('          CHR$(40)

        defb    %00000000
        defb    %00000100
        defb    %00001000
        defb    %00001000
        defb    %00001000
        defb    %00001000
        defb    %00000100
        defb    %00000000

; $29 - Character: ')'          CHR$(41)

        defb    %00000000
        defb    %00100000
        defb    %00010000
        defb    %00010000
        defb    %00010000
        defb    %00010000
        defb    %00100000
        defb    %00000000

; $2A - Character: '*'          CHR$(42)

        defb    %00000000
        defb    %00000000
        defb    %00010100
        defb    %00001000
        defb    %00111110
        defb    %00001000
        defb    %00010100
        defb    %00000000

; $2B - Character: '+'          CHR$(43)

        defb    %00000000
        defb    %00000000
        defb    %00001000
        defb    %00001000
        defb    %00111110
        defb    %00001000
        defb    %00001000
        defb    %00000000

; $2C - Character: ','          CHR$(44)

        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00001000
        defb    %00001000
        defb    %00010000

; $2D - Character: '-'          CHR$(45)

        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00111110
        defb    %00000000
        defb    %00000000
        defb    %00000000

; $2E - Character: '.'          CHR$(46)

        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00011000
        defb    %00011000
        defb    %00000000

; $2F - Character: '/'          CHR$(47)

        defb    %00000000
        defb    %00000000
        defb    %00000010
        defb    %00000100
        defb    %00001000
        defb    %00010000
        defb    %00100000
        defb    %00000000


SET1:
; $3A - Character: ':'          CHR$(58)

        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00010000
        defb    %00000000
        defb    %00000000
        defb    %00010000
        defb    %00000000

; $3B - Character: ';'          CHR$(59)

        defb    %00000000
        defb    %00000000
        defb    %00010000
        defb    %00000000
        defb    %00000000
        defb    %00010000
        defb    %00010000
        defb    %00100000

; $3C - Character: '<'          CHR$(60)

        defb    %00000000
        defb    %00000000
        defb    %00000100
        defb    %00001000
        defb    %00010000
        defb    %00001000
        defb    %00000100
        defb    %00000000

; $3D - Character: '='          CHR$(61)

        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00111110
        defb    %00000000
        defb    %00111110
        defb    %00000000
        defb    %00000000

; $3E - Character: '>'          CHR$(62)

        defb    %00000000
        defb    %00000000
        defb    %00010000
        defb    %00001000
        defb    %00000100
        defb    %00001000
        defb    %00010000
        defb    %00000000

; $3F - Character: '?'          CHR$(63)

        defb    %00000000
        defb    %00111100
        defb    %01000010
        defb    %00000100
        defb    %00001000
        defb    %00000000
        defb    %00001000
        defb    %00000000

; $40 - Character: '@'          CHR$(64)

        defb    %00000000
        defb    %00111100
        defb    %01001010
        defb    %01010110
        defb    %01011110
        defb    %01000000
        defb    %00111100
        defb    %00000000

SET3:
; $5B - Character: '['          CHR$(91)

        defb    %00000000
        defb    %00001110
        defb    %00001000
        defb    %00001000
        defb    %00001000
        defb    %00001000
        defb    %00001110
        defb    %00000000

; $5C - Character: '\'          CHR$(92)

        defb    %00000000
        defb    %00000000
        defb    %01000000
        defb    %00100000
        defb    %00010000
        defb    %00001000
        defb    %00000100
        defb    %00000000

; $5D - Character: ']'          CHR$(93)

        defb    %00000000
        defb    %01110000
        defb    %00010000
        defb    %00010000
        defb    %00010000
        defb    %00010000
        defb    %01110000
        defb    %00000000

; $5E - Character: '^'          CHR$(94)

        defb    %00000000
        defb    %00010000
        defb    %00111000
        defb    %01010100
        defb    %00010000
        defb    %00010000
        defb    %00010000
        defb    %00000000

; $5F - Character: '_'          CHR$(95)

        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %00000000
        defb    %11111111



; ****************
; ** KEY TABLES **
; ****************

; -------------------------------
; THE 'UNSHIFTED' CHARACTER CODES
; -------------------------------

K_UNSHIFT:
        defb    $5a             ; Z
        defb    $58             ; X
        defb    $43             ; C
        defb    $56             ; V
        defb    $41             ; A
        defb    $53             ; S
        defb    $44             ; D
        defb    $46             ; F
        defb    $47             ; G
        defb    $51             ; Q
        defb    $57             ; W
        defb    $45             ; E
        defb    $52             ; R
        defb    $54             ; T
        defb    $31             ; 1
        defb    $32             ; 2
        defb    $33             ; 3
        defb    $34             ; 4
        defb    $35             ; 5
        defb    $30             ; 0
        defb    $39             ; 9
        defb    $38             ; 8
        defb    $37             ; 7
        defb    $36             ; 6
        defb    $50             ; P
        defb    $4f             ; O
        defb    $49             ; I
        defb    $55             ; U
        defb    $59             ; Y
        defb    $0d             ; NEWLINE
        defb    $4c             ; L
        defb    $4b             ; K
        defb    $4a             ; J
        defb    $48             ; H
        defb    $20             ; SPACE
        defb    $2e             ; .
        defb    $4d             ; M
        defb    $4e             ; N
        defb    $42             ; B

; -----------------------------
; THE 'SHIFTED' CHARACTER CODES
; -----------------------------


K_SHIFT:
        defb    $3a             ; :
        defb    $3b             ; ;
        defb    $3f             ; ?
        defb    $2f             ; /
        defb    $00             ;
        defb    $00             ;
        defb    $00             ;
        defb    $00             ;
        defb    $00             ;
        defb    $00             ; 
        defb    $00             ; 
        defb    $00             ; 
        defb    $5b             ; [
        defb    $5d             ; ]
        defb    $21             ; !
        defb    $40             ; @
        defb    $23             ; #
        defb    $24             ; $
        defb    $25             ; %
        defb    $08             ; BACKSPACE
        defb    $5e             ; ^
        defb    $2a             ; *
        defb    $26             ; &
        defb    $27             ; '
        defb    $22             ; "
        defb    $29             ; )
        defb    $28             ; (
        defb    $24             ; $
        defb    $00             ;
        defb    $00             ;
        defb    $3d             ; =
        defb    $2b             ; +
        defb    $2d             ; -
        defb    $5f             ; _
        defb    $5c             ; \
        defb    $2c             ; ,
        defb    $3e             ; >
        defb    $3c             ; <
        defb    $2a             ; *

; ---

WAIT_KEY:
	call	$02bb
        ld      b,h
        ld      c,l
        ld      d,c
        inc     d
        jr      z,WAIT_KEY      	;
        ld      ($4025),hl		;LAST-KEY
        call    $07bd
	jr	nc,WAIT_KEY		;jump back in case of multiple keys
	ld	de,K_UNSHIFT-$7e
	add	hl,de
        ret

; ---

;; Auto Repeat Key
REP_KEY:
	ld      hl,($407b)		;sv Time - Autorepeat timer
        ld      a,h
        or      l
        call    ST_DLY
        jr      nz,W_DLY
        ld      hl,$0020
W_DLY:  ld      ($407b),hl
R_KEY:  call    $02bb
        ld      c,l
        inc     c
        jr      z,ST_DLY		;
        ld      de,($4025)		;LAST-KEY
        and     a
        sbc     hl,de
        jr      nz,R_KEY		;
        ld      hl,($407b)
        dec     hl
        ld      ($407b),hl		;sv Time - Autorepeat timer
        ld      a,h
        or      l
        jr      nz,R_KEY		;
	ret

ST_DLY:
	ld	hl,$300
	ld	($407b),hl
	ret

; ---


CF_UKEY:
	push	bc
	ld	hl,(SCRPOS)
	ld	a,$80
	ld	(hl),a

NOKEY:	call	REP_KEY
	call	WAIT_KEY
        ld      a,(hl)
	or	a
	jr	z,NOKEY
	pop	bc
	ld	h,$00
	ld	l,a
	jp	HPUSH


; ---

SCRPOS	equ	$400e

X_UEMIT:
	ld      hl,(SCRPOS)
	cp	$00
	ret	z
	cp      $0d                     ;CR ?
	jr      Z,EMIT_CR		;
	cp      $0a                     ;LF ?
	jr      Z,EMIT_CR		;
	cp      $08                     ;Backspace ?
	jr      Z,BACKSPACE	        ;
	sub	$20			;adjust ascii code to the range 0-63
	xor     $00			;put $80 here to invert the character pattern
	and     $bf			;clear bit 6 of the char code
CURSOR:
;	push    af			;sv char code
;	ld      a,(hl)                  ;NEWLINE?
;	cp      $76                     ;
;	jr      nz,NNL                  ;
;	inc     hl                      ;advance to next line
;	call    QSCROLL			;scroll the screen?
;NNL:	pop     af			;restore char code
	ld      (hl),a                  ;put it on screen
	inc     hl			;advance to next position

	ld	a,(hl)
	cp	$76
	jr	nz,SV_SCRPOS
	inc	hl
	call	QSCROLL

SV_SCRPOS:
        ld	(SCRPOS),hl
        ret

; ---

EMIT_CR:
        ld      a,(hl)
        inc     hl
        cp      $76
        jr      nz,EMIT_CR
        call    QSCROLL
        jr      SV_SCRPOS

; ---

BACKSPACE:
	ld	(hl),$00
	dec	hl
	ld	a,(hl)
	cp	$76
	jr	nz,SV_SCRPOS
        ld      de,($400C)
        or      a
	ex	de,hl
        sbc     hl,de
	ex	de,hl
        jr      nz,BCKSP1
        inc     hl
	inc	hl
BCKSP1:	dec	hl
        jr      SV_SCRPOS

; ---

QSCROLL:
	ld      de,($4010)		;sv VARS
        or      a
        ex	de,hl
        sbc     hl,de
        ex	de,hl
        ret	nz

SCR_UP:
        push    bc
	ld      hl,$21
        ld      de,($400C)
        add     hl,de
        ld      bc,$2f7
        ldir
	xor	a
	ld	b,$20
	ex	de,hl
	push	hl
DEL_LROW:
	inc	hl
	ld	(hl),a
	djnz	DEL_LROW
	pop	hl
        pop     bc
        inc	hl
        ret

; --------------------------------------------------------------------------------
;

SETCHRS:
	ld	hl,SET0			;chars $20-$2f
	ld	de,$2000
	ld	bc,$80
	ldir
	ld	hl,$1ee0		;chars $30-$39 (digits)
	ld	c,$50
	ldir
	ld	hl,SET1			;chars $3a-$40
	ld	c,$38
	ldir
	ld	hl,$1f30		;chars $41-$5a (alphabet)
	ld	c,$d0
	ldir
	ld	hl,SET3			;chars $5b-$5f
	ld	c,$28
	ldir
	ld	a,$20
	ld	i,a
	ret

START:
	ld      hl,$bfff		;Top of RAM
	ld      (X_COLD+1),hl		;Top of RAM
	call	SETCHRS

ORIG:	nop
	jp      X_COLD			;vector to COLD start
	nop
	jp      X_WARM			;vector to WARM start


	defb	FIGREL			;FIG release #
	defb	FIGREV			;FIG revision #
	defb	USRVER			;user version #
	defb	$0e			;implementation attributes
;
;
;
;	0EH = 0000:1110
;	      ---------
; B +ORIGIN   ...W:IEBA
;
; W: 0=above sufficient
;    1=other differences exist
; I: Interpreter is	0=pre-
;			1=post incrementing
; E: Addr must be even: 0 yes
;			1 no
; B: High byte @	0=low addr.
;			1=high addr.
; A: CPU Addr.		0=BYTE
;			1=WORD
;
;
;

	defw	W_TASK		;topmost word in FORTH vocabulary
	defw	BSIN		;backspace chr
UPINIT:	defw	0		;init (UP)

;
; * FOLLOWING USED BY COLD; MUST BE IN SAME ORDER AS USER VARIABLES *
;

S0INIT:	defw	0		;init (S0)
R0INIT:	defw	0		;init (R0)
TIBINI:	defw	0		;init (TIB)
	defw	$001f		;init (WIDTH)
	defw	$0000		;init (WARNING)
	defw	INITDP		;init (FENCE)
	defw	INITDP		;init (DP)
	defw	E_FORTH		;init (VOC-LINK)
;
; *  END DATA USED BY COLD *
;

; CPU identification (used by .CPU)
	defw	$19,$92f1	;Z80 CPU name (HW,LW)
				;(32 bit base 36 integer)
;	REGISTERS
;
;	FORTH	Z80	FORTH PRESERVATION RULES
;	-----	---	-----------------------
;	IP	BC	should be preserved
;			accross FORTH words.
;	W	DE	sometimes output from
;			NEXT, may be altered
;			b4 JP'ing to NEXT,
;			input only when 
;			"DPUSH" called.
;	SP	SP	should be used only as
;			Data Stack accross
;			FORTH words, may be
;			used within FORTH
;			words if restored
;			b4 "NEXT"
;		HL	Never output frm NEXT
;			input only when
;			"HPUSH" called
;
;
UP:	defw	0		;User area pointer
RPP:	defw	0		;Return Stack Pointer
BUF1:	defw	0		;Address of 1st buffer
;
;
;	COMMENT CONVENTIONS:
;
;	=	MEANS "IS EQUAL TO"
;	<--	MEANS ASSIGNMENT
;	NAME	=     ADDR OF NAME
;	(NAME)  =     CONTENTS @ NAME
;	((NAME))=     INDIRECT CONTENTS
;	CFA	=     CODE FIELD ADDR
;	LFA	=     LINK FIELD ADDR
;	NFA	=     NAME FIELD ADDR
;	PFA	=     PARAMETER FIELD ADDR
;	S1	=     ADDR OF 1st WORD OF PARAMETER STACK
;	S2	=     -"-  OF 2nd -"-  OF    -"-     -"-
;	R1	=     -"-  OF 1st -"-  OF RETURN STACK
;	R2	=     -"-  OF 2nd -"-  OF  -"-    -"-
; ( above Stack posn. valid b4 & after execution of any word, not during)
;
;	LSB	=     LEAST SIGNIFICANT BIT
;	MSB	=     MOST  SIGNIFICANT BIT
;	LB	=     LOW  BYTE
;	HB	=     HIGH BYTE
;	LW	=     LOW  WORD
;	HW	=     HIGH WORD
; (May be used as suffix to above names)

;	FORTH ADDRESS INTERPRETER
;	POST INCREMENTING VERSION
;
; ---

DPUSH:	push    de
HPUSH:	push    hl
NEXT:	ld      a,(bc)		;(W)<--((IP))
	ld      l,a		;
	inc     bc		;INC IP
	ld      a,(bc)		;
	ld      h,a		;(HL)<--CFA
	inc     bc		;INC IP
NEXTADDR:
	ld      e,(hl)		;(PC)<--((W))
	inc     hl		;
	ld      d,(hl)		;
	ex      de,hl		;
	jp      (hl)		;NOTE: (DE)=CFA+1


; --------------------------------------------------------------------------------
;
;                               -------------------
;                                ZX FORTH GLOSSARY
;                               -------------------
;
; Here starts the definitions of the words included in ZX-Forth. The first line
; of each entry shows a symbolic description of the action of the procedures on
; the parameter stack. The symbols indicate the order in which input parameters
; have been placed on the stack. Two dashes " -- " indicate the execution point;
; any parameters left on the stack are listed. In this notation, the top
; of the stack is to the right.
;
; The symbols include:
; addr	memory address
; b	8 bit byte (i.e. hi 8 bits zero)
; c	8 bit ASCII character (hi 8 bits zero)
; d	32 bit signed double integer, most significant portion with
;	sign on top of stack.
; f	boolean flag. 0-false, non-zero-true.
; ff	boolean false flag-0.
; n	16 bit signed integer number.
; u	16 bit unsigned integer.
; tf	boolean true flag-non-zero.
;
; The capital letters on the right show definition characteristics:
; C	May only be used within a colon definition. A digit indicates
;	number of memory addresses used, if other than one.
; E	Intended for execution only.
; L0	Level Zero definition of FORTH-78.
; L1	Level One definition of FORTH-78.
; P	Has precedence bit set. Will execute even when compiling.
; U	A user variable.
;
; Unless otherwise noted, all references to numbers are for 16 bit signed
; integers. For 32 bit signed double numbers, the most significant part (with
; the sign) is on top of the stack. All arithmetic is implicitly 16 bit signed
; integer math, with error and under-flow indication unspecified.
;
; --------------------------------------------------------------------------------
;
;	FORTH DICTIONARY
;	DICTIONARY FORMAT:
;
;				BYTE
;	ADDRESS NAME		CONTENTS
;	------- ----		--------
;						(MSB=1
;						(P=PRECEDENCE BIT
;						(S=SMUDGE BIT
;	NFA	NAME FIELD	1PS<LEN>	<NAME LENGTH
;				0<1CHAR>	MSB=0, NAME'S 1st CHAR
;				0<2CHAR>
;				  ...
;				1<LCHAR>	MSB=1, NAME'S LAST CHAR
;	LFA	LINK FIELD	<LINKLB>	=PREVIOUS WORD'S NFA
;				<LINKHB>
;LABEL:	CFA	CODE FIELD	<CODELB>	=ADDR CPU CODE
;				<CODEHB>
;	PFA	PARAMETER	<1PARAM>	1st PARAMETER BYTE
;		FIELD		<2PARAM>
;				  ...
;
;
;

; ------------
; THE LIT WORD
; ------------
;   -- n  								C2,L0
;
; Within a colon-definition, LIT is automatically compiled before each 16 bit
; literal number encountered in input text. Later execution of LIT causes the
; contents of the next dictionary address to be pushed to the stack.

W_LIT:			
	defb    $83
        defb    "LI",'T'+$80
        defw    $0000			;(LFA)=0 marks end of dictionary
C_LIT:
	defw    E_LIT			;(S1)<--((IP))
E_LIT:
	ld	a,(bc)			;(HL)<--((IP))=LITERAL
	inc	bc			;(IP)<--(IP)+2
	ld	l,a			;LB
	ld	a,(bc)			;HB
	inc	bc
	ld	h,a
        jr      HPUSH			;(S1)<--(HL)T

; ----------------
; THE EXECUTE WORD
; ----------------
; addr --   
;
; Execute the definition whose code field address is on the stack. The code field
; address is also called the compilation address.

W_EXECUTE:				;Jump to address on stack
	defb    $87
        defb    "EXECUT",'E'+$80
        defw    W_LIT
C_EXECUTE:
	defw    E_EXECUTE
E_EXECUTE:
	pop     hl			;Get addr off data stack
        jr      NEXTADDR		;

; ---------------
; THE BRANCH WORD
; ---------------
;   --   								C2,L0
; 
; The run-time procedure to unconditionally branch. An in-line offset is added to
; the interpretive pointer if to branch ahead or back. BRANCH is compiled by ELSE,
; AGAIN, REPEAT.

W_BRANCH:				;Add following offset to BC
	defb    $86
        defb    "BRANC",'H'+$80
        defw    W_EXECUTE
C_BRANCH:
	defw    E_BRANCH                ;(IP)<--(IP)+((IP))
E_BRANCH:
BRAN1:	ld      h,b			;(HL)<--(IP)
        ld      l,c			;
        ld      e,(hl)			;(DE)<--((IP))=BRANCH OFFSET
        inc     hl			;
        ld      d,(hl)			;
        dec     hl			;
        add     hl,de			;(HL)<--(HL)+((IP))
        ld      c,l			;(IP)<--(HL)
        ld      b,h			;
        jr      NEXT			;

; ----------------
; THE 0BRANCH WORD
; ----------------
;  f --   								C2
; 
; The run-time procedures to conditionally branch. If f is false (zero), the
; following in-line parameter is added to the interpretive pointer to branch ahead
; or back. Compiled by IF, UNTIL, and WHILE.

W_0BRANCH:				;Add offset to BC if stack top = 0
	defb    $87
        defb    "0BRANC",'H'+$80
        defw    W_BRANCH
C_0BRANCH:
	defw    E_0BRANCH
E_0BRANCH:
	pop     hl			;Get value off stack
        ld      a,h			;Set flags
        or      l			;
        jr      z,E_BRANCH		;If zero then do the branch
        inc     bc			;Else skip branch offset
        inc     bc			;
        jr      NEXT			;Continue execution

; ---------------
; THE (LOOP) WORD
; ---------------
;   --   								C2
; 
; The run-time procedure compiled by LOOP which increments the loop index and
; tests for loop completion. See LOOP.

W_XLOOP:				;Increment loop & branch if not done
	defb    $86
        defb    "(LOOP",')'+$80
        defw    W_0BRANCH
C_XLOOP:
	defw    E_XLOOP
E_XLOOP:
	ld	hl,(RPP)	;  ((HL))=INDEX=(R1)
	inc	(hl)		;/  index(lb) += 1
	ld	e,(hl)		;/
	inc	hl		;/ (hl)-->index(hb)
	jr	nz,XLOOP1	;/ jump if ((hl)) < 256
	inc	(hl)		;/ else index(hb) += 1
XLOOP1:	ld	d,(hl)		;/ (DE)<-- new INDEX
	inc	hl		;/ ((HL))=LIMIT
	ld	a,e
	sub	(hl)
	ld	a,d
	inc	hl
	sbc	a,(hl)		;  INDEX<LIMIT?
	jp	m,BRAN1		;  yes, loop again
	inc	hl		;  no, done
	ld	(RPP),hl	;  discard R1 & R2
	inc	bc
	inc	bc		;  skip branch offset
        jp      NEXT

; ----------------
; THE (+LOOP) WORD
; ----------------
;  n --   								C2
; 
; The run-time procedure compiled by +LOOP, which increments the loop index by n
; and tests for loop completion. See +LOOP.

W_XPLOOP:				;Loop + stack & branch if not done
	defb    $87
	defb    "(+LOOP",')'+$80
	defw    W_XLOOP
C_XPLOOP:
	defw    E_XPLOOP
E_XPLOOP:
	pop	de		;(DE)<--INCR
	ld	hl,(RPP)	;((HL))=INDEX
	ld	a,(hl)		;INDEX<--INDEX+INCR
	add	a,e
	ld	(hl),a
	ld	e,a
	inc	hl
	ld	a,(hl)
	adc	a,d
	ld	(hl),a
	inc	hl		;((HL))=LIMIT
	inc	d
	dec	d
	ld	d,a		;(DE)<--new INDEX
	jp	m,XLOO2		;if INCR>0
	ld	a,e
	sub	(hl)		;then (A)<--INDEX - LIMIT
	ld	a,d
	inc	hl
	sbc	a,(hl)
	jp	XLOO3
XLOO2:	ld	a,(hl)		;else (A)<--LIMIT - INDEX
	sub	e
	inc	hl
	ld	a,(hl)
	sbc	a,d
				;if (A)<0
XLOO3:	jp	m,BRAN1		;then loop agn
	inc	hl		;else done
	ld	(RPP),hl	;discard R1 & R2
	inc	bc		;skip branch offset
	inc	bc

; -------------
; THE (DO) WORD
; -------------
;  n1 n2 --   
; 
; The run-time procedure compiled by DO which moves the loop control parameters to
; the return stack. See DO.

W_XDO:					;Put start & end loop values on RPP
	defb    $84
        defb    "(DO",')'+$80
        defw    W_XPLOOP
C_XDO:
	defw    E_XDO
E_XDO:
	exx			;/ save IP
	pop	de		;  (DE)<--initial INDEX
	pop	bc		;/ (BC)<--LIMIT
	ld	hl,(RPP)	;  (HL)<--(RP)
	dec	hl
	ld	(hl),b
	dec	hl
	ld	(hl),c		;/ (R2)<--LIMIT
	dec	hl
	ld	(hl),d
	dec	hl
	ld	(hl),e		;  (R1)<--initial INDEX
	ld	(RPP),hl	;  (RP)<--(RP)-4
	exx			;/ RESTORE IP
        jp      NEXT

; ----------
; THE I WORD
; ----------
;   -- n  								C, L0
; 
; Used with a DO-LOOP to copy the loop index to the stack. Other use is implementation
; dependent. See R
;

W_I:					;Copy LOOP index to data stack
	defb	$81
	defb	'I'+$80
	defw	W_XDO
C_I:
	defw	E_I			;(S1)<--(R1), (R1) UNCHANGED
E_I:
	ld      hl,(RPP)		;Get return stack pointer
X_I2:	ld      e,(hl)			;(DE)<--(R1)
	inc     hl			;
	ld      d,(hl)			;
	push    de			;;(S1)<--(DE)
        jp      NEXT


; ----------
; THE J WORD
; ----------
;   -- n  								C, L0
; 
; Used with a DO-LOOP to copy the inner loop index to the stack. See I.
;

W_J:					;Push outer loop value on stack
	defb	$81
	defb	'J'+$80
	defw	W_I
C_J:
	defw	E_J			;(S1)<--(R1), (R1) UNCHANGED
E_J:
	ld	hl,(RPP)		;Get return stack pointer
	inc	hl			;Skip inner loop values
	inc	hl			;
	inc	hl			;
	inc	hl			;
	jp	X_I2

; --------------
; THE DIGIT WORD
; --------------
; c n1 -- n2 tf  (ok)
; c n1 -- ff  (bad)
; 
; Converts the ASCII character c (using base n1) to its binary, equivalent n2,
; accompanied by a true flag. If the conversion is invalid, leaves only a false
; flag.

W_DIGIT:				;Convert digit n2 using base n1
	defb	$85
	defb	"DIGI",'T'+$80
	defw	W_J
C_DIGIT:
	defw	E_DIGIT
E_DIGIT:
	pop	hl			;(L)<--(S1)LB = BASE value
	pop	de			;(E)<--(S2)LB = ASCII CHR to be converted
	ld	a,e			;ACCU<--CHR
	sub	'0'			;>=0?
	jr	c,DIGI2			;/ <0 is invalid
	cp	0ah			;>9?
	jr	c,DIGI1			;/ no, test BASE value
	sub	07h			;gap between "9" & "A", NW "A"=0AH
	cp	0ah			;>="A"?
	jr	c,DIGI2			;/ CHRs between "9" & "A" are invalid
DIGI1:	cp	l			;<BASE value?
	jr	nc,DIGI2		;/ no, invalid
	ld	e,a			;(S2)<--(DE) = converted digit
	ld	hl,0001h		;(S1)<--TRUE
	jp	DPUSH
DIGI2:	ld	l,h			;(HL)<--FALSE
	jp      HPUSH			;(S1)<--FALSE

; ---------------
; THE (FIND) WORD
; ---------------
; addr1 addr2 -- pfa b tf  (ok)
; addr1 addr2 -- ff  (bad)
;
; Searches the dictionary starting at the name field address addr2, matching to
; the text at addr1. Return parameter field address, length byte of name field
; and boolean true for a good match. If no match is found, only a boolean false
; is left.

W_PFIND:					;Find word & return vector,byte & flag
	defb	$86
	defb	"(FIND",')'+$80
	defw	W_DIGIT
C_PFIND:
	defw	E_PFIND			;Vector to code
E_PFIND:
	pop	de			;(DE)<--NFA
PFIN1:	pop	hl			;(HL)<--string ADDR
	push	hl			;save for next iteration
	ld	a,(de)
	xor	(hl)			;filter deviations
	and	3fh			;mask msb & precedence bit
	jr	nz,PFIN4		;lengths differ
PFIN2:	inc	hl			;(HL)<--ADDR next CHR in string
	inc	de			;(DE)<--ADDR next CHR in NF
	ld	a,(de)
	xor	(hl)			;filter deviations
	add	a,a
	jr	nz,PFIN3		;no match
	jr	nc,PFIN2		;match so far, loop agn
	ld	hl,0005h		;string matches
	add	hl,de			;((SP))<--PFA
	ex	(sp),hl
PFIN6:	dec	de			;posn DE on NFA
	ld	a,(de)
	or	a			;MSB=1? =length byte
	jp	p,PFIN6			;no, try next chr
	ld	e,a			;(E)<--length byte
	ld	d,00h
	ld	hl,0001h		;(HL)<--TRUE
	jp      DPUSH			;NF FOUND, RETURN
;
;ABOVE NF NOT A MATCH, TRY NEXT ONE
;
PFIN3:	jr	c,PFIN5			;CARRY=END OF NF
PFIN4:	inc	de			;FIND END OF NF
	ld	a,(de)
	or	a			;MSB=1?
	jp	p,PFIN4			;no, loop
PFIN5:	inc	de			;(DE)<--LFA
	ex	de,hl
	ld	e,(hl)
	inc	hl
	ld	d,(hl)			;(DE)<--(LFA)
	ld	a,d
	or	e			;end of dictionary? (LFA)=0
	jr	nz,PFIN1		;no, try previous definition
	pop	hl			;drop string addr
	ld	hl,0			;(HL)<--FALSE
	jp      HPUSH			;no match found, return

; ----------------
; THE ENCLOSE WORD
; ----------------
; addr1 c -- addr1 n1 n2 n3
; The text scanning primitive used by WORD. From the text address addr1 and an
; ASCII delimiting character c, is determined the byte offset to the first
; non-delimiter character n1, the offset to the first delimiter after the text
; n2, and the offset to the first character not included. This procedure will
; not process past an ASCII 'null', treating it as an unconditional delimiter.

W_ENCLOSE:
	defb $87
	defb	"ENCLOS",'E'+$80
	defw	W_PFIND
C_ENCLOSE:
	defw	E_ENCLOSE
E_ENCLOSE:
	pop	de		;(DE)<--(S1)=delimiter CHR
	pop	hl		;(HL)<--(S2)=addr of text to scan
	push	hl		;(S4)<--ADDR
	ld	a,e
	ld	d,a		;(D)<--delim CHR
	ld	e,-1		;init CHR offset counter
	dec	hl		;(HL)<--ADDR-1
ENCL1:	inc	hl		;skip over leading delim CHRs
	inc	e
	cp	(hl)		;delim CHR?
	jr	z,ENCL1		;yes, loop
	ld	d,0
	push	de		;(S3)<--(E)=offset to 1st non delim
	ld	d,a		;(D)<--delim CHR
	ld	a,(hl)
	and	a		;1st non-DELIM=NULL?
	jr	nz,ENCL2	;no
	ld	d,0		;yes
	inc	e
	push	de		;(S2)<--offset to byte following null
	dec	e
	push	de		;(S1)<--offset to null
	jp      NEXT
ENCL2:	ld	a,d		;(A)<--delim CHR
	inc	hl		;(HL)<--addr next CHR
	inc	e		;(E)<--offset to next CHR
	cp	(hl)		;delim CHR?
	jr	z,ENCL4		;yes
	ld	a,(hl)
	and	a		;null?
	jr	nz,ENCL2	;no, cont scan
ENCL3:	ld	d,0
	push	de		;(S2)<--offset to null
	push	de		;(S1)<--offset to null
	jp      NEXT
ENCL4:	ld	d,0
	push	de		;(S2)<--offset to byte following text
	inc	e
	push	de		;(S1)<--offset to 2 bytes after end of word
	jp      NEXT

; -------------
; THE EMIT WORD
; -------------
;  c --									L0
;
; Transmit ascii character c to the selected output device. OUT is incremented for
; each character output.
;
; 	x_uemit 1 OUT +! ;
;

W_EMIT:
	defb	$84
	defb	"EMI",'T'+$80
	defw	W_ENCLOSE
C_EMIT:
;	defw	E_COLON
;	defw	X_UEMIT
;	defw	C_1
;	defw	C_OUT
;	defw	C_PLUSSTORE
;	defw	C_STOP

	defw	E_EMIT
E_EMIT:
        pop	hl
        ld	a,l
        call	X_UEMIT
	ld	hl,(UP)
	ld	de,$1a
	add	hl,de
	inc	(hl)
	jr	nz,EMIT1
	inc	hl
	inc	(hl)
EMIT1:
	jp	NEXT


; ------------
; THE KEY WORD
; ------------
;   -- c								L0
; 
; Leave the ascii value of the next terminal key struck.

W_KEY:
	defb	$83
	defb	"KE",'Y'+$80
	defw	W_EMIT
C_KEY:
	defw	E_KEY
E_KEY:
	jp	CF_UKEY


; ------------------
; THE ?TERMINAL WORD
; ------------------
;   -- f
; 
; Perform a test of the terminal keyboard for actuation of the break key. A true
; flag indicates actuation.
; This definition is installation dependent.

W_QTERMINAL:
	defb	$89
	defb	"?TERMINA",'L'+$80
	defw	W_KEY
C_QTERMINAL:
	defw	E_QTERMINAL
E_QTERMINAL:
	call	$0f46			;check for BREAK key
	ld      hl,$0000
	jr	c,QTERM1
	inc	hl
QTERM1:	jp      HPUSH

; -----------
; THE CR WORD
; -----------
;   -- 									L0
;
;Transmit a carriage return and line feed to the selected output device.
;
;	0D EMIT ;
;

W_CR:
	defb	$82
	defb	"C",'R'+$80
	defw	W_QTERMINAL
C_CR:
	defw	E_COLON
	defw	C_LIT
	defw	$0d
	defw	C_EMIT
	defw	C_STOP


; --------------
; THE CMOVE WORD
; --------------
; from to count --
; 
; Move the specified quantity of bytes beginning at address from to address to.
; The contents of address from is moved first proceeding toward high memory. 

W_CMOVE:				;Move block
	defb	$85
	defb	"CMOV",'E'+$80
	defw	W_CR
C_CMOVE:
	defw	E_CMOVE
E_CMOVE:
	exx			;/ save IP
	pop	bc		;  (BC)<--(S1)= #CHRs
	pop	de		;  (DE)<--(S2)= dest ADDR
	pop	hl		;/ (HL)<--(S3)= source ADDR
	ld	a,b
	or	c		;  BC=0?
	jr	z,EXCMOV	;  yes, don't move anything
	ldir			;/ xfer string
EXCMOV:	exx			;/ restore IP
	jp      NEXT

; -----------
; THE U* WORD
; -----------
; u1 u2  --  ud
;
; Leave the unsigned double number product of two unsigned numbers.

W_USTAR:
	defb	$82			;U*   16*16 unsigned multiply
	defb	"U",'*'+$80		;994 T cycles average (8080)
	defw	W_CMOVE
C_USTAR:
	defw	E_USTAR
E_USTAR:
	pop	de		;(DE)<--MPLIER
	pop	hl		;(HL)<--MPCAND
	push	bc		;Save IP
	ld	b,h
	ld	a,l		;(BA)<--MPCAND
	call	MPYX		;(AHL)1<--MPCAND.LB*MPLIER
				;       1st partial product
	push	hl		;Save (HL)1
	ld	h,a
	ld	a,b
	ld	b,h		;save (A)1
	call	MPYX		;(AHL)2<--MPCAND.HB*MPLIER
				;	2nd partial product
	pop	de		;(DE)<--(HL)1
	ld	c,d		;(BC)<--(AH)1
;	form sum of partials:
;				; (AHL)1
;				;+(AHL)2
;				;-------
;				; (AHLE)
	add	hl,bc		;(HL)<--(HL)2+(AH)1
	adc	a,00h		;(AHLE)<--(BA)*(DE)
	ld	d,l
	ld	l,h
	ld	h,a		;(HLDE)<--MPLIER*MPCAND
	pop	bc		;restore IP
	push	de		;(S2)<--PRODUCT.LW
	jp	HPUSH		;(S1)<--PRODUCT.HW
;
;	MULTIPLY PRIMITIVE
;		 (AHL)<--(A)*(DE)
;	#BITS:	  24	8   16
;
MPYX:	ld	hl,0		;(HL)<--0=partial PRODUCT.LW
	ld	c,08h		;loop counter
MPYX1:	add	hl,hl		;left shift (AHL) 24 bits
	rla
	jr	nc,MPYX2	;if next mplier bit = 1
	add	hl,de		;then add MPCAND
	adc	a,0
MPYX2:	dec	c		;last mplier bit?
	jr	nz,MPYX1	;no, loop agn
	ret			;yes, done

; -----------
; THE U/ WORD
; -----------
; ud u1 -- u2 u3
;
; Leave the unsigned remainder u2 and unsigned quotient u3 from the unsigned
; double dividend ud and unsigned divisor u1.

W_UDIVMOD:
	defb	$82
	defb	"U",'/'+$80
	defw	W_USTAR
C_UDIVMOD:
	defw	E_UDIVMOD
E_UDIVMOD:
	ld	hl,0004h
	add	hl,sp		;((HL))<--NUMERATOR.LW
	ld	e,(hl)		;(DE)<--NUMER.LW
	ld	(hl),c		;save ip on stack
	inc	hl
	ld	d,(hl)
	ld	(hl),b
	POP	BC		;(BC)<--DENOMINATOR
	pop	hl		;(HL)<--NUMER.HW
	ld	a,l
	sub	c
	ld	a,h
	sbc	a,b		;NUMER >= DENOM?
	jr	c,USLA1		;no, go ahead
	ld	hl,0ffffh	;yes, overflow
	ld	d,h
	ld	e,l		;/ set REM & QUOT to MAX
	jp	USLA7
USLA1:	ld	a,10h		;loop counter
USLA2:	add	hl,hl		;left shift (HLDE) thru carry
	rla			;rot carry into ACCU bit 0
	ex	de,hl
	add	hl,hl
	jr	nc,USLA3
	inc	de		;add carry
	and	a		;reset carry
USLA3:	ex	de,hl		;shift done
	rra			;restore 1st carry & counter
	jr	nc,USLA4	;if carry=1
	or	a		;/ reset carry
	sbc	hl,bc		;/ then (HL)<--(HL)-(BC)
	jp	USLA5
USLA4:	sbc	hl,bc		;/ (HL)<--partial remainder
	jr	nc,USLA5
	add	hl,bc		;underflow, restore
	dec	de
USLA5:	inc	de		;inc QUOT
	dec	a		;counter=0?
	jp	nz,USLA2	;no, loop agn
USLA7:	pop	bc		;restore IP
	push	hl		;(S2)<--remainder
	push	de		;(S1)<--quotient
	jp      NEXT

; ------------
; THE AND WORD
; ------------
; n1  n2  --  n3							L0
; 
; Leave the bitwise logical and of n1 and n2 as n3.

W_AND:
	defb	$83
	defb	"AN",'D'+$80
	defw	W_UDIVMOD
C_AND:
	defw	E_AND			;(S1)<--(S1) AND (S2)
E_AND:
	pop     de
	pop     hl
	ld      a,e
	and     l
	ld      l,a
	ld      a,d
	and     h
	ld      h,a
	jp      HPUSH

; -----------
; THE OR WORD
; -----------
; n1 n2  --  n3								L0
; 
; Leave the bit-wise logical or of two l6 bit values.

W_OR:
	defb	$82
	defb	"O",'R'+$80
	defw	W_AND
C_OR:
	defw	E_OR			;(S1)<--(S1) OR (S2)
E_OR:
	pop     de
	pop     hl
	ld      a,e
	or      l
	ld      l,a
	ld      a,d
	or      h
	ld      h,a
	jp      HPUSH

; ------------
; THE XOR WORD
; ------------
; nl n2  --  n3							L1
; 
; Leave the bitwise logical exclusive or of two values.

W_XOR:
	defb	$83
	defb	"XO",'R'+$80
	defw	W_OR
C_XOR:
	defw	E_XOR			;(S1)<--(S1) XOR (S2)
E_XOR:
	pop     de
	pop     hl
	ld      a,e
	xor     l
	ld      l,a
	ld      a,d
	xor     h
	ld      h,a
	jp      HPUSH

; ------------
; THE SP@ WORD
; ------------
;   -- addr
; 
; A computer dependent procedure to return the address of the stack position to
; the top of the stack, as it was before SP@ was executed.
; (e.g.  1 2 SP@ @ . . .   would type 2 2 1)

W_SPFETCH:
	defb	$83
	defb	"SP",'@'+$80
	defw	W_XOR
C_SPFETCH:
	defw	E_SPFETCH		;(S1)<--(SP)
E_SPFETCH:
	ld	hl,$0000
	add     hl,sp			;(HL)<--(SP)
	jp      HPUSH

; ------------
; THE SP! WORD
; ------------
;   -- 
; 
; A computer dependent procedure to initialize the stack pointer from SO.

W_SPSTORE:
	defb	$83
	defb	"SP",'!'+$80
	defw	W_SPFETCH
C_SPSTORE:
	defw	E_SPSTORE		;(SP)<--(S0) (USER VARIABLE)
E_SPSTORE:
	ld      hl,(UP)			;(HL)<--USER VAR BASE ADDR
	ld      de,$0006
	add     hl,de			;(HL)<--S0
	ld      e,(hl)
	inc     hl
	ld      d,(hl)			;(DE)<--(S0)
	ex      de,hl
	ld      sp,hl			;(SP)<--(S0)
TONEXT:	jp      NEXT

; ------------
; THE RP@ WORD
; ------------
;   -- addr
; 
; A computer dependent procedure to return the address of the stack position to
; the top of the return stack.

W_RPFETCH:
	defb	$83
	defb	"RP",'@'+$80
	defw	W_SPSTORE
C_RPFETCH:
	defw	E_RPFETCH		;(S1)<--(RP)
E_RPFETCH:
	ld      hl,(RPP)
	jp      HPUSH

; ------------
; THE RP! WORD
; ------------
; (  --  )
; 
; A computer dependent procedure to initialize the return stack pointer from user
; variable R0.

W_RPSTORE:
	defb	$83
	defb	"RP",'!'+$80
	defw	W_RPFETCH
C_RPSTORE:
	defw	E_RPSTORE		;(RP)<--(R0) (USER VARIABLE)
E_RPSTORE:
	ld      hl,(UP)			;(HL)<--USER VAR BASE ADDR
	ld      de,0008h
	add     hl,de			;(HL)<--R0
	ld      e,(hl)
	inc     hl
	ld      d,(hl)			;(DE)<--(R0)
	ld      (RPP),de		;/ (RP)<--(R0)
        jp      NEXT

; -----------
; THE ;S WORD
; -----------
;   --  								P,L0
;
; Stop interpretation of a screen.
; ;S is also the run-time word compiled at the end of a colon-definition which
; returns execution to the calling procedure.

W_STOP:
	defb	$82
	defb	";",'S'+$80
	defw	W_RPSTORE
C_STOP:
	defw	E_STOP			;(IP)<--(R1)
E_STOP:
	ld      hl,(RPP)
	ld      c,(hl)
	inc     hl
	ld      b,(hl)			;(BC)<--(R1)
	inc     hl
	ld      (RPP),hl		;(RP)<--(RP)+2
        jp      NEXT

; --------------
; THE LEAVE WORD
; --------------
;   --  								C,L0
; 
; Force termination of a DO-LOOP at the next opportunity by setting the loop limit
; equal to the current value of the index. The index itself remains unchanged, and
; execution proceeds normally until LOOP or +LOOP is encountered.

W_LEAVE:
	defb	$85
	defb	"LEAV",'E'+$80
	defw	W_STOP
C_LEAVE:
	defw	E_LEAVE			;LIMIT<--INDEX
E_LEAVE:
	ld      hl,(RPP)
	ld      e,(hl)
	inc     hl
	ld      d,(hl)			;(DE)<--(R1)=INDEX
	inc     hl
	ld      (hl),e
	inc     hl
	ld      (hl),d			;(R2)<--(DE)=LIMIT
	jp      NEXT

; -----------
; THE >R WORD
; -----------
; n  -- 								C,L0
; 
; Remove a number from the computation stack and place as the most accessable on
; the return stack. Use should be balanced with R> in the same definition.

W_TOR:	defb	$82
	defb	">",'R'+$80
	defw	W_LEAVE
C_TOR:
	defw	E_TOR
E_TOR:
	pop	de
	ld	hl,(RPP)
	dec	hl
	ld	(hl),d		
	dec	hl
	ld	(hl),e			;/ (R1)<--(DE)
	ld	(RPP),hl		;  (RP)<--(RP)-2
        jp      NEXT

; -----------
; THE R> WORD
; -----------
;   --  n								L0
; 
; Remove the top value from the return stack and leave it on the computation stack. 
; See >R and R.


W_FROMR:
	defb	$82
	defb	"R",'>'+$80
	defw	W_TOR
C_FROMR:
	defw	E_FROMR
E_FROMR:
	ld	hl,(RPP)
	ld      e,(hl)
	inc     hl
	ld      d,(hl)
	inc     hl
	ld      (RPP),hl
	push    de 			;(S1)<--(R1)
        jp      NEXT

; ----------
; THE R WORD
; ----------
;   -- n
; 
; Copy the top of the return stack to the computation stack.

W_RR:
	defb	$81
	defb	'R'+$80
	defw	W_FROMR
C_RR:
	defw	E_I

; -----------
; THE 0= WORD
; -----------
; n -- f								L0
; 
; Leave a true flag is the number is equal to zero, otherwise leave a false flag.

W_0EQUAL:
	defb	$82
	defb	"0",'='+$80
	defw	W_RR
C_0EQUAL:
	defw	E_0EQUAL
E_0EQUAL:
	pop     hl
	ld      a,l
	or      h
	ld      hl,$0000
	jr      nz,ZEQU1
	inc     hl			;(HL)<--TRUE
ZEQU1:	jp      HPUSH

; -----------
; THE 0< WORD
; -----------
; n -- f								L0
; 
; Leave a true flag if the number is less than zero (negative), otherwise leave a
; false flag.

W_0LESS:
	defb	$82
	defb	"0",'<'+$80
	defw	W_0EQUAL
C_0LESS:
	defw	E_0LESS
E_0LESS:
	pop	af			;/ (A)<--(S1)H
	rla				;/ (CARRY)<--BIT 7
	ld	hl,0			;  (HL)<--FALSE
	jr	nc,ZLES1
	inc	l			;  (HL)<--TRUE
ZLES1:	jp     HPUSH

; ----------
; THE + WORD
; ----------
; n1 n2  --  sum							L0
; 
; Leave the sum of n1+n2.

W_PLUS:
	defb	$81
	defb	'+'+$80
	defw	W_0LESS
C_PLUS:
	defw	E_PLUS
E_PLUS:	pop     de
	pop     hl
	add     hl,de
	jp      HPUSH

; -----------
; THE D+ WORD
; -----------
; d1 d2 -- dsum
; 
; Leave the double number sum of two double numbers.

W_DPLUS:
	defb	$82			;D+ ( d1L d1H d2L d2h -- d3L d3H)
	defb	"D",'+'+$80
	defw	W_PLUS
C_DPLUS:
	defw	E_DPLUS
E_DPLUS:
	exx				;/ save IP
	pop	bc			;  (BC)<--d2H
	pop	hl			;  (HL)<--d2L
	pop	af			;d (AF)<--d1H
	pop	de			;  (DE)<--d1L
	push	af			;/ (S1)<--d1H
	add	hl,de			;  (HL)<--d2L+d1L=d3L
	ex	de,hl			;  (DE)<--d3L
	pop	hl			;  (HL)<--d1H
	adc	hl,bc			;/ (HL)<--d1H+d2H+CARRY=d3H
	push	de			;  (S2)<--d3L
	push	hl			;/ (S1)<--d3H
	exx				;/ restore IP
	jp      NEXT

; --------------
; THE MINUS WORD
; --------------
; n1 -- n2								L0
; 
; Leave the two's complement of a number.

W_NEGATE:
	defb	$85
	defb	"MINU",'S'+$80
	defw	W_DPLUS
C_NEGATE:
	defw	E_NEGATE
E_NEGATE:
	pop	de			;/
	xor	a			;/ RESET CARRY, (A)<--0
	ld	h,a			;/
	ld	l,a			;/ LD HL,0
	sbc	hl,de			;/ (HL)<--(DE)2's COMPL.
	jp      HPUSH

; ---------------
; THE DMINUS WORD
; ---------------
; d1 -- d2
; 
; Convert d1 to its double number two's complement.

W_DNEGATE:
	defb	$86
	defb	"DMINU",'S'+$80
	defw	W_NEGATE
C_DNEGATE:
	defw	E_DNEGATE
E_DNEGATE:
	pop     hl			;(HL)<--d1H
	pop     de			;(DE)<--d1L
	sub     a 			;(A)<--0
	sub     e
	ld      e,a 			;(E)<--NEG(E)
	ld      a,$00
	sbc     a,d
	ld      d,a 			;(D)<--NEG(D)
	ld      a,$00
	sbc     a,l
	ld      l,a			;(L)<--NEG(L)
	ld      a,$00
	sbc     a,h
	ld      h,a			;(H)<--NEG(H)
	jp      DPUSH 			;(S2)<--d2L, (S1)<--d2H

; -------------
; THE OVER WORD
; -------------
; nl n2 -- nl n2 n1							L0
; 
; Copy the second stack value, placing it as the new top.

W_OVER:
	defb	$84
	defb	"OVE",'R'+$80
	defw	W_DNEGATE
C_OVER:
	defw	E_OVER
E_OVER:	pop     de
	pop     hl
	push    hl
	jp      DPUSH

; -------------
; THE DROP WORD
; -------------
; n  --  								L0
; 
; Drop the number from the stack.

W_DROP:
	defb	$84
	defb	"DRO",'P'+$80
	defw	W_OVER
C_DROP:
	defw	E_DROP
E_DROP:	pop     hl
	jp      NEXT

; -------------
; THE SWAP WORD
; -------------
; nl n2 --- n2 n1							L0
; 
; Exchange the top two values On the stack.

W_SWAP:
	defb	$84
	defb	"SWA",'P'+$80
	defw	W_DROP
C_SWAP:
	defw	E_SWAP
E_SWAP:	pop     hl
	ex      (sp),hl
	jp      HPUSH

; ------------
; THE DUP WORD
; ------------
; n -- n n 								L0
; 
; Duplicate the value on the stack.

W_DUP:
	defb	$83
	defb	"DU",'P'+$80
	defw	W_SWAP
C_DUP:
	defw	E_DUP
E_DUP:	pop     hl
	push    hl
	jp      HPUSH

; -------------
; THE 2DUP WORD
; -------------
; d -- d d
; 
; Duplicate the double value on the stack.

W_2DUP:
	defb	$84
	defb	"2DU",'P'+$80
	defw	W_DUP
C_2DUP:
	defw	E_2DUP
E_2DUP:	pop     hl
	pop     de
	push    de
	push    hl
	jp      DPUSH

; -----------
; THE +! WORD
; -----------
; n addr  --								L0
; 
; Add n to the value at the address.
; Pronounced "plus-store".

W_PLUSSTORE:
	defb	$82
	defb	"+",'!'+$80
	defw	W_2DUP
C_PLUSSTORE:
	defw	E_PLUSSTORE
E_PLUSSTORE:
	pop     hl			;(HL)<--VAR ADDR
	pop     de  			;(DE)<--NUMBER
	ld      a,(hl)
	add     a,e
	ld      (hl),a
	inc     hl
	ld      a,(hl)
	adc     a,d
	ld      (hl),a       		;((HL))<--((HL))+NUMBER
	jp      NEXT

; ---------------
; THE TOGGLE WORD
; ---------------
; addr b --
; 
; Complement the contents of addr by the bit pattern b.

W_TOGGLE:
	defb	$86
	defb	"TOGGL",'E'+$80
	defw	W_PLUSSTORE
C_TOGGLE:
	defw	E_TOGGLE
E_TOGGLE:
	pop	de		;(E)<--BIT PATTERN
	pop	hl		;(HL)<--ADDR
	ld      a,(hl)
	xor     e
	ld      (hl),a
        jp      NEXT

; ----------
; THE @ WORD
; ----------
; addr -- n  								L0
;
; Leave the 16 bit contents of address.

W_FETCH:
	defb	$81
	defb	'@'+$80
	defw	W_TOGGLE
C_FETCH:
	defw	E_FETCH
E_FETCH:
	pop     hl
	ld      e,(hl)
	inc     hl
	ld      d,(hl)
	push    de
        jp      NEXT

; -----------
; THE C@ WORD
; -----------
; addr -- b
; 
; Leave the 8 bit contents of memory address.

W_CFETCH:
	defb	$82
	defb	"C",'@'+$80
	defw	W_FETCH
C_CFETCH:
	defw	E_CFETCH
E_CFETCH:
	pop     hl
	ld      l,(hl)
	ld      h,$00
	jp      HPUSH

; -----------
; THE 2@ WORD
; -----------
; addr -- d
; 
; Leave the 32 bit contents of address.

W_2FETCH:
	defb	$82
	defb	"2",'@'+$80
	defw	W_CFETCH
C_2FETCH:
	defw	E_2FETCH
E_2FETCH:
	exx				;/ SAVE IP
	pop	hl			;  (HL)<--ADDR
	ld	c,(hl)
	inc	hl
	ld	b,(hl)			;/ (BC)<--dH
	inc	hl
	ld	e,(hl)
	inc	hl
	ld	d,(hl)			;  (DE)<--dL
	push	de			;  (S2)<--dL
	push	bc			;/ (S1)<--dH
	exx				;/ RESTORE IP
        jp      NEXT

; ----------
; THE ! WORD
; ----------
; n addr -- 								L0
; 
; Store 16 bits of n at address. Pronounced "store".

W_STORE:
	defb	$81
	defb	'!'+$80
	defw	W_2FETCH
C_STORE:
	defw	E_STORE
E_STORE:
	pop     hl
	pop     de
	ld      (hl),e
	inc     hl
	ld      (hl),d
        jp      NEXT

; -----------
; THE C! WORD
; -----------
; b addr --
; 
; Store 8 bits at address.

W_CSTORE:
	defb	$82
	defb	"C",'!'+$80
	defw	W_STORE
C_CSTORE:
	defw	E_CSTORE
E_CSTORE:
	pop     hl
	pop     de
	ld      (hl),e
        jp      NEXT

; -----------
; THE 2! WORD
; -----------
; d addr -- 
; 
; Store 32 bits of d at address.

W_2STORE:
	defb	$82
	defb	"2",'!'+$80
	defw	W_CSTORE
C_2STORE:
	defw	E_2STORE
E_2STORE:
	pop     hl
	pop     de
	ld      (hl),e
	inc     hl
	ld      (hl),d
	inc     hl
	pop     de
	ld      (hl),e
	inc     hl
	ld      (hl),d
	jp      NEXT

; ----------
; THE : WORD
; ----------
;  -- 									P,E,L0
; 
; Used in the form called a colon-definition:
;  : cccc     ...     ;
; Creates a dictionary entry defining cccc as equivalent to the following sequence
; of Forth word definitions '...' until the next ';' or ';CODE'.
; The compiling process is done by the text interpreter as long as STATE is 
; non-zero. Other details are that the CONTEXT vocabulary is set to the CURRENT
; vocabulary and that words with the precedence bit set (P) are executed rather
; than being compiled.
;
; 	?EXEC CSP! CURRENT @ CONTEXT ! CREATE ] ;CODE ...code... IMMEDIATE
;

W_COLON:
	defb	$c1
	defb	':'+$80
	defw	W_2STORE
C_COLON:
	defw	E_COLON		
	defw	C_QEXEC
	defw	C_CSPSTORE
	defw	C_CURRENT
	defw	C_FETCH
	defw	C_CONTEXT
	defw	C_STORE
	defw	C_CREATE
	defw	C_RIGHTBRKT
	defw	C_CCODE

E_COLON:
	ld	hl,(RPP)
	dec     hl
	ld      (hl),b
	dec     hl
	ld      (hl),c
	ld      (RPP),hl
	inc     de
	ld      c,e
	ld      b,d
	jp      NEXT

; ----------
; THE ; WORD
; ----------
;  --  									P,C,L0
; 
; Terminate a colon-definition and stop further compilation. Compiles the run-time
; ;S.
;
;	?CSP COMPILE ;S SMUDGE [ ; IMMEDIATE

W_SEMICOLON:
	defb	$c1
	defb	';'+$80
	defw	W_COLON
C_SEMICOLON:
	defw	E_COLON
	defw	C_QCSP
	defw	C_COMPILE
	defw	C_STOP
	defw	C_SMUDGE
	defw	C_LEFTBRKT
	defw	C_STOP


; -------------
; THE NOOP WORD
; -------------
;  -- 
;

W_NOOP:
	defb	$84
	defb	"NOO",'P'+$80
	defw	W_SEMICOLON
C_NOOP:
	defw	E_COLON		
	defw	C_STOP

; -----------------
; THE CONSTANT WORD
; -----------------
; n -- 									E,L0
; 
; A defining word used in the form:
;     n CONSTANT cccc
; to create word cccc, with its parameter field containing n. When cccc is later
; executed, it will push the value of n to the stack.
;
;	CREATE SMUDGE , ;CODE ...code...

W_CONSTANT:
	defb	$88
	defb	"CONSTAN",'T'+$80
	defw	W_NOOP
C_CONSTANT:
	defw	E_COLON		
	defw	C_CREATE
	defw	C_SMUDGE
	defw	C_COMMA
	defw	C_CCODE

X_CONSTANT:
	inc	de
	ex      de,hl
	ld      e,(hl)
	inc     hl
	ld      d,(hl)
	push    de
        jp      NEXT

; -----------------
; THE VARIABLE WORD
; -----------------
; n -- 									E,L0
; 
; A defining word used in the form:
;     n VARIABLE cccc
; When VARIABLE is executed, it creates the definition cccc with its parameter
; field initialized to n. When cccc is later executed, the address of its parameter 
; field (containing n) is left on the stack, so that a fetch or store may access
; this location.
;
;	CONSTANT ;CODE ...code...
;

W_VARIABLE:
	defb	$88
	defb	"VARIABL",'E'+$80
	defw	W_CONSTANT
C_VARIABLE:
	defw	E_COLON		
	defw	C_CONSTANT
	defw	C_CCODE

X_VARIABLE:
	inc	de
	push    de
	jp      NEXT

; -------------
; THE USER WORD
; -------------
; n -- 									L0
; 
; A defining word used in the form:
;     n USER cccc
; which creates a user variable cccc. The parameter field of cccc contains n as
; a fixed offset relative to the user pointer register UP for this user
; variable. When cccc is later executed, it places the sum of its offset and the
; user area base address on the stack as the storage address of that particular
; variable.
;
;	CONSTANT ;CODE ...code...
;

W_USER:
	defb	$84
	defb	"USE",'R'+$80
	defw	W_VARIABLE
C_USER:
	defw	E_COLON		
	defw	C_CONSTANT
	defw	C_CCODE

X_USER:	inc	de
	ex      de,hl
	ld      e,(hl)
	ld      d,$00
	ld      hl,(UP)
	add     hl,de
	jp      HPUSH

; ----------
; THE 0 WORD
; ----------
;   -- n
; 
; Leave the number 0 on the stack.

W_ZERO:
	defb	$81
	defb	'0'+$80
	defw	W_USER
C_ZERO:
	defw	E_ZERO
E_ZERO:
	ld	hl,0
	jp	HPUSH

; ----------
; THE 1 WORD
; ----------
;   -- n
; 
; Leave the number 1 on the stack.

W_1:
	defb	$81
	defb	'1'+$80
	defw	W_ZERO
C_1:
	defw	E_1
E_1:
	ld	hl,1
	jp	HPUSH

; ----------
; THE 2 WORD
; ----------
;   -- n
; 
; Leave the number 2 on the stack.

W_2:
	defb	$81
	defb	'2'+$80
	defw	W_1
C_2:
	defw	E_2
E_2:
	ld	hl,2
	jp	HPUSH

; ----------
; THE 3 WORD
; ----------
;   -- n
; 
; Leave the number 3 on the stack.

W_3:
	defb	$81
	defb	'3'+$80
	defw	W_2
C_3:
	defw	E_3
E_3:
	ld	hl,3
	jp	HPUSH

; -----------
; THE BL WORD
; -----------
;  -- n
;
; A constant that leaves the ascii value for "blank".

W_BL:
	defb	$82
	defb	"B",'L'+$80
	defw	W_3
C_BL:
	defw	X_CONSTANT
	defw	$0020

; ------------
; THE C/L WORD
; ------------
;  -- n
; 
; Screen-file editor chars per line. The default value is 64.

W_CL:
	defb	$83
	defb	"C/",'L'+$80
	defw	W_BL
C_CL:
	defw	X_CONSTANT
	defw	$0040

; --------------
; THE FIRST WORD
; --------------
;  -- n
; 
; A constant that leaves the address of the first (lowest) block buffer.

W_FIRST:
	defb	$85
	defb	"FIRS",'T'+$80
	defw	W_CL
C_FIRST:
	defw	X_CONSTANT
	defw	0			;/ set by CLD

; --------------
; THE LIMIT WORD
; --------------
;  -- n
; 
; A constant leaving the address just above the highest memory available for a
; tape buffer. Usually this is the highest system memory.

W_LIMIT:
	defb	$85
	defb	"LIMI",'T'+$80
	defw	W_FIRST
C_LIMIT:
	defw	X_CONSTANT
	defw	0			;/ set by CLD

; --------------
; THE B/BUF WORD
; --------------
;  -- n
; 
; This constant leaves the number of bytes per tape buffer, the byte count read
; from tape by BLOCK.

W_BBUF:
	defb	$85
	defb	"B/BU",'F'+$80
	defw	W_LIMIT
C_BBUF:
	defw	X_CONSTANT
	defw	KBBUF

; --------------
; THE B/SCR WORD
; --------------
;  -- n
; 
; This constant leaves the number of blocks per editing screen. By convention, an
; editing screen is 1O24 bytes organized as 16 lines of 64 characters each.

W_BSCR:
	defb	$85
	defb	"B/SC",'R'+$80
	defw	W_BBUF
C_BSCR:
	defw	X_CONSTANT
	defw	$400/KBBUF

; ----------------
; THE +ORIGIN WORD
; ----------------
; n -- addr
; 
; Leave the memory address relative by n to the origin parameter area.
; n is the minimum address unit, either byte or word. This definition is used to
; access or modify the boot-up parameters at the origin area.

W_PLUSORIGIN:
	defb	$87
	defb	"+ORIGI",'N'+$80
	defw	W_BSCR
C_PLUSORIGIN:
	defw	E_COLON		
	defw	C_LIT
	defw	ORIG
	defw	C_PLUS
	defw	C_STOP

;
;	USER VARIABLES
;

; -----------
; THE S0 WORD
; -----------
;  ---  addr								U
; 
; A user variable that contains the initial value for the stack pointer.
; Pronounced S-zero. See SP!

W_S0:
	defb	$82
	defb	"S",'0'+80
	defw	W_PLUSORIGIN
C_S0:
	defw	X_USER
	defb	$06

; -----------
; THE R0 WORD
; -----------
;  ---  addr								U
; 
; A user variable containing the initial location of the return stack.
; Pronounced R-zero. See RP!

W_R0:
	defb	$82
	defb	"R",'0'+$80
	defw	W_S0
C_R0:
	defw	X_USER
	defb	$08

; ------------
; THE TIB WORD
; ------------
;  ---  addr								U
; 
; A user variable containing the address of the terminal input buffer.

W_TIB:
	defb	$83
	defb	"TI",'B'+$80
	defw	W_R0
C_TIB:
	defw	X_USER
	defb	$0a

; --------------
; THE WIDTH WORD
; --------------
;  ---  addr								U
; 
; In fig-FORTH, a user variable containing the maximum number of letters saved in
; the compilation of a definitions' name. It must be 1 thru 31, with a default
; value of 31. The name character count and its natural characters are saved, up to
; the value in WIDTH. The value may be changed at any time within the above limits.

W_WIDTH:
	defb	$85
	defb	"WIDT",'H'+$80
	defw	W_TIB
C_WIDTH:
	defw	X_USER
	defb	$0c

; ----------------
; THE WARNING WORD
; ----------------
;  ---  addr								U
; 
; A user variable containing a value controlling messages. If = 1 disc is present,
; and screen 4 of drive 0 is the base location for messages. If = 0, no disc is
; present and messages will be presented by number. If = -1, execute (ABORT) for a
; user specified procedure. See MESSAGE, ERROR.

W_WARNING:
	defb	$87
	defb	"WARNIN",'G'+$80
	defw	W_WIDTH
C_WARNING:
	defw	X_USER
	defb	$0e

; --------------
; THE FENCE WORD
; --------------
;  ---  addr								U
; 
; A user variable containing an address below which FORGETting is trapped. To 
; forget below this point the user must alter the contents of FENCE.

W_FENCE:
	defb	$85
	defb	"FENC",'E'+$80
	defw	W_WARNING
C_FENCE:
	defw	X_USER
	defb	$10

; -----------
; THE DP WORD
; -----------
;  ---  addr								U,L
;
; A user variable, the dictionary pointer, which contains the address of the next
; free memory above the dictionary. The value may be read by HERE and altered by
; ALLOT.


W_DP:
	defb	$82
	defb	"D",'P'+$80
	defw	W_FENCE
C_DP:
	defw	X_USER
	defb	$12

; -----------------
; THE VOC-LINK WORD
; -----------------
;  ---  addr								U
; 
; A user variable containing the address of a field in the definition of the most
; recently created vocabulary. All vocabulary names are linked by these fields to
; allow control for FORGETting thru multiple vocabularies.

W_VOC_LINK:
	defb	$88
	defb	"VOC-LIN",'K'+$80
	defw	W_DP
C_VOC_LINK:
	defw	X_USER
	defb	$14

; ------------
; THE BLK WORD
; ------------
;  ---  addr								U,L0
; 
; A user variable containing the block number being interpreted. If zero, input is
; being taken from the terminal input buffer.

W_BLK:	defb	$83
	defb	"BL",'K'+$80
	defw	W_VOC_LINK
C_BLK:	defw	X_USER
	defb	$16

; -----------
; THE IN WORD
; -----------
;  ---  addr								U,L0
; 
; A user variable containing the byte offset within the current input text buffer
; (terminal or disc) from which the next text will be accepted. WORD uses and moves 
; the value of IN.

W_IN:	defb	$82
	defb	"I",'N'+$80
	defw	W_BLK
C_IN:	defw	X_USER
	defb	$18

; ------------
; THE OUT WORD
; ------------
;  ---  addr								U
; 
; A user variable that contains a value incremented by EMIT. The user may alter and 
; examine OUT to control display formating.

W_OUT:
	defb	$83
	defb	"OU",'T'+$80
	defw	W_IN
C_OUT:
	defw	X_USER
	defb	$1a

; ------------
; THE SCR WORD
; ------------
;  ---  addr								U
; 
; A user variable containing the screen number most recently referenced by LIST.

W_SCR:
	defb	$83
	defb	"SC",'R'+$80
	defw	W_OUT
C_SCR:
	defw	X_USER
	defb	$1c

; ---------------
; THE OFFSET WORD
; ---------------
;  ---  addr								U
; 
; A user variable which may contain a block offset to disc drives. The contents of
; OFFSET is added to the stack number by BLOCK. Messages by MESSAGE are independent 
; of OFFSET. See BLOCK, DR0, DR1, MESSAGE.


W_OFFSET:
	defb	$86
	defb	"OFFSE",'T'+$80
	defw	W_SCR
C_OFFSET:
	defw	X_USER
	defb	$1e

; ----------------
; THE CONTEXT WORD
; ----------------
;  ---  addr								U,L0
; 
; A user variable containing a pointer to the vocabulary within which dictionary
; searches will first begin.

W_CONTEXT:
	defb	$87
	defb	"CONTEX",'T'+$80
	defw	W_OFFSET
C_CONTEXT:
	defw	X_USER
	defb	$20

; ----------------
; THE CURRENT WORD
; ----------------
;  ---  addr								U,L0
; 
; A user variable containing a pointer to the compiling vocabulary.

W_CURRENT:
	defb	$87
	defb	"CURREN",'T'+$80
	defw	W_CONTEXT
C_CURRENT:
	defw	X_USER
	defb	$22

; --------------
; THE STATE WORD
; --------------
;  ---  addr								U,L0
; 
; A user variable containing the compilation state. A non-zero value indicates
; compilation. The value itself may be implementation dependent.

W_STATE:
	defb	$85
	defb	"STAT",'E'+$80
	defw	W_CURRENT
C_STATE:
	defw	X_USER
	defb	$24

; -------------
; THE BASE WORD
; -------------
;  ---  addr								U,L0
; 
; A user variable containing the current number base used for input and output
; conversion.

W_BASE:
	defb	$84
	defb	"BAS",'E'+$80
	defw	W_STATE
C_BASE:
	defw	X_USER
	defb	$26

; ------------
; THE DPL WORD
; ------------
;  ---  addr								U,L0
; 
; A user variable containing the number of digits to the right of the decimal on
; double integer input. It may also be used to hold output column location of a
; decimal point, in user generated formating. The default value on single number
; input is -1.

W_DPL:
	defb	$83
	defb	"DP",'L'+$80
	defw	W_BASE
C_DPL:
	defw	X_USER
	defb	$28

; ------------
; THE FLD WORD
; ------------
;  ---  addr								U,L0
; 
; A user variable for control of number output field width. Presently unused in
; fig-FORTH.


W_FLD:
	defb	$83
	defb	"FL",'D'+$80
	defw	W_DPL
C_FLD:
	defw	X_USER
	defb	$2a

; ------------
; THE CSP WORD
; ------------
;  ---  addr								U
; 
; A user variable temporarily storing the stack pointer position, for compilation
; error checking.

W_CSP:
	defb	$83
	defb	"CS",'P'+$80
	defw	W_FLD
C_CSP:
	defw	X_USER
	defb	$2c

; -----------
; THE R# WORD
; -----------
;  ---  addr								U
; 
; A user variable which may contain the location of an editing cursor, or other
; file related function.

W_RHASH:
	defb	$82
	defb	"R",'#'+$80
	defw	W_CSP
C_RHASH:
	defw	X_USER
	defb	$2e

; ------------
; THE HLD WORD
; ------------
;  ---  addr								U
; 
; A user variable that holds the address of the latest character of text during
; numeric output conversion.

W_HLD:
	defb	$83
	defb	"HL",'D'+$80
	defw	W_RHASH
C_HLD:
	defw	X_USER
	defb	$30
;
;	END OF USER VARIABLES
;

; -----------
; THE 1+ WORD
; -----------
; n1 -- n2								L1
; 
; Increment n1 by 1.

W_1PLUS:
	defb	$82
	defb	"1",'+'+$80
	defw	W_HLD
C_1PLUS:
	defw	E_1PLUS
E_1PLUS:
	pop	hl      			;/
	inc	hl       			;/
	jp	HPUSH    			;/

; -----------
; THE 2+ WORD
; -----------
; n1 -- n2								L1
; 
; Increment n1 by 2.

W_2PLUS:
	defb	$82
	defb	"2",'+'+$80
	defw	W_1PLUS
C_2PLUS:
	defw	E_2PLUS
E_2PLUS:
	pop	hl     			;/
	inc	hl     			;/
	inc	hl     			;/
	jp	HPUSH  			;/

; -----------
; THE 1- WORD
; -----------
; n1 -- n2								L1
; 
; Decrement n1 by 1.

W_1MINUS:
	defb	$82
	defb	"1",'-'+$80
	defw	W_2PLUS
C_1MINUS:
	defw	E_1MINUS
E_1MINUS:
	pop	hl     			;/
	dec	hl     			;/
	jp	HPUSH   		;/

; -----------
; THE 2- WORD
; -----------
; n1 -- n2								L1
; 
; Decrement n1 by 2.

W_2MINUS:
	defb	$82
	defb	"2",'-'+$80
	defw	W_1MINUS
C_2MINUS:
	defw	E_2MINUS
E_2MINUS:
	pop	hl   			;/
	dec	hl   			;/
	dec	hl  			;/
	jp	HPUSH 			;/

; -----------
; THE 2* WORD
; -----------
; n1 -- n2								L1
; 
; Multiply n1 by 2.

W_2STAR:
	defb	$82
	defb	"2",'*'+$80
	defw	W_2MINUS
C_2STAR:
	defw	E_2STAR
E_2STAR:
	pop	hl   			;/
	add	hl,hl			;/ ASL HL
	jp	HPUSH			;/

; -----------
; THE 2/ WORD
; -----------
; n1 -- n2								L1
; 
; Divide n1 by 2.

W_2SLASH:
	defb	$82
	defb	"2",'*'+$80
	defw	W_2STAR
C_2SLASH:
	defw	E_2SLASH
E_2SLASH:
	pop	hl
	bit	7,h			;/
	jr	z,TWOSL1		;/
	inc	hl			;/
TWOSL1:	sra	h			;/
	rr	l			;/ ASR HL
	jp	HPUSH  			;/

; -------------
; THE HERE WORD
; -------------
;  -- addr								L0
; 
; Leave the address of the next available dictionary location.

W_HERE:
	defb	$84
	defb	"HER",'E'+$80
	defw	W_2SLASH
C_HERE:
	defw	E_COLON		
	defw	C_DP
	defw	C_FETCH
	defw	C_STOP

; --------------
; THE ALLOT WORD
; --------------
; n --  								L0
; 
; Add the signed number to the dictionary pointer DP. May be used to reserve
; dictionary space or re-origin memory. n is with regard to computer address type
; (byte or word).

W_ALLOT:
	defb	$85
	defb	"ALLO",'T'+$80
	defw	W_HERE
C_ALLOT:
	defw	E_COLON		
	defw	C_DP
	defw	C_PLUSSTORE
	defw	C_STOP

; ---------------
; THE , WORD
; ---------------
; n -- 									L0
; 
; Store n into the next available dictionary memory cell, advancing the dictionary
; pointer. (comma)

W_COMMA:
	defb	$81
	defb	','+$80
	defw	W_ALLOT
C_COMMA:
	defw	E_COLON		
	defw	C_HERE
	defw	C_STORE
	defw	C_2
	defw	C_ALLOT
	defw	C_STOP

; ---------------
; THE C, WORD
; ---------------
; b -- 									L0
; 
; Store 8 bits of b into the next available dictionary byte, advancing the
; dictionary pointer. This is only available on byte addressing computers, and
; should be used with caution on byte addressing mini-computers.

W_CCOMMA:
	defb	$82
	defb	"C",','+$80
	defw	W_COMMA
C_CCOMMA:
	defw	E_COLON		
	defw	C_HERE
	defw	C_CSTORE
	defw	C_1
	defw	C_ALLOT
	defw	C_STOP

; ----------
; THE - WORD
; ----------
;  n1 n2 -- diff 							L0
; 
; Leave the difference of n1-n2.

W_MINUS:
	defb	$81
	defb	'-'+$80
	defw	W_CCOMMA
C_MINUS:
	defw	E_MINUS
E_MINUS:
	pop     de
	pop     hl
	or      a
	sbc     hl,de
	jp      HPUSH

; ----------
; THE = WORD
; ----------
;  n1 n2 -- f 								L0
; 
; Leave a true flag if n1=n2; otherwise leave a false flag.

W_EQUAL:
	defb	$81
	defb	'='+$80
	defw	W_MINUS
C_EQUAL:
	defw	E_EQUAL
E_EQUAL:
	pop	de		;/
	pop	hl		;/
	xor	a		;/ reset carry
	sbc	hl,de		;/
	ld	h,a		;/
	ld	l,a		;/ LD HL,0000H
	jr	nz,EXEQU	;/ FALSE
	inc	l		;/ TRUE
EXEQU:	jp	HPUSH		;/

; ----------
; THE < WORD
; ----------
;  n1 n2 -- f 								L0
; 
; Leave a true flag if n1 is less than n2; otherwise leave a false flag.

W_LESS:
	defb	$81
	defb	'<'+$80
	defw	W_EQUAL
C_LESS:
	defw	E_LESS
E_LESS:
	pop	de
	pop	hl		;  (HL) (DE) <
	ld	a,d
	xor	h		;  one of them negative?
	jp	M,LES1		;  yes, determine which
	or	a		;/ clr carry
	sbc	hl,de		;/
LES1:	bit	7,h		;/ (H) negative?
	ld	hl,0
	jr	z,EXLESS	;/ no, false
	inc	l		;/ true
EXLESS:	jp      HPUSH

; -----------
; THE U< WORD
; -----------
;  u1 u2 -- f
; 
; Leave a true flag if u1 is less than u2; otherwise leave a false flag.

W_ULESS:
	defb	$82
	defb	"U",'<'+$80
	defw	W_LESS
C_ULESS:
	defw	E_ULESS
E_ULESS:
	pop	de
	pop	hl		;/ (HL) (DE) U<
	xor	a		;/
	sbc	hl,de		;/
	ld	h,a		;/
	ld	l,a		;/ LD HL,0000H
	jr	nc,EXULES	;/ FALSE
	inc	l		;/ TRUE
EXULES:	jp	HPUSH		;/

; ----------
; THE > WORD
; ----------
;  n1 n2 -- f 								L0
;
; Leave a true flag if n1 is greater than n2; otherwise a false flag.

W_GREATER:
	defb	$81
	defb	'>'+$80
	defw	W_ULESS
C_GREATER:
	defw	E_GREATER
E_GREATER:
	pop	hl		;/
	pop	de		;/ (HL) (DE) > = (DE) (HL) <
	ld	a,d
	xor	h		;  one of them negative?
	jp	m,GREAT1	;  yes, determine which
	or	a		;/ clr carry
	sbc	hl,de		;/
GREAT1:	bit	7,h		;/ (H) negative?
	ld	hl,0		;  (HL)<--FALSE
	jr	z,GREAT2	;/ no, FALSE
	inc	l		;/ (HL)<--TRUE
GREAT2:	jp	HPUSH

; ------------
; THE ROT WORD
; ------------
; n1 n2 n3 -- n2 n3 n1							L0
; 
; Rotate the top three values on the stack, bringing the third to the top.

W_ROT:
	defb	$83
	defb	"RO",'T'+$80
	defw	W_GREATER
C_ROT:
	defw	E_ROT
E_ROT:
	pop     de
	pop     hl
	ex      (sp),hl
	jp      DPUSH

; --------------
; THE SPACE WORD
; --------------
;  -- 									L0
; 
; Transmit an ascii blank to the output device.

W_SPACE:
	defb	$85
	defb	"SPAC",'E'+$80
	defw	W_ROT
C_SPACE:
	defw	E_COLON		
	defw	C_BL
	defw	C_EMIT
	defw	C_STOP

; -------------
; THE -DUP WORD
; -------------
; n1 -- n1 (if zero) 							L0
; n1 -- n1 n1 (non-zero)
; 
; Reproduce n1 only if it is non-zero. 
; This is usually used to copy a value just before IF, to eliminate the need for
; an ELSE part to drop it.

W_QUERYDUP:
	defb	$84
	defb	"-DU",'P'+$80
	defw	W_SPACE
C_QUERYDUP:
	defw	E_QUERYDUP
E_QUERYDUP:
	pop	hl		;/
	ld	a,h		;/
	or	l		;/ (HL)=0?
	jr	z,EXDDUP	;/ yes, don't DUP
	push	hl		;/
EXDDUP:	jp	HPUSH

; -----------------
; THE TRAVERSE WORD
; -----------------
; addr1 n --- addr2
; 
; Move across the name field of a fig-FORTH variable length name field.
; addr1 is the address of either the length byte or the last letter.
; If n=1, the motion is toward hi memory; if n=-1, the motion is toward low memory. 
; The addr2 resulting is address of the other end of the name.

W_TRAVERSE:
	defb	$88
	defb	"TRAVERS",'E'+$80
	defw	W_QUERYDUP
C_TRAVERSE:
TRAV:	defw	E_COLON
	defw	C_SWAP
TRAV1:	defw	C_OVER			;BEGIN
	defw	C_PLUS
	defw	C_LIT
	defw	$7f
	defw	C_OVER
	defw	C_CFETCH
	defw	C_LESS
	defw	C_0BRANCH		;UNTIL
	defw	TRAV1-$
	defw	C_SWAP
	defw	C_DROP
	defw	C_STOP

; ---------------
; THE LATEST WORD
; ---------------
;  -- addr
; 
; Leave the name field address of the topmost word in the CURRENT vocabulary.

W_LATEST:
	defb	$86
	defb	"LATES",'T'+$80
	defw	W_TRAVERSE
C_LATEST:
	defw	E_COLON		
	defw	C_CURRENT
	defw	C_FETCH
	defw	C_FETCH
	defw	C_STOP

; ------------
; THE LFA WORD
; ------------
; pfa -- lfa
; 
; Convert the parameter field address of a dictionary definition to its link field
; address.

W_LFA:	defb	$83
	defb	"LF",'A'+$80
	defw	W_LATEST
C_LFA:
	defw	E_LFA
E_LFA:
	pop	hl		;/ (HL)<--PFA
	dec	hl		;/
	dec	hl		;/
	dec	hl		;/
	dec	hl		;/ (HL)<--(HL)-4 = LFA
	jp	HPUSH		;/

; ------------
; THE CFA WORD
; ------------
; pfa -- cfa
; 
; Convert the parameter field address of a definition to its code field address.

W_CFA:
	defb	$83
	defb	"CF",'A'+$80
	defw	W_LFA
C_CFA:
	defw	E_COLON		
	defw	C_2MINUS
	defw	C_STOP

; ------------
; THE NFA WORD
; ------------
; pfa -- nfa
; 
; Convert the parameter. field address of a definition to its name field.

W_NFA:
	defb	$83
	defb	"NF",'A'+$80
	defw	W_CFA
C_NFA:
	defw	E_COLON
	defw	C_LIT
	defw	5
	defw	C_MINUS
	defw	C_LIT
	defw	-1
	defw	C_TRAVERSE
	defw	C_STOP

; ------------
; THE PFA WORD
; ------------
; nfa -- pfa
; 
; Convert the name field address of a compiled definition to its parameter field
; address.

W_PFA:
	defb	$83
	defb	"PF",'A'+$80
	defw	W_NFA
C_PFA:
	defw	E_COLON
	defw	C_1
	defw	C_TRAVERSE
	defw	C_LIT
	defw	5
	defw	C_PLUS
	defw	C_STOP

; -------------
; THE !CSP WORD
; -------------
;   -- 
; 
; Save the stack position in CSP. Used as part of the compiler security.

W_CSPSTORE:
	defb	$84
	defb	"!CS",'P'+$80
	defw	W_PFA
C_CSPSTORE:
	defw	E_COLON
	defw	C_SPFETCH
	defw	C_CSP
	defw	C_STORE
	defw	C_STOP

; ---------------
; THE ?ERROR WORD
; ---------------
; f n -- 
; 
; Issue an error message number n, if the boolean flag is true.
;
;	SWAP IF ERROR ELSE DROP ENDIF ;
;

W_QERROR:
	defb	$86
	defb	"?ERRO",'R'+$80
	defw	W_CSPSTORE
C_QERROR:
	defw	E_COLON
	defw	C_SWAP
	defw	C_0BRANCH		;IF
	defw	QERR1-$
	defw	C_ERROR
	defw	C_BRANCH		;ELSE
	defw	QERR2-$
QERR1:	defw	C_DROP			;ENDIF
QERR2:	defw	C_STOP

; --------------
; THE ?COMP WORD
; --------------
;   -- 
;
; Issue error message if not compiling.
;
;	STATE @ 0= 11 ?ERROR ;
;

W_QCOMP:
	defb	$85
	defb	"?COM",'P'+$80
	defw	W_QERROR
C_QCOMP:
	defw	E_COLON
	defw	C_STATE
	defw	C_FETCH
	defw	C_0EQUAL
	defw	C_LIT
	defw	$11
	defw	C_QERROR
	defw	C_STOP

; --------------
; THE ?EXEC WORD
; --------------
;   --  
; 
; Issue an error message if not executing.
;
;	STATE @ 12 ?ERROR 
;

W_QEXEC:
	defb	$85
	defb	"?EXE",'C'+$80
	defw	W_QCOMP
C_QEXEC:
	defw	E_COLON
	defw	C_STATE
	defw	C_FETCH
	defw	C_LIT
	defw	$12
	defw	C_QERROR
	defw	C_STOP

; ---------------
; THE ?PAIRS WORD
; ---------------
; n1 n2 --  
; 
; Issue an error message if n1 does not equal n2. The message indicates that
; compiled conditionals do not match.
;
;	- 13 ?ERROR ;
;

W_QPAIRS:
	defb	$86
	defb	"?PAIR",'S'+$80
	defw	W_QEXEC
C_QPAIRS:
	defw	E_COLON
	defw	C_MINUS
	defw	C_LIT
	defw	$13
	defw	C_QERROR
	defw	C_STOP

; -------------
; THE ?CSP WORD
; -------------
;   -- 
; 
; Issue error message if stack position differs from value saved in CSP.
;
;	SP@ CSP @ - 14 ?ERROR ;
;

W_QCSP:
	defb	$84
	defb	"?CS",'P'+$80
	defw	W_QPAIRS
C_QCSP:
	defw	E_COLON
	defw	C_SPFETCH
	defw	C_CSP
	defw	C_FETCH
	defw	C_MINUS
	defw	C_LIT
	defw	$14
	defw	C_QERROR
	defw	C_STOP

; -----------------
; THE ?LOADING WORD
; -----------------
;  -- 
; 
; Issue an error message if not loading
;
;	BLK @ 0= 16 ?ERROR ;
;

W_QLOADING:
	defb	$88
	defb	"?LOADIN",'G'+$80
	defw	W_QCSP
C_QLOADING:
	defw	E_COLON		
	defw	C_BLK
	defw	C_FETCH
	defw	C_0EQUAL
	defw	C_LIT
	defw	$16
	defw	C_QERROR
	defw	C_STOP

; ----------------
; THE COMPILE WORD
; ----------------
;  -- 									C2
; 
; When the word containing COMPILE executes, the execution address of the word
; following COMPILE is copied (compiled) into the dictionary.
; This allows specific compilation situations to be handled in addition to simply
; compiling an execution address (which the interpreter already does).
;
;	?COMP R> DUP 2+ >R @ , ;
;

W_COMPILE:
	defb	$87
	defb	"COMPIL",'E'+$80
	defw	W_QLOADING
C_COMPILE:
	defw	E_COLON
	defw	C_QCOMP
	defw	C_FROMR
	defw	C_DUP
	defw	C_2PLUS
	defw	C_TOR
	defw	C_FETCH
	defw	C_COMMA
	defw	C_STOP

; ----------
; THE [ WORD
; ----------
;   -- 									P,L1
; 
; Used in a colon-definition in form:
;     :  xxx    [  words   ]    more   ;
; Suspend compilation. The words after [ are executed, not compiled.
; This allows calculation or compilation exceptions before resuming compilation
; with ] .  See LITERAL, ].

W_LEFTBRKT:
	defb	$c1
	defb	'['+$80
	defw	W_COMPILE
C_LEFTBRKT:
	defw	E_COLON
	defw	C_ZERO
	defw	C_STATE
	defw	C_STORE
	defw	C_STOP

; ----------
; THE ] WORD
; ----------
;   --  								L1
;
; Resume compilation, to the completion of a colon-definition. See [

W_RIGHTBRKT:
	defb	$81
	defb	']'+$80
	defw	W_LEFTBRKT
C_RIGHTBRKT:
	defw	E_COLON
	defw	C_LIT
	defw	$c0
	defw	C_STATE
	defw	C_STORE
	defw	C_STOP

; ---------------
; THE SMUDGE WORD
; ---------------
;   --  
; 
; Used during word definition to toggle the "smudge bit" in a definitions' name
; field. This prevents an uncompleted definition from being found during
; dictionary searches, until compiling is completed without error.

W_SMUDGE:
	defb	$86
	defb	"SMUDG",'E'+$80
	defw	W_RIGHTBRKT
C_SMUDGE:
	defw	E_COLON
	defw	C_LATEST
	defw	C_LIT
	defw	$20
	defw	C_TOGGLE
	defw	C_STOP

; ------------
; THE HEX WORD
; ------------
;   --  								L0
;
; Set the numeric conversion base to sixteen (hexadecimal).

W_HEX:
	defb	$83
	defb	"HE",'X'+$80
	defw	W_SMUDGE
C_HEX:
	defw	E_COLON
	defw	C_LIT
	defw	$10
	defw	C_BASE
	defw	C_STORE
	defw	C_STOP

; ----------------
; THE DECIMAL WORD
; ----------------
;   --  								L0
;
; Set the numeric conversion BASE for decimal input-output.

W_DECIMAL:
	defb	$87
	defb	"DECIMA",'L'+$80
	defw	W_HEX
C_DECIMAL:
	defw	E_COLON
	defw	C_LIT
	defw	$0a
	defw	C_BASE
	defw	C_STORE
	defw	C_STOP

; ----------------
; THE (;CODE) WORD
; ----------------
;   -- 									C
; 
; The run-time procedure, compiled by ;CODE, that rewrites the code field of the
; most recently defined word to point to the following machine code sequence.
; See ;CODE.

W_CCODE:
	defb	$87
	defb	"(;CODE",')'+$80
	defw	W_DECIMAL
C_CCODE:
	defw	E_COLON
	defw	C_FROMR
	defw	C_LATEST
	defw	C_PFA
	defw	C_CFA
	defw	C_STORE
	defw	C_STOP

; --------------
; THE ;CODE WORD
; --------------
;   --  								P,C,L0
; 
; Used in the form:
;     : cccc .... ;CODE
; assembly mnemonics Stop compilation and terminate a new defining word cccc by
; compiling (;CODE). Set the CONTEXT vocabulary to ASSEMBLER, assembling to
; machine code the following mnemonics.
;
; When cccc later executes in the form:
;     cccc nnnn
; the word nnnn will be created with its execution procedure given by the machine
; code following cccc.
; That is, when nnnn is executed, it does so by jumping to the code after nnnn. An
; existing defining word must exist in cc prior to ;CODE

W_SCCODE:
	defb	$c5
	defb	";COD",'E'+$80
	defw	W_CCODE
C_SCCODE:
	defw	E_COLON
	defw	C_QCSP
	defw	C_COMPILE
	defw	C_CCODE
	defw	C_LEFTBRKT
	defw	C_NOOP
	defw	C_STOP

; ----------------
; THE <BUILDS WORD
; ----------------
;   -- 									C,L0
; 
; Used within a colon-definition:
;     : cccc  <BUILDS  ...
;       DOES>     ...    ;
; Each time cccc is executed, <BUILDS defines a new word with a high-level
; execution procedure. Executing cccc in the form:
;
;                     cccc nnnn
;
; uses <BUILDS to create a dictionary entry for nnnn with a call to the DOES> part
; for nnnn. When nnnn is later executed, it has the address of its parameter area
; on the stack and executes the words after DOES> in cccc. <BUILDS and DOES> allow
; runtime procedures to written in high-level rather than in assembler code (as
; required by ;CODE).

W_BUILDS:
	defb	$87
	defb	"<BUILD",'S'+$80
	defw	W_SCCODE
C_BUILDS:
	defw	E_COLON
	defw	C_ZERO
	defw	C_CONSTANT
	defw	C_STOP

; --------------
; THE DOES> WORD
; --------------
;   -- 									L0
;
; A word which defines the run-time action within a high-level defining word.
; DOES> alters the code field and first parameter of the new word to execute the
; sequence of compiled word addresses following DOES>. Used in combination with
; <BUILDS. When the DOES> part executes it begins with the address of the first
; parameter of the new word on the stack. This allows interpretation using this
; area or its contents. Typical uses include the Forth assembler, multidimensional
; arrays, and compiler generation.

W_DOES:
	defb	$85
	defb	"DOES",'>'+$80
	defw	W_BUILDS
C_DOES:
	defw	E_COLON
	defw	C_FROMR
	defw	C_LATEST
	defw	C_PFA
	defw	C_STORE
	defw	C_CCODE

X_DOES:	ld	hl,(RPP)
	dec     hl
	ld      (hl),b
	dec     hl
	ld      (hl),c
	ld      (RPP),hl
	inc     de
	ex      de,hl
	ld      c,(hl)
	inc     hl
	ld      b,(hl)
	inc     hl
	jp      HPUSH

; --------------
; THE COUNT WORD
; --------------
; addr1 -- addr2 n							L0
; 
; Leave the byte address addr2 and byte count n of a message text beginning at
; address addr1. It is presumed that the first byte at addr1 contains the text
; byte count and the actual text starts with the second byte.
; Typically COUNT is followed by TYPE.
;
; : COUNT	DUP 1+ SWAP C@ ;
;

W_COUNT:
	defb	$85
	defb	"COUN",'T'+$80
	defw	W_DOES
C_COUNT:
	defw	E_COLON
	defw	C_DUP
	defw	C_1PLUS
	defw	C_SWAP
	defw	C_CFETCH
	defw	C_STOP

; -------------
; THE TYPE WORD
; -------------
; addr count --								L0
; 
; Transmit count characters from addr to the selected output device.
;
; : TYPE	-DUP IF OVER + SWAP
;    		     (DO) I C@ EMIT (LOOP)
;		     ELSE DROP
;		     ENDIF ;

W_TYPE:
	defb	$84
	defb	"TYP",'E'+$80
	defw	W_COUNT
C_TYPE:
	defw	E_COLON
	defw	C_QUERYDUP
	defw	C_0BRANCH
	defw	TYPE1-$
	defw	C_OVER
	defw	C_PLUS
	defw	C_SWAP
	defw	C_XDO
TYPE2:	defw	C_I
	defw	C_CFETCH
	defw	C_EMIT
	defw	C_XLOOP
	defw	TYPE2-$
	defw	C_BRANCH
	defw	TYPE3-$
TYPE1:	defw	C_DROP
TYPE3:	defw	C_STOP

; ------------------
; THE -TRAILING WORD
; ------------------
; addr n1 -- addr n2
; 
; Adjusts the character count n1 of a text string beginning address to suppress
; the output of trailing blanks. i.e. the characters at addr+n1 to addr+n2 are
; blanks.

W_TRAILING:
	defb	$89
	defb	"-TRAILIN",'G'+$80
	defw	W_TYPE
C_TRAILING:
	defw	E_COLON
	defw	C_DUP
	defw	C_ZERO
	defw	C_XDO			;DO
DTRA1:	defw	C_2DUP       		;/
	defw	C_PLUS
	defw	C_1MINUS		;/
	defw	C_CFETCH
	defw	C_BL
	defw	C_MINUS
	defw	C_0BRANCH		;IF
	defw	DTRA2-$
	defw	C_LEAVE
	defw	C_BRANCH		;ELSE
	defw	DTRA3-$
DTRA2:	defw	C_1MINUS		;/
DTRA3:	defw	C_XLOOP			;LOOP
	defw	DTRA1-$
	defw	C_STOP

; -------------
; THE (.") WORD
; -------------
;   -- 									C
; 
; The run-time procedure, compiled by ." which transmits the following in-line
; text to the selected output device. See ."
;
; : (.") R COUNT DUP 1+ R> + >R TYPE ;
;

W_CQUOTE:
	defb	$84
	defb	"(.",$22,')'+$80
	defw	W_TRAILING
C_CQUOTE:
	defw	E_COLON
	defw	C_RR
	defw	C_COUNT
	defw	C_DUP
	defw	C_1PLUS
	defw	C_FROMR
	defw	C_PLUS
	defw	C_TOR
	defw	C_TYPE
	defw	C_STOP

; ---------------
; THE ." WORD
; ---------------
;   --									P,L0
; 
; Used in the form:
;     ." cccc"
; Compiles an in-line string cccc (delimited by the trailing ") with an execution
; procedure to transmit the text to the selected output device.
; If executed outside a definition, ." will immediately print the text until the
; final ". The maximum number of characters may be an installation dependent value. 
; See (.").
;
; : ."	22 STATE @ IF COMPILE (.") WORD HERE C@ 1+ ALLOT
;		   ELSE WORD HERE COUNT TYPE ENDIF ;
;

W_QUOTE:
	defb	$c2
	defb	".",$22+$80
	defw	W_CQUOTE
C_QUOTE:
	defw	E_COLON
	defw	C_LIT
	defw	$22
	defw	C_STATE
	defw	C_FETCH
	defw	C_0BRANCH		;IF
	defw	DOTQ1-$
	defw	C_COMPILE
	defw	C_CQUOTE
	defw	C_WORD
	defw	C_HERE
	defw	C_CFETCH
	defw	C_1PLUS
	defw	C_ALLOT
	defw	C_BRANCH		;ELSE
	defw	DOTQ2-$
DOTQ1:	defw	C_WORD
	defw	C_HERE
	defw	C_COUNT
	defw	C_TYPE			;ENDIF
DOTQ2:	defw	C_STOP

; -----------------
; THE EXPECT WORD
; -----------------
; addr count -- 							L0
; 
; Transfer characters from the terminal to address, until a "return" or the count
; of characters have been received. One or more nulls are added at the end of the
; text.
;
; : EXPECT	OVER + OVER
;		DO KEY DUP 8 =
;		   IF DROP DUP I = DUP R> 2- + >R
;			IF 0 ELSE 8 ENDIF
;		   ELSE DUP 0D = IF LEAVE DROP BL 0
;		      	         ELSE DUP
;			         ENDIF
;		   I C! 0 I 1+ !
;		   ENDIF EMIT
;		LOOP DROP ;
;

W_EXPECT:
	defb	$86
	defb	"EXPEC",'T'+$80
	defw	W_QUOTE
C_EXPECT:
	defw	E_COLON
	defw	C_OVER
	defw	C_PLUS
	defw	C_OVER
	defw	C_XDO			;DO
EXPE1:	defw	C_KEY
	defw	C_DUP
	defw	C_LIT
	defw	$0e
	defw	C_PLUSORIGIN
	defw	C_FETCH
	defw	C_EQUAL
	defw	C_0BRANCH 		;IF
	defw	EXPE2-$
	defw	C_DROP
	defw	C_DUP
	defw	C_I
	defw	C_EQUAL
	defw	C_DUP	
	defw	C_FROMR
	defw	C_2MINUS		;/
	defw	C_PLUS
	defw	C_TOR
	defw	C_0BRANCH		;IF
	defw	EXPE6-$
	defw	C_LIT
	defw	$00
	defw	C_BRANCH		;ELSE
	defw	EXPE7-$
EXPE6:	defw	C_LIT
	defw	BSOUT			;ENDIF
EXPE7:	defw	C_BRANCH		;ELSE
	defw	EXPE3-$
EXPE2:	defw	C_DUP
	defw	C_LIT
	defw	ACR			;/
	defw	C_EQUAL
	defw	C_0BRANCH		;IF
	defw	EXPE4-$
	defw	C_LEAVE
	defw	C_DROP
	defw	C_BL
	defw	C_ZERO
	defw	C_BRANCH		;ELSE
	defw	EXPE5-$
EXPE4:	defw	C_DUP 			;ENDIF
EXPE5:	defw	C_I
	defw	C_CSTORE
	defw	C_ZERO
	defw	C_I
	defw	C_1PLUS
	defw	C_STORE			;ENDIF
EXPE3:	defw	C_EMIT
	defw	C_XLOOP 		;LOOP
	defw	EXPE1-$
	defw	C_DROP
	defw	C_STOP

; --------------
; THE QUERY WORD
; --------------
;   -- 
; 
; Input 80 characters of text (or until a "return") from the operators terminal.
; Text is positioned at the address contained in TIB with IN set to zero.
;
; : QUERY TIB @ 50 EXPECT 0 IN ! ;

W_QUERY:
	defb	$85
	defb	"QUER",'Y'+$80
	defw	W_EXPECT
C_QUERY:
	defw	E_COLON		
	defw	C_TIB
	defw	C_FETCH
	defw	C_LIT
	defw	$50
	defw	C_EXPECT
	defw	C_ZERO
	defw	C_IN
	defw	C_STORE
	defw	C_STOP

; ----------
; THE X WORD
; ----------
; (  --  )
;
; This is pseudonym for the "null" or dictionary entry for a name of one character
; of ascii null. It is the execution proceedure to terminate interpretation of a
; line of text from the terminal or within a disc buffer, as both buffers always
; have a null at the end.
; 
;	BLK @ IF 1 BLK +! 0 IN ! BLK @ B/SCR 1- AND 0=
;	      IF ?EXEC R> DROP ENDIF
;             ELSE R> DROP ;
;

W_NULL:
	defb	$c1
	defb	$80
	defw	W_QUERY
C_NULL:
	defw	E_COLON
	defw	C_BLK
	defw	C_FETCH
	defw	C_0BRANCH 		;IF
	defw	NULL1-$
	defw	C_1
	defw	C_BLK
	defw	C_PLUSSTORE
	defw	C_ZERO
	defw	C_IN
	defw	C_STORE
	defw	C_BLK
	defw	C_FETCH
	defw	C_BSCR
	defw	C_1MINUS		;/
	defw	C_AND
	defw	C_0EQUAL
	defw	C_0BRANCH		;IF
	defw	NULL2-$
	defw	C_QEXEC
	defw	C_FROMR
	defw	C_DROP			;ENDIF
NULL2:	defw	C_BRANCH		;ELSE
	defw	NULL3-$
NULL1:	defw	C_FROMR
	defw	C_DROP			;ENDIF
NULL3:	defw	C_STOP

; -------------
; THE FILL WORD
; -------------
; addr quan b --
; 
; Fill memory at the address with the specified quantity of bytes b.

W_FILL:
	defb	$84               
	defb	"FIL",'L'+$80
	defw	W_NULL
C_FILL:
	defw	E_FILL
E_FILL:
	exx				;/ save IP
	pop	de			;/ (E)<--byte
	pop	bc			;  (BC)<--quantity
	pop	hl			;/ (HL)<--addr
FILL1:	ld	a,b
	or	c			;  QTY=0?
	jr	z,FILL2			;  yes
	ld	(hl),e			;/ ((HL))<--byte
	inc	hl			;  inc pointer
	dec	bc			;  dec counter
	jp	FILL1			;/
FILL2:	exx				;/ RESTORE IP
	jp      NEXT

; --------------
; THE ERASE WORD
; --------------
; addr n --
; 
; Clear a region of memory to zero from addr over n addresses.

W_ERASE:
	defb	$85
	defb	"ERAS",'E'+$80
	defw	W_FILL
C_ERASE:
	defw	E_COLON		
	defw	C_ZERO
	defw	C_FILL
	defw	C_STOP

; ---------------
; THE BLANKS WORD
; ---------------
; addr count --
;
; Fill an area of memory beginning at addr with blanks.

W_BLANKS:
	defb	$86
	defb	"BLANK",'S'+$80
	defw	W_ERASE
C_BLANKS:
	defw	E_COLON		
	defw	C_BL
	defw	C_FILL
	defw	C_STOP

; -------------
; THE HOLD WORD
; -------------
; c  --									L0
; 
; Used between <# and #> to insert an ascii character into a pictured numeric
; output string. e.g. 2E HOLD will place a decimal point.

W_HOLD:
	defb	$84
	defb	"HOL",'D'+$80
	defw	W_BLANKS
C_HOLD:
	defw	E_COLON		
	defw	C_LIT
	defw	-1
	defw	C_HLD
	defw	C_PLUSSTORE
	defw	C_HLD
	defw	C_FETCH
	defw	C_CSTORE
	defw	C_STOP

; ------------
; THE PAD WORD
; ------------
;  -- addr								L0
; 
; Leave the address of the text output buffer, which is a fixed offset above HERE.

W_PAD:
	defb	$83
	defb	"PA",'D'+$80
	defw	W_HOLD
C_PAD:
	defw	E_COLON
	defw	C_HERE
	defw	C_LIT
	defw	$44
	defw	C_PLUS
	defw	C_STOP

; -------------
; THE WORD WORD
; -------------
; c -- 									L0
; 
; Read the next text characters from the input stream being interpreted, until a
; delimiter c is found, storing the packed character string beginning at the
; dictionary buffer HERE. WORD leaves the character count in the first byte, the
; characters, and ends with two or more blanks. Leading occurrences of c are
; ignored.
; If BLK is zero text is taken from the terminal input buffer, otherwise from the
; disc block stored in BLK. See BLK, IN.
;
; : WORD        BLK @ IF BLK @ BLOCK ELSE TIB @ ENDIF
;               IN @ + SWAP ENCLOSE HERE 22 BLANKS IN +!
;               OVER - >R R HERE C! + HERE 1+ R> CMOVE ;
;

W_WORD:
	defb	$84
	defb	"WOR",'D'+$80
	defw	W_PAD
C_WORD:
	defw	E_COLON		
	defw	C_BLK
	defw	C_FETCH
	defw	C_0BRANCH		;IF
	defw	WORD1-$
	defw	C_BLK
	defw	C_FETCH
	defw	C_BLOCK
	defw	C_BRANCH 		;ELSE
	defw	WORD2-$
WORD1:	defw	C_TIB
	defw	C_FETCH
WORD2:	defw	C_IN
	defw	C_FETCH
	defw	C_PLUS
	defw	C_SWAP
	defw	C_ENCLOSE
	defw	C_HERE
	defw	C_LIT
	defw	$22
	defw	C_BLANKS
	defw	C_IN
	defw	C_PLUSSTORE
	defw	C_OVER
	defw	C_MINUS
	defw	C_TOR
	defw	C_RR
	defw	C_HERE
	defw	C_CSTORE
	defw	C_PLUS	
	defw	C_HERE
	defw	C_1PLUS
	defw	C_FROMR
	defw	C_CMOVE
	defw	C_STOP

; -----------------
; THE (NUMBER) WORD
; -----------------
; d1 addr1 -- d2 addr2
; 
; Convert the ascii text beginning at addr1+1 with regard to BASE. The new value
; is accumulated into double number d1, being left as d2.
; Addr2 is the address of the first unconvertable digit. Used by NUMBER.
;
;	BEGIN
;	   1+ DUP >R C@ BASE @ DIGIT
;	WHILE
;	   SWAP BASE @ U* DROP ROT BASE @
;	   U* D+ DPL @ 1+ IF 1 DPL +! ENDIF
;	   R>
;	REPEAT
;	   R> ;
;

W_PNUMBER:
	defb	$88
	defb	"(NUMBER",')'+$80
	defw	W_WORD
C_PNUMBER:
	defw	E_COLON		
PNUM1:	defw	C_1PLUS			;BEGIN
	defw	C_DUP
	defw	C_TOR
	defw	C_CFETCH
	defw	C_BASE
	defw	C_FETCH
	defw	C_DIGIT
	defw	C_0BRANCH		;WHILE
	defw	PNUM2-$
	defw	C_SWAP
	defw	C_BASE
	defw	C_FETCH
	defw	C_USTAR
	defw	C_DROP
	defw	C_ROT
	defw	C_BASE
	defw	C_FETCH
	defw	C_USTAR
	defw	C_DPLUS
	defw	C_DPL
	defw	C_FETCH
	defw	C_1PLUS
	defw	C_0BRANCH		;IF
	defw	PNUM3-$
	defw	C_1
	defw	C_DPL
	defw	C_PLUSSTORE		;ENDIF
PNUM3:	defw	C_FROMR
	defw	C_BRANCH		;REPEAT
	defw	PNUM1-$
PNUM2:	defw	C_FROMR
	defw	C_STOP

; ---------------
; THE NUMBER WORD
; ---------------
; addr -- d
; 
; Convert a character string left at addr with a preceeding count, to a signed
; double number, using the current numeric base. If a decimal point is encountered
; in the text, its position will be given in DPL, but no other effect occurs. If
; numeric conversion is not possible, an error message will be given.
;
;      0 0 ROT DUP 1+ C@ 2D = DUP >R + -1
;      BEGIN
;         DPL ! (NUMBER) DUP C@ BL -
;      WHILE
;         DUP C@ 2E - 0 ?ERROR 0
;      REPEAT
;      DROP R> IF DNEGATE ENDIF ;
;

W_NUMBER:
	defb	$86
	defb	"NUMBE",'R'+$80
	defw	W_PNUMBER
C_NUMBER:
	defw	E_COLON		
	defw	C_ZERO
	defw	C_ZERO
	defw	C_ROT
	defw	C_DUP
	defw	C_1PLUS
	defw	C_CFETCH
	defw	C_LIT
	defw	$002d
	defw	C_EQUAL
	defw	C_DUP
	defw	C_TOR
	defw	C_PLUS
	defw	C_LIT
	defw	-1
NUMB1:	defw	C_DPL			;BEGIN
	defw	C_STORE
	defw	C_PNUMBER
	defw	C_DUP
	defw	C_CFETCH
	defw	C_BL
	defw	C_MINUS
	defw	C_0BRANCH		;WHILE
	defw	NUMB2-$
	defw	C_DUP
	defw	C_CFETCH
	defw	C_LIT
	defw	$2e
	defw	C_MINUS
	defw	C_ZERO
	defw	C_QERROR
	defw	C_ZERO
	defw	C_BRANCH		;REPEAT
	defw	NUMB1-$
NUMB2:	defw	C_DROP
	defw	C_FROMR
	defw	C_0BRANCH		;IF
	defw	NUMB3-$
	defw	C_DNEGATE		;ENDIF
NUMB3:	defw	C_STOP

; --------------
; THE -FIND WORD
; --------------
; --- pfa b tf (found)
; --- ff (not found)
; 
; Accepts the next text word (delimited by blanks) in the input stream to HERE,
; and searches the CONTEXT and then CURRENT vocabularies for a matching entry. If
; found, the dictionary entry's parameter field address, its length byte, and a
; boolean true is left. Otherwise, only a boolean false is left.
;
; : -FIND       BL WORD HERE CONTEXT @ @ (FIND) DUP 0=
;               IF DROP HERE LATEST (FIND) ENDIF ;
;

W_MFIND:
	defb	$85
	defb	"-FIN",'D'+$80
	defw	W_NUMBER
C_MFIND:
	defw	E_COLON		
	defw	C_BL
	defw	C_WORD
	defw	C_HERE
	defw	C_CONTEXT
	defw	C_FETCH
	defw	C_FETCH
	defw	C_PFIND
	defw	C_DUP
	defw	C_0EQUAL
	defw	C_0BRANCH		;IF
	defw	DFIN1-$
	defw	C_DROP
	defw	C_HERE
	defw	C_LATEST
	defw	C_PFIND			;ENDIF
DFIN1:	defw	C_STOP

; ----------------
; THE (ABORT) WORD
; ----------------
;   -- 
; 
; Executes after an error when WARNING is -1. This word normally executes ABORT,
; but may be altered (with care) to a user's alternative procedure.
;
;	ABORT ;
;

W_CABORT:
	defb	$87
	defb	"(ABORT",')'+$80
	defw	W_MFIND
C_CABORT:
	defw	E_COLON		
	defw	C_ABORT
	defw	C_STOP

; --------------
; THE ERROR WORD
; --------------
; line --- in blk
; 
; Execute error notification and restart of system. WARNING is first examined. If
; 1, the text of line n, relative to screen 4 of drive 0 is printed. This line
; number may be positive or negative, and beyond just screen 4. If WARNING=0, n is
; just printed as a message number (non disc installation). If WARNING is -1, the
; definition (ABORT) is executed, which executes the system ABORT. The user may
; cautiously modify this execution by altering (ABORT).
; fig-FORTH saves the contents of IN and BLK to assist in determining the location
; of the error. Final action is execution of QUIT.
;
;	WARNING @ 0< IF (ABORT) ENDIF HERE COUNT
;	TYPE ." ? " MESSAGE SP! BLK @ -DUP
;	IF IN @ SWAP ENDIF QUIT ;
;

W_ERROR:
	defb	$85
	defb	"ERRO",'R'+$80
	defw	W_CABORT
C_ERROR:
	defw	E_COLON		
	defw	C_WARNING
	defw	C_FETCH
	defw	C_0LESS
	defw	C_0BRANCH 		;IF
	defw	ERRO1-$
	defw	C_CABORT		;ENDIF
ERRO1:	defw	C_HERE
	defw	C_COUNT
	defw	C_TYPE
	defw	C_CQUOTE
	defb	$02,"? "
	defw	C_MESSAGE
	defw	C_SPSTORE
	defw	C_BLK
	defw	C_FETCH
	defw	C_QUERYDUP
	defw	C_0BRANCH	 	;IF
	defw	ERRO2-$
	defw	C_IN
	defw	C_FETCH
	defw	C_SWAP	 		;ENDIF
ERRO2:	defw	C_QUIT

; ------------
; THE ID. WORD
; ------------
; addr --
; 
; Print a definition's name from its name field address.

W_ID:
	defb	$83
	defb	"ID",'.'+$80
	defw	W_ERROR
C_ID:
	defw	E_COLON
	defw	C_PAD
	defw	C_LIT
	defw	$20
	defw	C_BLANKS		;/
	defw	C_DUP
	defw	C_PFA
	defw	C_LFA
	defw	C_OVER
	defw	C_MINUS
	defw	C_DUP 			;/ change frm MODEL
	defw	C_TOR			;/ to suppress BIT 7
	defw	C_PAD
	defw	C_SWAP
	defw	C_CMOVE
	defw	C_PAD
	defw	C_FROMR			;/ for terminals
	defw	C_PAD			;/ with an 8 bit
	defw	C_PLUS			;/ ASCCI character set.
	defw	C_1MINUS		;/
	defw	C_DUP			;/
	defw	C_FETCH			;/
	defw	C_LIT			;/
	defw	7fh			;/
	defw	C_AND			;/
	defw	C_SWAP			;/
	defw	C_STORE			;/
	defw	C_COUNT
	defw	C_LIT
	defw	$1f
	defw	C_AND
	defw	C_TYPE
	defw	C_SPACE
	defw	C_STOP

; ---------------
; THE CREATE WORD
; ---------------
;   -- 
; 
; A defining word used in the form:
;      CREATE cccc
; by such words as CODE and CONSTANT to create a dictionary header for a Forth
; definition. The code field contains the address of the words parameter field.
; The new word is created in the CURRENT vocabulary.
;
;	-FIND IF DROP NFA ID. 4 MESSAGE SPACE ENDIF
;	HERE DUP C@ WIDTH @ MIN 1+ ALLOT DUP A0 TOGGLE
;	HERE 1- 80 TOGGLE LATEST , CURRENT @ ! HERE
;	2+ , ;
;

W_CREATE:
	defb	$86
	defb	"CREAT",'E'+$80
	defw	W_ID
C_CREATE:
	defw	E_COLON		
	defw	C_MFIND
	defw	C_0BRANCH		;IF
	defw	CREA1-$
	defw	C_DROP
	defw	C_NFA
	defw	C_ID
	defw	C_LIT
	defw	4
	defw	C_MESSAGE
	defw	C_SPACE			;ENDIF
CREA1:	defw	C_HERE
	defw	C_DUP
	defw	C_CFETCH
	defw	C_WIDTH
	defw	C_FETCH
	defw	C_MIN
	defw	C_1PLUS
	defw	C_ALLOT
	defw	C_DUP
	defw	C_LIT
	defw	$a0
	defw	C_TOGGLE
	defw	C_HERE
	defw	C_1MINUS
	defw	C_LIT
	defw	$80
	defw	C_TOGGLE
	defw	C_LATEST
	defw	C_COMMA
	defw	C_CURRENT
	defw	C_FETCH
	defw	C_STORE
	defw	C_HERE
	defw	C_2PLUS
	defw	C_COMMA
	defw	C_STOP

; ------------------
; THE [COMPILE] WORD
; ------------------
;   --  								P,C
;   -FIND 0= 0 ?ERROR DROP CFA , ; IMMEDIATE 
; Used in a colon-definition in form:
;     :  xxx    [COMPILE]   FORTH   ;
; [COMPILE] will force the compilation of an immediate definitions, that would
; otherwise execute during compilation. The above example will select the FORTH
; vocabulary then xxx executes, rather than at compile time.

W_CCOMPILE:
	defb	$c9
	defb	"[COMPILE",']'+$80
	defw	W_CREATE
C_CCOMPILE:
	defw	E_COLON		
	defw	C_MFIND
	defw	C_0EQUAL
	defw	C_ZERO
	defw	C_QERROR
	defw	C_DROP
	defw	C_CFA
	defw	C_COMMA
	defw	C_STOP

; ----------------
; THE LITERAL WORD
; ----------------
; n -- (compiling)							P,C2,L0
; 
; If compiling, then compile the stack value n as a 16 bit literal.
; This definition is immediate so that it will execute during a colon definition.
; The intended use is:
;    : xxx    [ calculate ]  LITERAL  ;
; Compilation is suspended for the compile time calculation of n value.
; Compilation is resumed and LITERAL compiles this value.
;
;      STATE @ IF COMPILE LIT , ENDIF ; IMMEDIATE
;

W_LITERAL:
	defb	$c7
	defb	"LITERA",'L'+$80
	defw	W_CCOMPILE
C_LITERAL:
	defw	E_COLON		
	defw	C_STATE
	defw	C_FETCH
	defw	C_0BRANCH		;IF
	defw	LITE1-$
	defw	C_COMPILE
	defw	C_LIT
	defw	C_COMMA			;ENDIF
LITE1:	defw	C_STOP

; -----------------
; THE DLITERAL WORD
; -----------------
; d -- d (executing)							P
; d --- (compiling)
; 
; If compiling, compile a stack double number into a literal. Later execution of
; the definition containing the literal will push it to the stack. If executing,
; the number will remain on the stack.
;
;     STATE @ IF SWAP LITERAL LITERAL ENDIF ;
;

W_DLITERAL:
	defb	$c8
	defb	"DLITERA",'L'+$80
	defw	W_LITERAL
C_DLITERAL:
	defw	E_COLON		
	defw	C_STATE
	defw	C_FETCH
	defw	C_0BRANCH		;IF
	defw	DLIT1-$
	defw	C_SWAP
	defw	C_LITERAL
	defw	C_LITERAL		;ENDIF
DLIT1:	defw	C_STOP

; ---------------
; THE ?STACK WORD
; ---------------
;   --  
; 
; Issue an error message if the stack is out of bounds. This definition may be
; installation dependent.
;
;       SP@ S0 @ SWAP U< 1 ?ERROR SP@ HERE 80 + U< 7 ?ERROR ;
;

W_QSTACK:
	defb	$86
	defb	"?STAC",'K'+$80
	defw	W_DLITERAL
C_QSTACK:
	defw	E_COLON
	defw	C_SPFETCH
	defw	C_S0
	defw	C_FETCH
	defw	C_SWAP
	defw	C_ULESS
	defw	C_1
	defw	C_QERROR
	defw	C_SPFETCH
	defw	C_HERE
	defw	C_LIT
	defw	$80
	defw	C_PLUS
	defw	C_ULESS
	defw	C_LIT
	defw	$07
	defw	C_QERROR
	defw	C_STOP

; ------------------
; THE INTERPRET WORD
; ------------------
;   --  
; 
; The outer text interpreter which sequentially executes or compiles text from the
; input stream (terminal or disc) depending on STATE. If the word name cannot be
; found after a search of CONTEXT and then CURRENT it is converted to a number
; according to the current base.
; That also failing, an error message echoing the name with a " ?" will be given.
; Text input will be taken according to the convention for WORD. If a decimal point 
; is found as part of a number, a double number value will be left. The decimal
; point has no other purpose than to force this action. See NUMBER.
;
;       BEGIN
;          -FIND IF STATE @ < IF CFA ,
;                             ELSE CFA EXECUTE ENDIF
;                ELSE HERE NUMBER DPL @ 1+ IF DLITERAL
;                                          ELSE DROP LITERAL ENDIF
;                ENDIF
;          ?STACK
;       AGAIN ;
;

W_INTERPRET:
	defb	$89
	defb	"INTERPRE",'T'+$80
	defw	W_QSTACK
C_INTERPRET:
 	defw	E_COLON		
INTE1:	defw	C_MFIND			;BEGIN
	defw	C_0BRANCH 		;IF
	defw	INTE2-$
	defw	C_STATE
	defw	C_FETCH
	defw	C_LESS
	defw	C_0BRANCH		;IF
	defw	INTE3-$
	defw	C_CFA
	defw	C_COMMA
	defw	C_BRANCH		;ELSE
	defw	INTE4-$
INTE3:	defw	C_CFA
	defw	C_EXECUTE 		;ENDIF
INTE4:	defw	C_BRANCH 		;ELSE
	defw	INTE5-$
INTE2:	defw	C_HERE
	defw	C_NUMBER
	defw	C_DPL
	defw	C_FETCH
	defw	C_1PLUS
	defw	C_0BRANCH		;IF
	defw	INTE6-$
	defw	C_DLITERAL
	defw	C_BRANCH 		;ELSE
	defw	INTE5-$
INTE6:	defw	C_DROP
	defw	C_LITERAL		;ENDIF
INTE5:	defw	C_QSTACK  		;ENDIF
	defw	C_BRANCH   		;AGAIN
	defw	INTE1-$

; ------------------
; THE IMMEDIATE WORD
; ------------------
;   -- 
; 
; Mark the most recently made definition so that when encountered at compile time,
; it will be executed rather than being compiled. i.e. the precedence bit in its
; header is set.
; This method allows definitions to handle unusual compiling situations, rather
; than build them into the fundamental compiler.
; The user may force compilation of an immediate definition by preceeding it with
; [COMPILE].

W_IMMEDIATE:
	defb	$89
	defb	"IMMEDIAT",'E'+$80
	defw	W_INTERPRET
C_IMMEDIATE:
	defw	E_COLON		
	defw	C_LATEST
	defw	C_LIT
	defw	$40
	defw	C_TOGGLE
	defw	C_STOP

; -------------------
; THE VOCABULARY WORD
; -------------------
;   -- 									E,L
; 
; A defining word used in the form:
;      VOCABULARY cccc
; to create a vocabulary definition cccc. Subsequent use of cccc will make it the
; CONTEXT vocabulary which is searched first by INTERPRET.
; The sequence "cccc DEFINITIONS" will also make cccc the CURRENT vocabulary into
; which new definitions are placed.
;
; In fig-FORTH, cccc will be so chained as to include all definitions of the
; vocabulary in which cccc is itself defined. All vocabularys ultimately chain to
; Forth. By convention, vocabulary names are to be declared IMMEDIATE. See 
; VOC-LINK.

W_VOCABULARY:
	defb	$8a
	defb	"VOCABULAR",'Y'+$80
	defw	W_IMMEDIATE
C_VOCABULARY:
	defw	E_COLON		
	defw	C_BUILDS
	defw	C_LIT
	defw	$a081
	defw	C_COMMA
	defw	C_CURRENT
	defw	C_FETCH
	defw	C_CFA
	defw	C_COMMA
	defw	C_HERE
	defw	C_VOC_LINK
	defw	C_FETCH
	defw	C_COMMA
	defw	C_VOC_LINK
	defw	C_STORE
	defw	C_DOES

C_LINK:	defw	C_2PLUS
	defw	C_CONTEXT
	defw	C_STORE
	defw	C_STOP

; --------------
; THE FORTH WORD
; --------------
;   -- 									P,L1
; 
; The name of the primary vocabulary.
; Execution makes FORTH the CONTEXT vocabulary. Until additional user vocabularies
; are defined, new user definitions become a part of FORTH. FORTH is immediate, so
; it will execute during the creation of a colon-definition, to select this
; vocabulary at compile time.

W_FORTH:
	defb	$c5
	defb	"FORT",'H'+$80
	defw	W_VOCABULARY
C_FORTH:
	defw	X_DOES
	defw	C_LINK

	defb	$81,' '+$80
L_FORTH:
	defw	W_TASK		;COLD start value only.
				;Changed each time a def is append to the
				;FORTH vocabulary list
E_FORTH:
	defw	$0000		;end of vocabulary list

; --------------------
; THE DEFINITIONS WORD
; --------------------
;   -- 									L1
; 
; Used in the form:
;      cccc DEFINITIONS
; Set the CURRENT vocabulary to the CONTEXT vocabulary. In the example, executing
; vocabulary name cccc made it the CONTEXT vocabulary and executing DEFINITIONS
; made both specify vocabulary cccc.

W_DEFINITIONS:
	defb	$8b
	defb	"DEFINITION",'S'+$80
	defw	W_FORTH
C_DEFINITIONS:
	defw	E_COLON		
	defw	C_CONTEXT
	defw	C_FETCH
	defw	C_CURRENT
	defw	C_STORE
	defw	C_STOP

; ----------
; THE ( WORD
; ----------
;   -- 									P,L0
; 
; Used in the form:
;     ( cccc)
; Ignore a comment that will be delimited by a right parenthesis on the same line.
; May occur during execution or in a colon-definition. A blank after the leading
; parenthesis is required.

W_OPENBRKT:
	defb	$c1
	defb	'('+$80
	defw	W_DEFINITIONS
C_OPENBRKT:
	defw	E_COLON
	defw	C_LIT
	defw	$29
	defw	C_WORD
	defw	C_STOP

; -------------
; THE QUIT WORD
; -------------
;   -- 
; 
; Clear the return stack, stop compilation, and return control to the operators
; terminal. No message is given.
;
; : QUIT 0 BLK ! [
;	 BEGIN
;	     RP! CR QUERY
;	     INTERPRET
;	     STATE @ 0= IF ." OK" ENDIF
;	 AGAIN ;

W_QUIT:
	defb	$84
	defb	"QUI",'T'+$80
	defw	W_OPENBRKT
C_QUIT:
	defw	E_COLON
	defw	C_ZERO
	defw	C_BLK
	defw	C_STORE
	defw	C_LEFTBRKT
QUIT1:	defw	C_RPSTORE		;BEGIN
	defw	C_CR
	defw	C_QUERY
	defw	C_INTERPRET
	defw	C_STATE
	defw	C_FETCH
	defw	C_0EQUAL
	defw	C_0BRANCH   		;IF
	defw	QUIT2-$
	defw	C_CQUOTE
	defb	$02
	defb	"OK"   			;ENDIF
QUIT2:	defw	C_BRANCH 		;AGAIN
	defw	QUIT1-$

; --------------
; THE ABORT WORD
; --------------
;   -- 									L0
; 
; Clear the stacks and enter the execution state. Return control to the operators
; terminal, printing a message appropriate to the installation.
;
; : ABORT SP! DECIMAL ?STACK
;	  CR .CPU ." FIG-FORTH 1.1H"
;	  CR ." BY KELLY A. MURTA - 2009"
;	  CR MEM
;	  FORTH DEFINITIONS
;	  QUIT ;

W_ABORT:
	defb	$85
	defb	"ABOR",'T'+$80
	defw	W_QUIT
C_ABORT:
	defw	E_COLON		
	defw	C_SPSTORE
	defw	C_DECIMAL
	defw	C_QSTACK
	defw	C_CR
	defw	C_DOTCPU
	defw	C_CQUOTE
	defb	$0e,"FIG-FORTH "
	defb	FIGREL+30H,ADOT,FIGREV+30H,USRVER
	defw	C_CR
	defw	C_CQUOTE
	defb	$18,"BY KELLY A. MURTA - 2009"
	defw	C_CR
	defw	C_MEM
	defw	C_FORTH
	defw	C_DEFINITIONS
	defw	C_QUIT

X_WARM:
	ld      bc,WRM1
	jp      NEXT
WRM1:	defw	C_WARM

; -------------
; THE WARM WORD
; -------------
;   -- 
; 
; Restart w. clean stacks and decimal base. WARNING is set to 1 if drive 0 file
; accessible, else -1.
;
; : WARM EMPTY-BUFFERS
;	 ABORT ;

W_WARM:
	defb	$84
	defb	"WAR",'M'+$80
	defw	W_ABORT
C_WARM:
	defw	E_COLON		
	defw	C_EBUFFERS
	defw	C_ABORT

X_COLD:
	ld	hl,$0000	;/  last RAM position
;	LD	L,0		;/ (HL)<--FBASE
	ld	(C_LIMIT+2),hl	;/ set LIMIT
	ld	de,BUFSIZ	;/ (DE)<--total disc buffer size
	or	a		;/ clr carry
	sbc	hl,de		;/ (HL)<--addr. of 1st disc buffer
	ld	(C_FIRST+2),hl	;/ set FIRST
	LD	(C_USE+2),HL	;/ set USE
	LD	(C_PREV+2),HL	;/ set PREV
	ld	(BUF1),hl	;/
	ld	de,US		;/ (DE)<--user variable space
	sbc	hl,de		;/ (HL)<--INITR0
	ld	(UPINIT),hl	;/
	ld	(R0INIT),hl	;/
	ld	(UP),hl		;/
	ld	(RPP),hl	;/
	ld	de,RTS		;/ (DE)<--return stack & terminal buffer space
	sbc	hl,de		;/ (HL)<--INITS0
	ld	(S0INIT),hl	;/
	ld	(TIBINI),hl	;/
	ld	sp,hl		;/
	ld	bc,CLD1
	jp      NEXT

CLD1: 	defw	C_COLD

; -------------
; THE COLD WORD
; -------------
;   --  
; 
; The cold start procedure to adjust the dictionary pointer to the minimum
; standard and restart via ABORT.
; May be called from the terminal to remove application programs and restart.
;
; : COLD EMPTY-BUFFERS
;	 0 OFFSET ! 12 +ORIGIN up @ 6 + 10 CMOVE
;        0C +ORIGIN @ l_forth ! ABORT ;

W_COLD:
	defb	$84
	defb	"COL",'D'+$80
	defw	W_WARM
C_COLD:
	defw	E_COLON
	defw	C_EBUFFERS
	defw	C_ZERO
	defw	C_OFFSET
	defw	C_STORE
	defw	C_LIT
	defw	ORIG+12h
	defw	C_LIT
	defw	UP
	defw	C_FETCH
	defw	C_LIT
	defw	$06
	defw	C_PLUS
	defw	C_LIT
	defw	$10
	defw	C_CMOVE
	defw	C_LIT
	defw	ORIG+0ch
	defw	C_FETCH
	defw	C_LIT
	defw	L_FORTH
	defw	C_STORE
	defw	C_ABORT

; -------------
; THE S->D WORD
; -------------
; n  --  d
; 
; Sign extend a single number to form a double number.

W_SIGNTODUB:
	defb	$84
	defb	"S->",'D'+$80
	defw	W_COLD
C_SIGNTODUB:
	defw	E_SIGNTODUB
E_SIGNTODUB:
	pop     de
	ld	hl,0
	bit	7,d			;/ # negative?
	jr	z,STOD1			;  no
	dec	hl			;  yes, extend sign
STOD1:	jp	DPUSH			;  ( n1--d1L d1H)

; -----------
; THE +- WORD
; -----------
; n1 n2  --  n3
; 
; Apply the sign of n2 to n1, which is left as n3.

W_PLUSMINUS:
	defb	$82
	defb	"+",'-'+$80
	defw	W_SIGNTODUB
C_PLUSMINUS:
	defw	E_COLON		
	defw	C_0LESS
	defw	C_0BRANCH		;IF
	defw	PM1-$
	defw	C_NEGATE		;ENDIF
PM1:	defw	C_STOP

; ------------
; THE D+- WORD
; ------------
; d1  n  --  d2
; 
; Apply the sign of n to the double number d1, leaving it as d2.

W_DPLUSMINUS:
	defb	$83
	defb	"D+",'-'+$80
	defw	W_PLUSMINUS
C_DPLUSMINUS:
	defw	E_COLON		
	defw	C_0LESS
	defw	C_0BRANCH 		;IF
	defw	DPM1-$
	defw	C_DNEGATE		;ENDIF
DPM1:	defw	C_STOP

; ------------
; THE ABS WORD
; ------------
; n  --  u 								L0
; 
; Leave the absolute value of n as u.

W_ABS:
	defb	$83
	defb	"AB",'S'+$80
	defw	W_DPLUSMINUS
C_ABS:
	defw	E_COLON		
	defw	C_DUP
	defw	C_PLUSMINUS
	defw	C_STOP

; -------------
; THE DABS WORD
; -------------
; d --- ud
; 
; Leave the absolute value ud of a double number.

W_DABS:
	defb	$84
	defb	"DAB",'S'+$80
	defw	W_ABS
C_DABS:
	defw	E_COLON		
	defw	C_DUP
	defw	C_DPLUSMINUS
	defw	C_STOP

; ------------
; THE MIN WORD
; ------------
; n1 n2  --  min 							L0
; 
; Leave the smaller of two numbers.

W_MIN:
	defb	$83
	defb	"MI",'N'+$80
	defw	W_DABS
C_MIN:
	defw	E_COLON
	defw	C_2DUP
	defw	C_GREATER
	defw	C_0BRANCH		;IF
	defw	MIN1-$
	defw	C_SWAP 			;ENDIF
MIN1:	defw	C_DROP
	defw	C_STOP

; ------------
; THE MAX WORD
; ------------
; n1 n2 --  max 							L0
; 
; Leave the greater of two numbers.

W_MAX:
	defb	$83
	defb	"MA",'X'+$80
	defw	W_MIN
C_MAX:
	defw	E_COLON		
	defw	C_2DUP
	defw	C_LESS
	defw	C_0BRANCH 		;IF
	defw	MAX1-$
	defw	C_SWAP 			;ENDIF
MAX1:	defw	C_DROP
	defw	C_STOP

; -----------
; THE M* WORD
; -----------
; n1 n2 --  d
; 
; A mixed magnitude math operation which leaves the double number signed product
; of two signed number.

W_MTIMES:
	defb	$82
	defb	"M",'*'+$80
	defw	W_MAX
C_MTIMES:
	defw	E_COLON		
	defw	C_2DUP
	defw	C_XOR
	defw	C_TOR
	defw	C_ABS
	defw	C_SWAP
	defw	C_ABS
	defw	C_USTAR
	defw	C_FROMR
	defw	C_DPLUSMINUS
	defw	C_STOP

; -----------
; THE M/ WORD
; -----------
; d n1 -- n2 n3
; 
; A mixed magnitude math operator which leaves the signed remainder n2 and signed
; quotient n3 from a double number dividend and divisor n1.
; The  remainder takes its sign from the dividend.

W_MDIV:
	defb	$82
	defb	"M",'/'+$80
	defw	W_MTIMES
C_MDIV:
	defw	E_COLON		
	defw	C_OVER
	defw	C_TOR
	defw	C_TOR
	defw	C_DABS
	defw	C_RR
	defw	C_ABS
	defw	C_UDIVMOD
	defw	C_FROMR
	defw	C_RR
	defw	C_XOR
	defw	C_PLUSMINUS
	defw	C_SWAP
	defw	C_FROMR
	defw	C_PLUSMINUS
	defw	C_SWAP
	defw	C_STOP

; ----------
; THE * WORD
; ----------
; n1 n2 -- prod								L0
; 
; Leave the signed product of two signed numbers.

W_TIMES:
	defb	$81
	defb	'*'+$80
	defw	W_MDIV
C_TIMES:
	defw	E_TIMES
E_TIMES:
	exx			;/ save IP
	pop	hl
	pop	de
	ld	a,l		;/
	ld	c,h		;/
	ld	b,10h		;/
	ld	hl,0		;/
STAR1:	srl	c		;/
	rra			;/ SRL CA  (MPCATOR)
	jr	nc,STAR2	;/ LSB (CA)=0?
	add	hl,de		;/ no, add mpcant to HL
STAR2:	sla	e		;/
	rl	d		;/ SLA DE  (MPCANT 2 *)
	djnz	STAR1		;/ do all 16 bits
	push	hl		;/ (S1)<--product
	exx			;/ restore IP
	jp      NEXT

; -------------
; THE /MOD WORD
; -------------
; n1 n2 -- rem quot							L0
; 
; Leave the remainder and signed quotient of n1/n2. The remainder has the sign of
; the dividend.

W_DIVMOD:
	defb	$84
	defb	"/MO",'D'+$80
	defw	W_TIMES
C_DIVMOD:
	defw	E_DIVMOD
E_DIVMOD:
	pop     de
	pop     hl
	push    bc
	bit     7,d
	jr      z,DIVMOD1
	push    de
	ex      de,hl
	ld      hl,0
	or      a
	sbc     hl,de
	ld      a,l
	ld      c,h
	pop     de
	ld      hl,0
	or      a
	sbc     hl,de
	ex      de,hl
	jr      DIVMOD3
DIVMOD1:
	ld      a,d
	or      e
	jr      nz,DIVMOD2
	ld      hl,-1
	ld      d,h
	ld      e,l
	jr      DIVMOD6
DIVMOD2:
	ld      a,l
	ld      c,h
DIVMOD3:
	ld      hl,0
	ld      b,$10
DIVMOD4:
	rla
	rl      c
	adc     hl,hl
	sbc     hl,de
	jr      nc,DIVMOD5
	add     hl,de
DIVMOD5:
	ccf
	djnz    DIVMOD4
	rla     
	rl      c
	ld      e,a
	ld      d,c
DIVMOD6:
	pop     bc
	ex      de,hl
	jp      DPUSH

; ----------
; THE / WORD
; ----------
; n1 n2 -- quot								L0
; 
; Leave the signed quotient of n1/n2.

W_DIV:
	defb	$81
	defb	'/'+$80
	defw	W_DIVMOD
C_DIV:
	defw	E_COLON		
	defw	C_DIVMOD
	defw	C_SWAP
	defw	C_DROP
	defw	C_STOP

; ------------
; THE MOD WORD
; ------------
; n1 n2 -- mod 								L0
; 
; Leave the remainder of n1/n2, with the same sign as n1.

W_MOD:
	defb	$83
	defb	"MO",'D'+$80
	defw	W_DIV
C_MOD:
	defw	E_COLON		
	defw	C_DIVMOD
	defw	C_DROP
	defw	C_STOP

; --------------
; THE */MOD WORD
; --------------
; n1 n2 n3 -- n4 n5							L0
; 
; Leave the quotient n5 and remainder n4 of the operation n1*n2/n3.
; A 31 bit intermediate product is used as for */.

W_TIMESDIVMOD:
	defb	$85
	defb	"*/MO",'D'+$80
	defw	W_MOD
C_TIMESDIVMOD:
	defw	E_COLON
	defw	C_TOR
	defw	C_MTIMES
	defw	C_FROMR
	defw	C_MDIV
	defw	C_STOP

; -----------
; THE */ WORD
; -----------
; n1 n2 n3 -- n4							L0
; 
; Leave the ratio n4 = n1*n2/n3 where all are signed numbers.
; Retention of an intermediate 31 bit product permits greater accuracy than would
; be available with the sequence:
;     n1  n2  *  n3  /

W_TIMESDIV:
	defb	$82
	defb	"*",'/'+$80
	defw	W_TIMESDIVMOD
C_TIMESDIV:
	defw	E_COLON		
	defw	C_TIMESDIVMOD
	defw	C_SWAP
	defw	C_DROP
	defw	C_STOP

; --------------
; THE M/MOD WORD
; --------------
; ud1 u2 --- u3 ud4
; 
; An unsigned mixed magnitude math operation which leaves a double quotient ud4
; and remainder u3, from a double dividend ud1 and single divisor u2.

W_MDIVMOD:
	defb	$85
	defb	"M/MO",'D'+$80
	defw	W_TIMESDIV
C_MDIVMOD:
	defw	E_COLON		
	defw	C_TOR
	defw	C_ZERO
	defw	C_RR
	defw	C_UDIVMOD
	defw	C_FROMR
	defw	C_SWAP
	defw	C_TOR
	defw	C_UDIVMOD
	defw	C_FROMR
	defw	C_STOP

; ---------------
; THE (LINE) WORD
; ---------------
; n1 n2 --- addr count
; 
; Convert the line number n1 and the screen n2 to the disc buffer address
; containing the data. A count of 64 indicates the full line text length.

W_CLINE:
	defb	$86
	defb	"(LINE",')'+$80
	defw	W_MDIVMOD
C_CLINE:
	defw	E_COLON
	defw	C_TOR
        defw	C_CL
        defw	C_BBUF
        defw	C_TIMESDIVMOD
        defw	C_FROMR
        defw	C_BSCR
        defw	C_TIMES
        defw	C_PLUS
	defw	C_BLOCK
	defw	C_PLUS
	defw	C_CL
	defw	C_STOP

; --------------
; THE .LINE WORD
; --------------
; line scr -- 								P
; 
; Print to stdout, a line of text from disc by its line and screen number, w.o.
; trailing blanks.

W_DOTLINE:
	defb	$85
	defb	".LIN",'E'+$80
	defw	W_CLINE
C_DOTLINE:
	defw	E_COLON		
	defw	C_CLINE
	defw	C_TRAILING
	defw	C_TYPE
	defw	C_STOP

; ----------------
; THE MESSAGE WORD
; ----------------
; n --
; 
; Print on the selected output device the text of line n relative to screen 4 of
; drive 0. n may be positive or negative. MESSAGE may be used to print incidental
; text such as report headers. If WARNING is zero, the message will simply be
; printed as a number (disc unavailable).

W_MESSAGE:
	defb	$87
	defb	"MESSAG",'E'+$80
	defw	W_DOTLINE
C_MESSAGE:
	defw	E_COLON
	defw	C_WARNING
	defw	C_FETCH
	defw	C_0BRANCH 		;IF
	defw	MESS1-$
	defw	C_QUERYDUP
	defw	C_0BRANCH		;IF
	defw	MESS2-$
	defw	C_LIT
	defw	4  			;1st MESSAGE SCREEN
	defw	C_OFFSET
	defw	C_FETCH
	defw	C_BSCR
	defw	C_DIV
	defw	C_MINUS
	defw	C_DOTLINE
	defw	C_SPACE 		;ENDIF
MESS2:	defw	C_BRANCH   		;ELSE
	defw    MESS3-$
MESS1:	defw	C_CQUOTE
	defb	$06,"MSG # "
	defw	C_DOT
MESS3:	defw	C_STOP

; -----------
; THE P@ WORD
; -----------
; n -- b
; 

W_PORTIN:
	defb	$82
	defb	"P",'@'+$80
	defw	W_MESSAGE
C_PORTIN:
	defw	E_PORTIN
E_PORTIN:
	exx				;d SAVE REGISTERS
	pop	bc     			;d (BC)<--PORT#
	in	l,(c)  			;d (L)<--DATA BYTE
	ld	h,0
	push	hl
	exx 				;d RESTORE REGISTERS
	jp      NEXT

; -----------
; THE P! WORD
; -----------
; b n --
; 

W_PORTOUT:
	defb    $82
	defb    "P",'!'+$80
	defw    W_PORTIN
C_PORTOUT:
	defw    E_PORTOUT
E_PORTOUT:
	exx				;d SAVE REGISTERS
	pop	bc 			;d (C)<--PORT#
	pop	hl 			;d (L)<--DATA BYTE
	out	(c),l
	exx  	 			;d RESTORE REGISTERS
	jp      NEXT

; ------------
; THE USE WORD
; ------------
;  ---  addr								U
; 
; A user variable that holds the address of the mass storage buffer to use

W_USE:
	defb	$83
	defb	"US",'E'+$80
	defw	W_PORTOUT
C_USE:
	defw	X_VARIABLE		;/ initialised by CLD
	defb	0
	
; -------------
; THE PREV WORD
; -------------
;  ---  addr								U
; 
; A user variable that holds the address of the mass storage buffer just used

W_PREV:
	defb	$84
	defb	"PRE",'V'+$80
	defw	W_USE
C_PREV:
	defw	X_VARIABLE		;/ initialised by CLD
	defb	0

; --------------
; THE #BUFF WORD
; --------------
;  ---  n								U
; 
; A constant that leaves the number of block buffers. Because a buffer that is
; being interpreted is locked in memory, this is also a limit to the nesting
; depth of blocks loading other blocks.

W_NBUFF:
	defb	$85
	defb	"#BUF",'F'+$80
	defw	W_PREV
C_NBUFF:
	defw	X_CONSTANT
	defb	NBUF

; -------------
; THE +BUF WORD
; -------------
; addr1 --- addr2 ff								U
; 
; Advance the disc buffer address addr1 to the address of the next buffer addr2.
; Boolean ff is false when addr2 is the buffer presently pointed to by variable PREV.

W_PBUF:
	defb	$84
	defb	"+BU",'F'+$80
	defw	W_NBUFF
C_PBUF:
	defw	E_COLON
	defw	C_LIT,CO
	defw	C_PLUS
	defw	C_DUP
	defw	C_LIMIT
	defw	C_EQUAL
	defw	C_0BRANCH
	defw	PBUF1-$
	defw	C_DROP
	defw	C_FIRST
PBUF1:	defw	C_DUP
	defw	C_PREV
	defw	C_FETCH
	defw	C_MINUS
	defw	C_STOP

; ---------------
; THE UPDATE WORD
; ---------------
;   ---  								U
; 
; Marks the most recently referenced block (pointed to by PREV ) as altered. The block
; will subsequently be transferred automatically to disc should its buffer be required
; for storage of a different block. In fact the block is transferred to disk immediately

W_UPDATE:
	defb	$86
	defb	"UPDAT",'E'+$80
	defw	W_PBUF
C_UPDATE:
	defw	E_COLON
	defw	C_PREV
	defw	C_FETCH
	defw	C_FETCH
	defw	C_LIT,$8000
	defw	C_OR
	defw	C_PREV
	defw	C_FETCH
	defw	C_STORE
	defw	C_STOP

; ----------------------
; THE EMPTY-BUFFERS WORD
; ----------------------
;   -- 									L0
;
; Mark all block-buffers as empty, not necessarily affecting the contents.
; Updated blocks are not written to the disc. This is also an initialization
; procedure before first use of the disc.

W_EBUFFERS:
	defb	$8d
	defb	"EMPTY-BUFFER",'S'+$80
	defw	W_UPDATE
C_EBUFFERS:
	defw	E_COLON		
	defw	C_FIRST
	defw	C_LIMIT
	defw	C_OVER
	defw	C_MINUS
	defw	C_ERASE
	defw	C_STOP

; ---------------
; THE BUFFER WORD
; ---------------
;   -- 									L0
;

W_BUFFER:
	defb	$86
	defb	"BUFFE",'R'+$80
	defw	W_EBUFFERS
C_BUFFER:
	defw	E_COLON
	defw	C_USE,C_FETCH
	defw	C_DUP,C_TOR
BUFF1:	defw	C_PBUF			;won't work if single buffer
	defw	C_0BRANCH,BUFF1-$
	defw	C_USE,C_STORE
	defw	C_RR,C_FETCH
        defw	C_0LESS
	defw	C_0BRANCH,BUFF2-$
	defw	C_RR,C_2PLUS
	defw	C_RR,C_FETCH
	defw	C_LIT,$7fff
	defw	C_AND,C_ZERO
	defw	C_RW
BUFF2:	defw	C_RR,C_STORE
	defw	C_RR,C_PREV
	defw	C_STORE,C_FROMR
	defw	C_2PLUS
	defw	C_STOP

; --------------
; THE BLOCK WORD
; --------------
; n -- addr								L0
; 
; Leave the memory address of the block buffer containing block n. If the block is
; not already in memory, it is transferred from disc to which ever buffer Was
; least recently written. If the block occupying that buffer has been marked as
; updated, it is rewritten to disc before block n is read into the buffer.
; See also BUFFER, R/W, FLUSH

W_BLOCK:
	defb	$85
	defb	"BLOC",'K'+$80
	defw	W_BUFFER
C_BLOCK:
	defw	E_COLON		
	defw	C_OFFSET,C_FETCH
	defw	C_PLUS,C_TOR
	defw	C_PREV,C_FETCH
	defw	C_DUP,C_FETCH
	defw	C_RR,C_MINUS
	defw	C_DUP,C_PLUS
	defw	C_0BRANCH,BLOC1-$
BLOC2:	defw	C_PBUF,C_0EQUAL
	defw	C_0BRANCH,BLOC3-$
	defw	C_DROP,C_RR
	defw	C_BUFFER,C_DUP
	defw	C_RR,C_1
	defw	C_RW
	defw	C_2MINUS		;/
BLOC3:	defw	C_DUP,C_FETCH
	defw	C_RR,C_MINUS
	defw	C_DUP,C_PLUS
	defw	C_0EQUAL
	defw	C_0BRANCH,BLOC2-$
	defw	C_DUP,C_PREV
	defw	C_STORE
BLOC1:	defw	C_FROMR,C_DROP
	defw	C_2PLUS
	defw	C_STOP

; --------------
; THE FLUSH WORD
; --------------
;   -- 
; 
; Save the current screen on tape
; 
; : FLUSH	FIRST DUP @ BLOCK-WRITE ;

W_FLUSH:
	defb	$85
	defb	"FLUS",'H'+$80
	defw	W_BLOCK
C_FLUSH:
	defw	E_COLON		
	defw	C_NBUFF,C_1PLUS
        defw	C_ZERO,C_XDO
FLUS1:  defw	C_ZERO,C_BUFFER
        defw	C_DROP
	defw	C_XLOOP,FLUS1-$
	defw	C_STOP

; -------------
; THE LOAD WORD
; -------------
; n -- 									L0
;
; Begin interpretation of screen n.
; Loading will terminate at the end of the screen or at ;S.
; See ;S and -->
;
; BLK @ >R IN @ >R 0 IN ! B/SCR * BLK ! INTERPRET R> IN ! R> BLK ! ;
W_LOAD:
	defb	$84
	defb	"LOA",'D'+$80
	defw	W_FLUSH
C_LOAD:
	defw	E_COLON		
	defw	C_BLK,C_FETCH
	defw	C_TOR
	defw	C_IN,C_FETCH
	defw	C_TOR,C_ZERO
	defw	C_IN,C_STORE
	defw	C_BSCR,C_TIMES
	defw	C_BLK,C_STORE		;BLK <-- SCR * B/SCR
	defw	C_INTERPRET		;interpret from other screen
	defw	C_FROMR,C_IN
	defw	C_STORE
	defw	C_FROMR,C_BLK
	defw	C_STORE
	defw	C_STOP

; ------------
; THE --> WORD
; ------------
;   -- 									P,L0
; 
; Continue interpretation with the next disc screen. (pronounced next-screen).

W_NEXTSCREEN:
	defb	$c3
	defb	"--",'>'+$80
	defw	W_LOAD
C_NEXTSCREEN:
	defw	E_COLON		
	defw	C_QLOADING
	defw	C_ZERO
	defw	C_IN,C_STORE
	defw	C_BSCR,C_BLK
	defw	C_FETCH,C_OVER
	defw	C_MOD,C_MINUS
	defw	C_BLK,C_PLUSSTORE
	defw	C_STOP

; ------------
; THE R/W WORD
; ------------
; addr blk f --
; 
; The fig-FORTH standard disc read-write linkage. addr specifies the source or
; destination block buffer, blk is the sequential number of the referenced block
; and f is a flag for f=O write and f=1 read.
; R/W determines the location on mass storage, performs the read-write and performs 
; any error checking.

W_RW:
	defb	$83
	defb	"R/",'W'+$80
	defw	W_NEXTSCREEN
C_RW:
	defw	E_COLON		
	defw	C_TOR			;save boolean
        defw	C_BBUF,C_TIMES
        defw	C_LIT,$C000
        defw	C_PLUS,C_DUP
        defw	C_LIT,$FFFF
        defw	C_GREATER
        defw	C_LIT,6
        defw	C_QERROR		;range check
        defw	C_FROMR
        defw	C_0BRANCH,RW1-$		;read
        defw	C_SWAP
RW1:	defw	C_BBUF,C_CMOVE
	defw	C_STOP

; ----------
; THE ' WORD
; ----------
;   -- addr								P,L0
; 
; Used in the form:
;    ' nnnn
; Leaves the parameter field address of dictionary word nnnn. As a compiler
; directive, executes in a colon-definition to compile the address as a literal.
; If the word is not found after a search of CONTEXT and CURRENT, an appropriate
; error message is given. Pronounced "tick".

W_TICK:
	defb	$c1
	defb	'''+$80
	defw	W_RW
C_TICK:
	defw	E_COLON		
	defw	C_MFIND
	defw	C_0EQUAL
	defw	C_ZERO
	defw	C_QERROR
	defw	C_DROP
	defw	C_LITERAL
	defw	C_STOP

; ---------------
; THE FORGET WORD
; ---------------
;   --									E,L0
; 
; Executed in the form:
;    FORGET cccc
; Deletes definition named cccc from the dictionary with all entries physically
; following it. In fig-FORTH, an error message will occur if the CURRENT and
; CONTEXT vocabularies are not currently the same.
;
;	CURRENT @ CONTEXT @ - 18 ?ERROR ' DUP FENCE @ U<
;	15 ?ERROR DUP NFA DP ! LFA @ CONTEXT @ ! ;
;

W_FORGET:
	defb	$86
	defb	"FORGE",'T'+$80
	defw	W_TICK
C_FORGET:
	defw	E_COLON		
	defw	C_CURRENT
	defw	C_FETCH
	defw	C_CONTEXT
	defw	C_FETCH
	defw	C_MINUS
	defw	C_LIT
	defw	$18
	defw	C_QERROR
	defw	C_TICK
	defw	C_DUP
	defw	C_FENCE
	defw	C_FETCH
	defw	C_ULESS			;/ FORGET >8000h nw o.k.
	defw	C_LIT
	defw	$15
	defw	C_QERROR
	defw	C_DUP
	defw	C_NFA
	defw	C_DP
	defw	C_STORE
	defw	C_LFA
	defw	C_FETCH
	defw	C_CONTEXT
	defw	C_FETCH
	defw	C_STORE
	defw	C_STOP

; -------------
; THE BACK WORD
; -------------
; addr --
; 
; Calculate the backward branch offset from HERE to addr and compile into the next
; available dictionary memory address.

W_BACK:
	defb	$84
	defb	"BAC",'K'+$80
	defw	W_FORGET
C_BACK:
	defw	E_COLON		
	defw	C_HERE
	defw	C_MINUS
	defw	C_COMMA
	defw	C_STOP

; --------------
; THE BEGIN WORD
; --------------
;  -- addr n  (compiling)						P,L0
; 
; Occurs in a colon-definition in form:
;     BEGIN ... UNTIL
;     BEGIN ... AGAIN
;     BEGIN ... WHILE ... REPEAT
; At run-time, BEGIN marks the start of a sequence that may be repetitively
; executed. It serves as a return point from the corresponding UNTIL, AGAIN or
; REPEAT. When executing UNTIL, a return to BEGIN will occur if the top of the
; stack is false; for AGAIN and REPEAT a return to BEGIN always occurs.
;
; At compile time BEGIN leaves its return address and n for compiler error
; checking.

W_BEGIN:
	defb	$c5
	defb	"BEGI",'N'+$80
	defw	W_BACK
C_BEGIN:
	defw	E_COLON		
	defw	C_QCOMP
	defw	C_HERE
	defw	C_1
	defw	C_STOP

; --------------
; THE ENDIF WORD
; --------------
; addr n --  (compile)							P,CO,L0
; 
; Occurs in a colon-definition in form:
;     IF ... ENDIF
;     IF ... ELSE ... ENDIF
; At run-time, ENDIF serves only as the destination of a forward branch from IF or
; ELSE. It marks the conclusion of the conditional structure. THEN is another name
; for ENDIF. Both names are supported in fig-FORTH. See also IF and ELSE.
;
; At compile-time, ENDIF computes the forward branch offset from addr to HERE and
; stores it at addr. n is used for error tests.
;
; : ENDIF       ?COMP 2 ?PAIRS HERE OVER - SWAP ! ;
;

W_ENDIF:
	defb	$c5
	defb	"ENDI",'F'+$80
	defw	W_BEGIN
C_ENDIF:
	defw	E_COLON		
	defw	C_QCOMP
	defw	C_2
	defw	C_QPAIRS
	defw	C_HERE
	defw	C_OVER
	defw	C_MINUS
	defw	C_SWAP
	defw	C_STORE
	defw	C_STOP

; -------------
; THE THEN WORD
; -------------
; addr n --  (compile)							P,CO,L0
; 
; An alias for ENDIF.

W_THEN:
	defb	$c4
	defb	"THE",'N'+$80
	defw	W_ENDIF
C_THEN:
	defw	E_COLON		
	defw	C_ENDIF
	defw	C_STOP

; -----------
; THE DO WORD
; -----------
; n1 n2 -- (execute)							P,C2,L0
; addr n --- (compile)
;
; Occurs in a colon-definition in form:
;     DO ... LOOP
; At run time, DO begins a sequence with repetitive execution controlled by a loop
; limit n1 and an index with initial value n2. DO removes these from the stack.
; Upon reaching LOOP the index is incremented by one. Until the new index equals
; or exceeds the limit, execution loops back to just after DO; otherwise the loop
; parameters are discarded and execution continues ahead. Both n1 and n2 are
; determined at run-time and may be the result of other operations.
; Within a loop 'I' will copy the current value of the index to the stack. See I,
; LOOP, +LOOP, LEAVE.
;
; When compiling within the colon definition, DO compiles (DO), leaves the
; following address addr and n for later error checking.
;
;	COMPILE (DO) HERE 3 ;
;

W_DO:
	defb	$c2
	defb	"D",'O'+$80
	defw	W_THEN
C_DO:
	defw	E_COLON		
	defw	C_COMPILE
	defw	C_XDO
	defw	C_HERE
	defw	C_3
	defw	C_STOP

; -------------
; THE LOOP WORD
; -------------
; addr n --  (compiling)						P,C2,L0
; 
; Occurs in a colon-definition in form:
;     DO ... LOOP
; At run-time, LOOP selectively controls branching back to the corresponding DO
; based on the loop index and limit. The loop index is incremented by one and
; compared to the limit. The branch back to DO occurs until the index equals or
; exceeds the limit; at that time, the parameters are discarded and execution
; continues ahead.
;
; At compile-time. LOOP compiles (LOOP) and uses addr to calculate an offset to DO. 
; n is used for error testing.
;
;	3 ?PAIRS COMPILE (LOOP) BACK ;
;

W_LOOP:
	defb	$c4
	defb	"LOO",'P'+$80
	defw	W_DO
C_LOOP:
	defw	E_COLON		
	defw	C_3
	defw	C_QPAIRS
	defw	C_COMPILE
	defw	C_XLOOP
	defw	C_BACK
	defw	C_STOP

; --------------
; THE +LOOP WORD
; --------------
; n1 -- (execute)
; 
; Used in a colon-definition in the form:
;     DO . . . n1 +LOOP
; At run-time, LOOP selectively controls branching back to the corresponding DO
; based on n1, the loop index and the loop limit. The signed increment n1 is added
; to the index and the total compared to the limit. The branch back to DO occurs
; until the new index is equal to or greater than the limit (n1 > 0), or until the
; new index is equal to or less than the limit (n1 < 0). Upon exiting the loop,
; the parameters are discarded and execution continues ahead.

W_PLUSLOOP:
	defb	$c5
	defb	"+LOO",'P'+$80
	defw	W_LOOP
C_PLUSLOOP:
	defw	E_COLON		
	defw	C_3
	defw	C_QPAIRS
	defw	C_COMPILE
	defw	C_XPLOOP
	defw	C_BACK
	defw	C_STOP

; --------------
; THE UNTIL WORD
; --------------
; f --- (run-time)							P,C2,L0
; addr n --- (compile) 
; 
; Occurs within a colon-definition in the form:
;     BEGIN ... UNTIL
; At run-time, UNTIL controls the conditional branch back to the corresponding
; BEGIN. If f is false, execution returns to just after BEGIN; if true, execution
; continues ahead.
;
; At compile-time, UNTIL compiles (0BRANCH) and an offset from HERE to addr.
; n is used for error tests.

W_UNTIL:
	defb	$c5
	defb	"UNTI",'L'+$80
	defw	W_PLUSLOOP
C_UNTIL:
	defw	E_COLON		
	defw	C_1
	defw	C_QPAIRS
	defw	C_COMPILE
	defw	C_0BRANCH
	defw	C_BACK
	defw	C_STOP

; ------------
; THE END WORD
; ------------
;   -- 									P,C2,L0
; 
; This is an 'alias' or duplicate definition for UNTIL.

W_END:
	defb	$c3
	defb	"EN",'D'+$80
	defw	W_UNTIL
C_END:
	defw	E_COLON		
	defw	C_UNTIL
	defw	C_STOP

; --------------
; THE AGAIN WORD
; --------------
; addr n -- (compiling)							P,C2,L0
; 
; Used in a colon-definition in the form:
;     BEGIN ... AGAIN
; At run-time, AGAIN forces execution to return to corresponding BEGIN.
; There is no effect on the stack. Execution cannot leave this loop (unless R>
; DROP is executed one level below).
;
; At compile time, AGAIN compiles BRANCH with an offset from HERE to addr.
; n is used for compile-time error checking.

W_AGAIN:
	defb	$c5
	defb	"AGAI",'N'+$80
	defw	W_END
C_AGAIN:
	defw	E_COLON		
	defw	C_1
	defw	C_QPAIRS
	defw	C_COMPILE
	defw	C_BRANCH
	defw	C_BACK
	defw	C_STOP

; ---------------
; THE REPEAT WORD
; ---------------
; addr n --- (compiling)						P,C2
; 
; Used within a colon-definition in the form:
;     BEGIN ... WHILE ... REPEAT
; At run-time, REPEAT forces an unconditional branch back to just after the
; corresponding BEGIN.
;
; At compile-time, REPEAT compiles BRANCH and the offset from HERE to addr.
; n is used for error testing.

W_REPEAT:
	defb	$c6
	defb	"REPEA",'T'+$80
	defw	W_AGAIN
C_REPEAT:
	defw	E_COLON		
	defw	C_TOR
	defw	C_TOR
	defw	C_AGAIN
	defw	C_FROMR
	defw	C_FROMR
	defw	C_2MINUS		;/
	defw	C_ENDIF
	defw	C_STOP

; -----------
; THE IF WORD
; -----------
; f --- (run-time)							P,C2,L0
;  -- addr n (compile)
;
; Occurs is a colon-definition in form:
;     IF (tp) ...  ENDIF      .
;     IF (tp) ... ELSE (fp) ... ENDIF
; At run-time, IF selects execution based on a boolean flag. If f is true
; (non-zero), execution continues ahead thru the true part. If f is false (zero),
; execution skips till just after ELSE to execute the false part. After either
; part, execution resumes after ENDIF.
; ELSE and its false part are optional; if missing, false execution skips to just
; after ENDIF.
;
; At compile-time IF compiles 0BRANCH and reserves space for an offset at addr.
; addr and n are used later for resolution of the offset and error testing.


W_IF:
	defb	$c2
	defb	"I",'F'+$80
	defw	W_REPEAT
C_IF:
	defw	E_COLON		
	defw	C_COMPILE
	defw	C_0BRANCH
	defw	C_HERE
	defw	C_ZERO
	defw	C_COMMA
	defw	C_2
	defw	C_STOP

; -------------
; THE ELSE WORD
; -------------
; addr1 n1 --- addr2 n2 (compiling)					P,C2,L0
; 
; Occurs within a colon-definition in the form:
;    IF ... ELSE ... ENDIF
; At run-time, ELSE executes after the true part following IF. ELSE forces
; execution to skip over the following false part and resumes execution after the
; ENDIF. It has no stack effect.
;
; At compile-time ELSE emplaces BRANCH reserving a branch offset, leaves the
; address addr2 and n2 for error testing. ELSE also resolves the pending forward
; branch from IF by calculating the offset from addr1 to HERE and storing at addr1.

W_ELSE:
	defb	$c4
	defb	"ELS",'E'+$80
	defw	W_IF
C_ELSE:
	defw	E_COLON		
	defw	C_2
	defw	C_QPAIRS
	defw	C_COMPILE
	defw	C_BRANCH
	defw	C_HERE
	defw	C_ZERO
	defw	C_COMMA
	defw	C_SWAP
	defw	C_2
	defw	C_ENDIF
	defw	C_2
	defw	C_STOP

; --------------
; THE WHILE WORD
; --------------
; f --- (run-time)							 P,C2
; ad1 nl --- ad1 n1 ad2 n2
; 
; Occurs in a colon-definition in the form:
;     BEGIN ... WHILE (tp) ... REPEAT
; At run-time, WHILE selects conditional execution based on boolean flag f. If f
; is true (non-zero), WHILE continues execution of the true part thru to REPEAT,
; which then branches back to BEGIN. If f is false (zero), execution skips to just
; after REPEAT, exiting the structure.
;
; At compile time, WHILE emplaces (0BRANCH) and leaves ad2 of the reserved offset.
; The stack values will be resolved by REPEAT.

W_WHILE:
	defb	$c5
	defb	"WHIL",'E'+$80
	defw	W_ELSE
C_WHILE:
	defw	E_COLON		
	defw	C_IF
	defw	C_2PLUS
	defw	C_STOP

; ---------------
; THE SPACES WORD
; ---------------
; n --									L0
; 
; Transmit n ascii blanks to the output device.

W_SPACES:
	defb	$86
	defb	"SPACE",'S'+$80
	defw	W_WHILE
C_SPACES:
	defw	E_COLON		
	defw	C_ZERO
	defw	C_MAX
	defw	C_QUERYDUP
	defw	C_0BRANCH		;IF
	defw	SPAX1-$
	defw	C_ZERO
	defw	C_XDO			;DO
SPAX2:	defw	C_SPACE
	defw	C_XLOOP			;LOOP ENDIF
	defw	SPAX2-$
SPAX1:	defw	C_STOP

; -----------
; THE <# WORD
; -----------
;   -- 									L0
; 
; Setup for pictured numeric output formatting using the words:
;    <# # #S SIGN #>
; The conversion is done on a double number producing text at PAD.

W_LESSHARP:
	defb	$82
	defb	"<",'#'+$80
	defw	W_SPACES
C_LESSHARP:
	defw	E_COLON		
	defw	C_PAD
	defw	C_HLD
	defw	C_STORE
	defw	C_STOP

; -----------
; THE #> WORD
; -----------
; d -- addr count							L0
; 
; Terminates numeric output conversion by dropping d, leaving the text address and
; character count suitable for TYPE.

W_SHARPGT:
	defb	$82
	defb	"#",'>'+$80
	defw	W_LESSHARP
C_SHARPGT:
	defw	E_COLON		
	defw	C_DROP
	defw	C_DROP
	defw	C_HLD
	defw	C_FETCH
	defw	C_PAD
	defw	C_OVER
	defw	C_MINUS
	defw	C_STOP

; -------------
; THE SIGN WORD
; -------------
; n d -- d								L0
; 
; Stores an ascii "-" sign just before a converted numeric output string in the
; text output buffer when n is negative. n is discarded but double number d is
; maintained. Must be used between <# and #>.

W_SIGN:
	defb	$84
	defb	"SIG",'N'+$80
	defw	W_SHARPGT
C_SIGN:
	defw	E_COLON		
	defw	C_ROT
	defw	C_0LESS
	defw	C_0BRANCH 		;IF
	defw	SIGN1-$
	defw	C_LIT
	defw	$2d
	defw	C_HOLD			;ENDIF
SIGN1:	defw	C_STOP

; ----------
; THE # WORD
; ----------
; d1 -- d2								L0
; 
; Generate from a double number d1, the next ascii character which is placed in an
; output string. Result d2 is the quotient after division by BASE, and is
; maintained for further processing. Used between <# and #>. See #S.

W_SHARP:
	defb	$81
	defb	'#',+$80
	defw	W_SIGN
C_SHARP:
	defw	E_COLON		
	defw	C_BASE
	defw	C_FETCH
	defw	C_MDIVMOD
	defw	C_ROT
	defw	C_LIT
	defw	9
	defw	C_OVER
	defw	C_LESS
	defw	C_0BRANCH 		;IF
	defw	DIG1-$
	defw	C_LIT
	defw	7
	defw	C_PLUS			;ENDIF
DIG1:	defw	C_LIT
	defw	$30
	defw	C_PLUS
	defw	C_HOLD
	defw	C_STOP

; -----------
; THE #S WORD
; -----------
; d1 -- d2								L0
; 
; Generates ascii text in the text output buffer, by the use of #, until a zero
; double number n2 results. Used between <# and #>.

W_SHARPS:
	defb	$82
	defb	"#",'S'+$80
	defw	W_SHARP
C_SHARPS:
	defw	E_COLON		
DIGS1:	defw	C_SHARP 		;BEGIN
	defw	C_2DUP			;/
	defw	C_OR
	defw	C_0EQUAL
	defw	C_0BRANCH		;UNTIL
	defw	DIGS1-$
	defw	C_STOP

; ------------
; THE D.R WORD
; ------------
; d n --
; 
; Print a signed double number d right aligned in a field n characters wide.

W_DDOTR:
	defb	$83
	defb	"D.",'R'+$80
	defw	W_SHARPS
C_DDOTR:
	defw	E_COLON		
	defw	C_TOR
	defw	C_SWAP
	defw	C_OVER
	defw	C_DABS
	defw	C_LESSHARP
	defw	C_SHARPS
	defw	C_SIGN
	defw	C_SHARPGT
	defw	C_FROMR
	defw	C_OVER
	defw	C_MINUS
	defw	C_SPACES
	defw	C_TYPE
	defw	C_STOP

; -----------
; THE .R WORD
; -----------
; n1 n2 --
; 
; Print the number n1 right aligned in a field whose width is n2. No following
; blank is printed.

W_DOTR:
	defb	$82
	defb	".",'R'+$80
	defw	W_DDOTR
C_DOTR:
	defw	E_COLON		
	defw	C_TOR
	defw	C_SIGNTODUB
	defw	C_FROMR
	defw	C_DDOTR
	defw	C_STOP

; -----------
; THE D. WORD
; -----------
; d --									L1
;
; Print a signed double number from a 32 bit two's complement value.
; The high-order l6 bits are most accessable on the stack. Conversion is performed
; according to the current BASE. A blank follows. Pronounced D-dot.

W_DDOT:
	defb	$82
	defb	"D",'.'+$80
	defw	W_DOTR
C_DDOT:
	defw	E_COLON		
	defw	C_ZERO
	defw	C_DDOTR
	defw	C_SPACE
	defw	C_STOP

; ----------
; THE . WORD
; ----------
; n -- 									L0
;
; Print a number from a signed 16 bit two's complement value, converted according
; to the numeric BASE. A trailing blanks follows.
; Pronounced "dot".

W_DOT:	defb	$81
	defb	'.'+$80
	defw	W_DDOT
C_DOT:
	defw	E_COLON		
	defw	C_SIGNTODUB
	defw	C_DDOT
	defw	C_STOP

; ----------
; THE ? WORD
; ----------
; addr --								L0
; 
; Print the value contained at the address in free format according to the current
; base.

W_QUESTION:
	defb	$81
	defb	'?'+$80
	defw	W_DOT
C_QUESTION:
	defw	E_COLON		
	defw	C_FETCH
	defw	C_DOT
	defw	C_STOP

; -----------
; THE U. WORD
; -----------
; u  --  
; 
; Print a number from an unsigned 16 bit two's complement value, converted
; according to the numeric BASE. A trailing blanks follows.

W_UDOT:
	defb	$82
	defb	"U",'.'+$80
	defw	W_QUESTION
C_UDOT:
	defw	E_COLON		
	defw	C_ZERO
	defw	C_DDOT
	defw	C_STOP

; --------------
; THE VLIST WORD
; --------------
;   --
; 
; List the names of the definitions in the context vocabulary. "Break" will
; terminate the listing.
;
;	CR 0 OUT ! CONTEXT @ @
;	BEGIN
;	   OUT @ 2C0 > IF CR 0 OUT ! KEY DROP ENDIF
;	   DUP ID. SPACE SPACE PFA LFA @
;	   DUP 0= ?TERMINAL OR
;	UNTIL
;	DROP ;
;

W_VLIST:
	defb	$85
	defb	"VLIS",'T'+$80
	defw	W_UDOT
C_VLIST:
	defw	E_COLON
;	defw	C_LIT
;	defw	$80
	defw	C_CR
	defw	C_ZERO
	defw	C_OUT
	defw	C_STORE
	defw	C_CONTEXT
	defw	C_FETCH
	defw	C_FETCH
VLIS1:	defw	C_OUT   		;BEGIN
	defw	C_FETCH
;	defw	C_CL
	defw	C_LIT
	defw	$2c0
	defw	C_GREATER
	defw	C_0BRANCH 		;IF
	defw	VLIS2-$
	defw	C_CR
	defw	C_ZERO
	defw	C_OUT
	defw	C_STORE
	defw	C_KEY
	defw	C_DROP	 		;ENDIF
VLIS2:	defw	C_DUP
	defw	C_ID
	defw	C_SPACE
;	defw	C_SPACE
	defw	C_PFA
	defw	C_LFA
	defw	C_FETCH
	defw	C_DUP
	defw	C_0EQUAL
	defw	C_QTERMINAL
	defw	C_OR
	defw	C_0BRANCH		;UNTIL
	defw	VLIS1-$
	defw	C_DROP
	defw	C_CR
	defw	C_STOP

; ------------
; THE BYE WORD
; ------------
;   -- 
; 
; Return to BASIC

W_BYE:	defb	$83
	defb	"BY",'E'+$80
	defw	W_VLIST
C_BYE:
	defw	E_BYE
E_BYE:
	rst     08h
	defb	$ff
	defb	$00

; -------------
; THE LIST WORD
; -------------
; n --									L0
; 
; Display the ascii text of screen n on the selected output device.
; SCR contains the screen number during and after this process.

W_LIST:
	defb	$84
	defb	"LIS",'T'+$80
	defw	W_BYE
C_LIST:
	defw	E_COLON		
	defw	C_DECIMAL
	defw	C_CR
	defw	C_DUP
	defw	C_SCR
	defw	C_STORE
	defw	C_CQUOTE
	defb	$06,"SCR # "
	defw	C_DOT
	defw	C_LIT
	defw	$10
	defw	C_ZERO
	defw	C_XDO
LIST1:	defw	C_CR
	defw	C_I
	defw	C_3			;/ WAS LIT,3
	defw	C_DOTR
	defw	C_SPACE
	defw	C_I
	defw	C_SCR
	defw	C_FETCH
	defw	C_DOTLINE
	defw	C_QTERMINAL
	defw	C_0BRANCH 		;IF
	defw	LIST2-$
	defw	C_LEAVE
LIST2:	defw	C_XLOOP 		;ENDIF
	defw	LIST1-$
	defw	C_CR
	defw	C_STOP

;	defb	85H		;INDEX
;	DM	'INDEX'
;	defw	LIST-7
;INDEX:	defw	DOCOL
;	defw	LIT,FF
;	defw	EMIT,CR
;	defw	ONEP,SWAP
;	defw	XDO
;INDE1:	defw	CR,IDO
;	defw	THREE		;/ WAS LIT,3
;	defw	DOTR,SPACE
;	defw	ZERO,IDO
;	defw	DLINE,QTERM
;	defw	ZBRAN,INDE2-$	;IF
;	defw	LEAVE		;ENDIF
;INDE2:	defw	XLOOP,INDE1-$
;	defw	SEMIS
;
;	defb	85H		;TRIAD
;	DM	'TRIAD'
;	defw	INDEX-8
;TRIAD:	defw	DOCOL
;	defw	LIT,FF
;	defw	EMIT
;	defw	THREE		;/ WAS LIT,3
;	defw	SLASH
;	defw	THREE		;/ WAS LIT,3
;	defw	STAR
;	defw	THREE		;/ WAS LIT,3
;	defw	OVER,PLUS
;	defw	SWAP,XDO
;TRIA1:	defw	CR,IDO
;	defw	LIST
;	defw	QTERM
;	defw	ZBRAN,TRIA2-$	;IF
;	defw	LEAVE
;TRIA2:	defw	XLOOP,TRIA1-$	;ENDIF
;	defw	CR
;	defw	LIT,15
;	defw	MESS,CR
;	defw	SEMIS

; -------------
; THE .CPU WORD
; -------------
;   -- 
; 
; Prints the host string identification.
; : .CPU	BASE @ 36 BASE ! 34 +ORIGIN 2@ D. BASE ! ;

W_DOTCPU:
	defb	$84
	defb	".CP",'U'+$80
	defw	W_LIST
C_DOTCPU:
	defw	E_COLON		
	defw	C_BASE
	defw	C_FETCH
	defw	C_LIT
	defw	36
	defw	C_BASE
	defw	C_STORE
	defw	C_LIT
	defw	$0022
	defw	C_PLUSORIGIN
	defw	C_2FETCH
	defw	C_DDOT
	defw	C_BASE
	defw	C_STORE
	defw	C_STOP

; -------------
; THE FAST WORD
; -------------
;   --  
; 
; Change to FAST mode

W_FAST:
	defb	$84
	defb	"FAS",'T'+$80
	defw	W_DOTCPU
C_FAST:
	defw	E_FAST
E_FAST:
	call    $0f23
	jp      NEXT

; -------------
; THE SLOW WORD
; -------------
;   --  
; 
; Change to SLOW mode

W_SLOW:
	defb	$84
	defb	"SLO",'W'+$80
	defw	W_FAST
C_SLOW:
	defb	E_SLOW
E_SLOW:
	push	bc
	call    $0f2b
	pop	bc
	jp      NEXT


; ------------
; THE CLS WORD
; ------------
;   --  
; 
; Clear the terminal screen.

W_CLS:
	defb	$83
	defb	"CL",'S'+$80
	defw	W_SLOW
C_CLS:
	defw	E_CLS
E_CLS:
	push    bc
        ld      hl,($400C)
        inc     hl
        ld      (SCRPOS),hl
	ld	c,$18
	xor	a
CLR_LN:
	ld	b,$20
CLR_CH:
	ld      (hl),a
        inc     hl
        djnz    CLR_CH
        inc     hl
        dec     c
        jr      nz,CLR_LN
	pop     bc
	jp	NEXT


; ------------
; THE MEM WORD
; ------------
;   --  
; 
; Print the amount of memory left.
;
; : MEM SP@ HERE - U. ." BYTES FREE." ;

W_MEM:
	defb	$83
	defb	"ME",'M'+$80
	defw	W_CLS
C_MEM:
	defw	E_COLON
	defw	C_SPFETCH
	defw	C_HERE
	defw	C_MINUS
	defw	C_UDOT
	defw	C_CQUOTE
	defb	$0b,"BYTES FREE",$0d
	defw	C_STOP

; -------------
; THE NEXT WORD
; -------------
;   -- 
; 
; This is the inner interpreter that uses the interpretative pointer IP to execute
; compiled Forth definitions. It is not directly executed but is it the return
; point for all code procedures. It acts by fetching the address pointed by IP,
; storing this value in register W. It then jumps to the address pointed to by the
; address pointed to by W. W points to the code field of a definition which
; contains the address of the code which executes for that definition.
; This usage of indirect threaded code is a major contributor to the power,
; portability, and extensibility of Forth. Locations of IP and W are computer
; specific.
;

W_NEXT:
	defb    $84
	defb    "NEX",'T'+$80
	defw    W_MEM
C_NEXT:
	defw    E_COLON
	defw	C_LIT
	defw	$C3			;JP instruction
	defw	C_CCOMMA
	defw	C_LIT
	defw	NEXT
	defw	C_COMMA
	defw    C_STOP

; -------------
; THE TASK WORD
; -------------
;   --
; 
; A no-operation word which can mark the boundary between applications.
; By forgetting TASK and re-compiling, an application can be discarded in its
; entirety.
;
; : TASK ;

W_TASK:
	defb    $84
	defb    "TAS",'K'+$80
	defw    W_NEXT
C_TASK:
	defw    E_COLON
	defw    C_STOP

INITDP	equ	$4500


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


; Show code statistics when compiling

.ECHO "Lenght: "
.ECHO ($ - $2200)
.ECHO " bytes\n"



        end
