Home > Previous Page >  Disassembly of Jupiter ACE ROM
Archive Search  

Disassembly of Jupiter ACE ROM

Click here to go to a German text Version



[ thanks to Geoff Wearmouth ]
; Disassembly of the file "C:\ACE\JupiterAce.rom"
;
; CPU Type: Z80
;
; Created with dZ80 1.50
;
; on Monday, 21 of January 2002 at 07:11 PM
;
; last updated 02-NOV-2002
;
; Cross-assembles to an 8K ROM file.
;
; Note. A Low-level Assembly Listing only.

#define DEFB    .BYTE
#define DEFW    .WORD
#define DEFM    .TEXT
#define EQU     .EQU
#define ORG     .ORG

        ORG     $0000

; -------------------
; THE 'START' RESTART
; -------------------

L0000:  DI                              ; disable interrupts.
        LD      HL,$3C00                ; start of 'User' RAM
        LD      A,$FC                   ; a test byte and 1K masking byte.
        JR      L0028                   ; forward to continue at Part 2.

; -------------------
; THE 'PRINT' RESTART
; -------------------

L0008:  EXX                             ; preserve main registers.
        BIT     3,(IX+$3E)              ; test FLAGS for print destination.
        JP      L03EE                   ; forward to

; ---------------------------
; THE 'STACK WORD DE' RESTART
; ---------------------------

L0010:  LD      HL,($3C3B)              ; SPARE
        LD      (HL),E
        INC     HL
        JP      L085F                   ;

; -------------------------
; THE 'POP WORD DE' RESTART
; -------------------------


L0018:  LD      HL,($3C3B)              ; SPARE
        DEC     HL
        LD      D,(HL)
        JP      L0859                   ;

; -------------------
; THE 'ERROR' RESTART
; -------------------

L0020:  POP     HL
        LD      A,(HL)
        LD      ($3C3D),A               ; ERR_NO
        JP      L00AD                   ;

; ------------------------------------
; THE 'INITIALIZATION ROUTINE' Part 2.
; ------------------------------------

L0028:  INC     H                       ; increase high byte
        LD      (HL),A                  ; insert A value
        CP      (HL)                    ; compare to expected
        JR      Z,L0028                 ; loop back while RAM is populated.

        AND     H                       ; limit to nearest 1K segment.
        LD      H,A                     ; place back in H.
        LD      ($3C18),HL              ; set system variable RAMTOP.
        LD      SP,HL                   ; initialize the stack pointer.

; the Z80 instructions CALL, PUSH and POP can now be used.

        LD      HL,L010D                ; prepare to copy the system variables
                                        ; initial state from ROM.
        JR      L003B                   ; skip past the fixed-position restart.

; -----------------------
; THE 'INTERRUPT' RESTART
; -----------------------

L0038:  JP      L013A                   ; jump to somewhere more convenient.

;------------------------------------------------------------------------------
;
; MEMORY MAP
;
; $0000 +======================================================+
;       |                                                      |
;       |                   ROM 8K                             |
;       |                                     v $2300          |
; $2000 +======================================================+ - - - - - -
;       |       copy of $2400                 |0|<  cassette  >|
; $2400 +-------------------------------------+-+--------------+
;       |       VIDEO MEMORY 768 bytes        |0| PAD 254 bytes| 1K RAM
; $2800 +-------------------------------------+-+--------------+
;       |       copy of $2c00                 ^ $2700          |
; $2C00 +------------------------------------------------------+
;       |       CHARACTER SET - Write-Only                     | 1K RAM
; $3000 +------------------------------------------------------+
;       |       copy of $3c00                                  |
; $3400 +------------------------------------------------------+
;       |       copy of $3c00                                  |
; $3800 +------------------------------------------------------+
;       |       copy of $3c00                                  |
; $3C00 +-------+----------------------------------------------+
;       |SYSVARS| DICT {12} DATA STACK ->         <- RET STACK | 1K RAM
; $4000 +=======+==============================================+ - - - - - -
;       |                                                      |
;                       48K AVAILABLE FOR EXPANSION.
;       |                                                      |
; $FFFF +======================================================+
;
; The Ace had an 8K ROM and was sold with 3K of RAM each byte of which had
; at least two addresses and sometimes four addresses so the mapping of the
; 3K of RAM was as above.
; The 768 bytes of video memory is accessed by the ROM using addresses
; $2400 - $26FF. This gives priority to the video circuitry which also needs
; this information to build the TV picture. The byte at $2700 is set to zero
; so that it is easy for the ROM to detect when it is at the end of the screen.
; The 254 bytes remaining are the PAD - the workspace used by FORTH.
; This same area is used by the tape recorder routines to assemble the tape
; header information but since, for accurate tape timing, the FORTH ROM needs
; priority over the video circuitry, then the ROM uses addresses $2301 - $23FF.
;
; Similarly the Character Set is written to by the ROM (and User) at the 1K
; section starting at $2C00. The video circuitry accesses this using addresses
; $2800 - $2BFF to build the TV picture. It is not possible for the ROM or User
; to read back the information from either address so this precludes the saving
; of character sets and writing a driver for a device like the ZX Printer.
;
; The final 1K or RAM has four addresses although it is normal to use addresses
; $3C00 - $3FFF. The first sixty three bytes are the System Variables which
; hold information like the number BASE and CONTEXT, and even the plotting
; coordinates should the user wish to develop a word like DRAW to draw lines.
;
; Then comes the User Dictionary, the first word of which is "FORTH" which links
; to the Dictionary in ROM. Next a gap of 12 bytes to allow for Data Stack
; underflow and then the Data Stack itself which grows upwards.
; At the opposite end of free memory is the Return Stack (machine stack) which
; grows downwards.

; ------------------------------------
; THE 'INITIALIZATION ROUTINE' Part 3.
; ------------------------------------

L003B:  LD      DE,$3C24                ; destination system variable L_HALF
        LD      BC,$002D                ; number of bytes.
        LDIR                            ; copy initial state from ROM to RAM.

        LD      IX,$3C00                ; set IX to index the system variables.
        LD      IY,L04C8                ; set IY to the SLOW return address.

L004B:  CALL    L0A24                   ; routine CLS.

        XOR     A                       ; clear accumulator.

        LD      ($2700),A               ; make location after screen zero.

; There are 128 bit-mapped 8x8 characters.
; Define the 8 Battenberg graphics ($10 to $17) from low byte of address.
; This routine also sets the other characters $00 to $0F and $18 to $1F
; to copies of this range. The inverse form of character $17 is used as the
; normal cursor - character $97.

L0052:  LD      HL,$2C00                ; point to the start of the 1K write-
                                        ; only Character Set RAM.

L0055:  LD      A,L                     ; set A to low byte of address
        AND     $BF                     ; AND %10111111
        RRCA                            ; rotate
        RRCA                            ; three times
        RRCA                            ; to test bit 2
        JR      NC,L005F                ; forward if not set.

        RRCA                            ; else rotate
        RRCA                            ; twice more.

L005F:  RRCA                            ; set carry from bit (3) or (6)

        LD      B,A

        SBC     A,A                     ; $00 or $FF
        RR      B
        LD      B,A
        SBC     A,A
        XOR     B
        AND     $F0
        XOR     B
        LD      (HL),A                  ; insert the byte.
        INC     L                       ; increment low byte of address
        JR      NZ,L0055                ; loop back until the first 256 bytes
                                        ; have been filled with 32 repeating
                                        ; characters.

; Now copy the bit patterns at the end of this ROM to the last 768 bytes of
; the Character RAM, filling in some blank bytes omitted to save ROM space.
; This process starts at high memory and works downwards.

L006E:  LD      DE,$2FFF                ; top of destination.
        LD      HL,L1FFB                ; end of copyright character.
        LD      BC,$0008                ; 8 characters

        LDDR                            ; copy the  ©  character

        EX      DE,HL                   ; switch pointers.

        LD      A,$5F                   ; set character counter to ninety five.
                                        ; i.e. %0101 1111
                                        ; bit 5 shows which 32-character sector
                                        ; we are in.

; enter a loop for the remaining characters supplying zero bytes as required.

L007C:  LD      C,$07                   ; set byte counter to seven.

        BIT     5,A                     ; test bit 5 of the counter.
        JR      Z,L0085                 ; forward if not in middle section
                                        ; which includes "[A-Z]"

        LD      (HL),B                  ; else insert a zero byte.
        DEC     HL                      ; decrement the destination address.
        DEC     C                       ; and the byte counter.

L0085:  EX      DE,HL                   ; switch pointers.

        LDDR                            ; copy the 5 or 6 characters.

        EX      DE,HL                   ; switch pointers.

        LD      (HL),B                  ; always insert the blank top byte.
        DEC     HL                      ; decrement the address.

        DEC     A                       ; decrement the character counter.

        JR      NZ,L007C                ; back for all 95 characters.

        IM      1                       ; Select Interrupt Mode 1

        JR      L009B                   ; and then jump into the code for the
                                        ; QUIT word.


; ---------------
; THE 'QUIT' WORD
; ---------------
; (  --  )
; Clears return stack, empties input buffer and returns control to the
; keyboard.

L0092:  DEFM    "QUI"                   ; 'name field'
        DEFB    'T' + $80

L0096:  DEFW    $0000                   ; 'link field' - end of linked list.

L0098:  DEFB    $04                     ; 'name length field'

L0099:  DEFW    L009B                   ; 'code field'
                                        ; address of machine code for routine.

; ---

L009B:  LD      SP,($3C18)              ; set stack-pointer to RAMTOP.

        EI                              ; Enable Interrupts.

        JP      L04F2                   ; jump forward to the main execution
                                        ; loop.

; ----------------
; THE 'ABORT' WORD
; ----------------
; Clears the data and return stacks, deletes any incomplete definition
; left in the dictionary, prints 'ERROR' and the byte from address $3C3D
; if the byte is non-negative, empties the input buffer, and returns
; control to the keyboard.


L00A3:  DEFM    "ABOR"                  ; 'name field'
        DEFB    'T' + $80

        DEFW    L0098                   ; 'link field' to previous word QUIT.

L00AA:  DEFB    $05                     ; 'name length field'

L00AB:  DEFW    L00AD                   ; 'code field'

; ---

; -> also continuation of the error restart.

L00AD:  PUSH    IY                      ; preserve current IY value slow/fast.

        LD      IY,L04B9                ; set IY to FAST
                                        ; now empty the data stack
        LD      HL,($3C37)              ; STKBOT
        LD      ($3C3B),HL              ; SPARE
        LD      HL,$3C3E                ; address FLAGS
        LD      A,(HL)                  ; fetch status from FLAGS.
        AND     $B3                     ; AND %10110011
                                        ; reset bit 2 - show definition complete
                                        ; reset bit 3 - output to screen.
                                        ; reset bit 6 - show in interpreter mode
        BIT     2,(HL)                  ; was there an incomplete definition ?
        LD      (HL),A                  ; update FLAGS
        JR      Z,L00DE                 ; forward if no incomplete word.

L00C4:  CALL    L04B9                   ; do forth

        DEFW    L0490                   ; dict          address of sv DICT
        DEFW    L08B3                   ; @             value of sv DICT (d).
        DEFW    L104B                   ; stk_data      d.         length field
        DEFB    $05                     ; five          d, 5.
        DEFW    L0DD2                   ; +             d+5.       code field
        DEFW    L086B                   ; dup           d+5, d+5.
        DEFW    L1610                   ; prvcur        d+5.
        DEFW    L15B5                   ; namefield     n.
        DEFW    L1011                   ; stackwrd      n.
        DEFW    $3C37                   ; (stkbot)      n, stkbot.
        DEFW    L08C1                   ; !             .
        DEFW    L1A0E                   ; end-forth.    .

; at this stage the system variable STKBOT holds the address of the
; obsolete name field and the system variable CURRENT points to the
; address of the previous complete word - obtained from the old link field.

L00DE:  BIT     7,(IX+$3D)              ; test ERR_NO for normal value 255.
        JR      NZ,L00FF                ; set-min then main-loop if OK.

        CALL    L1808                   ; else pr-inline

; ---

L00E7:  DEFM    "ERRO"                  ; the message "ERROR" with the last
        DEFB    'R' + $80               ; character inverted.

; ---

L00EC:  CALL    L04B9                   ; forth

        DEFW    L1011                   ; stack next word
        DEFW    $3C3D                   ; -> system variable ERR_NO
        DEFW    L0896                   ; C@            - fetch content byte
        DEFW    L09B3                   ; .             - print it
        DEFW    L0A95                   ; CR
        DEFW    L1A0E                   ; end-forth.

        LD      (IX+$3D),$FF            ; set ERR_NO to 'No Error'

L00FF:  LD      HL,($3C37)              ; fetch STKBOT
        LD      BC,$000C                ; allow twelve bytes for stack underflow
        ADD     HL,BC                   ; add the extra
        LD      ($3C3B),HL              ; set SPARE
        POP     IY                      ; restore previous state of IY

        JR      L009B                   ; rejoin main loop

; -------------------------
; THE 'DEFAULT ENVIRONMENT'
; -------------------------
; This is the default environment that is copied from ROM to RAM as part of
; the initialization process. This also contains the FORTH word FORTH definition

L010D:  DEFW    $26E0                   ; L_HALF

        DEFB    $00                     ; KEYCOD
        DEFB    $00                     ; KEYCNT copy the 32 bytes.
        DEFB    $00                     ; STATIN
        DEFW    $0000                   ; EXWRCH
        DEFB    $00                     ; FRAMES
        DEFB    $00                     ; FRAMES
        DEFB    $00                     ; FRAMES
        DEFB    $00                     ; FRAMES
        DEFB    $00                     ; XCOORD
        DEFB    $00                     ; YCOORD
        DEFW    $3C4C                   ; CURRENT
        DEFW    $3C4C                   ; CONTEXT
        DEFW    $3C4F                   ; VOCLNK
        DEFW    $3C51                   ; STKBOT
        DEFW    $3C45                   ; DICT
        DEFW    $3C5D                   ; SPARE
        DEFB    $FF                     ; ERR_NO
        DEFB    $00                     ; FLAGS
        DEFB    $0A                     ; BASE

; FORTH

        DEFM    "FORT"                  ; The 'name field'
        DEFB    'H' + $80               ; FORTH


        DEFW    $0000                   ; length field - filled when next word
                                        ; is defined.
        DEFW    L1FFF                   ; link field copied to $3C49.
        DEFB    $05                     ; name length field
        DEFW    L11B5                   ; code field
        DEFW    $3C49                   ; address of parameters
        DEFB    $00                     ; VOCLNK                        [$3C4F]
        DEFB    $00                     ; - link to next vocabulary.
        DEFB    $00                     ; last byte to be copied.    to [$3C51]

; -----------------------------------------------
; THE 'CONTINUATION OF THE Z80 INTERRUPT' ROUTINE
; -----------------------------------------------
; The destination of the jump at $0038.
; Begin by saving both accumulators and the 3 main registers.

L013A:  PUSH    AF                      ; preserve both accumulators
        EX      AF,AF'                  ;
        PUSH    AF                      ;

        PUSH    BC                      ; and main registers.
        PUSH    DE                      ;
        PUSH    HL                      ;

; Now wait for 62 * 12 clock cycles. ( To avoid flicker perhaps? ).

        LD      B,$3E                   ; delay counter.

L0142:  DJNZ    L0142                   ; self loop for delay

; Increment the 4-byte frames counter for use as a system clock.

        LD      HL,$3C2B                ; FRAMES1

L0147:  INC     (HL)                    ; increment timer.
        INC     HL                      ; next significant byte of four.
        JR      Z,L0147                 ; loop back if the value wrapped back
                                        ; to zero.

; Note. as manual points out, there is no actual check on this and if
; you leave your Ace switched on for 2.75 years it will advance to the
; following system variables although it takes several millennia to advance
; through the screen coordinates.

; Now read the keyboard and if no new key then exit after restoring the
; preserved registers.

        CALL    L0310                   ; routine KEYBOARD.

        LD      HL,$3C28                ; address system variable STATIN

        BIT     0,(HL)                  ; new key?
        JR      Z,L0176                 ; forward if not to RESTORE/EXIT

        AND     A                       ; zero key code ?
        JR      Z,L0176                 ; forward if so to EXIT.

        CP      $20                     ; compare to SPACE
        JR      C,L0170                 ; forward if less as an Editing Key.

        BIT     1,(HL)                  ; CAPS shift?
        CALL    NZ,L0807                ; routine TO_UPPER

        BIT     2,(HL)                  ; GRAPHICS mode?
        JR      Z,L0167                 ; skip forward if not

        AND     $9F                     ; convert to one of 8 mosaic characters

L0167:  BIT     3,(HL)                  ; INVERSE mode?
        JR      Z,L016D                 ; forward if not.

        OR      $80                     ; set bit 7 to make character inverse.

L016D:  CALL    L0196                   ; routine pr_buffer

L0170:  CALL    L01E6                   ; routine EDIT_KEY
        CALL    L0282                   ; routine pr_cursor

; Before exiting restore the preserved registers.

L0176:  POP     HL                      ;
        POP     DE                      ;
        POP     BC                      ;
        POP     AF                      ;
        EX      AF,AF'                  ;
        POP     AF                      ;

        EI                              ; Enable Interrupts

        RET                             ; return.

; -----------------------------------
; THE 'PRINT to LOWER SCREEN' ROUTINE
; -----------------------------------

L017E:  CP      $0D                     ; carriage return?
        JR      NZ,L0196                ; forward if not

; a carriage return to input buffer i.e. lower screen memory.

        LD      HL,$2700                ; set pointer to location after the
                                        ; input buffer.

        LD      ($3C22),HL              ; set ENDBUF - end of logical line
        LD      ($3C20),HL              ; set the CURSOR

        XOR     A                       ; clear A

        CALL    L0198                   ; print character zero.

        LD      HL,$26E0                ; left hand position of bottom line.
        LD      ($3C1E),HL              ; set INSCRN to this position.
        RET                             ; return.

; ---------------------------------------
; THE 'PRINT CHARACTER TO BUFFER' ROUTINE
; ---------------------------------------

L0196:  AND     A                       ; check for zero character
        RET     Z                       ; return if so.

; => also called from previous routine only to print a zero skipping above test.

L0198:  EX      AF,AF'                  ; preserve the output character.

        LD      HL,($3C22)              ; fetch ENDBUF end of logical line
        LD      A,(HL)                  ; fetch character from position
        AND     A                       ; is it zero ?
        JR      Z,L01A6                 ; skip forward if so.

; else lower screen scrolling is required.

        LD      DE,$D900                ; $0000 - $2700
        ADD     HL,DE                   ; test if position is within video RAM
        JR      NC,L01CE                ; forward if < $26FF

; now check that the limit of 22 lines in lower screen is not exceeded.

L01A6:  LD      DE,($3C24)              ; fetch start of buffer from L_HALF
        LD      HL,$DBA0                ; $0000 - $2460
        ADD     HL,DE                   ;
        JR      NC,L01E4                ; forward to exit if buffer full.


        LD      HL,($3C1C)              ; fetch position SCRPOS for upper screen
        LD      BC,$0020                ; allow an extra 32 characters - 1 line.
        ADD     HL,BC                   ;
        SBC     HL,DE                   ; subtract the start of input buffer
        PUSH    DE                      ; and save the L_HALF value

        CALL    NC,L0421                ; routine to scroll upper display.

        CALL    L02B0                   ; find zerobyte loc in HL

        POP     DE                      ; retrieve the L_HALF value

        CALL    L042F                   ; routine scroll and blank

; The four system variables INSCRN, CURSOR, ENDBUF and L_HALF are each
; reduced by 32 bytes a screen line.

        LD      HL,$3C1E                ; address INSCRN the left-hand location
                                        ; of the current input line.

        LD      B,$04                   ; four system variables to update

L01C9:  CALL    L0443                   ; routine SCR-PTRS

        DJNZ    L01C9                   ; repeat for all four pointers.

; ok to print

L01CE:  CALL    L0302                   ; routine find characters to EOL.

        LD      D,H                     ; HL is end of line
        LD      E,L                     ; transfer to DE register.
        INC     HL                      ; increment
        LD      ($3C22),HL              ; update ENDBUF
        DEC     HL                      ; decrement
        DEC     HL                      ; so HL = DE -1

        JR      Z,L01DD                 ; skip if BC zero.

        LDDR                            ; else move the characters.

L01DD:  EX      AF,AF'                  ; restore the output character.
        LD      (DE),A                  ; insert at screen position.
                                        ; (a zero if CR lower)
        INC     DE                      ; next character position
        LD      ($3C20),DE              ; update CURSOR

L01E4:  XOR     A                       ; ?
        RET                             ; return.

; -------------------------
; THE 'EDIT KEY' SUBROUTINE
; -------------------------

L01E6:  LD      HL,L01F0                ; address the EDIT KEYS table.

        LD      D,$00                   ; prepare to index by one byte.
        LD      E,A                     ; character code to E.
        ADD     HL,DE                   ; index into the table.

        LD      E,(HL)                  ; pick up required offset to the
                                        ; handling routine.

        ADD     HL,DE                   ; add to the current address.
        JP      (HL)                    ; exit via the routine.

; ---------------------
; THE 'EDIT KEYS' TABLE
; ---------------------

L01F0:  DEFB    $20             ; L0210         $00     - RET
L01F1:  DEFB    $13             ; L0204         $01     - LEFT
L01F2:  DEFB    $0C             ; L01FE         $02     - CAPS
L01F3:  DEFB    $1E             ; L0211         $03     - RIGHT
L01F4:  DEFB    $0A             ; L01FE         $04     - GRAPH
L01F5:  DEFB    $37             ; L022C         $05     - DEL
L01F6:  DEFB    $1A             ; L0210         $06     - RET
L01F7:  DEFB    $50             ; L0247         $07     - UP
L01F8:  DEFB    $06             ; L01FE         $08     - INV
L01F9:  DEFB    $9C             ; L0295         $09     - DOWN
L01FA:  DEFB    $C9             ; L02C3         $0A     - DEL LINE
L01FB:  DEFB    $15             ; L0210         $0B     - RET
L01FC:  DEFB    $14             ; L0210         $0C     - RET
L01FD:  DEFB    $D3             ; L02D0         $0D     - KEY-ENTER

; -------------------------------
; THE 'TOGGLE STATUS BIT' ROUTINE
; -------------------------------
; The keycodes have been cleverly mapped to individual bits of the STATIN
; system variable so this simple routine maintains all three status bits.
; KEY '2' - CAPS SHIFT, '4' - GRAPHICS, '8' - INVERSE VIDEO.

L01FE:  LD      HL,$3C28                ; system variable STATIN
        XOR     (HL)                    ; toggle the single relevant bit.
        LD      (HL),A                  ; put back.
        RET                             ; return.

; ----------------------------
; THE 'CURSOR LEFT' SUBROUTINE
; ----------------------------
; this subroutine moves the cursor to the left unless the character at that
; position is zero.

L0204:  LD      HL,($3C20)              ; fetch CURSOR.
        DEC     HL                      ; decrement value.
        LD      A,(HL)                  ; fetch character at new position.
        AND     A                       ; test for zero. (cr)
        RET     Z                       ; return if so.                  >>

        LD      ($3C20),HL              ; else update CURSOR
        INC     HL                      ; step back
        LD      (HL),A                  ; and put character that was at new
                                        ; cursor position where cursor is now.

L0210:  RET                             ; return.

; Note. various unallocated keys in the EDIT KEYS table point to the
; above RET instruction.

; -----------------------------
; THE 'CURSOR RIGHT' SUBROUTINE
; -----------------------------

L0211:  LD      HL,($3C20)              ; fetch CURSOR position
        INC     HL                      ; and increment it.

        LD      DE,($3C22)              ; fetch ENDBUF - end of current line.
        AND     A                       ; prepare to subtract.
        SBC     HL,DE                   ; test
        RET     Z                       ; return if zero - CURSOR is at ENDBUF

        ADD     HL,DE                   ; else reform the pointers.
        LD      ($3C20),HL              ; update CURSOR
        LD      A,(HL)                  ; fetch character at new position.
        DEC     HL                      ; decrement
        LD      (HL),A                  ; and insert where cursor was.
        RET                             ; ret.

; ---------------------------
; THE 'DELETE CURSOR' ROUTINE
; ---------------------------
; Moves cursor position to right and then continues into DEL-CHAR

L0225:  LD      HL,($3C20)              ; fetch CURSOR
        INC     HL                      ; increment position.
        LD      ($3C20),HL              ; update CURSOR


; ------------------------------
; THE 'DELETE CHARACTER' ROUTINE
; ------------------------------

L022C:  CALL    L0302                   ; routine finds characters to EOL.

        LD      H,D                     ; transfer CURSOR position DE to HL.
        LD      L,E                     ;
        DEC     DE                      ; decrement DE
        LD      A,(DE)                  ; fetch character to left of original
                                        ; cursor.
        AND     A                       ; test for zero.
        RET     Z                       ; return if so.                 >>

        LD      ($3C20),DE              ; else update CURSOR
        LD      A,B                     ; check for count of characters
        OR      C                       ; being zero
        JR      Z,L023F                 ; skip if so.

L023D:  LDIR                            ; else shift characters to left.

L023F:  DEC     HL                      ; decrement HL so that points to end -
                                        ; last position on the logical line.
        LD      (HL),$20                ; insert a space.
        LD      ($3C22),HL              ; set ENDBUF
        INC     C                       ; reset zero flag??
        RET                             ; return.

; -----------------------
; THE 'CURSOR UP' ROUTINE
; -----------------------
; When the cursor is moved up while editing a multi-line word definition,
; then the cursor is first moved to the left of the screen abutting the
; character zeros at the leftmost position.
; These zero characters appear as spaces but mark the beginning of each logical
; line. A logical line may, for instance if it contains a text item, extend over
; several physical screen lines.

L0247:  CALL    L0204                   ; routine CURSOR-LEFT
        JR      Z,L0254                 ; skip forward if not possible.

; else move left by thirty two positions. This may achieve a vertical move if
; attempted when a word is first being entered. Alternatively if one of the
; calls to cursor left fails having encountered a zero, then all subsequent
; calls will fail. The routine will return with the cursor adjacent to the zero.

        LD      B,$1F                   ; count 31 decimal
L024E:  CALL    L0204                   ; move cursor left thirty one times.
        DJNZ    L024E                   ; makes thirty two moves counting first

        RET                             ; return.

; ---

L0254:  LD      HL,($3C1E)              ; fetch INSCRN start of current line.
        LD      DE,($3C24)              ; fetch L_HALF start of buffer.
        AND     A                       ; reset carry for
        SBC     HL,DE                   ; true subtraction.
        RET     Z                       ; return if at beginning of input buffer

        CALL    L0225                   ; routine DEL-CURSOR

        LD      HL,($3C1E)              ; fetch INSCRN leftmost location of
                                        ; current line.
        LD      DE,$FFE0                ; make DE minus thirty two.
        XOR     A                       ; clear accumulator to zero.

L0269:  ADD     HL,DE                   ; subtract 32
        CP      (HL)                    ; compare contents to zero
                                        ; ( i.e. prev (cr) or buffer start?)
        JR      NZ,L0269                ; loop back until HL holds zero.

        LD      ($3C1E),HL              ; update INSCRN

        CALL    L02F4                   ; find endbuf

        LD      ($3C20),HL              ; set CURSOR

; ----------
; PR_CURSOR
; ----------

L0276:  LD      A,$A0                   ; inverse space - so solid square

        CALL    L017E                   ; routine PR_LOWER

        LD      HL,($3C20)              ; CURSOR
        DEC     HL
        LD      ($3C20),HL              ; CURSOR

; -> from interrupt
L0282:  LD      HL,($3C20)              ; CURSOR

        LD      A,($3C28)               ; STATIN
        RRA                             ; ignore bit 0
        LD      (HL),$97                ; pixel cursor.
        RRA                             ; test bit 1 - CAPS
        JR      NC,L0290                ; forward if no CAPS SHIFT

        LD      (HL),$C3                ; inverse [C] cursor.

L0290:  RRA                             ; test bit 2 - GRAPHICS.
        RET     NC                      ; return if not

L0292:  LD      (HL),$C7                ; inverse [G] cursor.
        RET                             ; return

; -------------------------
; THE 'CURSOR DOWN' ROUTINE
; -------------------------


L0295:  CALL    L0211                   ; routine CURSOR RIGHT
        JR      Z,L02A2                 ; forward if not possible.

        LD      B,$1F                   ; set counter to thirty one.

L029C:  CALL    L0211                   ; routine CURSOR RIGHT
        DJNZ    L029C                   ; thirty two moves altogether.
        RET                             ; return.

; ---

L02A2:  CALL    L02B0                   ; find zerobyte
        RET     PO                      ; return if    found

        PUSH    HL                      ; save position
        CALL    L0225                   ; routine DEL-CURSOR
        POP     HL                      ; retrieve position.
        CALL    L02ED                   ; set logical line
        JR      L0276                   ; back to exit via pr_cursor.

; ---
; find zerobyte
; ---
; -> called 5 times

L02B0:  LD      HL,$2700                ; this location is always zero.
                                        ; the byte following video RAM.
        LD      DE,($3C1E)              ; INSCRN        e.g. $26E0

        AND     A                       ; prepare for true subtraction

        SBC     HL,DE                   ; subtract to give number of chars

        LD      B,H                     ; transfer count to
        LD      C,L                     ; the BC register pair.

        EX      DE,HL                   ; transfer INSCR value to HL.

        INC     HL                      ; start next location
        XOR     A                       ; search for a zero character.

        CPIR                            ; at most BC locations.
                                        ; sets P/O flag if BC!=0

        DEC     HL                      ; step back to last non-zero
        RET                             ; return.

; -------------------------
; THE 'DELETE LINE' ROUTINE
; -------------------------
; CHR$ 10

L02C3:  LD      HL,($3C22)              ; ENDBUF
        DEC     HL                      ;
        LD      ($3C20),HL              ; CURSOR

L02CA:  CALL    L022C                   ; KEY-DEL
        JR      NZ,L02CA                ; repeat

        RET                             ; return.

; --------------------------
; THE 'KEY-ENTER' SUBROUTINE
; --------------------------

L02D0:  LD      HL,$3C28                ; STATIN
        SET     5,(HL)                  ; signal new key.
        RES     0,(HL)                  ; reset new key flag
        RET                             ; return.


; ------------------------
; THE 'SET BUFFER' ROUTINE
; ------------------------
; called by LIST, QUERY

L02D8:  LD      HL,$2700                ; one past end of screen.
        LD      DE,($3C24)              ; fetch start of buffer from L_HALF

        CALL    L07FA                   ; routine SPACE_FILL

        LD      HL,$26E0                ; first location of bottom line.
        LD      ($3C24),HL              ; set L_HALF

        LD      (HL),$00                ; insert a ZERO.

; -> called by retype
L02EA:  LD      HL,($3C24)              ; fetch L_HALF

; -> from cursor down
L02ED:  LD      ($3C1E),HL              ; set INSCRN
        INC     HL                      ; step past the zero
        LD      ($3C20),HL              ; set CURSOR

; => from cursor up.
L02F4:  CALL    L02B0                   ; find zerobyte

        LD      A,$20                   ; prepare a space

L02F9:  DEC     HL                      ; move to the left.
        CP      (HL)                    ; compare to space.
        JR      Z,L02F9                 ; back while spaces exist.

        INC     HL                      ; point to last space encountered.
        LD      ($3C22),HL              ; set ENDBUF - end of logical line.
        RET                             ; return.

; ----------------------------------
; THE 'COUNT TO END OF LINE' ROUTINE
; ----------------------------------
; Find the number of characters to the end of the logical line.

L0302:  LD      HL,($3C22)              ; system variable ENDBUF
        LD      DE,($3C20)              ; system variable CURSOR
        AND     A                       ; prepare to subtract.
        SBC     HL,DE                   ; subtract to give character places
        LD      B,H                     ; transfer result
        LD      C,L                     ; to the BC register pair.
        ADD     HL,DE                   ; reform the pointers.

        RET                             ; return with zero flag set if cursor
                                        ; at EOL.

; ----------------------
; THE 'KEYBOARD' ROUTINE
; ----------------------

L0310:  CALL    L0336                   ; routine KEY_SCAN

        LD      B,A                     ; save key in B

        LD      HL,($3C26)              ; load L with KEYCOD - last key pressed
                                        ; load H with KEYCNT - debounce counter

        XOR     L                       ; compare to previous key.
        JR      Z,L0325                 ; forward if a match.

        XOR     L                       ; reform original
        JR      Z,L0320                 ; forward if zero - no key.

        XOR     A                       ; else clear accumulator.

        CP      L                       ; compare with last.
        RET     NZ                      ; return if not zero.

L0320:  LD      L,B                     ; set L to original keycode
        LD      H,$20                   ; set counter to thirty two.
        JR      L0332                   ; forward to store values and exit
                                        ; returning zero.

; ---

; Key is same as previously accepted key.
; It repeats after two interrupts

L0325:  DEC     H                       ; decrement the counter.
        LD      A,H                     ; fetch counter to A.
        CP      $1E                     ; compare to thirty.
        JR      Z,L0331                 ; forward if so to return key in A.

        XOR     A                       ; clear accumulator.
        CP      H                       ; is counter zero?
        JR      NZ,L0332                ; forward if not to keep counting.

        LD      H,$04                   ; else set counter to four.

L0331:  LD      A,L                     ; pick up previous key.

L0332:  LD      ($3C26),HL              ;  update KEYCOD/KEYCNT

        RET                             ; return.

;----------------------------------------------------------------------------
;                          LOGICAL VIEW OF KEYBOARD
;
;         0     1     2     3     4 -Bits-  4     3     2     1     0
; PORT                                                                    PORT
;
; F7FE  [ 1 ] [ 2 ] [ 3 ] [ 4 ] [ 5 ]  |  [ 6 ] [ 7 ] [ 8 ] [ 9 ] [ 0 ]   EFFE
;  ^                                   |                                   v
; FBFE  [ Q ] [ W ] [ E ] [ R ] [ T ]  |  [ Y ] [ U ] [ I ] [ O ] [ P ]   DFFE
;  ^                                   |                                   v
; FDFE  [ A ] [ S ] [ D ] [ F ] [ G ]  |  [ H ] [ J ] [ K ] [ L ] [ ENT ] BFFE
;  ^                                   |                                   v
; FEFE  [SHI] [SYM] [ Z ] [ X ] [ C ]  |  [ V ] [ B ] [ N ] [ M ] [ SPC ] 7FFE
;  ^            v                                                ^         v
; Start         +------------>--------------------->-------------+        End
;
;
;----------------------------------------------------------------------------


; ----------------------------------
; THE 'KEYBOARD SCANNING' SUBROUTINE
; ----------------------------------
; This routine is called by the KEYBOARD routine 50 times a second and
; by the ACE FORTH 'INKEY' WORD.
; The above diagram shows the logical view of the Keyboard and PORTS.
; The physical view is similar except that the symbol shift key is to the
; left of the space key.


L0336:  LD      BC,$FEFE                ; port address - B is also an 8 counter

        IN      D,(C)                   ; read from port to D.
                                        ; when a key is pressed, the
                                        ; corresponding bit is reset.

        LD      E,D                     ; save in E

        SRL     D                       ; read the outer SHIFT key.

        SBC     A,A                     ; $00 if SHIFT else $FF.
        AND     $D8                     ; $00 if SHIFT else $D8.

        SRL     D                       ; read the symbol shift bit
        JR      C,L0347                 ; skip if not pressed.

        LD      A,$28                   ; load A with 40 decimal.

L0347:  ADD     A,$57                   ; gives $7F SYM, $57 SHIFT, or $2F

; Since 8 will be subtracted from the initial key value there are three
; distinct ranges 0 - 39, 40 - 79, 80 - 119.

        LD      L,A                     ; save key range value in L
        LD      A,E                     ; fetch the original port reading.
        OR      $03                     ; cancel the two shift bits.

        LD      E,$FF                   ; set a flag to detect multiple keys.

; KEY_LINE the half-row loop.

L034F:  CPL                             ; complement bits

        AND     $1F                     ; mask off the rightmost five key bits.
        LD      D,A                     ; save a copy in D.
        JR      Z,L0362                 ; forward if no keys pressed to do the
                                        ; next row.

        LD      A,L                     ; else fetch the key value
        INC     E                       ; test E for $FF
        JR      NZ,L036B                ; forward if not now zero to quit

L0359:  SUB     $08                     ; subtract 8 from key value

        SRL     D                       ; test next bit affecting zero and carry

        JR      NC,L0359                ; loop back until the set bit is found.

        LD      E,A                     ; transfer key value to E.
        JR      NZ,L036B                ; forward to abort if more than one key
                                        ; is pressed in the row.

L0362:  DEC     L                       ; decrement the key value for next row.

        RLC     B                       ; rotate the 8 counter and port address

        JR      NC,L036D                ; skip forward when all 8 rows have
                                        ; been read.

        IN      A,(C)                   ; else read the next half-row.
        JR      L034F                   ; and back to KEY_LINE.

; ---
; ABORTKEY

L036B:  LD      E,$FF                   ; signal invalid key.

; the normal exit checks if E holds a key and not $FF.

L036D:  LD      A,E                     ; fetch possible key value.
        INC     A                       ; increment
        RET     Z                       ; return if was $FF as original.

        LD      HL,L0376                ; else address KEY TABLE
        ADD     HL,DE                   ; index into table.
                                        ; (D is zero)

        LD      A,(HL)                  ; pick up character.

        RET                             ; return with translated character.



; ---------------
; THE 'KEY TABLE'
; ---------------

; -----------------------
; THE '40 UNSHIFTED KEYS'
; -----------------------

L0376:  DEFB    $76                     ; V - v
        DEFB    $68                     ; H - h
        DEFB    $79                     ; Y - y
        DEFB    $36                     ; 6 - 6
        DEFB    $35                     ; 5 - 5
        DEFB    $74                     ; T - t
        DEFB    $67                     ; G - g
        DEFB    $63                     ; C - c
        DEFB    $62                     ; B - b
        DEFB    $6A                     ; J - j
        DEFB    $75                     ; U - u
        DEFB    $37                     ; 7 - 7
        DEFB    $34                     ; 4 - 4
        DEFB    $72                     ; R - r
        DEFB    $66                     ; F - f
        DEFB    $78                     ; X - x
        DEFB    $6E                     ; N - n
        DEFB    $6B                     ; K - k
        DEFB    $69                     ; I - i
        DEFB    $38                     ; 8 - 8
        DEFB    $33                     ; 3 - 3
        DEFB    $65                     ; E - e
        DEFB    $64                     ; D - d
        DEFB    $7A                     ; Z - z
        DEFB    $6D                     ; M - m
        DEFB    $6C                     ; L - l
        DEFB    $6F                     ; O - o
        DEFB    $39                     ; 9 - 9
        DEFB    $32                     ; 2 - 2
        DEFB    $77                     ; W - w
        DEFB    $73                     ; S - s
        DEFB    $00                     ; SYMBOL
        DEFB    $20                     ; SPACE
        DEFB    $0D                     ; ENTER
        DEFB    $70                     ; P - p
        DEFB    $30                     ; 0 - 0
        DEFB    $31                     ; 1 - 1
        DEFB    $71                     ; Q - q
        DEFB    $61                     ; A - a
        DEFB    $00                     ; SHIFT

; ---------------------
; THE '40 SHIFTED KEYS'
; ---------------------

        DEFB    $56                     ; V - V
        DEFB    $48                     ; H - H
        DEFB    $59                     ; Y - Y
        DEFB    $07                     ; 6 - 7 KEY-UP
        DEFB    $01                     ; 5 - 1 KEY-LEFT
        DEFB    $54                     ;
        DEFB    $47
        DEFB    $43
        DEFB    $42
        DEFB    $4A
        DEFB    $55
        DEFB    $09                     ; 7 - 9 KEY-DOWN
        DEFB    $08                     ; 4 - 8 INV-VIDEO
        DEFB    $52
        DEFB    $46
        DEFB    $58
        DEFB    $4E
        DEFB    $4B
        DEFB    $49
        DEFB    $03                     ; 8 - 3 KEY-RIGHT
        DEFB    $33                     ; 3 - 3
        DEFB    $45
        DEFB    $44
        DEFB    $5A
        DEFB    $4D
        DEFB    $4C
        DEFB    $4F
        DEFB    $04                     ; 9 - 4 GRAPH
        DEFB    $02                     ; 2 - 2 CAPS LOCK
        DEFB    $57                     ; W - W
        DEFB    $53                     ; S - S
        DEFB    $00                     ; SYMB
        DEFB    $20                     ; SPACE
        DEFB    $0D                     ; ENTER
        DEFB    $50                     ; P - P
        DEFB    $05                     ; 0 - 5   DEL
        DEFB    $0A                     ; 1 - 0A  DEL_LINE
        DEFB    $51                     ; Q - Q
        DEFB    $41                     ; A - A
        DEFB    $00                     ; SHIFT

; --------------------------
; THE '40 SYMBOL SHIFT KEYS'
; --------------------------

        DEFB    $2F                     ; V - /
        DEFB    $5E                     ; H - ^
        DEFB    $5B                     ; Y - [
        DEFB    $26                     ; 6 - &
        DEFB    $25                     ; 5 - %
        DEFB    $3E                     ; T - >
        DEFB    $7D                     ;
        DEFB    $3F
        DEFB    $2A
        DEFB    $2D
        DEFB    $5D
        DEFB    $27
        DEFB    $24
        DEFB    $3C
        DEFB    $7B
        DEFB    $60
        DEFB    $2C
        DEFB    $2B
        DEFB    $7F
        DEFB    $28
        DEFB    $23
        DEFB    $45
        DEFB    $5C
        DEFB    $3A
        DEFB    $2E
        DEFB    $3D
        DEFB    $3B
        DEFB    $29
        DEFB    $40                     ; 2 - @
        DEFB    $57                     ; W - W
        DEFB    $7C                     ; S
        DEFB    $00                     ; SYMB
        DEFB    $20                     ; SPACE
        DEFB    $0D                     ; ENTER
        DEFB    $22                     ; P - "
        DEFB    $5F                     ; 0 - _
        DEFB    $21                     ; 1 - !
        DEFB    $51                     ; Q - Q
        DEFB    $7E                     ; A - ~
        DEFB    $00                     ; SHIFT

; end of key tables


; ---------------------------
; THE 'PRINT ROUTINE' Part 2.
; ---------------------------
; If output is not directed into the input buffer then jump forward else
; call the routine to output to lower screen.

L03EE:  JR      Z,L03F5                 ; forward to main screen print.

        CALL    L017E                   ; PR_LOWER

        EXX                             ; restore main set
        RET                             ; return.                >>

; the print output is not directed to the input buffer but first check that
; the user has not set up a vector to their own routine to print characters
; for instance to a printer.

L03F5:  LD      B,A                     ; save the character in the B register.

        LD      HL,($3C29)              ; fetch possible vector from EXWRCH
                                        ; (normally 0)
        LD      A,H                     ; test for
        OR      L                       ; the value zero.
        LD      A,B                     ; fetch the character back to A.

        JR      Z,L03FF                 ; skip forward if no user-supplied
                                        ; routine.

L03FE:  JP      (HL)                    ; else jump to user-supplied routine
                                        ; which should finish with a JP (IY)**
                                        ; ** 2022 update This is an error in the
                                        ; listing **
                                        ; The character is provided in the A register
                                        ; of the Z80.
                                        ; The output routine should preserve the
                                        ; auxiliary registers, ix and iy, and
                                        ; finish off with exx and ret.
                                        ; see page  142 of manual.
; ---
; PRINTING TO UPPER SCREEN
; ---

L03FF:  LD      HL,($3C1C)              ; SCRPOS
        LD      DE,($3C24)              ; L_HALF

        EX      DE,HL                   ; ??

        SCF                             ; inclusive byte.
        SBC     HL,DE                   ; subtract screen position+1 from
                                        ; the start of input buffer.
        EX      DE,HL                   ; hl=scrpos

        CALL    C,L0421                 ; if no room then scroll upper display

        CP      $0D                     ; carriage return?

        JR      Z,L0416                 ; skip forward if so.

        LD      (HL),A                  ; else insert the character.

        INC     HL                      ; point to next position.
        JR      L041C                   ; forward

; ---

; a carriage return

L0416:  INC     HL                      ; increment screen address.
        LD      A,L                     ; fetch low byte of address and mask.
        AND     $1F                     ; a zero result indicates a line skip.
        JR      NZ,L0416                ; loop until a new line of 32 columns
                                        ; is started.

; both paths converge.

L041C:  LD      ($3C1C),HL              ; update SCRPOS

        EXX                             ; back to main set.

        RET                             ; return.

; -------------------------------------
; The 'UPPER DISPLAY SCROLLING' ROUTINE
; -------------------------------------

L0421:  PUSH    AF                      ; save character

        LD      HL,$3C1C                ; address the low order byte SCRPOS

        CALL    L0443                   ; routine cursor up
                                        ; i.e. SCRPOS = SCRPOS - 32

        POP     AF                      ; restore character

; now calculate the number of characters to scroll in the upper display.

        LD      HL,($3C24)              ; fetch L_HALF the start of input buffer
        LD      DE,$2420                ; second line in video display

;
; => scroll lower display enters here
L042F:  AND     A                       ; prepare for true subtraction.
        SBC     HL,DE                   ; find number of characters to scroll.

        LD      B,H                     ; result to BC
        LD      C,L

        LD      HL,$FFE0                ; set HL to -32d
        ADD     HL,DE                   ; now HL = DE -32d
        EX      DE,HL                   ; switch so DE = HL - 32

        LDIR                            ; scroll the lines up.

        LD      B,$20                   ; blank a line of 32 characters

L043D:  DEC     HL                      ; decrement screen address.
        LD      (HL),$20                ; insert a space character
        DJNZ    L043D                   ; and loop for all 32 characters

        RET                             ; return.

; --------------------------------
; THE 'SCREEN POINTERS' SUBROUTINE
; --------------------------------
;

L0443:  LD      A,(HL)                  ; fetch low byte of screen address
        SUB     $20                     ; subtract thirty two characters.
        LD      (HL),A                  ; and put back.

        INC     HL                      ; address high-order byte.
        JR      NC,L044B                ; forward if low byte did not wrap

        DEC     (HL)                    ; else decrement the high byte as the
                                        ; position has moved across a third of
                                        ; the display.

L044B:  INC     HL                      ; address following System Variable
        RET                             ; return.

; -----------------------------------
; THE 'INDEX SYSTEM VARIABLE' ROUTINE
; -----------------------------------
; This routine is used by words CONTEXT, CURRENT, BASE etc. to index and then
; stack a system variable associated with a FORTH word. See shortly.
;
; It is a bit overblown considering the eventual position of the System
; Variables and ld d,$3c; rst 10h; jp (iy) could have been used instead of
; the long-winded addition below.

L044D:  EX      DE,HL                   ; HL addresses the offset byte.
        LD      E,(HL)                  ; fetch to E register
;
        LD      D,$00                   ; prepare to add.
        LD      HL,$3C00                ; the address of start of SYSVARS
        ADD     HL,DE                   ; add the 8-bit offset
        EX      DE,HL                   ; location to DE.
        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; ---------------
; THE 'HERE' WORD
; ---------------
; ( -- address)
; Leaves the address of one past the end of the dictionary.

L0459:  DEFM    "HER"                   ; 'name field'
        DEFB    'E' + $80

        DEFW    L00AA                   ; 'link field'

L045F:  DEFB    $04                     ; 'name length field'

L0460:  DEFW    L0462                   ; 'code field'

; ---

L0462:  LD      DE,($3C37)              ; system variable STKBOT.
        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; ------------------
; THE 'CONTEXT' WORD
; ------------------
; (  -- 15411 )
; A system variable pointing to the context vocabulary.
; $3C33 CONTEXT

L0469:  DEFM    "CONTEX"                ; 'name field'
        DEFB    'T' + $80

        DEFW    L045F                   ; 'link field'

L0472:  DEFB    $07                     ; 'name length field'

L0473:  DEFW    L044D                   ; 'code field'

; ---

L0475:  DEFB    $33                     ; low byte of system variable.

; ------------------
; THE 'CURRENT' WORD
; ------------------
; (  -- 15409 )
; A system variable pointing to the current vocabulary.
; $3C31 CURRENT

L0476:  DEFM    "CURREN"                ; 'name field'
        DEFB    'T' + $80

        DEFW    L0472                   ; 'link field'

L047F:  DEFB    $07                     ; 'name length field'

L0480:  DEFW    L044D                   ; 'code field'

; ---

L0482:  DEFB    $31                     ; a single parameter low-byte of $3C31.

; ---------------
; THE 'BASE' WORD
; ---------------
; ( -- 15423)
; A one-byte variable containing the system number base.
; $3C3F BASE

L0483:  DEFM    "BAS"                   ; 'name field'
        DEFB    'E' + $80

        DEFW    L047F                   ; 'link field'

L0489:  DEFB    $04                     ; 'name length field'

L048A:  DEFW    L044D                   ; 'code field'

; ---

L048C:  DEFB    $3F                     ; low-byte of system variable BASE

; ---

; These two Internal Words are used to stack the value of FLAGS and DICT.

; -------------------------
; The 'flags' Internal Word
; -------------------------

L048D:  DEFW    L044D                   ; headerless 'code field'

; ---

L048F:  DEFB    $3E                     ; low-order byte of FLAGS $3C3E

; -------------------------
; The 'dict' Internal Word
; -------------------------

L0490:  DEFW    L044D                   ; headerless 'code field'

; ---

L0492:  DEFB    $39                     ; low-order byte of DICT $3C39


; --------------
; THE 'PAD' WORD
; --------------
; (  -- 9985 )
; Stacks the address of the 254-byte workpad.
; On most FORTH systems the PAD floats about in memory but on the Ace it is
; fixed in location and size. Its definition is simply a constant.

l0493   DEFM    "PA"                    ; 'name field'
        DEFB    'D' + $80

        DEFW    L0489                   ; 'link field'

L0498:  DEFB    $03                     ; 'name length field'

L0499:  DEFW    L0FF5                   ; 'code field' - stack word

; ---

L049B:  DEFW    $2701                   ; parameter is 9985 decimal -
                                        ; work pad address

; ------------
; THE ';' WORD
; ------------
; Terminates colon, DEFINER and COMPILER definitions.

L049D:  DEFB    ';' + $80               ; 'name field'

        DEFW    L0498                   ; 'link field'

L04A0:  DEFB    $41                     ; length 1 + $40 (immediate word)

L04A1:  DEFW    L1108                   ; 'code field' - compile

; ---

L04A3:  DEFW    L04B6                   ; exit

L04A5:  DEFW    L12D8                   ; check-for
        DEFB    $0A                     ; ten                   marker byte?
        DEFW    L1A0E                   ; end-forth.

; code gels

L04AA:  LD      HL,$3C3E                ; address FLAGS
        LD      A,(HL)                  ; fetch FLAGS value.

        AND     $BB                     ; AND %10111011
                                        ; reset bit 2 - show definition complete
                                        ; reset bit 6 - show in interpreter mode

        LD      (HL),A                  ; update FLAGS value.

        JP      (IY)                    ; to 'next'.

; ----
; Note. these backward links to the beginning of words will probably be less
; of a mystery when the syntax checking and listing modules are more fully
; explored. A value of $FFFF sometimes occurs.

x04b3   DEFB    $00                     ;;

x04b4   DEFB    $E8                     ;;
x04b5   DEFB    $FF                     ;; 04b5 + ffe8 = 049d  = ';'

; ----------------------------------
; THE 'ADDRESS' INTERPRETER ROUTINES
; ----------------------------------

; ------------------------
; The 'Exit' Internal Word
; ------------------------
; Drops the 'Next Word' pointer from the Return Stack thereby ending a
; subroutine and returning to next word in calling thread.

L04B6:  DEFW    L04B8                   ; headerless 'code field'

; ---

L04B8:  POP     HL                      ; discard the next word pointer.

; ------------------------------
; THE 'ADDRESS INTERPRETER' LOOP
; ------------------------------
; Sometimes known as the Sequencer.
;
; iy_fast

L04B9:  POP     HL                      ; word pointer.

; =====> from DOCOLON and BRANCH

L04BA:  LD      E,(HL)
        INC     HL
        LD      D,(HL)
        INC     HL

        PUSH    HL                      ; word pointer.

; ==>
;
L04BF:  EX      DE,HL
        LD      E,(HL)
        INC     HL
        LD      D,(HL)
        INC     HL
        EX      DE,HL

        JP      (HL)                    ; jump to machine code (4 clock cycles)
                                        ; which will terminate with a JP (IY)
                                        ; instruction (8 clock cycles).



; --------------------------------
; The 'Memory Check' Internal Word
; --------------------------------
; This internal word which also checks the BREAK key is only used from the
; start of the LINE definition. However the machine code entry point is the
; normal value of the IY register and so this code is executed at the end of
; every word.

L04C6:  DEFW    L04C8                   ; headerless 'code field'

; iy_slow

L04C8:  LD      BC,$000B                ; allow overhead of eleven bytes
        LD      DE,($3C3B)              ; SPARE
        LD      HL,($3C37)              ; STKBOT
        ADD     HL,BC                   ; add the overhead
        SBC     HL,DE                   ; subtract the SPARE value
        JR      C,L04D9                 ; forward if the original 12 byte gap
                                        ; remains.

; else stack underflow has occurred.

L04D7:  RST     20H                     ; Error 2
        DEFB    $02                     ; Data stack underflow.

; ---

L04D9:  LD      BC,$0000                ; allow no overhead.

        CALL    L0F8C                   ; check free memory
        CALL    L04E4                   ; check BREAK key.
        JR      L04B9                   ; back to iy_fast

; ------------------------------------
; THE 'CHECK FOR BREAK KEY' SUBROUTINE
; ------------------------------------
; Check for the key combination SHIFT/SPACE.

L04E4:  LD      A,$FE                   ; read port $FEFE -
        IN      A,($FE)                 ; keys SPACE, SYMSHIFT, M, N, B.

        RRA                             ; test bit for outermost key
        RET     C                       ; return if not pressed.

        LD      A,$7F                   ; read port $7FFE -
        IN      A,($FE)                 ; keys SHIFT, Z, X, C, V.

        RRA                             ; test bit for outermost key
        RET     C                       ; return if not pressed.

L04F0:  RST     20H                     ; Error 3.
        DEFB    $03                     ; BREAK pressed.

; -------------------------
; THE 'MAIN EXECUTION' LOOP
; -------------------------
; The final part of the QUIT definition, as in all FORTH implementations,
; just loops through two FORTH words.

; The first call - to the Address Interpreter - does not return.
; The return address is the next word QUERY which the interpreter pops off
; the Return Stack and then before executing puts the address of the next word
; on Return Stack. The default action of the Address Interpreter is to execute
; words in turn until some word, such as branch, alters this default behaviour.

L04F2:  CALL    L04B9                   ; forth.

L04F5:  DEFW    L058C                   ; QUERY         - input buffer
        DEFW    L0506                   ; LINE          - interpret buffer
        DEFW    L0536                   ; prOK          - print OK
        DEFW    L1276                   ; branch        - relative jump

L04FD:  DEFW    $FFF7                   ; back to L04F5

; ---
; the first high-level interpreted word.
; ---

; ---------------
; THE 'LINE' WORD
; ---------------
; Interprets input buffer as a normal FORTH line.

L04FF:  DEFM    "LIN"                   ; 'name field'
        DEFB    'E' + $80

        DEFW    L04A0                   ; 'link field'

L0505:  DEFB    $04                     ; 'name length field'

L0506:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0508:  DEFW    L04C6                   ; check mem each time through loop
                                        ; as dictionary could be expanding.

        DEFW    L063D                   ; FIND          - search the dictionary
        DEFW    L08EE                   ; ?DUP          - duplicate if found
        DEFW    L1283                   ; ?branch       - forward if not a
L0510:  DEFW    $0007                   ; to L0518      - word.

        DEFW    L054F                   ; test and stack??
        DEFW    L1276                   ; branch
L0516:  DEFW    $FFF1                   ; back to L0508

L0518:  DEFW    L06A9                   ; NUMBER
        DEFW    L08EE                   ; ?DUP
        DEFW    L1283                   ; ?branch       - forward if not a
L051E:  DEFW    $0007                   ; to L0526      - number.

        DEFW    L0564                   ; pop de with test
        DEFW    L1276                   ; branch
L0524:  DEFW    $FFE3                   ; loop back to L0508

L0526:  DEFW    L061B                   ; stack-length
        DEFW    L0C1A                   ; 0=
        DEFW    L1283                   ; ?branch       - forward with anything
L052C:  DEFW    $0003                   ; to L0530      - else

L052E:  DEFW    L04B6                   ; EXIT                          >>>

; ---

L0530:  DEFW    L0578                   ; RETYPE        - [?] at relevant place
        DEFW    L1276                   ; branch        - once corrected back
L0534:  DEFW    $FFD3                   ; to L0508      - to the loop.

; ----------------------------
; The 'Print OK' Internal Word
; ----------------------------
; prints the OK message after successful execution.

L0536:  DEFW    L0538                   ; headerless 'code field'

L0538:  LD      A,($3C3E)               ; fetch system variable FLAGS

        BIT     6,A                     ; test for 'COMPILER' mode.
        JR      NZ,L054D                ; forward if so.

        BIT     4,A                     ; test for 'INVIS' mode.
        JR      NZ,L054D                ; forward if so.

        CALL    L1808                   ; else print the inline string.

; ---

        DEFM    " OK"                   ; the OK message between two spaces.
        DEFB    ' ' + $80               ; last one inverted.

; ---

L054A:  LD      A,$0D                   ; prepare a carriage return.
        RST     08H                     ; and PRINT also.

L054D:  JP      (IY)                    ; to 'next'.

; ------------------------------
; The 'XXXXXXXXXX' Internal Word
; ------------------------------
; to handle a Word from LINE

L054F:  DEFW    L0551                   ; headerless 'code field'

; ---

L0551:  RST     18H                     ; pop address from Data Stack to DE

        DEC     DE                      ; point to the 'name length field'

        LD      A,(DE)                  ; fetch contents of the address.

        CPL                             ; complement.

        AND     (IX+$3E)                ; FLAGS

        AND     $40                     ; isolate BIT 6 of FLAGS, set if in
                                        ; compiler mode.

        INC     DE                      ; increment address to 'code field'

        JR      Z,L0561                 ; forward if not in compiling mode

        RST     10H                     ; push word DE          - add to dict
        LD      DE,L0F4E                ; ','                   - enclose

L0561:  JP      L04BF                   ; next word.

; -----------------------
; The '???' Internal Word
; -----------------------
; after handling a number from LINE

L0564:  DEFW    L0566                   ; headerless 'code field'

; ---

L0566:  RST     18H                     ; pop word DE

        BIT     6,(IX+$3E)              ; test FLAGS - compiler mode ?

        JR      NZ,L0561                ; loop back while in compiler mode.

        JP      (IY)                    ; to 'next'.

; -----------------
; THE 'RETYPE' WORD
; -----------------
; Allows user to edit the input line. Turns cursor to [?].

L056F:  DEFM    "RETYP"                 ; 'name field'
        DEFB    'E' + $80

        DEFW    L058B                   ; 'link field'

L0577:  DEFB    $06                     ; 'name length field'

L0578:  DEFW    L057A                   ; 'code field'

; ---

L057A:  CALL    L02EA                   ; routine sets logical line.

        CALL    L0276                   ; routine pr_cursor

        LD      (HL),$BF                ; the inverse [?] character

        JR      L0594                   ; forward to join the QUERY routine.

; ----------------
; THE 'QUERY' WORD
; ----------------
; Clears input buffer, then accepts characters until ENTER pressed.
; Buffer can be edited as usual and is limited to 22 lines.

L0584:  DEFM    "QUER"                  ; 'name field'
        DEFB    'Y' + $80

        DEFW    L0505                   ; 'link field'

L058B:  DEFB    $05                     ; 'name length field'

L058C:  DEFW    L058E                   ; 'code field'

; ---

L058E:  CALL    L02D8                   ; routine SETBUF

        CALL    L0276                   ; routine pr_cursor

; ->
L0594:  LD      HL,$3C28                ; fetch STATIN
        SET     0,(HL)                  ;
        RES     5,(HL)                  ; (bit 5 set by interrupt when the user
                                        ; presses the ENTER key)

L059B:  BIT     5,(HL)                  ; wait for interrupt to set the bit.
        JR      Z,L059B                 ; loop until.

        CALL    L0225                   ; routine DEL-CURSOR
        JP      (IY)                    ; to 'next'.

; ---------------
; THE 'WORD' WORD
; ---------------
; WORD text
; ( delimiter -- address )
; Takes text out of the input buffer up as far as a delimiter, and copies it
; to pad, starting at the second byte there. Puts the length (not including
; the delimiter) in the first byte of the pad, and stacks the address of the
; first byte of the pad.
; At most 253 characters are taken from the input buffer. If there are more
; left before the delimiter, then the first byte of the pad shows 254.
; Initial delimiters are ignored.

L05A4:  DEFM    "WOR"                   ; 'name field'
        DEFB    'D' + $80

        DEFW    L0577                   ; 'link field'

L05AA:  DEFB    $04                     ; 'name length field'

L05AB:  DEFW    L05AD                   ; 'code field'

; ---

L05AD:  RST     18H                     ; pop word DE
        LD      HL,$27FE                ; set HL to penultimate byte of 'pad'.
        LD      B,$FD                   ; the count is 253.

L05B3:  LD      (HL),$20                ; insert a space in pad.
        DEC     HL                      ; decrement the address.
        DJNZ    L05B3                   ; repeat for the 253 locations.

        PUSH    DE                      ; save the delimiter.
        EX      DE,HL                   ; save in HL also, DE is start of pad.

        RST     10H                     ; stack data word DE
        POP     DE                      ; retrieve the delimiter.

        CALL    L05E1                   ;

        INC     B
        DEC     B
        JR      Z,L05C6                 ;

        LD      BC,$00FF

L05C6:  LD      HL,$2701
        LD      (HL),C
        INC     HL
        LD      A,$FC
        CP      C
        JR      NC,L05D1                ;

        LD      C,A

L05D1:  INC     C
        PUSH    DE
        PUSH    BC
        EX      DE,HL
        LDIR
        POP     BC
        POP     DE
        DEC     C
        CALL    L07DA                   ;
        JP      (IY)                    ; to 'next'.

; --------------------------------
; THE 'GET BUFFER TEXT' SUBROUTINE
; --------------------------------
; Called from FIND, NUMBER and XXXXX. Word may have leading spaces and is
; terminated by a space or newline (zero).
; It is also used to find the end of a comment delimited by ')'.
;
; =>
L05DF:  LD      E,$20                   ; set a space as the skip character.

; =>called with E holding delimiter.
;
L05E1:  LD      HL,($3C24)              ; fetch L_HALF - start of screen buffer.
        LD      ($3C1E),HL              ; make INSCRN start of logical line the
                                        ; same.

        LD      BC,$0000                ; initialize letter count to zero.

; -> loop
L05EA:  INC     HL                      ; increment screen address.
        LD      A,(HL)                  ; fetch character to A.
        CP      E                       ; compare to character in E.
        JR      Z,L05EA                 ; loop while character matches.

        AND     A                       ; test for zero (at $2700?)
        JR      Z,L0600                 ; forward if so.

; a word has been found on the screen line.

        PUSH    HL                      ; save pointer to start of word.

L05F3:  INC     BC                      ; increment the letter count.
        INC     HL                      ; increment the screen pointer.

        LD      A,(HL)                  ; fetch new character
        AND     A                       ; test for zero.
        JR      Z,L05FC                 ; skip forward as at end of word.

        CP      E                       ; compare to the skip character.
        JR      NZ,L05F3                ; loop back if still within a word.

L05FC:  POP     DE                      ; retrieve pointer to start of word.

        XOR     A                       ;; clear A
        CP      B                       ;; compare to B zero

        RET                             ; return. with carry reset for success.

; ---

L0600:  PUSH    DE                      ; save delimiter

        CALL    L02B0                   ; routine find zerobyte
        JP      PO,L0614                ; jump if found to exit failure

        LD      DE,($3C24)              ; else set DE from L_HALF
        CALL    L07FA                   ; routine SPACE_FILL (DE-HL)
        LD      ($3C24),HL              ; set L_HALF to next line

        POP     DE                      ; restore delimiter

        JR      L05E1                   ; loop back using new line.

; ---

; branch here if a word not found.

L0614:  EX      DE,HL                   ; DE addresses cursor.
        POP     BC                      ; discard saved delimiter
        LD      BC,$0000                ; set BC, to zero
        SCF                             ; signal not found
        RET                             ; return.

; --------------------------------
; The 'stack length' Internal Word
; --------------------------------
; used once only from LINE to check for any extraneous text that is not a Word
; or a Number.

L061B:  DEFW    L061D                   ; headerless 'code field'

; ---

L061D:  CALL    L05DF                   ; get buffer

        LD      D,B                     ; transfer length of word
        LD      E,C                     ; from BC to DE
        RST     10H                     ; push word DE
        JP      (IY)                    ; to 'next'.


; ----------------
; THE 'VLIST' WORD
; ----------------
; List dictionary to screen, including words in ROM.
; (no pause after 18 lines)

L0625:  DEFM    "VLIS"                  ; 'name field'
        DEFB    'T' + $80

        DEFW    L05AA                   ; 'link field'

L062C:  DEFB    $05                     ; 'name length field'

L062D:  DEFW    L062F                   ; 'code field'

; ---

L062F:  LD      A,$0D                   ; prepare a newline

        RST     08H                     ; print it.

        LD      C,$00                   ; set a flag for 'do all names'.

        JR      L0644                   ; forward to FIND.


; ---------------
; THE 'FIND' WORD
; ---------------
; ( -- compilation address )
; Leaves compilation address of first word in input buffer, if defined in
; context vocabulary; else 0.

L0636:  DEFM    "FIN"                   ; 'name field'
        DEFB    'D' + $80

        DEFW    L062C                   ; 'link field'

L063C:  DEFB    $04                     ; 'name length field'

L063D:  DEFW    L063F                   ; 'code field'

; ---

L063F:  CALL    L05DF                   ; get buffer word, gets length in C.

        JR      C,L068A                 ; back if null to stack word zero

; ->

L0644:  LD      HL,($3C33)              ; fetch value of system variable CONTEXT
        LD      A,(HL)                  ; extract low byte of address.
        INC     HL                      ; increment pointer.
        LD      H,(HL)                  ; extract high byte of address.
        LD      L,A                     ; address now in HL.

; The address points to the 'name length field' of the most recent word in the
; Dictionary.


L064B:  LD      A,(HL)                  ; fetch addressed byte.
        AND     $3F                     ; discount bit 6, the immediate word
                                        ; indicator, to give length 1-31

        JR      Z,L067F                 ; a 'zero' length indicates this is a
                                        ; link like the example at the end of
                                        ; this ROM.

        XOR     C                       ; match against C.
        JR      Z,L0657                 ; skip forward if lengths match.

        LD      A,C                     ; test flag C
        AND     A                       ; for value zero.
        JR      NZ,L067F                ; forward if C not zero.

; else a name that matches the search length or all names are required - VLIST.


L0657:  PUSH    DE                      ; preserve DE
        PUSH    HL                      ; preserve 'name length field' pointer.

        CALL    L15E8                   ; routine WORDSTART finds start of name.
                                        ; A is returned as zero.

        OR      C                       ; test C for zero
        JR      Z,L0676                 ; branch forward to print if in VLIST.

; else the search is for a specific word and a word with same length, at least,
; has been found.

        LD      B,C                     ; copy the length to counter B.

L0660:  LD      A,(DE)                  ; fetch first letter of match word.

        CALL    L0807                   ; routine UPPERCASE

        INC     DE                      ; update pointer (in lower screen)
        XOR     (HL)                    ; match against letter (in dictionary).
        AND     $7F                     ; disregard any inverted bit.
        INC     HL                      ; increment dictionary pointer.

        JR      NZ,L067D                ; exit loop to try next link if no match

        DJNZ    L0660                   ; else loop back for all letters.

; Oh Frabjous day - a match.

        POP     DE                      ; pop 'name length field' pointer.
        INC     DE                      ; increment to point to compilation
                                        ; address.
        RST     10H                     ; stack date word DE.

; the remaining task is to clean up the input buffer in the lower screen.

        POP     DE                      ; pop the DE - screen pointer.

        CALL    L07DA                   ; clean up - backfill with spaces.

        JP      (IY)                    ; to 'next'.

; -----------------------
; THE 'PRINT NAME' BRANCH
; -----------------------
; This branch is taken from the above loop when all found words are to be
; printed by VLIST. It takes its time as if the user has expanded the
; dictionary then the list will scroll off the top of the screen. By waiting
; for an interrupt each time, it ensures that a standard listing takes about
; three seconds and there is ample opportunity to press BREAK to stop at a
; certain point.

L0676:  CALL    L17FB                   ; routine print string and space

        HALT                            ; wait for an interrupt.

        CALL    L04E4                   ; routine checks BREAK key.

L067D:  POP     HL                      ; restore 'name length field' pointer
        POP     DE                      ; restore DE

L067F:  DEC     HL                      ; point to high byte of 'link field'
        LD      A,(HL)                  ; hold it in A.
        DEC     HL                      ; point to low byte of 'link field'
        LD      L,(HL)                  ; transfer address of the new
        LD      H,A                     ; 'name length field' to HL pointer.

        OR      L                       ; test if address is zero - for the
                                        ; last entry in the linked list.

        JR      NZ,L064B                ; loop back while this is not the
                                        ; last entry in the vocabulary.

L0687:  DEFB    $C3                     ; A JP instruction i.e. JP L068A

; Note. The intention is to jump past the headerless code word for the internal
; word stk_zero. Since the word that would follow the first byte of the jump
; instruction would be identical to the word it is jumping over then the word
; can be omitted. Only saves one byte but this is back in 1983.

; ----------------------------
; The 'stk-zero' Internal Word
; ----------------------------
; (  -- 0 )

L0688:  DEFW    L068A                   ; headerless 'code field'

; ---

L068A:  LD      DE,$0000                ; load DE with the value zero.
        RST     10H                     ; stack Data Word DE

        JP      (IY)                    ; to 'next'.

; ------------------
; THE 'EXECUTE' WORD
; ------------------
; ( compilation address --  )
; Executes the word with the given compilation address.

L0690:  DEFM    "EXECUT"                ; 'name field'
        DEFB    'E' + $80

        DEFW    L063C                   ; 'link field'

L0699:  DEFB    $07                     ; 'name length field'

L069A:  DEFW    L069C                   ; 'code field'

; ---

L069C:  RST     18H

        JP      L04BF                   ;

; -----------------
; THE 'NUMBER' WORD
; -----------------
; Takes a number from the start of the input buffer. Leaves the number and
; a non-zero address on the stack. (The address is the compilation address
; of a literal compiler, so that if you then say EXECUTE, the literal compiler
; compiles the number into the dictionary as a literal - for an integer it
; is 4102, for a floating point number it is 4181).
; If no valid number then leaves just 0 on the stack.

L06A0:  DEFM    "NUMBE"                 ; 'name field'
        DEFB    'R' + $80

        DEFW    L0699                   ; 'link field'

L06A8:  DEFB    $06                     ; 'name length field'

L06A9:  DEFW    L06AB                   ; 'code field'

; ---

L06AB:  CALL    L05DF                   ; get buffer

        JR      C,L068A                 ; if empty stack word zero.

        PUSH    BC
        PUSH    DE

        CALL    L074C                   ;

        JR      NZ,L06BC                ;

        LD      DE,$1006                ; addr literal?
        JR      L0714                   ;

; ---

L06BC:  RST     18H                     ; pop word DE
        LD      DE,$0000
        RST     10H                     ; push word DE
        LD      DE,$4500
        POP     BC
        PUSH    BC
        LD      A,(BC)
        CP      $2D                     ; is it '-' ?
        JR      NZ,L06CE                ;

        LD      D,$C5
        INC     BC
L06CE:  RST     10H                     ; push word DE
        LD      D,B
        LD      E,C
        DEC     HL
        DEC     HL

L06D3:  CALL    L0723                   ; routine GET_DECIMAL

        INC     HL
        INC     (HL)
        DEC     HL
        JR      NC,L06D3                ;

        CP      $FE
        JR      NZ,L071C                ;

L06DF:  CALL    L0723                   ; routine GET_DECIMAL

        JR      NC,L06DF                ;

        ADD     A,$30                   ; add '0' converting to letter.
        CALL    L077B                   ;
        JR      NZ,L06EF                ;

        LD      E,$00
        JR      L06FD                   ;

L06EF:  AND     $DF                     ;

        CP      $45                     ; is it 'E' - extended format?
        JR      NZ,L071C                ;

        PUSH    HL

        CALL    L074C                   ;

        RST     18H                     ; pop word DE
        POP     HL
        JR      NZ,L071C                ;

L06FD:  CALL    L0740                   ;
        JR      Z,L0711                 ;

        INC     HL
        LD      A,(HL)
        AND     $7F
        ADD     A,E

        JP      M,L071C                 ; forward +->

        JR      Z,L071C                 ; forward +->

        XOR     (HL)
        AND     $7F
        XOR     (HL)
        LD      (HL),A
L0711:  LD      DE,L1055                ; stk_fp
L0714:  RST     10H                     ; push word DE
        POP     DE
        POP     BC
        CALL    L07DA                   ;
        JP      (IY)                    ; to 'next'.

; ---

; +->
L071C:  POP     HL
        POP     HL
        RST     18H                     ; pop word DE
        RST     18H                     ; pop word DE
        JP      L068A                   ;

; ----------------------------
; THE 'GET DECIMAL' SUBROUTINE
; ----------------------------
; Fetch character and return with carry set if after conversion is not in
; range 0 to 9.

L0723:  LD      A,(DE)
        INC     DE
        SUB     $30                     ; subtract '0'
        RET     C                       ; return if was less than '0'

        CP      $0A                     ; compare to ten.
        CCF                             ; complement
        RET     C                       ; return - with carry set if over 9.

; ---------
; normalize?
; ---------
; => from below only.
L072C:  LD      C,A
        LD      A,(HL)
        AND     $F0
        RET     NZ

        LD      A,C

; => (int/print_fp)
L0732:  DEC     HL
        DEC     HL
        LD      C,$03

L0736:  RLD                             ;  A = xxxx3210  <--   7654<-3210 (HL)

        INC     HL                      ;
        DEC     C
        JR      NZ,L0736                ;

        DEC     (HL)                    ; decrement exponent
        DEC     HL                      ; point to start of BCD nibbles
        CP      A
        RET

; ---

; from ufloat to normalize 6-nibble mantissa

L0740:  LD      B,$06                   ; six nibbles

L0742:  XOR     A

        CALL    L072C                   ;

        RET     NZ

        DJNZ    L0742                   ;

        INC     HL
        LD      (HL),B

        RET

; ---------------------------
; THE 'GET NUMBER' SUBROUTINE
; ---------------------------
; can be called twice by the above code for the word 'NUMBER'.
; Once to get the first number encountered and sometimes, if in extended
; format, the exponent as well.

L074C:  RST     10H                     ; push word DE

        CALL    L04B9                   ; forth

L0750:  DEFW    L086B                   ; dup
        DEFW    L0896                   ; C@
        DEFW    L104B                   ; stk-data
        DEFB    $2D                     ;  chr '-'
        DEFW    L0C4A                   ; =
        DEFW    L086B                   ; dup
        DEFW    L0DA9                   ; negate
        DEFW    L08D2                   ; >R
        DEFW    L0DD2                   ; +
        DEFW    L0E1F                   ; 1-
        DEFW    L0688                   ; stk-zero
        DEFW    L0688                   ; stk-zero
        DEFW    L08FF                   ; rot
L0769:  DEFW    L078A                   ; convert
        DEFW    L08FF                   ; rot
        DEFW    L08DF                   ; R>
        DEFW    L0D94                   ; pos
        DEFW    L08FF                   ; rot
        DEFW    L0879                   ; drop
        DEFW    L0885                   ; swap
        DEFW    L1A0E                   ; end-forth.

L0779:  RST     18H                     ; pop word DE
        LD      A,(DE)

L077B:  CP      $20
        RET     Z

        AND     A
        RET

; ------------------
; THE 'CONVERT' WORD
; ------------------
; (  ud1, addr1 -- ud2, addr2  )
: Accumulates digits from text into an unsigned double length
; number ud1: for each digit, the double length accumulator is
; multiplied by the system number base and the digit (converted
; from ASCII) is added on. The text starts at addr1 + 1. addr2 is
; the address of the first unconvertible character, ud2 is the
; final value of the accumulator.

L0780:  DEFM    "CONVER"                ; 'name field'
        DEFB    'T' + $80

        DEFW    L06A8                   ; 'link field'

L0789:  DEFB    $07                     ; 'name length field'

L078A:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L078C:  DEFW    L0E09                   ; 1+
L078E:  DEFW    L086B                   ; dup
L0790:  DEFW    L08D2                   ; >R
L0792:  DEFW    L0896                   ; C@
L0794:  DEFW    L07B8                   ; stk_digit
L0796:  DEFW    L1283                   ; ?branch
L0798:  DEFW    $001B                   ; to 0799 + 1B = $07B4

L079A:  DEFW    L0885                   ; swap
L079C:  DEFW    L048A                   ; get base
L079E:  DEFW    L0896                   ; C@
L07A0:  DEFW    L0CA8                   ; u*
L07A2:  DEFW    L0879                   ; drop
L07A4:  DEFW    L08FF                   ; rot
L07A6:  DEFW    L048A                   ; get base
L07A8:  DEFW    L0896                   ; C@
L07AA:  DEFW    L0CA8                   ; U*
L07AC:  DEFW    L0DEE                   ; D+
L07AE:  DEFW    L08DF                   ; R>
L07B0:  DEFW    L1276                   ; branch
L07B2:  DEFW    $FFD9                   ; loop back to L078C

L07B4:  DEFW    L08DF                   ; R>
L07B6:  DEFW    L04B6                   ; exit

; -----------------------------
; The 'stk_digit' Internal Word
; -----------------------------

L07B8:  DEFW    L07BA                   ; headerless 'code field'

; ---

L07BA:  RST     18H                     ; pop word DE

        LD      A,E                     ; character to A

        CALL    L0807                   ; to_upper

        ADD     A,$D0                   ; add to give carry with '0' and more.

        JR      NC,L07D7                ; if less than '0' push byte 0 false.

        CP      $0A                     ; compare to ten.
        JR      C,L07CD                 ; forward to stack bytes 0 - 9.

        ADD     A,$EF                   ;
        JR      NC,L07D7                ; push word false 0.

        ADD     A,$0A

L07CD:  CP      (IX+$3F)                ; compare to BASE
        JR      NC,L07D7                ; push word false 0.

; else digit is within range of number base

        LD      D,$00
        LD      E,A
        RST     10H                     ; push word DE
        SCF                             ; set carry to signal true

L07D7:  JP      L0C21                   ; push word 1 or 0

; ---
;       ??
; ---

L07DA:  LD      H,D
        LD      L,E
        INC     BC
        ADD     HL,BC
        PUSH    HL
        BIT     4,(IX+$3E)              ; FLAGS
        CALL    Z,L097F                 ; pr_string

        CALL    L02B0                   ; curs?

        POP     DE
        AND     A
        SBC     HL,DE
        LD      B,H
        LD      C,L
        LD      HL,($3C1E)              ; INSCRN
        INC     HL
        EX      DE,HL
        JR      C,L07FB                 ;

        JR      Z,L07FA                 ; forward to SPACE_FILL.

        LDIR

; ------------------------
; The 'SPACE FILL' routine
; ------------------------
; -> from cls

L07FA:  AND     A                       ; prepare to subtract two screen
                                        ; pointers.

L07FB:  SBC     HL,DE                   ; number of bytes in HL.
        EX      DE,HL                   ; now in DE, HL = start of area.

L07FE:  LD      A,D                     ; check if the
        OR      E                       ; counter is zero.
        RET     Z                       ; return if so.                 >>

        LD      (HL),$20                ; insert a space character.
        INC     HL                      ; next address.
        DEC     DE                      ; decrement byte counter.
        JR      L07FE                   ; loop back to exit on zero.

; --------------------------
; THE 'UPPERCASE' SUBROUTINE
; --------------------------
; converts characters to uppercase.

L0807:  AND     $7F                     ; ignore inverse bit 7
        CP      $61                     ; compare to 'a'
        RET     C                       ; return if lower

        CP      $7B                     ; compare to 'z' + 1
        RET     NC                      ; return if higher than 'z'

        AND     $5F                     ; make uppercase
        RET                             ; return.

; --------------
; THE 'VIS' WORD
; --------------
; Allows copy-up mechanism and 'OK'.

L0812:  DEFM    "VI"                    ; 'name field'
        DEFB    'S' + $80

        DEFW    L0789                   ; 'link field'

L0817:  DEFB    $03                     ; 'name length field'

L0818:  DEFW    L081A                   ; 'code field'

; ---

L081A:  RES     4,(IX+$3E)              ; update FLAGS signal visible mode.
        JP      (IY)                    ; to 'next'.

; ----------------
; THE 'INVIS' WORD
; ----------------
; Suppresses copy-up mechanism and 'OK'.

L0820:  DEFM    "INVI"                  ; 'name field'
        DEFB    'S' + $80

        DEFW    L0817                   ; 'link field'

L0827:  DEFB    $05                     ; 'name length field'

L0828:  DEFW    L082A                   ; 'code field'

; ---

L082A:  SET     4,(IX+$3E)              ; update FLAGS signal invisible mode.

        JP      (IY)                    ; to 'next'.


; ---------------
; THE 'FAST' WORD
; ---------------
; Fast mode - runs without error checks.
; Debugged programs run 25% faster.

L0830:  DEFM    "FAS"                   ; 'name field'
        DEFB    'T' + $80

        DEFW    L0827                   ; 'link field'

L0836:  DEFB    $04                     ; 'name length field'

L0837:  DEFW    L0839                   ; 'code field'

; ---

L0839:  LD      IY,L04B9                ; miss memory checks on return

        JP      (IY)                    ; to 'next'.

; ---------------
; THE 'SLOW' WORD
; ---------------
; ( -- )
; Slow mode with error checking.
; Make IY point to a return routine that performs housekeeping.


L083F:  DEFM    "SLO"                   ; 'name field'
        DEFB    'W' + $80

        DEFW    L0836                   ; 'link field'

L0845:  DEFB    $04                     ; 'name length field'


L0846:  DEFW    L0848                   ; 'code field'

; ---

L0848:  LD      IY,L04C8                ; set vector to memory checks each pass

        JP      (IY)                    ; to 'next'.

; ---------------------------------
; THE 'DATA STACK TO BC' SUBROUTINE
; ---------------------------------
; Called on twenty occasions to fetch a word from the Data Stack into the
; BC register pair. Very similar to RST 18H which does the same thing with the
; DE register pair as the destination on 73 occasions.
; In fact, as two Z80 restarts are unused, then 40 bytes of ROM code could have
; been saved by making this a restart also.

L084E:  LD      HL,($3C3B)              ; fetch SPARE - start of Spare Memory.
        DEC     HL                      ; decrement to point to last stack item
        LD      B,(HL)                  ; load high byte to B.
        DEC     HL                      ; address low byte of word.
        LD      C,(HL)                  ; and load to C.
        LD      ($3C3B),HL              ; update the system variable SPARE to
                                        ; a location two bytes less than it was.
        RET                             ; return.

; -----------------------------------------
; THE 'CONTINUATION OF THE RST 18H' RESTART
; -----------------------------------------
; complete the operation of popping a word to DE from the data stack.

L0859:  DEC     HL                      ;
        LD      E,(HL)                  ;
        LD      ($3C3B),HL              ; update SPARE
        RET                             ; return.

; -----------------------------------------
; THE 'CONTINUATION OF THE RST 10H' RESTART
; -----------------------------------------
; complete the operation of pushing a word in DE to the data stack.

L085F:  LD      (HL),D                  ;
        INC     HL                      ;
        LD      ($3C3B),HL              ; update SPARE
        RET                             ; return.

; --------------
; THE 'DUP' WORD
; --------------
; ( n -- n, n )
; Duplicates the top of the stack.

L0865:  DEFM    "DU"                    ; 'name field'
        DEFB    'P' + $80

        DEFW    L0845                   ; 'link field'

L086A:  DEFB    $03                     ; 'name length field'

L086B:  DEFW    L086D                   ; 'code field'

; ---

L086D:  RST     18H                     ; unstack Data Word DE
        RST     10H                     ; stack Data Word DE
        RST     10H                     ; stack Data Word DE

        JP      (IY)                    ; to 'next'.

; ---------------
; THE 'DROP' WORD
; ---------------
; ( n -- )
; Throws away the top of the stack.

L0872:  DEFM    "DRO"                   ; 'name field'
        DEFB    'P' + $80

        DEFW    L086A                   ; 'link field'

L0878:  DEFB    $04                     ; 'name length field'

L0879:  DEFW    L087B                   ; 'code field'

; ---

L087B:  RST     18H                     ; unstack Data Word DE
        JP      (IY)                    ; to 'next'.

; ---------------
; THE 'SWAP' WORD
; ---------------
; (n1, n2 -- n2, n1)

L087E:  DEFM    "SWA"                   ; 'name field'
        DEFB    'P' + $80

        DEFW    L0878                   ; 'link field'

L0884:  DEFB    $04                     ; 'name length field'

L0885:  DEFW    L0887                   ; 'code field'

; ---

L0887:  RST     18H                     ; pop word DE
        CALL    L084E                   ; stk_to_bc
        RST     10H                     ; push word DE
        LD      D,B                     ;
        LD      E,C                     ;
        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; -------------
; THE 'C@' WORD
; -------------
; (address -- byte)
; Fetches the contents of a given address.

L0891:  DEFB    'C'                     ; 'name field'
        DEFB    '@' + $80

        DEFW    L0884                   ; 'link field'

L0895:  DEFB    $02                     ; 'name length field'

L0896:  DEFW    L0898                   ; 'code field'

; ---

L0898:  RST     18H                     ; pop word DE
        LD      A,(DE)
        LD      E,A
        LD      D,$00

        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; -------------
; THE 'C!' WORD
; -------------
; (n, address -- )
; Stores the less significant byte on n at a given address.

L08A0:  DEFB    'C'                     ; 'name field'
        DEFB    '!' + $80

        DEFW    L0895                   ; 'link field'

L08A4:  DEFB    $02                     ; 'name length field'

L08A5:  DEFW    L08A7                   ; 'code field'

; ---

L08A7:  RST     18H                     ; pop word DE
        CALL    L084E                   ; stk_to_bc
        LD      A,C
        LD      (DE),A

        JP      (IY)                    ; to 'next'.

; ------------
; THE '@' WORD
; ------------
; (address -- n)
; Leaves on stack the single length integer at the given address.

L08AF:  DEFB    '@' + $80               ; 'name field'

        DEFW    L08A4                   ; 'link field'

L08B2:  DEFB    $01                     ; 'name length field'

L08B3:  DEFW    L08B5                   ; 'code field'

; ---

L08B5:  RST     18H                     ; pop word DE

        EX      DE,HL
        LD      E,(HL)
        INC     HL
        LD      D,(HL)

        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; ------------
; THE '!' WORD
; ------------
; (n,address --)
; Stores the single-length integer n at the given address in memory.

L08BD:  DEFB    '!' + $80               ; 'name field'

        DEFW    L08B2                   ; 'link field'

L08C0:  DEFB    $01                     ; 'name length field'

L08C1:  DEFW    L08C3                   ; 'code field'

; ---

L08C3:  RST     18H                     ; pop word DE
        CALL    L084E                   ; stk_to_bc
        EX      DE,HL
        LD      (HL),C
        INC     HL
        LD      (HL),B

        JP      (IY)                    ; to 'next'.

; -------------
; THE '>R' WORD
; -------------
; (n -- )
; Transfers top entry on data stack to return stack.
; It can be copied back using 'I'.

L08CD:  DEFB    '>'                     ; 'name field'
        DEFB    'R' + $80

        DEFW    L08C0                   ; 'link field'

L08D1:  DEFB    $02                     ; 'name length field'

L08D2:  DEFW    L08D4                   ; 'code field'

; ---

L08D4:  RST     18H
        POP     BC
        PUSH    DE
        PUSH    BC
        JP      (IY)                    ; to 'next'.

; -------------
; THE 'R>' WORD
; -------------
; ( -- entry from return stack)
; Transfers top entry on return stack to data stack.

L08DA:  DEFB    'R'                     ; 'name field'
        DEFB    '>' + $80

        DEFW    L08D1                   ; 'link field'

L08DE:  DEFB    $02                     ; 'name length field'

L08DF:  DEFW    L08E1                   ; 'code field'

; ---

L08E1:  POP     BC
        POP     DE
        PUSH    BC
        RST     10H                     ; push word DE
        JP      (IY)                    ; to 'next'.

; ---------------
; THE '?DUP' WORD
; ---------------
; (n -- n, n)    if n!=0.
; (n -- n)       if n=0.

L08E7:  DEFM    "?DU"                   ; 'name field'
        DEFB    'P' + $80

        DEFW    L08DE                   ; 'link field'

L08ED:  DEFB    $04                     ; 'name length field'

L08EE:  DEFW    L08F0                   ; 'code field'

; ---


L08F0:  RST     18H                     ; fetch word DE
        RST     10H                     ; push it back
        LD      A,D                     ; test if fetched
        OR      E                       ; word is zero
        CALL    NZ,L0010                ; push word DE if non-zero
        JP      (IY)                    ; to 'next'.

; --------------
; THE 'ROT' WORD
; --------------
; (n1, n2, n3 -- n2, n3, n1)

L08F9:  DEFM    "RO"                    ; 'name field'
        DEFB    'T' + $80

        DEFW    L08ED                   ; 'link field'

L08FE:  DEFB    $03                     ; 'name length field'

L08FF:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0901:  DEFW    L08D2                   ; >R
L0903:  DEFW    L0885                   ; swap
L0905:  DEFW    L08DF                   ; R>
L0907:  DEFW    L0885                   ; swap
L0909:  DEFW    L04B6                   ; exit

; ---------------
; THE 'OVER' WORD
; ---------------
; (n1, n2 -- n1, n2, n1)

L090B:  DEFM    "OVE"                   ; 'name field'
        DEFB    'R' + $80

        DEFW    L08FE                   ; 'link field'

L0911:  DEFB    $04                     ; 'name length field'

L0912:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0914:  DEFW    L08D2                   ; >R
L0916:  DEFW    L086B                   ; dup
L0918:  DEFW    L08DF                   ; R>
L091A:  DEFW    L0885                   ; swap
L091C:  DEFW    L04B6                   ; exit

; ---------------
; THE 'PICK' WORD
; ---------------
; (n1 -- n2)
; Copies the n1-th stack entry (after dropping n1 itself) to the top.
; Error 7 if n1 <= 0.

L091E:  DEFM    "PIC"                   ; 'name field'
        DEFB    'K' + $80

        DEFW    L0911                   ; 'link field'

L0924:  DEFB    $04                     ; 'name length field'

        DEFW    L0927                   ; 'code field'

; ---

L0927:  CALL    L094D                   ;
        JP      (IY)                    ; to 'next'.

; ---------------
; THE 'ROLL' WORD
; ---------------
; (n -- )
; Extracts the nth stack value to the top of the stack, after dropping n
; itself, and moves the remaining values down to fill the vacated position.
; Error 7 if n <= 0.

L092C:  DEFM    "ROL"                   ; 'name field'
        DEFB    'L' + $80

        DEFW    L0924                   ; 'link field'

L0932:  DEFB    $04                     ; 'name length field'

L0933:  DEFW    L0935                   ; 'code field'

; ---

L0935:  CALL    L094D                   ;
        EX      DE,HL
        LD      HL,($3C37)              ; STKBOT
        SBC     HL,DE
        JP      NC,L04D7                ; jump back to Error 2

        LD      H,D
        LD      L,E
        INC     HL
        INC     HL
        LDIR
        LD      ($3C3B),DE              ; SPARE
        JP      (IY)                    ; to 'next'.

; ---

L094D:  CALL    L084E                   ; stk_to_bc
        DEC     BC
        SLA     C
        RL      B
        INC     BC
        INC     BC
        JR      NC,L095B                ; skip the error routine

        RST     20H                     ; Error 7
        DEFB    $07                     ; PICK or ROLL used with operand 0
                                        ; or negative

; ---

L095B:  LD      HL,($3C3B)              ; SPARE
        SBC     HL,BC
        PUSH    HL
        LD      E,(HL)
        INC     HL
        LD      D,(HL)
        RST     10H                     ; push word DE
        POP     HL
        RET

; ---------------
; THE 'TYPE' WORD
; ---------------
; (address, n -- )
; EMITs n characters from memory starting at the address.


L0967:  DEFM    "TYP"                   ; 'name field'
        DEFB    'E' + $80

        DEFW    L0932                   ; 'link field'

L096D:  DEFB    $04                     ; 'name length field'

L096E:  DEFW    L0970                   ; 'code field'

; ---

L0970:  CALL    L084E                   ; stk_to_bc
        RST     18H                     ; pop word DE
        CALL    L097F                   ; routine pr_string (below)

        JP      (IY)                    ; to 'next'.

; --------------------------
; THE 'PRINT STRING' ROUTINE
; --------------------------
; The first entry point prints strings embedded in the Dictionary with the
; DE pointing to the preceding length word.
;
; The second entry point prints a string with length in BC and start in DE.
; It is called by TYPE above and to print comment fields.

; ->

L0979:  LD      A,(DE)
        LD      C,A
        INC     DE
        LD      A,(DE)
        LD      B,A
        INC     DE

; -->
L097F:  LD      A,B
        OR      C
        RET     Z

        LD      A,(DE)
        INC     DE
        DEC     BC
        RST     08H                     ; print_ch

        JR      L097F                   ;

; -------------
; THE '<#' WORD
; -------------
; (  --  )
; Initiates formatted output.

L0988:  DEFB    '<'                     ; 'name field'
        DEFB    '#' + $80

        DEFW    L096D                   ; 'link field'

L098C:  DEFB    $02                     ; 'name length field'

L098D:  DEFW    L098F                   ; 'code field'

; ---

L098F:  LD      HL,$27FF                ; end of pad
        LD      ($3C1A),HL              ; update system variable HLD
        JP      (IY)                    ; to 'next'.

; -------------
; THE '#>' WORD
; -------------
; (ud -- address, n)
; Finishes formatted output, leaving the address and length (n) of the
; resultant string.

L0997:  DEFB    '#'                     ; 'name field'
        DEFB    '>' + $80

        DEFW    L098C                   ; 'link field'

L099B:  DEFB    $02                     ; 'name length field'

L099C:  DEFW    L099E                   ; 'code field'

; ---

L099E:  RST     18H                     ; pop word DE
        RST     18H                     ; pop word DE
        LD      DE,($3C1A)              ; HLD
        RST     10H                     ; push word DE (address)
        LD      HL,$27FF                ; end of pad.
        AND     A                       ; prepare to subtract.
        SBC     HL,DE                   ; find length of string.
        EX      DE,HL                   ; transfer to DE
        RST     10H                     ; push word DE (n)

        JP      (IY)                    ; to 'next'.

; ------------
; THE '.' WORD
; ------------
;

L09AF:  DEFB    '.' + $80               ; 'name field'

        DEFW    L0A49                   ; 'link field'

L09B2:  DEFB    $01                     ; 'name length field'

L09B3:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L09B5:  DEFW    L098D                   ; <#
        DEFW    L086B                   ; dup
        DEFW    L0C0D                   ; abs
        DEFW    L0688                   ; stk-zero
        DEFW    L09E1                   ; #s
        DEFW    L08FF                   ; rot
        DEFW    L0A4A                   ; sign

L09C3:  DEFW    L099C                   ; #>
        DEFW    L096E                   ; type
        DEFW    L0A73                   ; space
        DEFW    L04B6                   ; exit

; -------------
; THE 'U.' WORD
; -------------
; (un -- )
; Prints the unsigned single length integer 'un' to the television screen,
; followed by a space.

L09CB:  DEFB    'U'                     ; 'name field'
        DEFB    '.' + $80

        DEFW    L09B2                   ; 'link field'

L09CF:  DEFB    $02                     ; 'name length field'

L09D0:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L09D2:  DEFW    L0688                   ; stk-zero
L09D4:  DEFW    L098D                   ; <#
L09D6:  DEFW    L09E1                   ; #S
L09D8:  DEFW    L1276                   ; branch
L09DA:  DEFW    $FFE8                   ; -> 09C3


; -------------
; THE '#S' WORD
; -------------
; (ud -- 0,0)
; Applies # repeatedly (at least once) until the double length number left
; on the stack is 0.

L09DC:  DEFB    '#'                     ; 'name field'
        DEFB    'S' + $80

        DEFW    L09CF                   ; 'link field'

L09E0:  DEFB    $02                     ; 'name length field'

L09E1:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L09E3:  DEFW    L09F7                   ; #
        DEFW    L0912                   ; over
        DEFW    L0912                   ; over
        DEFW    L0E36                   ; or
        DEFW    L0C1A                   ; 0=
        DEFW    L128D                   ; ?branch

L09EF:  DEFW    $FFF3                   ; back to L09E3

        DEFW    L04B6                   ; exit

; ------------
; THE '#' WORD
; ------------
; (ud1 -- ud2)
; used in formatted output. Generates one digit from the unsigned double
; length integer ud1 and holds it in the pad. The unsigned double length
; integer ud2 is the quotient when ud1 is divided by the number base.

L09F3:  DEFB    '#' + $80               ; 'name field'

        DEFW    L09E0                   ; 'link field'

L09F6:  DEFB    $01                     ; 'name length field'

L09F7:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L09F9:  DEFW    L048A                   ; get base
L09FB:  DEFW    L0896                   ; C@
L09FD:  DEFW    L0CC4                   ; div?
L09FF:  DEFW    L08FF                   ; rot
L0A01:  DEFW    L0A07                   ; stk-char
L0A03:  DEFW    L0A5C                   ; hold
L0A05:  DEFW    L04B6                   ; exit

; ----------------------------
; The 'stk-char' Internal Word
; ----------------------------
; used from above thread.

L0A07:  DEFW    L0A09                   ; headerless 'code field'

; ---

L0A09:  RST     18H                     ; data stack to DE
        LD      A,E                     ; character to A
        ADD     A,$30                   ; convert digit to ASCII
        CP      $3A                     ; compare to '9'
        JR      C,L0A13                 ; forward if digit
        ADD     A,$07                   ; else add for hex

L0A13:  LD      E,A                     ; back to E
        RST     10H                     ; push ASCII on data stack.
        JP      (IY)                    ; to 'next'.

; --------------
; THE 'CLS' WORD
; --------------
; ( -- )
; Clears the screen and sets the print position to the top left of
; the screen.

L0A17:  DEFM    "CL"                    ; 'name field'
        DEFB    'S' + $80

        DEFW    L09F6                   ; 'link field'

L0A1C:  DEFB    $03                     ; 'name length field'

        DEFW    L0A1F                   ; 'code field'

; ---

L0A1F:  CALL    L0A24                   ; routine CLS below.

        JP      (IY)                    ; to 'next'.


; --------------------
; THE 'CLS' SUBROUTINE
; --------------------
; Called from the 'CLS' word definition above and also from the initialization
; routine.

L0A24:  LD      DE,$26FF                ; point destination to end of video
                                        ; memory.
        LD      HL,($3C24)              ; set HL to first byte of input buffer
                                        ; from system variable L_HALF.
                                        ; (at initialization $26E0).

        LD      BC,$0020                ; set count to thirty two.

        ADD     HL,BC                   ; add to the low address.
        DEC     HL                      ; step back and
        LDDR                            ; copy the 32 bytes.

; while BC is zero, set the plotting coordinates.

        LD      ($3C2F),BC              ; set XCOORD and YCOORD to zero.

; set the screen position to the start of video memory.

        LD      HL,$2400                ; start of the 768 bytes of video RAM.
        LD      ($3C1C),HL              ; set system variable SCRPOS.

        INC     DE                      ; the byte before logical line.
        EX      DE,HL                   ; transfer to HL.
        LD      ($3C24),HL              ; set L_HALF.
        JP      L07FA                   ; jump back to fill the locations
                                        ; from DE to HL -1 with spaces.

; ---------------
; THE 'SIGN' WORD
; ---------------
; (n -- )
; In formatted output, holds a minus sign in the pad if n is negative.


L0A43:  DEFM    "SIG"                   ; 'name field'
        DEFB    'N' + $80

        DEFW    L099B                   ; 'link field'

L0A49:  DEFB    $04                     ; 'name length field'

L0A4A:  DEFW    L0A4C                   ; 'code field'

; ---

L0A4C:  RST     18H                     ; pop word DE
        RL      D                       ; test sign bit
        LD      E,$2D                   ; prepare a '-'
        JR      C,L0A5F                 ; forward if minus
        JP      (IY)                    ; to 'next'.

; ---------------
; THE 'HOLD' WORD
; ---------------
; (character -- )
; Used in formatted output to hold the character in the pad.

L0A55:  DEFM    "HOL"                   ; 'name field'
        DEFB    'D' + $80

L0A59:  DEFW    L0A1C                   ; 'link field'

L0A5B:  DEFB    $04                     ; 'name length field'

L0A5C:  DEFW    L0A5E                   ; 'code field'

; ---

L0A5E:  RST     18H                     ; data stack to DE

L0A5F:  LD      HL,($3C1A)              ; HLD
        DEC     L
        JR      Z,L0A69                 ; forward when full

        LD      ($3C1A),HL              ; update HLD
        LD      (HL),E                  ; and place character in buffer

L0A69:  JP      (IY)                    ; to 'next'.

; ----------------
; THE 'SPACE' WORD
; ----------------
; (  --  )
; EMITs a space.

L0A6B:  DEFM    "SPAC"                  ; 'name field'
        DEFB    'E' + $80

        DEFW    L0A5B                   ; 'link field'

L0A72:  DEFB    $05                     ; 'name length field'

L0A73:  DEFW    L0A75                   ; 'code field'

; ---

L0A75:  LD      A,$20                   ; load accumulator with the ASCII
                                        ; code for space.
        RST     08H                     ; print_ch

L0A78:  JP      (IY)                    ; to 'next'.

; -----------------
; THE 'SPACES' WORD
; -----------------
; (n -- )
; EMITs n spaces if n >= 1.

L0A7A:  DEFM    "SPACE"                 ; 'name field'
        DEFB    'S' + $80

        DEFW    L0A72                   ; 'link field'

L0A82:  DEFB    $06                     ; 'name length field'

        DEFW    L0A85                   ; 'code field'

; ---

L0A85:  RST     18H                     ; fetch stack data to DE

L0A86:  DEC     DE                      ; decrement the counter.
        BIT     7,D                     ; test for a negative value
        JR      NZ,L0A78                ; back to a jp iy  when done    >>

        LD      A,$20                   ; prepare a space
        RST     08H                     ; print it
        JR      L0A86                   ; loop back for more.

; -------------
; THE 'CR' WORD
; -------------
; Outputs a carriage return character to the television.

L0A90:  DEFB    'C'                     ; 'name field'
        DEFB    'R' + $80

        DEFW    L0A82                   ; 'link field'

L0A94:  DEFB    $02                     ; 'name length field'

L0A95:  DEFW    L0A97                   ; 'code field'

; ---

L0A97:  LD      A,$0D                   ; prepare a CR
        RST     08H                     ; print it.

        JP      (IY)                    ; to 'next'.

; ---------------
; THE 'EMIT' WORD
; ---------------
; (character -- )
; writes the character to the television screen.

L0A9C:  DEFM    "EMI"                   ; 'name field'
        DEFB    'T' + $80

        DEFW    L0A94                   ; 'link field'

L0AA2:  DEFB    $04                     ; 'name length field'

L0AA3:  DEFW    L0AA5                   ; 'code field'

; ---

L0AA5:  RST     18H                     ; pop de off data stack
        LD      A,E                     ; character to A
        RST     08H                     ; print it.

        JP      (IY)                    ; to 'next'.


; -------------
; THE 'F.' WORD
; -------------
; (f -- )
; print a floating point number.
; If 1.0E-4 <= f < 1.0E9, then f is printed without an exponent and with a
; decimal point in the appropriate place. If f is outside this range, then
; it is printed in standard form f'En where 0 <= f' < 10 and -64 <= n <= 62.
; Input may be either form, but only six significant digits are accepted -
; further digits are ignored.
; Floating point numbers are stored as 3 bytes of binary coded decimal
; mantissa and 1 byte for sign and decimal exponents.
;
; e.g. the number 123.456 on Data Stack would be two words, four bytes.
;
;       ^       43              01000011   bits 5 - 0 are exponent
;       |       12      BCD     ||
;       |       34      BCD     |sign of exponent 1=positive (bit 6)
;       |       56      BCD     sign of number 0=positive (bit 7)
;
; Zero 0. is a special case floating point number with all four bytes set
; to zero.


L0AAA:  DEFB    'F'                     ; 'name field'
        DEFB    '.' + $80

        DEFW    $0AA2                   ; 'link field'

L0AAE:  DEFB    $02                     ; 'name length field'

L0AAF:  DEFW    $0AB1                   ; 'code field'

; ---

L0AB1:  LD      HL,($3C3B)              ; set pointer from system variable SPARE
        DEC     HL                      ; now points to last byte of data stack.
        BIT     7,(HL)                  ; test sign of number.
        RES     7,(HL)                  ; reset the sign bit.
        JR      Z,L0ABE                 ; forward if initially positive.

        LD      A,$2D                   ; prepare  the '-' character.
        RST     08H                     ; print the minus sign.

; The E register is initialized to zero to denote not E-FORMAT

L0ABE:  LD      E,$00                   ; signal not scientific notation.

        LD      A,(HL)                  ; fetch exponent byte
        DEC     A                       ; adjust to make zero $FF

        CP      $49                     ; compare to +9   e.g.  123456000.
        JR      NC,L0ACA                ; skip forward if out of range.

        CP      $3C                     ; compare to -4   e.g  .000123456
        JR      NC,L0ACE                ; skip forward if in range.

; else E format printing will be used with decimal point after first digit.

L0ACA:  LD      (HL),$41                ; make Data Stack exponent +1
        INC     A                       ; restore true exponent byte
        LD      E,A                     ; transfer to E.

; the branch was here when within range for normal printing.

L0ACE:  LD      A,$40                   ; test value is plus zero.
        SUB     (HL)                    ; subtract signed exponent.
        JR      C,L0ADC                 ; forward if positive

; exponent is negative so decimal point comes first. e.g. .001

        LD      B,A                     ; result of subtraction to B.
        INC     B                       ; B is now one less than count of
                                        ; leading zeros.

        LD      A,$2E                   ; prepare '.'

L0AD7:  RST     08H                     ; print decimal point or zero.

        LD      A,$30                   ; prepare a zero - '0'

        DJNZ    L0AD7                   ; loop back to print leading zeros
                                        ; unless the counter was 1.

; the branch was here with positive exponent (and zero)
; now enter a loop to print each of the leading BCD digits
; the loop will end when the exponent is <= +0 and all 6 nibbles contain zero.

L0ADC:  LD      A,$40                   ; set accumulator to plus 0
        CP      (HL)                    ; compare to exponent on data stack.
        SBC     A,A                     ; $FF if more leading digits else $00.
        DEC     HL                      ; address first two nibbles.
        OR      (HL)                    ; combine.
        DEC     HL                      ; address next two nibbles.
        OR      (HL)                    ; combine.
        DEC     HL                      ; address last two nibbles.
        OR      (HL)                    ; combine.

        INC     HL                      ; adjust the pointer to
        INC     HL                      ; the start of the mantissa.

        JR      Z,L0AFC                 ; forward if all digits have been
                                        ; printed.

; else print each binary coded decimal in turn.

        XOR     A                       ; prepare to feed a zero nibble in.

        CALL    L0732                   ; routine shift_fp extracts the most
                                        ; significant nibble from the 3 bytes
                                        ; also decrementing the exponent.

        ADD     A,$30                   ; convert to ASCII
        RST     08H                     ; print digit

        INC     HL                      ; point to reduced exponent.
        LD      A,(HL)                  ; fetch to accumulator and
        CP      $40                     ; compare to zero.

        JR      NZ,L0ADC                ; loop back while more digits.

; else this is the place to print the mid or trailing decimal point.

        LD      A,$2E                   ; prepare '.'
        RST     08H                     ; print it.

        JR      L0ADC                   ; loop back for end test and any digits
                                        ; following the decimal point.

; ---

; the branch was to here when all digits of the mantissa have been printed.

L0AFC:  LD      A,E                     ; fetch the exponent format flag - from
                                        ; the E register appropriately.
        AND     A                       ; test for zero - normal format.
        JR      NZ,L0B05                ; forward to E_FORMAT if not.

        LD      A,$20                   ; else prepare a space
        RST     08H                     ; print it

        JR      L0B10                   ; forward to delete the two words from
                                        ; the data stack and exit.

; ---

; this branch deals with scientific notation. The accumulator holds the
; original exponent. $01-$3C (negative) $49-$7F (positive).

L0B05:  SUB     $41                     ; convert to signed 8-bit.
        LD      L,A                     ; low order byte to L.
        SBC     A,A                     ; $FF negative or $00 positive
        LD      H,A                     ; set the high order byte.

        LD      A,$45                   ; prepare a 'E'
        RST     08H                     ; print it

        CALL    L180E                   ; routine pr_int_hl prints the signed
                                        ; integer followed by a space.

; finally delete the floating point number from the Data Stack.


L0B10:  RST     18H                     ; unstack word DE
        RST     18H                     ; unstack word DE

        JP      (IY)                    ; to 'next'.

; -------------
; THE 'AT' WORD
; -------------
; (line, column -- )
; Sets print position to line and column numbers on the stack.
; There are 23 lines (0 to 22) and 32 columns (0 to 31). The
; column number is taken modulo 32, and ERROR 9 if trying to print
; in the input buffer at the bottom.

L0B14:  DEFB    'A'                     ; 'name field'
        DEFB    'T' + $80

        DEFW    L0AAE                   ; 'link field'

L0B18:  DEFB    $02                     ; 'name length field'

        DEFW    L0B1B                   ; 'code field'

; ---

L0B1B:  RST     18H                     ; pop word DE

        CALL    L084E                   ; stk_to_bc

        LD      A,C

        CALL    L0B28                   ;

        LD      ($3C1C),HL              ; update system variable SCRPOS

        JP      (IY)                    ; to 'next'.

; ---

; plotsub

L0B28:  ADD     A,$20
        LD      L,A
        LD      H,$01
        ADD     HL,HL
        ADD     HL,HL
        ADD     HL,HL
        ADD     HL,HL
        ADD     HL,HL
        LD      D,$00
        LD      A,E
        AND     $1F
        LD      E,A
        ADD     HL,DE
        LD      DE,($3C24)              ; fetch start of lower half from L_HALF
        SBC     HL,DE
        ADD     HL,DE
        RET     C

;

        RST     20H                     ; Error 9
        DEFB    $09                     ; Erroneous 'AT' Command.

; ---------------
; THE 'PLOT' WORD
; ---------------
; (x, y, n -- )
; Plots pixel (x, y) with plot mode n.
; n =   0       unplot
;       1       plot
;       2       move
;       3       change
; If n>3, takes value modulo 4.

L0B43:  DEFM    "PLO"                   ; 'name field'
        DEFB    'T' + $80

        DEFW    L0B18                   ; 'link field'

L0B49:  DEFB    $04                     ; 'name length field'

        DEFW    L0B4C                   ; 'code field'

; ---

L0B4C:  CALL    L084E                   ; stk_to_bc

        RST     18H                     ; pop word DE
        LD      (IX+$30),E              ; YCOORD
        SRL     E
        RL      C
        LD      A,$16                   ; 24
        SUB     E

        RST     18H                     ; pop word DE
        LD      (IX+$2F),E              ; XCOORD
        SRL     E
        RL      C

        CALL    L0B28                   ;

        LD      A,(HL)
        AND     $78                     ; 01111000
        CP      $10
        LD      A,(HL)
        JR      Z,L0B6F                 ;

        LD      A,$10

L0B6F:  LD      E,A
        LD      D,$87
        LD      A,C
        AND     $03
        LD      B,A
        JR      Z,L0B7F                 ;

        CPL

        ADD     A,$02
        ADC     A,$03
        LD      D,A
        LD      B,E
L0B7F:  LD      A,C
        RRCA
        RRCA
        RRCA
        SBC     A,A
        BIT     3,C
        JR      NZ,L0B8C                ;
        XOR     E
        RLCA
        SBC     A,A
        XOR     B

L0B8C:  AND     D
        XOR     E
        LD      (HL),A
        JP      (IY)                    ; to 'next'.

; ---------------
; THE 'BEEP' WORD
; ---------------
; ( m, n --  )
; Plays a note on the loudspeaker. 8 * m = period in microseconds,
; n = time in milliseconds.

L0B91:  DEFM    "BEE"                   ; 'name field'
        DEFB    'P' + $80

        DEFW    L0B49                   ; 'link field'

L0B97:  DEFB    $04                     ; 'name length field'

        DEFW    L0EC3                   ; 'code field'  m, n.

; ---

L0B9A:  DEFW    L0912                   ; OVER          m, n, m.
        DEFW    L104B                   ; stk-data      m, n, m, 125.
        DEFB    $7D                     ;  (125)
        DEFW    L0885                   ; SWAP          m, n, 125, m.
        DEFW    L0D7A                   ; */            m, (n*125)/m
        DEFW    L1A0E                   ; end

; ---

L0BA5:  RST     18H                     ; pop word DE

        CALL    L084E                   ; stk_to_bc

        LD      HL,$00F9                ;
        ADD     HL,BC                   ;
        INC     L                       ;

        DI                              ; Disable Interrupts.

L0BAF:  LD      A,$7F                   ; place $7FFE on address bus and read
        IN      A,($FE)                 ; from port, pushing the loudspeaker
                                        ; diaphragm in.

        RRCA                            ; test the read 'SPACE' key bit.

        JR      NC,L0BC7                ; forward if BREAK pressed.

        CALL    L0BC9                   ; routine delay_HL

        DEC     DE                      ; decrement counter.

        LD      A,D                     ; all even addresses are reserved for
                                        ; Jupiter Ace so any value does for the
                                        ; high order byte. $FE is low value.

        OUT     ($FE),A                 ; push the loudspeaker diaphragm out.

        CALL    L0BC9                   ; routine delay_HL

        OR      E                       ; test for counter DE reaching zero.
        JP      NZ,L0BAF                ; loop back if not.

        EI                              ; Enable Interrupts.

        JP      (IY)                    ; to 'next'.

; ---

L0BC7:  RST     20H                     ; Error 3
        DEFB    $03                     ; BREAK pressed.

; ---------------------------
; THE 'BEEP DELAY' SUBROUTINE
; ---------------------------
; called twice from the above BEEP routine.

L0BC9:  LD      B,L                     ; transfer the value of
        LD      C,H                     ; the HL register to BC.

L0BCB:  DJNZ    L0BCB                   ; self-loop for B times

        DEC     B                       ; set B to $FF for future loops
        DEC     C                       ; decrement outer loop counter C
        JP      NZ,L0BCB                ; JUMP back if not zero           (10)

        RET                             ; return

; ----------------
; THE 'INKEY' WORD
; ----------------
; ( -- ASCII code)
; Reads the keyboard. Puts ASCII value on the stack if a key is pressed, 0
; otherwise.


L0BD3:  DEFM    "INKE"                  ; 'name field'
        DEFB    'Y' + $80

        DEFW    L0B97                   ; 'link field'

L0BDA:  DEFB    $05                     ; 'name length field'

L0BDB:  DEFW    L0BDD                   ; 'code field'

; ---

L0BDD:  CALL    L0336                   ; routine KEY-SCAN

        LD      E,A                     ; transfer the key code to E.
        LD      D,$00                   ; make high order byte zero.

        RST     10H                     ; stack Data Word DE

        JP      (IY)                    ; to 'next'.

; -------------
; THE 'IN' WORD
; -------------
; (port address -- data byte)
; Inputs a data byte from an I/O port.

L0BE6:  DEFB    'I'                     ; 'name field'
        DEFB    'N' + $80

        DEFW    L0BDA                   ; 'link field'

L0BEA:  DEFB    $02                     ; 'name length field'

        DEFW    L0BED                   ; 'code field'

; ---

L0BED:  CALL    L084E                   ; stk_to_bc
        LD      D,$00                   ; make high order byte zero.

        IN      E,(C)                   ; read the port to E.

        RST     10H                     ; stack Data Word DE.

L0BF5:  JP      (IY)                    ; to 'next'.

; --------------
; THE 'OUT' WORD
; --------------
; (data byte, port address -- )
; Outputs a data byte to an I/O port.

L0BF7:  DEFM    "OU"                    ; 'name field'
        DEFB    'T' + $80

        DEFW    L0BEA                   ; 'link field'

L0BFC:  DEFB    $03                     ; 'name length field'

        DEFW    L0BFF                   ; 'code field'

; ---

L0BFF:  CALL    L084E                   ; stk_to_bc
                                        ; all 16 bits are placed on the
                                        ; Z80A address bus.
        RST     18H                     ; pop word DE

        OUT     (C),E                   ; output byte to port address.

        JP      (IY)                    ; to 'next'.

; --------------
; THE 'ABS' WORD
; --------------
; (n -- absolute value of n)

L0C07:  DEFM    "AB"                    ; 'name field'
        DEFB    'S' + $80

        DEFW    L0BFC                   ; 'link field'

L0C0C:  DEFB    $03                     ; 'name length field'

L0C0D:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

        DEFW    L086B                   ; DUP
        DEFW    L0D94                   ; pos
        DEFW    L04B6                   ; EXIT

; -------------
; THE '0=' WORD
; -------------
; (n -- flag)
; flag is 1 in n = 0.

L0C15:  DEFB    '0'                     ; 'name field'
        DEFB    '=' + $80

        DEFW    L0C0C                   ; 'link field'

L0C19:  DEFB    $02                     ; 'name length field'

L0C1A:  DEFW    L0C1C                   ; 'code field'

; ---

L0C1C:  RST     18H                     ; pop word DE
        LD      A,D                     ; test for
        OR      E                       ; zero
        CP      $01                     ; sets carry if word is zero

; -> zero_or_one

L0C21:  LD      A,$00                   ; make accumulator zero.
        LD      D,A                     ; set D to zero
        RLA                             ; pick up carry (1/0)
        LD      E,A                     ; set DE to one or zero
        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; -------------
; THE '0<' WORD
; -------------
; (n -- flag)
; flag is 1 if n is negative

L0C29:  DEFB    '0'                     ; 'name field'
        DEFB    '<' + $80

        DEFW    L0C19                   ; 'link field'

L0C2D:  DEFB    $02                     ; 'name length field'

L0C2E:  DEFW    L0C30                   ; 'code field'

; ---

L0C30:  RST     18H                     ; pop word DE
        RL      D                       ; test the sign bit.

        JR      L0C21                   ; back to above routine to stack the
                                        ; carry as one (true) or zero (false).

; -------------
; THE '0>' WORD
; -------------
; (n -- flag)
; flag is 1 if n is positive.


L0C35:  DEFB    '0'                     ; 'name field'
        DEFB    '>' + $80

        DEFW    L0C2D                   ; 'link field'

L0C39:  DEFB    $02                     ; 'name length field'

L0C3A:  DEFW    L0C3C                   ; 'code field'

; ---

L0C3C:  RST     18H                     ; pop word DE
        LD      A,D
        OR      E
        JR      Z,L0C21                 ; to stack word one or zero

        RL      D
        CCF
        JR      L0C21                   ; to stack word one or zero

; ------------
; THE '=' WORD
; ------------
; (n1, n2 -- flag)
; flag is 1 if n1=n2.

L0C46:  DEFB    '=' + $80               ; 'name field'

        DEFW    L0C39                   ; 'link field'

L0C49:  DEFB    $01                     ; 'name length field'

L0C4A:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0C4C:  DEFW    L0DE1                   ; -
        DEFW    L0C1A                   ; 0=
        DEFW    L04B6                   ; exit

; ------------
; THE '>' WORD
; ------------
; (n1, n2 -- flag)
; flag is 1 if n1>n2.

L0C52:  DEFB    '>' + $80               ; 'name field'

        DEFW    L0C49                   ; 'link field'

L0C55:  DEFB    $01                     ; 'name length field'

L0C56:  DEFW    L0C58                   ; 'code field'

; ---

L0C58:  RST     18H                     ; pop word DE
        PUSH    DE                      ;
        RST     18H                     ; pop word DE
        POP     HL                      ;

        CALL    L0C99                   ;

        JR      L0C21                   ; to stack word one or zero

; ------------
; THE '<' WORD
; ------------
; (n1, n2 -- flag)
; flag is 1 if n1 < n2.

L0C61:  DEFB    '<' + $80               ; 'name field'

        DEFW    L0C55                   ; 'link field'

L0C64:  DEFB    $01                     ; 'name length field'

L0C65:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

        DEFW    L0885                   ; swap
        DEFW    L0C56                   ; >
        DEFW    L04B6                   ; exit


; -------------
; THE 'U<' WORD
; -------------
; (un1, un2 -- flag)
; The flag is 1 if, of the two unsigned single length integers, un1 is less
; than un2.

L0C6D:  DEFB    'U'                     ; 'name field'
        DEFB    '<' + $80

        DEFW    L0C64                   ; 'link field'

L0C71:  DEFB    $02                     ; 'name length field'

L0C72:  DEFW    L0C74                   ; 'code field'

; ---

L0C74:  CALL    L084E                   ; stk_to_bc

L0C77:  RST     18H                     ; pop word DE
        EX      DE,HL
        AND     A
        SBC     HL,BC
        JR      L0C21                   ; to stack word one or zero

; -------------
; THE 'D<' WORD
; -------------
; (d1, d2 -- flag)
; flag is 1 if the signed double integer, d1 < d2.

L0C7E:  DEFB    'D'                     ; 'name field'
        DEFB    '<' + $80

        DEFW    L0C71                   ; 'link field'

L0C82:  DEFB    $02                     ; 'name length field'

L0C83:  DEFW    L0C85                   ; 'code field'

; ---

L0C85:  RST     18H                     ; pop word DE
        PUSH    DE
        CALL    L084E                   ; stk_to_bc
        RST     18H                     ; pop word DE
        POP     HL
        AND     A
        SBC     HL,DE
        JR      Z,L0C77                 ;

        ADD     HL,DE
        EX      DE,HL

        CALL    L0C99                   ;

        RST     18H                     ; pop word DE
        JR      L0C21                   ; to stack word one or zero

; ---
; THE 'sign?' SUBROUTINE
; ---

L0C99:  LD      A,H
        XOR     D
        JP      M,L0CA0                 ;

        SBC     HL,DE

L0CA0:  RL      H
        RET

; -------------
; THE 'U*' WORD
; -------------
; (un1, un2 -- double length(un1 * un2))
; Multiplies two unsigned single length integers to give an unsigned
; double length product.

L0CA3:  DEFB    'U'                     ; 'name field'
        DEFB    '*' + $80

        DEFW    L0C82                   ; 'link field'

L0CA7:  DEFB    $02                     ; 'name length field'

L0CA8:  DEFW    L0CAA                   ; 'code field'

; => mult

L0CAA:  RST     18H                     ; pop word DE
        CALL    L084E                   ; stk_to_bc
        LD      HL,$0000
        LD      A,$10
L0CB3:  ADD     HL,HL
        EX      DE,HL
        ADC     HL,HL
        EX      DE,HL
        JR      NC,L0CBE                ;

        ADD     HL,BC
        JR      NC,L0CBE                ;

        INC     DE

L0CBE:  DEC     A
        JR      NZ,L0CB3                ;

        EX      DE,HL
        JR      L0CF3                   ;

; ---
; The 'div?' Internal Word
; ---

L0CC4:  DEFW    L0CC6

L0CC6:  RST     18H                     ; pop word DE
        EXX
        RST     18H                     ; pop word DE
        PUSH    DE
        RST     18H                     ; pop word DE
        POP     HL
        LD      A,H
        OR      L
        LD      A,$21                   ; 33
        JR      NZ,L0CD5                ;

        EX      DE,HL
        LD      A,$11                   ; 17

L0CD5:  EXX
        LD      B,A
        XOR     A
        LD      H,A
        LD      L,A
        LD      C,A

L0CDB:  ADC     HL,HL
        SBC     A,A
        AND     A
        SBC     HL,DE
        SBC     A,C
        JR      NC,L0CE5                ;
        ADD     HL,DE

L0CE5:  CCF
        EXX
        EX      DE,HL
        ADC     HL,HL
        EX      DE,HL
        ADC     HL,HL
        EXX
        DJNZ    L0CDB                   ;

        EX      DE,HL
        RST     10H                     ; push word DE
        EXX

L0CF3:  PUSH    HL
        RST     10H                     ; push word DE
        POP     DE
        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; ---------------
; THE '/MOD' WORD
; ---------------
; (n1, n2 -- remainder, quotient of n1/n2)
; The remainder has the same sign as the dividend n1.

L0CF9:  DEFM    "/MO"                   ; 'name field'
        DEFB    'D' + $80

        DEFW    L0CA7                   ; 'link field'

L0CFF:  DEFB    $04                     ; 'name length field'

L0D00:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0D02:  DEFW    L0885                   ; swap
        DEFW    L08D2                   ; >R
        DEFW    L12E9                   ; I
        DEFW    L0C0D                   ; abs
        DEFW    L104B                   ; stk_data
        DEFB    $00                     ; zero
; ->
L0D0D:  DEFW    L08FF                   ; rot
        DEFW    L086B                   ; dup
        DEFW    L12E9                   ; I
        DEFW    L0E60                   ; xor
        DEFW    L08D2                   ; >R
        DEFW    L0C0D                   ; abs
        DEFW    L0D8C                   ; U/MOD
        DEFW    L08DF                   ; >R
        DEFW    L0D94                   ; pos
        DEFW    L0885                   ; swap
        DEFW    L08DF                   ; >R
        DEFW    L0D94                   ; pos
        DEFW    L0885                   ; swap
        DEFW    L04B6                   ; exit

; ----------------
; THE '*/MOD' WORD
; ----------------
; (n1, n2, n3 -- remainder, quotient of (n1 * n2)/n3)
; As in */, n1 * n2 is held to double length.

L0D29:  DEFM    "*/MO"                  ; 'name field'
        DEFB    'D' + $80

        DEFW    L0CFF                   ; 'link field'

L0D30:  DEFB    $05                     ; 'name length field'

L0D31:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

        DEFW    L08FF                   ; rot
        DEFW    L08D2                   ; >R
        DEFW    L12E9                   ; I
        DEFW    L0C0D                   ; abs
        DEFW    L08FF                   ; rot
        DEFW    L086B                   ; dup
        DEFW    L08DF                   ; >R
        DEFW    L0E60                   ; xor
        DEFW    L08D2                   ; >R
        DEFW    L0C0D                   ; abs
        DEFW    L0CA8                   ; u*
        DEFW    L1276                   ; branch

L0D4B:  DEFW    $FFC1                   ; back to L0D0D  (in /MOD)




; ------------
; THE '/' WORD
; ------------
; (n1, n2 -- n1/n2)
; Single length signed integer division.

L0D4D:  DEFB    '/' + $80               ; 'name field'

        DEFW    L0D30                   ; 'link field'

L0D50:  DEFB    $01                     ; 'name length field'

L0D51:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0D53:  DEFW    L0D00                   ; /MOD
        DEFW    L0885                   ; swap
        DEFW    L0879                   ; drop
        DEFW    L04B6                   ; exit

; --------------
; THE 'MOD' WORD
; --------------
; (n1, n2 -- remainder n1/n2)
; The remainder has the same sign as the dividend.

L0D5B:  DEFM    "MO"                    ; 'name field'
        DEFB    'D' + $80

        DEFW    L0D50                   ; 'link field'

L0D60:  DEFB    $03                     ; 'name length field'

L0D61:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

        DEFW    L0D00                   ; /MOD
        DEFW    L0879                   ; drop
        DEFW    L04B6                   ; exit


; ------------
; THE '*' WORD
; ------------
; (n1, n2 -- n1*n2)

L0D69:  DEFB    '*' + $80               ; 'name field'

        DEFW    L0D60                   ; 'link field'

L0D6C:  DEFB    $01                     ; 'name length field'

        DEFW    L0EC3                   ; 'code field' - docolon

; ---

        DEFW    L0CA8                   ; u*
        DEFW    L0879                   ; drop
        DEFW    L04B6                   ; exit


; -------------
; THE '*/' WORD
; -------------
; (n1, n2, n3 -- (n1*n2)/n3)
; The intermediate product n1*n2 is held to double length.

L0D75:  DEFB    '*'                     ; 'name field'
        DEFB    '/' + $80

        DEFW    L0D6C                   ; 'link field'

L0D79:  DEFB    $02                     ; 'name length field'

L0D7A:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

        DEFW    L0D31                   ; */MOD
        DEFW    L0885                   ; swap
        DEFW    L0879                   ; drop
        DEFW    L04B6                   ; exit

; --------------
; THE 'U/MOD' WORD
; --------------
; (ud1, un2 -- un3, un4)
; In unsigned arithmetic throughout, divides the double length integer ud1
; by the single length integer un2 to give a single length remainder un3
; and a single length quotient un4.

L0D84:  DEFM    "U/MO"                  ; 'name field'
        DEFB    'D' + $80

        DEFW    L0D79                   ; 'link field'

L0D8B:  DEFB    $05                     ; 'name length field'

L0D8C:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0D8E:  DEFW    L0CC4                   ; div?
        DEFW    L0879                   ; drop
        DEFW    L04B6                   ; exit

; ---

; make positive

L0D94:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0D96:  DEFW    L0C2E                   ; 0<
        DEFW    L1283                   ; ?branch               (if false)
L0D9A:  DEFW    $0003                   ; to L0D9E

        DEFW    L0DA9                   ; negate

L0D9E:  DEFW    L04B6                   ; exit

; -----------------
; THE 'NEGATE' WORD
; -----------------
; (n -- -n)


L0DA0:  DEFM    "NEGAT"                 ; 'name field'
        DEFB    'E' +$80

        DEFW    L0D8B                   ; 'link field'

L0DA8:  DEFB    $06                     ; 'name length field'

L0DA9:  DEFW    L0DAB                   ; 'code field'

; ---

L0DAB:  LD      BC,$0002                ;
        JR      L0DBF                   ;

; ------------------
; THE 'DNEGATE' WORD
; ------------------
; (d -- -d)
; Double length integer negation.

L0DB0:  DEFM    "DNEGAT"                ; 'name field'
        DEFB    'E' +$80

        DEFW    L0DA8                   ; 'link field'

L0DB9:  DEFB    $07                     ; 'name length field'

L0DBA:  DEFW    L0DBC                   ; 'code field'

; ---

L0DBC:  LD      BC,$0004

; NEGATE joins here with bc=2

L0DBF:  LD      HL,($3C3B)              ; SPARE
        AND     A
        SBC     HL,BC

L0DC5:  LD      A,B
        SBC     A,(HL)
        LD      (HL),A
        INC     HL
        DEC     C
        JR      NZ,L0DC5                ;

        JP      (IY)                    ; to 'next'.

; ------------
; THE '+' WORD
; ------------
; (n1, n2 -- n1 + n2)

L0DCE:  DEFB    '+' + $80               ; 'name field'

        DEFW    L0DB9                   ; 'link field'

L0DD1:  DEFB    $01                     ; 'name length field'

L0DD2:  DEFW    L0DD4                   ; 'code field'

; ---

L0DD4:  RST     18H                     ; pop word DE
        PUSH    DE                      ; save on machine stack
        RST     18H                     ; pop word DE
        POP     HL                      ; first number to HL

        ADD     HL,DE                   ; the actual addition

        EX      DE,HL                   ; result to DE
        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; ------------
; THE '-' WORD
; ------------
; (n1, n2 -- n1-n2)
; flip the sign and do a plus.

L0DDD:  DEFB    '-' + $80               ; 'name field'

        DEFW    L0DD1                   ; 'link field'

L0DE0:  DEFB    $01                     ; 'name length field'

L0DE1:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0DE3:  DEFW    L0DA9                   ; negate
        DEFW    L0DD2                   ; +
        DEFW    L04B6                   ; exit

; -------------
; THE 'D+' WORD
; -------------
; (d1, d2 -- d1 + d2)
; double length integer addition.

L0DE9:  DEFB    'D'                     ; 'name field'
        DEFB    '+' + $80

        DEFW    L0DE0                   ; 'link field'

L0DED:  DEFB    $02                     ; 'name length field'

L0DEE:  DEFW    L0DF0                   ; 'code field'

; ---

L0DF0:  RST     18H                     ; pop word DE

        PUSH    DE
        CALL    L084E                   ; stk_to_bc
        RST     18H                     ; pop word DE
        PUSH    DE
        RST     18H                     ; pop word DE
        EX      DE,HL
        ADD     HL,BC
        EX      DE,HL
        RST     10H                     ; push word DE
        POP     BC
        POP     HL
        ADC     HL,BC
        EX      DE,HL
        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; -------------
; THE '1+' WORD
; -------------
; (n -- n+1)

L0E04:  DEFB    '1'                     ; 'name field'
        DEFB    '+' + $80

        DEFW    L0DED                   ; 'link field'

L0E08:  DEFB    $02                     ; 'name length field'

L0E09:  DEFW    L0E0B                   ; 'code field'

; ---

L0E0B:  RST     18H                     ; get word 'n' in DE
        JR      L0E17                   ; forward to increment and stack

; -------------
; THE '2+' WORD
; -------------
; (n -- n+2)

L0E0E:  DEFB    '2'                     ; 'name field'
        DEFB    '+' + $80

        DEFW    L0E08                   ; 'link field'

L0E12:  DEFB    $02                     ; 'name length field'

L0E13:  DEFW    L0E15                   ; 'code field'

; ---

L0E15:  RST     18H                     ; get word 'n' in DE.
        INC     DE                      ; increment n                   (4)
; ->
L0E17:  INC     DE                      ; increment n                   (4)
        JR      L0E2E                   ; forward to push word DE and exit

; -------------
; THE '1-' WORD
; -------------
; (n -- n-1)


L0E1A:  DEFB    '1'                     ; 'name field'
        DEFB    '-' + $80

        DEFW    L0E12                   ; 'link field'

L0E1E:  DEFB    $02                     ; 'name length field'

L0E1F:  DEFW    L0E21                   ; 'code field'

; ---

L0E21:  RST     18H                     ;
        JR      L0E2D                   ;

; -------------
; THE '2-' WORD
; -------------
; (n -- n-2)


L0E24:  DEFB    '2'                     ; 'name field'
L0E25:  DEFB    '-' + $80

L0E26:  DEFW    L0E1E                   ; 'link field'

L0E28:  DEFB    $02                     ; 'name length field'

L0E29:  DEFW    L0E2B                   ; 'code field'

; ---

;
L0E2B:  RST     18H
        DEC     DE

; ->
L0E2D:  DEC     DE

; ->
L0E2E:  RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; -------------
; THE 'OR' WORD
; -------------
; (n1, n2 -- n1 OR n2)
; Bitwise Boolean operation.


L0E31:  DEFB    'O'                     ; 'name field'
        DEFB    'R' + $80

        DEFW    L0E28                   ; 'link field'

L0E35:  DEFB    $02                     ; 'name length field'

L0E36:  DEFW    L0E38                   ; 'code field'

; ---

L0E38:  RST     18H                     ; pop word DE
        CALL    L084E                   ; stk_to_bc

        LD      A,E                     ;
        OR      C                       ; OR low order bytes
        LD      E,A                     ;

        LD      A,D                     ;
        OR      B                       ; OR high order bytes
        LD      D,A                     ;

        RST     10H                     ; push word DE

        JP      (IY)                    ; to 'next'.

; --------------
; THE 'AND' WORD
; --------------
; (n1, n2 -- n1 AND n2)
; Bitwise Boolean operation.


L0E45:  DEFM    "AN"                    ; 'name field'
        DEFB    'D' + $80

        DEFW    L0E35                   ; 'link field'

L0E4A:  DEFB    $03                     ; 'name length field'

        DEFW    L0E4D                   ; 'code field'

; ---

L0E4D:  RST     18H
        CALL    L084E                   ; stk_to_bc

        LD      A,E                     ;
        AND     C                       ;
        LD      E,A                     ;

        LD      A,D                     ;
        AND     B                       ;
        LD      D,A                     ;

        RST     10H                     ; push word DE
        JP      (IY)                    ; to 'next'.

; --------------
; THE 'XOR' WORD
; --------------
; (n1, n2 -- n1 XOR n2)
; Bitwise Boolean XOR (exclusive or)

L0E5A:  DEFM    "XO"                    ; 'name field'
        DEFB    'R' + $80

        DEFW    L0E4A                   ; 'link field'

L0E5F:  DEFB    $03                     ; 'name length field'

L0E60:  DEFW    L0E62                   ; 'code field'

; ---

L0E62:  RST     18H
        CALL    L084E                   ; stk_to_bc

        LD      A,E                     ;
        XOR     C                       ;
        LD      E,A                     ;

        LD      A,D                     ;
        XOR     B                       ;
        LD      D,A                     ;

        RST     10H                     ; push word DE
        JP      (IY)                    ; to 'next'.

; --------------
; THE 'MAX' WORD
; --------------
; (n1, n2 -- max (n1, n2))
; Calculates the larger of two numbers.

L0E72:  DEFM    "MA"                    ; 'name field'
        DEFB    'X' + $80

        DEFW    L0E5F                   ; 'link field'

L0E74:  DEFB    $03                     ; 'name length field'

L0E75:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0E77:  DEFW    L0912                   ; over
        DEFW    L0912                   ; over
        DEFW    L0C65                   ; <
        DEFW    L1271                   ; branch
L0E7F:  DEFW    $000F                   ; forward to L0E8F

; --------------
; THE 'MIN' WORD
; --------------
; (n1, n2 -- min (n1, n2))
; Calculates the smaller of two numbers.

L0E81:  DEFM    "MI"                    ; 'name field'
        DEFB    'N' + $80

        DEFW    L0E74                   ; 'link field'

L0E86:  DEFB    $03                     ; 'name length field'

        DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0E89:  DEFW    L0912                   ; over
        DEFW    L0912                   ; over
        DEFW    L0C56                   ; >
; ->
L0E8F:  DEFW    L1283                   ; ?branch
L0E91:  DEFW    $0003                   ; forward to L0995

        DEFW    L0885                   ; swap

L0995:  DEFW    L0879                   ; drop
        DEFW    L04B6                   ; exit

; ------------------
; THE 'DECIMAL' WORD
; ------------------
; (  --  )
; Sets the system number base to ten.

L0E99:  DEFM    "DECIMA"                ; 'name field'
        DEFB    'L' + $80

        DEFW    L0E86                   ; 'link field'

L0EA2:  DEFB    $07                     ; 'name length field'

        DEFW    L0EA5                   ; 'code field'

; ---

L0EA5:  LD      (IX+$3F),$0A            ; update system variable BASE to 10

        JP      (IY)                    ; to 'next'.

; ------------
; THE ':' WORD
; ------------
; Introduces colon definitions.

L0EAB:  DEFB    ':' + $80               ; 'name field'

        DEFW    L0EA2                   ; 'link field'

L0EAE:  DEFB    $01                     ; 'name length field'

L0EAF:  DEFW    L1085                   ; 'code field' - create and enclose

; ---

L0EB1:  DEFW    L0EC3                   ; do_colon

        DEFW    L104B                   ; stk_data
        DEFB    $0A                     ; ten                   marker byte?
; ->
L0EB6:  DEFW    L1A0E                   ; end_forth

L0EB8:  LD      HL,$3C3E                ; FLAGS

        LD      A,(HL)                  ; update bits 6 and 2.
        OR      $44                     ; signal in compile mode, definition
                                        ; incomplete.
        LD      (HL),A                  ; update FLAGS.

        JP      (IY)                    ; to 'next'.

; ---

x0EC1   DEFB    $E9                     ;;
x0Ec2   DEFB    $FF                     ;; 0ec2 + ffe9 =  0eab = ':'

; -------------------------------
; THE 'ENTER' or 'DOCOLON' action
; -------------------------------
;

L0EC3:  EX      DE,HL                   ;
        JP      L04BA                   ;


; -----------------
; THE 'CREATE' WORD
; -----------------
; CREATE name
; (  --  )
; Defines a new word with a header and an empty parameter field.
; When executed, the new word stacks its parameter field address.

L0EC7:  DEFM    "CREAT"                 ; 'name field'
        DEFB    'E' + $80

        DEFW    L0EAE                   ; 'link field'

L0ECF:  DEFB    $06                     ; 'name length field'

L0ED0:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0ED2:  DEFW    L104B                   ; stk_data
        DEFB    $20                     ; a space               delimiter
        DEFW    L05AB                   ; word to pad
        DEFW    L0EFB                   ; get-name              in dict
        DEFW    L0688                   ; stk-zero              link
        DEFW    L0F4E                   ; ,
        DEFW    L0480                   ; current
        DEFW    L08B3                   ; @
        DEFW    L086B                   ; dup
        DEFW    L08B3                   ; @
        DEFW    L0F4E                   ; ,
        DEFW    L0460                   ; here
        DEFW    L0885                   ; swap
        DEFW    L08C1                   ; !
        DEFW    L0499                   ; pad
        DEFW    L0896                   ; C@            fetch 1 byte
        DEFW    L0F5F                   ; C,
        DEFW    L1011                   ; stack next word
        DEFW    $0FEC                   ; ???
        DEFW    L0F4E                   ; ,
L0EF9:  DEFW    L04B6                   ; exit

; ----------------------------
; The 'get_name' Internal Word
; ----------------------------
; Used only by the above CREATE thread.

L0EFB:  DEFW    L0EFD                   ; headerless 'code field'

; ---

L0EFD:  CALL    L0F2E                   ; blank stack

        RST     18H                     ; pop word DE

        LD      A,(DE)
        DEC     A                       ; zero becomes $FF
        CP      $3F                     ; max length is 64
        JR      C,L0F09                 ; forward if n range 1 - 64.

        RST     20H                     ; Error 6
        DEFB    $06                     ; Name of new word too short or long.

; ---

L0F09:  ADD     A,$08                   ; allow for prev/len/addr 3 missing

        LD      C,A                     ;
        LD      B,$00                   ; length to BC

L0F0E:  CALL    L0F8C                   ; check free memory.

x0f11   LD      A,(DE)                  ; true length to A
        LD      C,A                     ; and BC again

        LD      HL,($3C37)              ; STKBOT

        PUSH    DE                      ;
        CALL    L0F9E                   ; routine MAKE ROOM
        POP     DE                      ;

        LD      A,(DE)                  ; length of word in pad
        LD      B,A                     ; transfer to counter.

L0F1D:  INC     DE                      ; increase source
        LD      A,(DE)                  ; fetch character

        CALL    L0807                   ; to_upper makes uppercase.

        LD      (HL),A                  ; store in dictionary
        INC     HL                      ; increase destination
        DJNZ    L0F1D                   ; loop back for all letters.

        LD      ($3C39),HL              ; store this location in SPARE
        DEC     HL                      ; step back to last letter of word.
        SET     7,(HL)                  ; and 'invert' it.
        JP      (IY)                    ; to 'next'.

; ---


L0F2E:  BIT     2,(IX+$3E)              ; test FLAGS incomplete definition ?
        JR      Z,L0F36                 ; forward if not.

        RST     20H                     ; Error 12
        DEFB    $0C                     ; Incomplete definition in dictionary.

; ---

L0F36:  LD      HL,($3C37)              ; fetch STKBOT
        LD      DE,($3C39)              ; fetch SPARE

        XOR     A                       ; clear accumulator and carry flag

        SBC     HL,DE                   ; subtract

        EX      DE,HL                   ;
        LD      (HL),E                  ; place low byte at next STACK slot.
        INC     HL                      ;
        LD      (HL),D                  ; place high byte
        LD      H,A                     ; make HL zero
        LD      L,A                     ;
        LD      ($3C39),HL              ; update system variable SPARE to zero

        RET                             ; return

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

; ------------
; THE ',' WORD
; ------------
; ( n --   )
; Encloses the single length integer in the dictionary.

L0F4A:  DEFB    ',' + $80               ; 'name field'

        DEFW    L0ECF                   ; 'link field'

L0F4D:  DEFB    $01                     ; 'name length field'

L0F4E:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0F50:  DEFW    L0F83                   ; allot2

        DEFW    L0460                   ; here
        DEFW    L0E29                   ; 2-
        DEFW    L08C1                   ; !
        DEFW    L04B6                   ; exit


; -------------
; THE 'C,' WORD
; -------------
; ( n --   )
; Encloses the less significant byte of n in the dictionary.

L0F5A:  DEFB    'C'                     ; 'name field'
        DEFB    ',' + $80

        DEFW    L0F4D                   ; 'link field'

L0F5E:  DEFB    $02                     ; 'name length field'

L0F5F:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L0F61:  DEFW    L104B                   ; stk-data
        DEFB    $01                     ; one
        DEFW    L0F76                   ; allot

x0f66   DEFW    L0460                   ; here
        DEFW    L0E1F                   ; 1-
        DEFW    L08A5                   ; C!
        DEFW    L04B6                   ; exit

; ----------------
; THE 'ALLOT' WORD
; ----------------
; (n -- )
; Encloses n bytes in the dictionary, without initializing them.

L0F6E:  DEFM    "ALLO"                  ; 'name field'
        DEFB    'T' + $80

        DEFW    L0F5E                   ; 'link field'

L0F75:  DEFB    $05                     ; 'name length field'

L0F76:  DEFW    L0F78                   ; 'code field'

; ---

L0F78:  CALL    L084E                   ; stk_to_bc
        LD      HL,($3C37)              ; STKBOT
        CALL    L0F9E                   ; routine MAKE ROOM
        JP      (IY)                    ; to 'next'.

; --------------------------
; The 'allot2' Internal Word
; --------------------------
; Encloses 2 bytes in the dictionary, without initializing them.

L0F83:  DEFW    L0EC3                   ; headerless 'code field' - docolon

; ---

L0F85:  DEFW    L104B                   ; stk_data
        DEFB    $02                     ; two bytes required
        DEFW    L0F76                   ; allot
        DEFW    L04B6                   ; exit

; ----------------------------------
; THE 'DEFAULT MEMORY CHECK' ROUTINE
; ----------------------------------
; called each cycle in slow mode to check free memory.

L0F8C:  LD      HL,$001E                ; Allow a thirty byte overhead.

; ----------------------------------
; THE 'CHECK FREE MEMORY' SUBROUTINE
; ----------------------------------

L0F8F:  PUSH    BC                      ; save bytes to check.

        ADD     HL,BC                   ;
        LD      BC,($3C3B)              ; SPARE
        ADD     HL,BC                   ; carry indicates error - past 65535

        POP     BC                      ; restore number of bytes
        JR      C,L0F9C                 ; forward with error

        SBC     HL,SP                   ; now check against the return stack
                                        ; (machine stack)
        RET     C                       ; return if value is less

L0F9C:  RST     20H                     ; Error 1
        DEFB    $01                     ; Not enough memory

; --------------------------
; THE 'MAKE ROOM' SUBROUTINE
; --------------------------

L0F9E:  EX      DE,HL                   ; first new location to DE
        LD      HL,$0028                ; overhead 40 bytes.

L0FA2:  CALL    L0F8F                   ; check free memory.

; now increase the two data stack pointers.

        LD      HL,($3C37)              ; fetch value of STKBOT
        ADD     HL,BC                   ; add required room.
        LD      ($3C37),HL              ; update STKBOT.

        LD      HL,($3C3B)              ; fetch value of SPARE
        PUSH    HL                      ; take a copy of 'old' value
        ADD     HL,BC                   ; add required room.
        LD      ($3C3B),HL              ; update SPARE.

        EX      (SP),HL                 ; new SPARE value to stack,
                                        ; old SPARE value to HL.
        PUSH    HL                      ; push old SPARE value.
        AND     A                       ; clear carry.

        SBC     HL,DE                   ; get length of stack and 12
        LD      B,H                     ;
        LD      C,L                     ;
        POP     HL                      ; old spare
        POP     DE                      ; new spare
        RET     Z                       ; return if same.

; else new SPARE must be higher than old spare.

        DEC     HL                      ; point to end of data stack
        DEC     DE                      ; adjust destination.
        LDDR                            ; copy the Data Stack + gap upwards.

L0FC2:  INC     HL                      ; point to first new location.

        RET                             ; return.

; -------------------
; THE 'VARIABLE' WORD
; -------------------
; VARIABLE name
; (n -- )
; Sets up a variable with the given name, and initializes its value to n.

L0FC4:  DEFM    "VARIABL"               ; 'name field'
        DEFB    'E' + $80

        DEFW    L0F75                   ; 'link field'

L0FCE:  DEFB    $08                     ; 'name length field'

        DEFW    L1085                   ; 'code field' - create and enclose

; ---

L0FD1:  DEFW    L0FF0                   ; push word DE
        DEFW    L0F4E                   ; ,

        DEFW    L04B6                   ; exit

; -------------------
; THE 'CONSTANT' WORD
; -------------------
; CONSTANT name
; (n -- )
; Defines a constant with the given name and value n.

L0FD7:  DEFM    "CONSTAN"               ; 'name field'
        DEFB    'T' + $80

        DEFW    L0FCE                   ; 'link field'

L0FE1:  DEFB    $08                     ; 'name length field'

L0FE2:  DEFW    L1085                   ; 'code field' - create and enclose

; ---

L0FE4:  DEFW    L0FF5                   ; pad??
        DEFW    L0F4E                   ; ,
        DEFW    L04B6                   ; exit

; ---
; ???

x0fea   DEFB    $DC                     ;;
x0feb   DEFB    $FE                     ;;  0feb + fedc = 0Ec7 = CREATE

; ->
L0FEC:  JR      L0FF0                   ; skip forward

x0fee   DEFB    $D5                     ;;
x0fef   DEFB    $FF                     ;;  0fef + ffd5 = 0fc4 = VARIABLE

; ---

L0FF0:  RST     10H                     ; push word DE
        JP      (IY)                    ; to 'next'.

; ---

x0FF3   DEFB    $E3                     ;;
x0ff4   DEFB    $FF                     ;;  0ff4 + ffe3 = 0fd7 = CONSTANT

; --> pad

L0FF5:  EX      DE,HL
        LD      E,(HL)
        INC     HL
        LD      D,(HL)
        RST     10H                     ; push word DE
        JP      (IY)                    ; to 'next'.

; ------------------
; THE 'LITERAL' WORD
; ------------------
; (n -- )
; Compiles the top of the stack into a word definition as a literal.
; Compiles integers. decimal 4102 = $1006. c.f. $1055

L0FFC:  DEFM    "LITERA"                ; 'name field'
        DEFB    'L' + $80

        DEFW    L0FE1                   ; 'link field'

L1005:  DEFB    $47                     ; 'name length field'

L1006:  DEFW    L1108                   ; 'code field' - compile

; ---

L1008:  DEFW    L1011                   ; stack next word
        DEFW    L0F4E                   ; ,
        DEFW    L04B6                   ; exit

; ---

x100E:  DEFB    $02                     ;;
x100f   DEFB    $FF                     ;; 100f + ff02 = 0f11 nah!
x1010   DEFB    $FF                     ;;

; -----------------------------------
; The 'Stack Next Word' Internal Word
; -----------------------------------

L1011:  DEFW    L1013                   ; headerless 'code field'

; ---

L1013:  LD      B,$01                   ; counter - one word to push

L1015:  POP     HL                      ; drop the 'Next Word' pointer.
        LD      E,(HL)                  ; low byte to E.
        INC     HL                      ; increment pointer.
        LD      D,(HL)                  ; high byte to D.

; -> E B=1 (one byte op)

L1019:  INC     HL                      ; increment the 'Next Word' pointer

L101A:  PUSH    HL                      ; the 'Next Word' pointer goes to
                                        ; the Return Stack.
        RST     10H                     ; stack Data Word DE
        DJNZ    L1015                   ; loop back if more than one.

L101E:  JP      (IY)                    ; to 'next'.


; ----------------
; THE 'ASCII' WORD
; ----------------
; Takes the next word from the input buffer, and yields the ASCII code
; of its first character. If compiling, then compiles this as a literal.
;
; e.g.      :STARS 0 DO ASCII * EMIT LOOP ;
; (--ASCII code)         (if interpreting)
; (--)                   (if compiling)

L1020:  DEFM    "ASCI"                  ; 'name field'
        DEFB    'I' + $80

        DEFW    L1005                   ; 'link field'

L1027:  DEFB    $45                     ; 'name length field' (immediate mode)

L1029:  DEFW    L0EC3                   ; 'code field' - docolon

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

L102A:  DEFW    L104B                   ; stk_data
        DEFB    $20                     ; space delimiter
        DEFW    L05AB                   ; word  to pad
        DEFW    L0E09                   ; 1+
        DEFW    L0896                   ; C@
        DEFW    L1A0E                   ; end-forth.

        BIT     6,(IX+$3E)              ; FLAGS
        JR      Z,L101E                 ; back to a jp (iy)

        CALL    L04B9                   ; forth

L103E:  DEFW    L1011                   ; stack next word
        DEFW    L104B                   ; (stk_data)
        DEFW    L0F4E                   ; ,
        DEFW    L0F5F                   ; c,
        DEFW    L04B6                   ; exit

; ---

x1048   DEFB    $01                     ;; ?

x1049   DEFB    $D6                     ;; ?
x104a   DEFB    $FF                     ;; ?  104a + ffd6 = 1020 = ASCII

; ----------------------------
; The 'stk-data' Internal Word
; ----------------------------
; used succinctly to stack the following byte as a word.

L104B:  DEFW    L104D                   ; headerless 'code field'

; ---

L104D:  POP     HL                      ; retrieve the 'Next Word' pointer.

        LD      E,(HL)                  ; fetch the single byte from there.
        LD      D,$00                   ; set high order byte to zero.

        LD      B,$01                   ; set counter to 1.

        JR      L1019                   ; back to stack one word and
                                        ; put the incremented pointer back on
                                        ; the Return Stack.

; --------------------------
; The 'stk_fp' Internal Word
; --------------------------
; stack and enclose a floating point number - two words.

L1055:  DEFW    L1108                   ; headerless 'code field' - compile

; ---

        DEFW    L1064                   ; stack two words.
        DEFW    L0885                   ; swap
        DEFW    L0F4E                   ; ,
        DEFW    L0F4E                   ; ,
        DEFW    L04B6                   ; exit
; ---

x1061   DEFB    $04                     ;;
x1062   DEFB    $FF                     ;; 1062 + ff04 = 0f66 XX
x1063   DEFB    $FF                     ;;

; -----------------------------------
; The 'STACK TWO WORDS' Internal Word
; -----------------------------------

L1064:  DEFW    L1066                   ; headerless 'code field'

; ---

L1066:  LD      B,$02                   ; set counter to two

        JR      L1015                   ; back to stack 2 words


; -----------------
; THE 'DEFINER' WORD
; -----------------
; Used with 'DOES>' to define new defining words. i.e. words that themselves
; define new words.
; The format is
; DEFINER name
;       defining routine
; DOES>
;       action routine
; ;
; name is the name of the new defining word; when executed it will set up
; the header of a new word and use its defining routine to set up the
; parameter field. When this new word in its turn is executed, its parameter
; field will be put on the stack and the action routine will be executed.

L106A:  DEFM    "DEFINE"                ; 'name field'
        DEFB    'R' + $80

        DEFW    L1027                   ; 'link field'

L1073:  DEFB    $07                     ; 'name length field'

L1074:  DEFW    L1085                   ; 'code field' - create and enclose

; ---

L1076:  DEFW    L1085                   ; create and enclose
        DEFW    L0460                   ; here

        DEFW    L104B                   ; stk-data

        DEFB    $0C                     ; 12                    marker byte

        DEFW    L0F83                   ; allot2
        DEFW    L1276                   ; branch
L1081:  DEFW    $FE34                   ; back to L0EB6

; ---

x1083   DEFB    $E6                     ;;
x1084   DEFB    $FF                     ;; 1084 + ffe6 = 106a = DEFINER

; ---
;; createe and fill
; ----
; used seven times as a code word.

L1085:  CALL    L0FF0                   ; push word DE (save addr nxt wrd on DS)

        DEFW    L0ED0                   ; create
        DEFW    L086B                   ; dup
        DEFW    L08B3                   ; @
        DEFW    L0460                   ; here
        DEFW    L0E29                   ; 2-
        DEFW    L08C1                   ; !

L1094:  DEFW    L0E13                   ; 2+
        DEFW    L109A                   ; pop DE
        DEFW    L04B6                   ; exit

; -----------
; pop word DE
; -----------
; branch to addr on stack???

L109A:  DEFW    L109C                   ; headerless 'code field'

; ---

L109C:  RST     18H                     ; unstack Data Word DE

        JP      L0EC3                   ; start new thread.

; ---------------
; THE 'CALL' WORD
; ---------------
; (address -- )
; Executes Z80 machine code at address on the stack. The code is terminated
; by a jp (iy)
; e.g. in hex
; DEFINER CODE DOES> CALL ;
; CODE EI FB C, FD C, E9 C,
; The word EI will enable interrupts.

L10A0:  DEFM    "CAL"                   ; 'name field'
        DEFB    'L' + $80

        DEFW    L1073                   ; 'link field'

L10A6:  DEFB    $04                     ; 'name length field'

L10A7:  DEFW    L10A9                   ; 'code field'

; ---

L10A9:  RST     18H
        EX      DE,HL

        JP      (HL)

; ----------------
; THE 'DOES>' WORD
; ----------------
; See DEFINER.

L10AC:  DEFM    "DOES"                  ; 'name field'
        DEFB    '>' + $80

        DEFW    L10F4                   ; 'link field'

L10B3:  DEFB    $45                     ; 'name length field' (immediate mode)

L10B4:  DEFW    L1108                   ; 'code field' - compile

L10B6:  DEFW    L10E8                   ; exit

        DEFW    L12D8                   ; check??

        DEFB    $0C                     ; 12

        DEFW    L10CD                   ;
        DEFW    L104B                   ; stk_data

        DEFB    $CD                     ; data                  call ?

        DEFW    L0F5F                   ; C,
        DEFW    L1011                   ; stack next word
        DEFW    L0FF0                   ; (push word DE)
        DEFW    L0F4E                   ; ,
        DEFW    L104B                   ; stk-data

        DEFB    $0A                     ; ten                   marker byte.

        DEFW    L04B6                   ; exit

; -----------------------
; The '???' Internal Word
; -----------------------

L10CD:  DEFW    L0EC3                   ; headerless 'code field' - docolon

; ---

        DEFW    L086B                   ; dup
        DEFW    L0E29                   ; 2-
        DEFW    L15B5                   ; namefield
        DEFW    L0460                   ; here
        DEFW    L0DE1                   ; -
        DEFW    L0E1F                   ; 1-
        DEFW    L0F4E                   ; ,
        DEFW    L0460                   ; here
        DEFW    L0885                   ; swap
        DEFW    L08C1                   ; !
        DEFW    L04B6                   ; exit

; ---

x10e5   DEFB    $05                     ;;

x10e6   DEFB    $C5                     ;;
x10e7   DEFB    $FF                     ;; 10e7 + ffc5 = 10ac = DOES>

; ---

L10E8:  DEFW    L04B8                   ; exit?

; -------------------
; THE 'COMPILER' WORD
; -------------------
; Used with 'RUNS>' for defining new compiling words, i.e. words that are
; used within word definitions to give an immediate effect of compiling
; some information into the dictionary.
; (This is traditionally done with IMMEDIATE, but COMPILER...RUNS> works
; better with EDIT etc.)

L10EA:  DEFM    "COMPILE"               ; 'name field'
        DEFB    'R' + $80

        DEFW    L10A6                   ; 'link field'

L10F4:  DEFB    $08                     ; 'name length field'

L10F5:  DEFW    L1085                   ; 'code field' - create and enclose

; ---

        DEFW    L1108                   ; compile
        DEFW    L1160                   ; immediate
        DEFW    L0460                   ; here
        DEFW    L104B                   ; stk_data

L10FF:  DEFB    $0B                     ; 11                    marker byte

        DEFW    L0F83                   ; allot2
        DEFW    L1276                   ; branch
L1104:  DEFW    $FDB1                   ; back to L0EB6

; ---

x1106   DEFB    $E3                     ;;
x1107   DEFB    $FF                     ;; 1107 + ffe3 = 10ea = COMPILER

; ---------------------
; THE 'COMPILE' ROUTINE
; ---------------------
; Instead of executing code words as they are encountered, lay them down in
; the dictionary along with any parameters.

L1108:  BIT     6,(IX+$3E)              ; test FLAGS - compiler mode ?
        JR      NZ,L1110                ; skip error if so.

        RST     20H                     ; Error 4.
        DEFB    $04                     ; Compiling word used in interpret mode.

L1110:  CALL    L0FF0                   ; push word DE (then jp (iy))

        DEFW    L086B                   ; dup
        DEFW    L08B3                   ; @
        DEFW    L0F4E                   ; ,
        DEFW    L1276                   ; branch
L111B:  DEFW    $FF78                   ; to L1094 - definer code

; ----------------
; THE 'RUNS>' WORD
; ----------------
; See COMPILER

L111D:  DEFM    "RUNS"                  ; 'name field'
        DEFB    '>' + $80

        DEFW    L10B3                   ; 'link field'

L1124:  DEFB    $45                     ; 'name length field' (immediate mode)

L1125:  DEFW    L1108                   ; 'code field' - compile

; ---

L1127:  DEFW    L1140                   ; vv
        DEFW    L12D8                   ; check-for
        DEFB    $0B                     ; 11                    marker byte.
        DEFW    L0885                   ; swap
        DEFW    L0F5F                   ; c,
        DEFW    L10CD                   ; ?
        DEFW    L1011                   ; stack next word
        DEFW    L1142
        DEFW    L0F4E                   ; ,

        DEFW    L104B                   ; stk-data
        DEFB    $0A                     ; ten.                  marker byte.
        DEFW    L04B6                   ; exit

; ---

x113d   DEFB    $05                     ;;

x113e   DEFB    $DE                     ;;
x113f   DEFB    $FF                     ;; 113f + ffde = 111d = RUNS>

; ---

L1140:  DEFW    L04B8

L1142:  POP     HL
        PUSH    DE
        EX      DE,HL

        RST     10H                     ; push word DE
        LD      B,D
        LD      C,E
        POP     DE
        PUSH    DE
        DEC     DE
        DEC     DE

        CALL    L159E                   ;

        POP     DE
        PUSH    BC
        JP      L0EC3                   ;

; --------------------
; THE 'IMMEDIATE' WORD
; --------------------
; (  --  )
; The most recent word in the current vocabulary is made immediate, so that
; it will execute even in compile mode.

L1154:  DEFM    "IMMEDIAT"              ; 'name field'
        DEFB    'E' + $80

        DEFW    L1124                   ; 'link field'

L115F:  DEFB    $09                     ; 'name length field'

L1160:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L1162:  DEFW    L0480                   ; current
        DEFW    L08B3                   ; @
        DEFW    L08B3                   ; @
        DEFW    L1A0E                   ; end-forth.

L116A:  RST     18H                     ; pop word DE
        EX      DE,HL
        SET     6,(HL)
        JP      (IY)                    ; to 'next'.

; ---------------------
; THE 'VOCABULARY' WORD
; ---------------------
; (  --  )
; Defines a new vocabulary with the given name.

L1170:  DEFM    "VOCABULAR"             ; 'name field'
        DEFB    'Y' + $80

        DEFW    L115F                   ; 'link field'

L117C:  DEFB    $0A                     ; 'name length field'

L117D:  DEFW    L1085                   ; 'code field' - create and enclose

; ---

L117F:  DEFW    L11B5                   ; set context
        DEFW    L0480                   ; current
        DEFW    L08B3                   ; @
        DEFW    L0E13                   ; 2+
        DEFW    L0F4E                   ; ,
        DEFW    L0688                   ; stk-zero
        DEFW    L0F5F                   ; C,
        DEFW    L0460                   ; here
        DEFW    L1011                   ; stack next word
        DEFW    $3C35                   ; (VOCLNK)
        DEFW    L086B                   ; dup
        DEFW    L08B3                   ; @
        DEFW    L0F4E                   ; ,
        DEFW    L08C1                   ; !
        DEFW    L04B6                   ; exit

; ----------------------
; THE 'DEFINITIONS' WORD
; ----------------------
; (  --  )
; The CONTEXT vocabulary is made the CURRENT vocabulary as well.

L119D:  DEFM    "DEFINITION"            ; 'name field'
        DEFB    'S' + $80

        DEFW    L117C                   ; 'link field'

L11AA:  DEFB    $0B                     ; 'name length field'

L11AB:  DEFW    L11AD                   ; 'code field'

; ---

L11AD:  LD      HL,($3C33)              ; CONTEXT
        LD      ($3C31),HL              ; CURRENT
        JP      (IY)                    ; to 'next'.

; ---

L11B5:  LD      ($3C33),DE              ; CONTEXT
        JP      (IY)                    ; to 'next'.

; ---

; -------------
; THE 'IF' WORD
; -------------
; (n -- )
; Used in the form
; IF ... THEN
; or
; IF ... ELSE ... THEN
; In the first form, if n is non-zero then the words between IF and THEN
; are executed; otherwise they are skipped over.
; In the second form, if n is non-zero then the words between IF and ELSE
; are executed and those between ELSE and THEN are skipped over, while if
; n is zero then the words between IF and ELSE are skipped over and those
; between ELSE and THEN are executed.

L11BB:  DEFB    'I'                     ; 'name field'
        DEFB    'F' + $80

        DEFW    L13E0                   ; 'link field'

L11BF:  DEFB    $42                     ; 'name length field' (immediate word)

        DEFW    L1108                   ; 'code field' - compile

; ---

        DEFW    L1283                   ; ?branch
        DEFW    L0460                   ; here

        DEFW    L104B                   ; stk_data
        DEFB    $02                     ; 2 locations required for jump length
        DEFW    L0F83                   ; allot2
        DEFW    L04B6                   ; exit

; ----------------
; THE 'WHILE' WORD
; ----------------
; (n -- )
; Used in BEGIN ... WHILE ... REPEAT. If n = 0 then skips over to just past
; REPEAT.

L11CD:  DEFM    "WHIL"                  ; 'name field'
        DEFB    'E' + $80

        DEFW    L11BF                   ; 'link field'

L11D4:  DEFB    $45                     ; 'name length field' (immediate mode)

L11D5:  DEFW    L1108                   ; 'code field' - compile

; ---

        DEFW    L1288                   ; ?branch

        DEFW    L12D8                   ; check-for
        DEFB    $01                     ;  1
        DEFW    L0460                   ; here
        DEFW    L104B                   ; stk-data
        DEFB    $04                     ;  four
        DEFW    L0F83                   ; allot
        DEFW    L04B6                   ; exit

; ---------------
; THE 'ELSE' WORD
; ---------------
; (  --  )
; Used with IF and THEN.

L11E5:  DEFM    "ELS"                   ; 'name field'
        DEFB    'E' + $80

        DEFW    L11D4                   ; 'link field'

L11EB:  DEFB    $44                     ; 'name length field' (immediate mode)

L11EC:  DEFW    L1108                   ; 'code field' - compile

; ---

        DEFW    L1271                   ; branch

        DEFW    L12D8                   ; check-for
        DEFB    $02                     ; two
        DEFW    L0F83                   ; allot2
        DEFW    L1225                   ; ?
        DEFW    L0460                   ; here
        DEFW    L0E29                   ; 2-
        DEFW    L104B                   ; stk-data
        DEFB    $02                     ; two
        DEFW    L04B6                   ; exit

; ---------------
; THE 'THEN' WORD
; ---------------
; Used with IF.

L1200:  DEFM    "THE"                   ; 'name field'
        DEFB    'N' + $80

        DEFW    L11EB                   ; 'link field'

L1206:  DEFB    $44                     ; 'name length field' (immediate mode)

L1207:  DEFW    L1108                   ; 'code field' - compile

; ---

        DEFW    L12A4                   ; end?

        DEFW    L12D8                   ; check-for
        DEFB    $02
        DEFW    L1225                   ; ?
        DEFW    L04B6                   ; exit

; ---------------
; THE 'BEGIN' WORD
; ---------------
; (  --  )
; Used with either UNTIL or WHILE...REPEAT.

L1212:  DEFM    "BEGI"                  ; 'name field'
        DEFB    'N' + $80

        DEFW    L1206                   ; 'link field'

L1219:  DEFB    $45                     ; 'name length field' (immediate mode)

L121A:  DEFW    L1108                   ; 'code field' - compile

; ---

        DEFW    L129F
        DEFW    L0460                   ; here
        DEFW    L104B                   ; stk_data
        DEFB    $01                     ; 1
        DEFW    L04B6                   ; exit

; -----------------------
; The '???' Internal Word
; -----------------------

L1225:  DEFW    L0EC3                   ; headerless 'code field' - docolon

; ---

        DEFW    L086B                   ; dup
        DEFW    L0460                   ; here
        DEFW    L0885                   ; swap
        DEFW    L0DE1                   ; -
        DEFW    L0E1F                   ; 1-
        DEFW    L0885                   ; swap
        DEFW    L08C1                   ; !
        DEFW    L04B6                   ; exit

; -----------------------
; The '???' Internal Word
; -----------------------

L1237:  DEFW    L0EC3                   ; headerless 'code field' - docolon

; ---

        DEFW    L0460                   ; here
        DEFW    L0DE1                   ; -
        DEFW    L0E1F                   ; 1-
        DEFW    L0F4E                   ; ,
        DEFW    L04B6                   ; exit


; -----------------
; THE 'REPEAT' WORD
; -----------------
; (  --  )
; Used in construction BEGIN ... WHILE .. REPEAT.
; Causes a jump back to just after BEGIN.


L1243:  DEFM    "REPEA"                 ; 'name field'
        DEFB    'T' + $80

        DEFW    L1219                   ; 'link field'

L124B:  DEFB    $46                     ; 'name length field' (immediate mode)

L124C:  DEFW    L1108                   ; 'code field' - compile

; ---

L124E   DEFW    L1276                   ; branch
L1250:  DEFW    L12D8                   ; check_for
        DEFB    $04                     ; four
        DEFW    L0885                   ; swap
        DEFW    L1237                   ; ?
        DEFW    L1225                   ; ?
        DEFW    L04B6                   ; exit

; ----------------
; THE 'UNTIL' WORD
; ----------------
; (n -- )
; Used in BEGIN ... UNTIL.
; Loops back to BEGIN if n = 0

L125B:  DEFM    "UNTI"                  ; 'name field'
        DEFB    'L' + $80

        DEFW    L124B                   ; 'link field'

L1262:  DEFB    $45                     ; 'name length field' (immediate mode)

L1263:  DEFW    L1108                   ; 'code field' - compile

; ---

        DEFW    L128D                   ; ?branch
        DEFW    L12D8                   ; check_for
        DEFB    $01                     ;
        DEFW    L1237                   ; ?
        DEFW    L04B6                   ; exit

; ---

x126E   DEFB    $02                     ;;

x126F   DEFB    $75                     ;;
x1270   DEFB    $FF                     ;; 1270 + ff75 = 11e5 = ELSE

; ---


L1271:  DEFW    L1278                   ; ?

; ---
x1273   DEFB    $02                     ;;

x1274   DEFB    $CE                     ;;
x1275   DEFB    $FF                     ;; 1275 + ffce = 1243 = REPEAT

; --------------------------
; The 'branch' Internal Word
; --------------------------

L1276:  DEFW    L1278                   ; headerless 'code field'

; ---

L1278:  POP     HL                      ; drop next word pointer
        LD      E,(HL)                  ; read the 16-bit offset
        INC     HL                      ; that is
        LD      D,(HL)                  ; stored there.

L127C:  ADD     HL,DE                   ; add to current address.

        JP      L04BA                   ; jump back into address loop so that
                                        ; a new address gets stacked as IP.

; ---

x1280   DEFB    $02                     ;;

x1281   DEFB    $39                     ;;
x1282   DEFB    $FF                     ;; 1282 + ff39 = 11bb = IF

; ---

L1283:  DEFW    L128F                   ; from IF, convert, line, min, etc.

; ---

x1285   DEFB    $02                     ;;

x1286   DEFB    $46                     ;;
x1287   DEFB    $FF                     ;; 1287 + ff46 = 11cd = WHILE

; ---

L1288:  DEFW    L128F                   ; from WHILE

; ---

x128A   DEFB    $02                     ;;

x128B   DEFB    $CF                     ;;
x128C   DEFB    $FF                     ;; 128c + ffcf = 125b = UNTIL

; ---------------------------
; The '?branch' Internal Word
; ---------------------------

L128D:  DEFW    L128F                   ; headerless 'code field'

; ---

L128F:  CALL    L084E                   ; stk_to_bc

        LD      A,B                     ; test for
        OR      C                       ; zero

; -> from +loop
L1294:  JR      Z,L1278                 ; make the jump to "branch" if zero.

        POP     HL                      ; else drop the pointer.
        INC     HL                      ; step over.
        INC     HL                      ; the jump bytes
        JP      L04BA                   ; jump back into address loop so that
                                        ; a new address gets stacked as IP.

; ---

x129C   DEFB    $00                     ;;
x129D   DEFB    $74                     ;;
x129E   DEFB    $FF                     ;; 129e + ff74 = 1212 = BEGIN

; ---

L129F:  DEFW    L04B9                   ; forth

; ---

x12A1   DEFB    $00                     ;;
x12A2   DEFB    $5D                     ;;
x12A3   DEFB    $FF                     ;; 12a3 + ff5d = 1200 = THEN

; ---

L12A4:  DEFW    L04B9

; -------------
; THE 'DO' WORD
; -------------
; (limit, initial value -- )
; Sets up a DO loop, initializing the loop counter to the initial value.
; The limit and loop counter are stored on the return stack.
; See LOOP and +LOOP.

L12A6:  DEFB    'D'                     ; 'name field'
        DEFB    'O' + $80

        DEFW    L1262                   ; 'link field'

L12AA:  DEFB    $42                     ; 'name length field' (immediate mode)

L12AB:  DEFW    L1108                   ; 'code field' - compile

; ---

        DEFW    L1323                   ; shuffle
        DEFW    L0460                   ; here
        DEFW    L104B                   ; stk_data
        DEFB    $03                     ; 3                     marker byte.
        DEFW    L04B6                   ; exit

; ---------------
; THE 'LOOP' WORD
; ---------------
; (  --  )
; Like +LOOP (below) but the number added onto the loop counter is 1.

L12B6:  DEFM    "LOO"                   ; 'name field'
        DEFB    'P' + $80

        DEFW    L12AA                   ; 'link field'

L12BC:  DEFB    $44                     ; 'name length field' (immediate mode)

L12BD:  DEFW    L1108                   ; 'code field' - compile

; ---

        DEFW    L1332                   ; shuffle more

L12C1:  DEFW    L12D8                   ; check-for
        DEFB    $03                     ; 3                     marker byte
        DEFW    L1237                   ; ?
        DEFW    L04B6                   ; exit

; ----------------
; THE '+LOOP' WORD
; ----------------
; (n -- )
; Used with DO. Adds n to the loop counter, and loops back if the loop counter
; is now less than the limit (if n >= 0) or greater than the limit (if n < 0).

L12C8:  DEFM    "+LOO"                  ; 'name field'
        DEFB    'P' + $80

        DEFW    L12BC                   ; 'link field'

L12CF:  DEFB    $45                     ; 'name length field' (immediate mode)

L12D0:  DEFW    L1108                   ; 'code field' - compile

; ---

L12D2:  DEFW    L133C                   ; ?
        DEFW    L1276                   ; branch

L12D6:  DEFW    $FFEA                   ; back to L12C1

; -----------------------------
; The 'check-for' Internal Word
; -----------------------------
; Checks for expected marker byte which indicates stack is balanced and that
; a previous mandatory word was present.

L12D8:  DEFW    L12DA                   ; headerless 'code field'

; ---

L12DA:  RST     18H                     ; pop word DE
        POP     HL                      ;
        LD      A,(HL)                  ;
        INC     HL                      ;
        PUSH    HL                      ;
        SUB     E                       ;
        OR      D                       ;

        JR      Z,L132D                 ; to next via jp (iy).

; else...

        RST     20H                     ; Error 5
        DEFB    $05                     ; Word is not properly structured.

; ------------
; THE 'I' WORD
; ------------
; ( -- loop counter)
; Copies the top of the return stack to the data stack. This will be either
; the loop counter for the innermost DO...LOOP, or the number most recently
; transferred by >R.


L12E5:  DEFB    'I' + $80               ; 'name field'

        DEFW    L11AA                   ; 'link field'

L12E8:  DEFB    $01                     ; 'name length field'

L12E9:  DEFW    L12EB                   ; 'code field'

; ---

L12EB:  POP     BC                      ; pop return address
        POP     DE                      ; pop the loop counter to DE.
        PUSH    DE                      ; now restore the stack
        PUSH    BC                      ; exactly as it was.

        RST     10H                     ; push Data Word DE - inner loop counter

        JP      (IY)                    ; to 'next'.

; -------------
; THE 'I'' WORD
; -------------
; ( -- limit)
; Copies the second number down on the return stack to the data stack
; (so in a DO loop it copies  the limit of the loop).

L12F2:  DEFB    'I'                     ; 'name field'
        DEFB    $A7                     ; "'" + $80

        DEFW    L12E8                   ; 'link field'

L12F6:  DEFB    $02                     ; 'name length field'

L12F7:  DEFW    L12F9                   ; 'code field'

; ---

L12F9:  LD      HL,$0004                ; two bytes per entry.
        JR      L1307                   ; forward to use the 'J' indexing
                                        ; routine

; ------------
; THE 'J' WORD
; ------------
; ( -- loop counter)
; Copies the third entry on the return stack to the data stack.
; This will be either the loop counter for the second innermost DO loop
; or the number put on the return stack by the most recent >R.

L12FE:  DEFB    'J' + $80               ; 'name field'

        DEFW    L12F6                   ; 'link field'

L1301:  DEFB    $01                     ; 'name length field'

L1302:  DEFW    L1304                   ; 'code field'

; ---

L1304:  LD      HL,$0006                ; two bytes per entry

; -> I' joins here with HL=4

L1307:  ADD     HL,SP                   ; index the stack pointer.
        LD      E,(HL)                  ; low order byte to E
        INC     HL                      ; address high byte.
        LD      D,(HL)                  ; DE now holds a copy of the required
                                        ; entry from the Return Stack

        RST     10H                     ; stack Data Word DE

        JP      (IY)                    ; to 'next'.

; ----------------
; THE 'LEAVE' WORD
; ----------------
; (  --  )
; Forces termination of a DO loop at the next LOOP or +LOOP by setting the
; loop counter equal to the limit.

L130E:  DEFM    "LEAV"                  ; 'name field'
        DEFB    'E' + $80

        DEFW    L1301                   ; 'link field'

L1315:  DEFB    $05                     ; 'name length field'

L1316:  DEFW    L1318                   ; 'code field'

; ---

L1318:  POP     BC                      ; pop return address to BC.
        POP     HL                      ; pop the loop counter.
        POP     HL                      ; now the limit.
        PUSH    HL                      ; push unaltered limit.
        PUSH    HL                      ; push counter - now limit.
        PUSH    BC                      ; restore return address.

        JP      (IY)                    ; to 'next'.

; ---


x1320   DEFB    $00                     ;;
x1321   DEFB    $84                     ;;
x1322   DEFB    $FF                     ;; 1322 + ff84 = 12a6 = DO

; -----------------------
; The '???' Internal Word
; -----------------------

L1323:  DEFW    L1325                   ; headerless 'code field'

; ---

L1325:  CALL    L084E                   ; stk_to_bc
        RST     18H                     ; pop word DE
        POP     HL
        PUSH    DE

L132B:  PUSH    BC
        PUSH    HL

L132D:  JP      (IY)                    ; to 'next'.

; ---

x132F   DEFB    $02                     ;;
x1330   DEFB    $85                     ;;
x1331   DEFB    $FF                     ;; 1331 + ff85 = 12b6 = LOOP

; -----------------------
; The '???' Internal Word
; -----------------------

L1332:  DEFW    L1334                   ; headerless 'code field'

; ---

L1334:  LD      DE,$0001
        JR      L133F                   ; forward =>

; ---

x1339   DEFB    $02
x133A   DEFB    $8D
x133B   DEFB    $FF

; -----------------------
; The '???' Internal Word
; -----------------------
; loop counter + n
; Note. ADC HL,DE is used in preference to ADD HL,DE as affects P/O flag

L133C:  DEFW    L133E                   ; headerless 'code field'

; ---

L133E:  RST     18H                     ; pop word DE - number to be added (n)
; =>
L133F:  POP     BC                      ; pop return address to BC.
        POP     HL                      ; loop counter to HL.
        AND     A                       ; clear carry.
        ADC     HL,DE                   ; add the number specified.
        LD      A,D                     ; save MSB of (n) in A.
        POP     DE                      ; now pop the limit to DE.
        SCF                             ; set carry.
        JP      PE,L1358                ; jump forward with overflow.

        PUSH    DE                      ; push limit
        PUSH    HL                      ; push adjusted counter.
        RLCA                            ; now test sign of number (n)
        JR      NC,L1350                ;

        EX      DE,HL

L1350:  CALL    L0C99                   ;

        CCF

        JR      NC,L1358                ;

        POP     HL
        POP     HL

L1358:  PUSH    BC
        SBC     A,A
        JP      L1294                   ; jump to branch on zero.

; ------------
; THE '(' WORD
; ------------
; Starts a comment terminated by ')'

L135D:  DEFB    '(' + $80               ; 'name field'

        DEFW    L13D4                   ; 'link field'

L1360:  DEFB    $41                     ; 'name length field' (immediate mode)

L1361:  DEFW    L1108                   ; 'code field' - compile

; ---

L1363:  DEFW    L1379                   ;
        DEFW    L104B                   ; stk_data

        DEFB    $29                     ; character ')'         - delimiter

L1368:  DEFW    L0460                   ; here
        DEFW    L0885                   ; swap
        DEFW    L0F83                   ; allot2
        DEFW    L139F                   ; find)
        DEFW    L0885                   ; swap
        DEFW    L08C1                   ; !

        DEFW    L04B6                   ; exit

; ---

x1376   DEFB    $FF                     ;;
x1377   DEFB    $E5                     ;;
x1378   DEFB    $FF                     ;; 1378 + ffe5 = 135d = '('

; -----------------------
; The '???' Internal Word
; -----------------------

L1379:  DEFW    L137B                   ; headerless 'code field'

; ---

L137B:  POP     HL
        LD      E,(HL)
        INC     HL
        LD      D,(HL)

        INC     DE

        JP      L127C                   ;

; -------------
; THE '."' WORD
; -------------
; (  --  )
; Prints the following string terminated by ".

L1383:  DEFB    '.'                     ; 'name field'
        DEFB    '"' + $80

        DEFW    L1360                   ; 'link field'

L1387:  DEFB    $42                     ; 'name length field' (immediate mode)

L1388:  DEFW    L1108                   ; 'code field' - compile

; ---

L138A:  DEFW    L1396                   ; pr_embedded string.
        DEFW    L104B                   ; stk_data
        DEFB    $22                     ; '"'                   - delimiter

        DEFW    L1276                   ; branch
L1391:  DEFW    $FFD6                   ; back to 1368 (1392+$FFD6)
                                        ; same routine as for matching comments

; ---

x1393   DEFB    $FF                     ;;
x1394   DEFB    $EE                     ;;
x1395   DEFB    $FF                     ;; 1395 + ffee = 1383 = ."

; -----------------------
; The '???' Internal Word
; -----------------------
; print string embedded in Dictionary

L1396:  DEFW    L1398                   ; headerless 'code field'

; ---

L1398:  POP     DE
        CALL    L0979                   ; pr_string1
        PUSH    DE
        JP      (IY)                    ; to 'next'.

; -----------------------
; The '???' Internal Word
; -----------------------
; enclose comment
; comments may be multiple
; e.g. : SV ( system) ( variables) CLS BEGIN 0 0 AT 15360 80 TYPE 0 UNTIL ;


L139F:  DEFW    L13A1                   ; headerless 'code field'

; ---

L13A1:  RST     18H                     ; pop word DE
        PUSH    DE                      ; save delimiter.

        CALL    L05E1                   ; find the ')' delimiter

        LD      H,D
        LD      L,E
        ADD     HL,BC
        LD      A,(HL)
        POP     HL                      ; pop the delimiter.
        CP      L
        JR      Z,L13B8                 ; forward with a match.         =->

        EX      DE,HL                   ;
        RST     10H                     ; push word DE
        LD      DE,$0578                ; addr retype?

        CALL    L1815                   ; pr2

        JR      L13A1                   ; loop back

; ---
; =->

L13B8:  PUSH    DE
        PUSH    BC
        LD      HL,($3C37)              ; STKBOT

        CALL    L0F9E                   ; routine MAKE ROOM

        POP     BC
        POP     DE
        PUSH    DE
        PUSH    BC
        EX      DE,HL
        LDIR                            ; copy comment to dictionary.
        POP     BC
        LD      D,B
        LD      E,C
        RST     10H                     ; push word DE
        POP     DE

        CALL    L07DA                   ;

        JP      (IY)                    ; to 'next'.

; ------------
; THE '[' WORD
; ------------
; (  --  )
; Enters interpret mode.

L13D1:  DEFB    '[' + $80               ; 'name field'

        DEFW    L12CF                   ; 'link field'

L13D4:  DEFB    $41                     ; 'name length field' (immediate mode)

L13D5:  DEFW    L13D7                   ; 'code field'

; ---

L13D7:  RES     6,(IX+$3E)              ; FLAGS
        JP      (IY)                    ; to 'next'.

; ------------
; THE ']' WORD
; ------------
; (  --  )
; Enters compile mode.

L13DD:  DEFB    ']' + $80               ; 'name field'

        DEFW    L1315                   ; 'link field'

L13E0:  DEFB    $01                     ; 'name length field'

L13E1:  DEFW    L13E3                   ; 'code field'

; ---

L13E3:  SET     6,(IX+$3E)              ; FLAGS
        JP      (IY)                    ; to 'next'.


; ---------------
; THE 'EXIT' WORD
; ---------------
; (  --  )
; Exits immediately from the word in whose definition it is contained.
; Cannot be used between DO and LOOP or +LOOP, nor between >R and R>.

L13E9:  DEFM    "EXI"                   ; 'name field'
        DEFB    'T' + $80

        DEFW    L1387                   ; 'link field'

L13EF:  DEFB    $04                     ; 'name length field'

L13F0:  DEFW    L04B8                   ; 'code field'

; -------------------
; THE 'REDEFINE' WORD
; -------------------
; REDEFINE name
; (  --  )
; Takes word 'name' and replaces it with the most recent word in the
; dictionary. Updates entire dictionary to take changes into account.
; Most commonly used as
;  EDIT name
;  REDEFINE name

L13F2:  DEFM    "REDEFIN"               ; 'name field'
        DEFB    'E' + $80

        DEFW    L13EF                   ; 'link field'

L13FC:  DEFB    $08                     ; 'name length field'

L13FD:  DEFW    L13FF                   ; 'code field'

; ---

L13FF:  CALL    L0F2E                   ; blank stack

        LD      HL,($3C31)              ; CURRENT

        LD      E,(HL)
        INC     HL
        LD      D,(HL)

        EX      DE,HL                   ; transfer value to HL
        INC     HL
        LD      ($2705),HL              ; store in pad

        PUSH    HL                      ; (*)

        CALL    L15C0                   ; get 'name field' address

        LD      ($270D),HL              ; name field addr
        LD      ($2707),BC              ; parameter field addr
        LD      ($270B),DE              ; length field value

        LD      HL,($3C37)              ; STKBOT
        SBC     HL,DE
        JP      NZ,L14DA                ; forward if not matched to Error 11.

        POP     DE                      ; (*)

        RST     10H                     ; push word DE

        CALL    L04B9                   ; forth

L1429:  DEFW    L1610                   ; prvcur
        DEFW    L063D                   ; find
        DEFW    L1A0E                   ; end-forth.

; ---

L1425:  RST     18H                     ; pop word DE
        LD      HL,$C3AF
        ADD     HL,DE
        JP      NC,L14CF                ;

        EX      DE,HL
        LD      ($2703),HL

        CALL    L15C0                   ; get 'name field' address

        LD      ($2701),HL

L1441:  PUSH    HL
        LD      ($2709),DE
        LD      A,B
        OR      C
        LD      DE,($2707)
        JR      Z,L1452                 ;

        LD      A,D
        OR      E
        JR      Z,L14CF                 ;

L1452:  POP     HL
        LD      BC,($270D)
        SBC     HL,BC
        EX      DE,HL
        ADD     HL,DE
        LD      ($2707),HL
        LD      HL,($270B)
        ADD     HL,DE
        LD      BC,($2709)
        AND     A
        SBC     HL,BC
        LD      ($270B),HL
        LD      BC,$002E                ; 46d
        ADD     HL,BC
        BIT     7,H
        JR      NZ,L147F                ;

        LD      BC,($3C3B)              ; SPARE
        ADD     HL,BC
        JR      C,L14CF                 ;

        SBC     HL,SP
        JR      NC,L14CF                ;

L147F:  LD      HL,($2703)
        PUSH    HL
        DEC     HL
        DEC     HL
        LD      B,(HL)
        DEC     HL
        LD      C,(HL)
        LD      HL,($2705)
        PUSH    HL
        DEC     HL
        DEC     HL
        LD      (HL),B
        DEC     HL
        LD      (HL),C
        POP     HL
        ADD     HL,DE
        POP     BC
        AND     A
        SBC     HL,BC
        LD      ($2705),HL
        LD      DE,($2701)
        LD      HL,($2709)
        AND     A
        SBC     HL,DE
        LD      B,H
        LD      C,L
        PUSH    DE
        PUSH    BC

        CALL    L14DC                   ; RECLAIM

        LD      HL,($270B)
        POP     BC
        ADD     HL,BC
        LD      B,H
        LD      C,L
        POP     HL
        PUSH    BC

        CALL    L0F9E                   ; routine MAKE ROOM

        EX      DE,HL                   ;
        LD      HL,($270D)              ;
        LD      BC,($270B)              ;
        ADD     HL,BC                   ;
        POP     BC                      ;
        PUSH    BC                      ;
        PUSH    HL                      ;

        LDIR                            ;

        POP     DE
        POP     BC

        CALL    L14DC                   ; RECLAIM
        CALL    L14F8                   ;

        JP      (IY)                    ; to 'next'.

; ---

L14CF:  LD      HL,($3C31)              ; CURRENT
        LD      DE,($2705)
        DEC     DE
        LD      (HL),E
        INC     HL
        LD      (HL),D

L14DA:  RST     20H                     ; Error 11
        DEFB    $0B                     ; Error in REDEFINE or FORGET

; ---------------------------
; THE 'RECLAIMING' SUBROUTINE
; ---------------------------

L14DC:  LD      HL,($3C37)              ; fetch STKBOT
        AND     A                       ; clear carry flag
        SBC     HL,BC                   ; subtract number of bytes to reclaim.
        LD      ($3C37),HL              ; update STKBOT

        LD      HL,($3C3B)              ; fetch SPARE
        SBC     HL,BC                   ; subtract number of bytes to reclaim.
        LD      ($3C3B),HL              ; update SPARE

        SBC     HL,DE                   ; subtract
        RET     Z                       ; return if same address.

        PUSH    BC                      ;
        LD      B,H                     ;
        LD      C,L                     ;
        POP     HL                      ;
        ADD     HL,DE                   ;

        LDIR                            ;

        RET                             ;

; ---
;
; ---

L14F8:  LD      BC,$3C31                ; CURRENT

        CALL    L1557                   ;
        CALL    L1557                   ;

        LD      BC,$3C40                ; addr. of "FORTH" in RAM.

L1504:  LD      HL,($3C37)              ; STKBOT
        SCF                             ;
        SBC     HL,BC                   ;
        RET     C                       ;

L150B:  LD      A,(BC)                  ;
        RLA                             ;
        INC     BC                      ;
        JR      NC,L150B                ;

        INC     BC                      ;
        INC     BC                      ;
        CALL    L1557                   ;
        INC     BC                      ;
        CALL    L1557                   ;

L1519:  CALL    L15FB                   ; routine INDEXER

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

        DEFW    L0EC3                   ; DE value
L151E:  DEFB    $1C                     ; to L153A

        DEFW    L1085                   ; DE value
L1521:  DEFB    $16                     ; to L1537

        DEFW    L1108                   ; DE value
L1524:  DEFB    $13                     ; to L1537

        DEFW    L11B5                   ; DE value
L1527:  DEFB    $18                     ; to L153F

        DEFW    $0000                   ; zero end marker

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

L152A:  LD      HL,$FFF9
        ADD     HL,BC

        LD      C,(HL)
        INC     HL
        LD      B,(HL)
        DEC     HL

        ADD     HL,BC

        LD      B,H
        LD      C,L
        JR      L1504                   ;

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

L1537:  CALL    L1557                   ;

; ->

L153A:  CALL    L1548                   ;
        JR      L1504                   ;

; ---

L153F:  CALL    L1557                   ;
        INC     BC                      ;
        CALL    L1557                   ;
        JR      L1504                   ;

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

; XXX?

L1548:  CALL    L1557                   ;
        LD      HL,L04B6                ;
        AND     A                       ;
        SBC     HL,DE                   ;
        RET     Z                       ;

        CALL    L159E                   ;

        JR      L1548                   ;

; ---
; often called twice
; ---


L1557:  LD      A,(BC)                  ; lo byte
        LD      E,A                     ;
        INC     BC                      ;
        LD      A,(BC)                  ; hi byte
        LD      D,A                     ;
        DEC     BC                      ; BC now unchanged, DE contents

        CALL    L1568                   ; routine below. header?

        EX      DE,HL                   ; value to DE
        LD      A,E                     ;
        LD      (BC),A                  ; lo byte
        INC     BC                      ;
        LD      A,D                     ;
        LD      (BC),A                  ; hi byte
        INC     BC                      ;
        RET                             ; to next - BC+=2

; ---

L1568:  LD      HL,($2701)              ; first bytes of pad.
        AND     A                       ;
        SBC     HL,DE                   ; subtract the DE value read from
                                        ; memory
        LD      H,D                     ;
        LD      L,E                     ; transfer that DE to HL as well

        RET     NC                      ; return if HL was higher than DE

        LD      HL,($2709)              ; tape header
        SBC     HL,DE
        JR      NC,L1584                ; forward if higher to

        LD      HL,($270D)
        SBC     HL,DE
        JR      C,L1592                 ; forward if lower to

        LD      HL,($270B)              ;
        ADD     HL,DE
        RET                             ; return

; ---

L1584:  LD      HL,($2703)
        SBC     HL,DE
        LD      HL,($2707)
        RET     C

        LD      HL,($2705)
        ADD     HL,DE
        RET

; ---

L1592:  LD      HL,($2701)
        ADD     HL,DE
        LD      DE,($270D)
        AND     A
        SBC     HL,DE
        RET

; ---

L159E:  DEC     DE
        LD      A,(DE)
        RLA
        RET     NC

L15A2:  DEC     DE
        DEC     DE
        LD      A,(DE)
        LD      L,A                     ; low byte
        LD      H,$00                   ; make high byte zero
        INC     A                       ; test offset for $FF.
        JR      NZ,L15B1                ; forward if not.

        LD      A,(BC)
        LD      L,A
        INC     BC
        LD      A,(BC)
        LD      H,A
        INC     BC

L15B1:  ADD     HL,BC

        LD      B,H
        LD      C,L
        RET

; ---
;
; ---


L15B5:  DEFW    L15B7

; ---

L15B7:  RST     18H                     ; pop word DE

        EX      DE,HL

        CALL    L15E7                   ; WORDSTART1

        EX      DE,HL

        RST     10H                     ; push word DE
        JP      (IY)                    ; to 'next'.

; ---
;
; ---

L15C0:  PUSH    HL
        LD      E,(HL)
        INC     HL
        LD      D,(HL)

L15C4:  CALL    L15FB                   ; routine INDEXER

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

        DEFW    L1108
L15C9:  DEFB    $0B                     ; to L15D4 - find parameter field

        DEFW    L1085
L15CC:  DEFB    $08                     ; to L15D4 - find parameter field

        DEFW    $0000                   ; zero end_marker.

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

L15CF:  LD      BC,$0000                ; zero indicates no parameter field.
        JR      L15DB                   ; forward to consider total length.

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

L15D4:  POP     HL                      ; retrieve the code field address
        PUSH    HL                      ; save it again

        INC     HL                      ; step past the
        INC     HL                      ; address word
        LD      C,(HL)                  ; and get following address
        INC     HL                      ; which if in RAM could be the
        LD      B,(HL)                  ; parameter field to              BC.

; ->

L15DB:  POP     HL                      ; retrieve the code field address
        PUSH    HL                      ; and save it again

        DEC     HL                      ; the name length field
        DEC     HL                      ; link field high order byte
        DEC     HL                      ; link field low order byte
        DEC     HL                      ; possible length field high
        LD      D,(HL)                  ; save in D
        DEC     HL                      ; possible length field low
        LD      E,(HL)                  ; save in E
        ADD     HL,DE                   ; add this length
        EX      DE,HL                   ; and save result in              DE.

        POP     HL                      ; retrieve code field address

; ->
; indexes the header information of a FORTH word

L15E7:  DEC     HL                      ; point to name length field

; =>
L15E8:  LD      A,H                     ; fetch high order byte of the
                                        ; header address.
        CP      $3C                     ; compare to RAM location
        LD      A,(HL)                  ; fetch length byte.
        RES     6,A                     ; reset the immediate mode bit
        JR      C,L15F2                 ; forward if definition is in ROM.

        ADD     A,$02                   ; else add extra for 'length field'

L15F2:  DEC     HL                      ; step past the
        DEC     HL                      ; link to previous word.

L15F4:  DEC     HL                      ; now address last letter on name.
        DEC     A                       ; decrement the length
        JR      NZ,L15F4                ; loop back until at first letter  HL.

        RET                             ; return.

; -------
; INDEXER
; -------

; indexerloop

L15F9:  INC     HL                      ; step past the
        PUSH    HL                      ; offset byte.

; -> Call Entry point

L15FB:  POP     HL                      ; drop return address - points to byte
                                        ; after the call.
        LD      A,(HL)                  ; read low-order byte
        INC     HL                      ; increment address once
        PUSH    HL                      ; push return address

        LD      H,(HL)                  ; read high-order byte.
        LD      L,A                     ; now HL holds the read word
        OR      H                       ; test for two zeros.
        RET     Z                       ; two zeros - return
                                        ; (ret addr is second NOP)

        SBC     HL,DE                   ; compare to value passed in DE

        POP     HL                      ; now increment the
        INC     HL                      ; return address on machine stack.

        JR      NZ,L15F9                ; loop back if read word is not
                                        ; equal to DE

        PUSH    DE                      ; else preserve DE

        LD      D,$00                   ; a 1 byte relative jump.
        LD      E,(HL)                  ; read one-byte offset.
        ADD     HL,DE                   ; add to read address.

        POP     DE                      ; restore DE

        JP      (HL)                    ; >>>

; ---

L1610:  DEFW    L0EC3                   ; 'code field' - docolon

        DEFW    L0E1F                   ; 1-
        DEFW    L0E29                   ; 2-
        DEFW    L08B3                   ; @
        DEFW    L0480                   ; current
        DEFW    L08B3                   ; @
        DEFW    L08C1                   ; !
        DEFW    L04B6                   ; exit

; ---------------------------------
; THE 'FIND WORD IN RAM' SUBROUTINE
; ---------------------------------
; This subroutine is used by FORGET, EDIT and LIST.
; First use the standard FORTH word find to get address of word (in pad).
; If word does not exist then returned value will be zero.
; The lowest word in RAM is the FORTH word at L3C51 so a check is made
; against this address.

L1620:  CALL    L04B9                   ; forth
        DEFW    L063D                   ; find

L1625:  DEFW    L1A0E                   ; end-forth.

        RST     18H                     ; pop word DE

        LD      HL,$C3AF                ; i.e $0000 - $3C51

        ADD     HL,DE                   ; add to test value.
        RET     C                       ; carry signals that word exists in RAM.
                                        ; return the address in DE.

; else generate an error code.

        RST     20H                     ; Error 13
        DEFB    $0D                     ; Error word not found or is in ROM.

; -----------------
; THE 'FORGET' WORD
; -----------------
; FORGET name.
; Erases the word 'name' and all subsequently defined names from the dictionary.

L162F:  DEFM    "FORGE"                 ; 'name field'
        DEFB    'T' + $80

        DEFW    L13FC                   ; 'link field'

L1637:  DEFB    $06                     ; 'name length field'

L1638:  DEFW    L163A                   ; 'code field'

; ---

L163A:  LD      HL,($3C31)              ; CURRENT
        LD      DE,($3C33)              ; CONTEXT
        AND     A
        SBC     HL,DE

        JP      NZ,L14DA                ;

        CALL    L1620                   ; findramword

        LD      HL,$FFFB
        ADD     HL,DE
        LD      ($3C39),HL              ; SPARE
        SET     2,(IX+$3E)              ; FLAGS

        RST     20H                     ; Invoke error routine.
        DEFB    $FF                     ; No error

; ---------------
; THE 'EDIT' WORD
; ---------------
; EDIT name
; Lists word 'name' at bottom of the screen to be edited. Lists 18 lines at
; a time, then waits for editing until ENTER is pressed.
; A new version of the word is entered at the end of the dictionary.
; While editing, cursor up and cursor down are needed to move the cursor
; from one line to another. DELETE LINE deletes one line.

L1657:  DEFM    "EDI"                   ; 'name field'
        DEFB    'T' + $80

        DEFW    L1637                   ; 'link field'

L165D:  DEFB    $04                     ; 'name length field'

L165E:  DEFW    L1660                   ; 'code field'

; ---

L1660:  CALL    L1620                   ; findramword

        SET     3,(IX+$3E)              ; update FLAGS output -> input buffer
        JR      L1675                   ; forward to list routine the difference
                                        ; being that the listing will go to the
                                        ; lower screen.

; ---------------
; THE 'LIST' WORD
; ---------------
; LIST name
; (  --  )
; Lists word 'name' on the screen. It must have been defined by :, DEFINER,
; or COMPILER. Lists about 18 lines at a time and waits for key depression
; (shifted space breaks).

L1669:  DEFM    "LIS"                   ; 'name field'
        DEFB    'T' + $80

        DEFW    L165D                   ; 'link field'

L166F:  DEFB    $04                     ; 'name length field'

L1670:  DEFW    L1672                   ; 'code field'

; ---

L1672:  CALL    L1620                   ; findramword

; edit path joins here but carriage returns are printed as zeros.

L1675:  LD      A,$0D                   ; prepare a carriage return.
        RST     08H                     ; print_ch

        BIT     3,(IX+$3E)              ; test FLAGS output->input buffer?

        PUSH    DE

        CALL    NZ,L02D8                ; call if so to initialize buffer

        POP     BC                      ; LD DE,(BC)

        LD      A,(BC)
        LD      E,A
        INC     BC
        LD      A,(BC)
        LD      D,A
        DEC     BC

        CALL    L15FB                   ; routine INDEXER

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

L168A:  DEFW    L0EC3                   ; DE value
L168C:  DEFB    $0B                     ; offset to L1697

L168D:  DEFW    L1108                   ; DE value
L168F:  DEFB    $0D                     ; offset to L169C

L1690:  DEFW    L1085                   ; DE value
L1692:  DEFB    $1F                     ; offset to L16B1

        DEFW    $0000                   ; zero end-marker

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

L1695:  RST     20H                     ; Error 14
        DEFB    $0E                     ; Word unlistable.

; Only words defined by ':', 'DEFINER' or 'COMPILER' are listable.

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

; ':'
L1697:  LD      HL,$0002
        JR      L16B4                   ;
; ---

L169C:  PUSH    DE
        LD      HL,$0002
        ADD     HL,BC
        LD      A,(HL)
        INC     HL
        LD      H,(HL)
        LD      L,A
        DEC     HL
        DEC     HL
        DEC     HL

        LD      L,(HL)
        LD      A,L
        RLCA
        SBC     A,A
        LD      H,A

        CALL    L180E                   ; pr_int_hl?

        POP     DE

L16B1:  LD      HL,$0004


L16B4:  ADD     HL,BC
        PUSH    HL
        PUSH    BC

        CALL    L17E4                   ;

        POP     DE
        POP     BC

        CALL    L17E4                   ;

        LD      (IX+$14),$01            ; LISTWSx

L16C3:  LD      (IX+$16),$10            ; LISTWSx

L16C7:  CALL    L1708                   ; index_table

        JR      C,L16D2                 ;

        DEC     (IX+$16)                ; LISTWSx
        JP      P,L16C7                 ;

L16D2:  BIT     3,(IX+$3E)              ; FLAGS
        JR      NZ,L16E8                ; branch forward  =->

        JR      C,L1702                 ;

        LD      HL,$3C26                ; KEYCOD
        LD      (HL),$00                ;

L16DF:  LD      A,(HL)                  ;
        AND     A                       ;
        JR      Z,L16DF                 ; loop back while zero

        CALL    L04E4                   ; check break

        JR      L16C3                   ; loop back

; =->

L16E8:  PUSH    AF
        RES     3,(IX+$3E)              ; FLAGS
        PUSH    BC

        CALL    L04B9                   ; forth

        DEFW    L0578                   ; retype        - allow user to retype
        DEFW    L0506                   ; line          - interpret buffer
        DEFW    L1A0E                   ; end-forth.


        SET     3,(IX+$3E)              ; FLAGS

        CALL    L02D8                   ;

        POP     BC
        POP     AF
        JR      NC,L16C3                ;

L1702:  RES     3,(IX+$3E)              ; FLAGS
        JP      (IY)                    ; to 'next'.

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

; called once

L1708:  LD      A,($3C14)               ; LISTWS2
        LD      ($3C15),A               ; LISTWS3

        LD      (IX+$13),$05            ; LISTWS

L1712:  LD      A,(BC)
        LD      E,A
        INC     BC
        LD      A,(BC)
        LD      D,A
        INC     BC

L1718:  CALL    L15FB                   ; routine INDEXER

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

L171B:  DEFW    L1283                   ;
L171D:  DEFB    $40                     ; offset to L175D

L171E:  DEFW    L1271                   ;
L1720:  DEFB    $44                     ; offset to L1764

L1721:  DEFW    L12A4                   ;
L1723:  DEFB    $48                     ; offset to L176B

L1724:  DEFW    L129F                   ;
L1726:  DEFB    $37                     ; offset to L175D

L1727:  DEFW    L128D                   ;
L1729:  DEFB    $42                     ; offset to L176B

L172A:  DEFW    L1288                   ;
L172C:  DEFB    $38                     ; offset to L1764

L172D:  DEFW    L1276                   ;
L172F:  DEFB    $3C                     ; offset to L176B

L1730:  DEFW    L1323                   ;
L1732:  DEFB    $2B                     ; offset to L175D

L1733:  DEFW    L1332                   ;
L1735:  DEFB    $36                     ; offset to L176B

L1736:  DEFW    L133C                   ;
L1738:  DEFB    $33                     ; offset to L176B

L1739:  DEFW    L10E8                   ;
L173B:  DEFB    $29                     ; offset to L1764

L173C:  DEFW    L1140                   ;
L173E:  DEFB    $26                     ; offset to L1764

L173F:  DEFW    L1011                   ;
L1741:  DEFB    $3B                     ; offset to L177C

L1742:  DEFW    L1064                   ;
L1744:  DEFB    $47                     ; offset to L178B

L1745:  DEFW    L104B                   ;
L1747:  DEFB    $51                     ; offset to L1798

L1748:  DEFW    L1379                   ;
L174A:  DEFB    $62                     ; offset to L17AC

L174B:  DEFW    L1396                   ;
L174D:  DEFB    $63                     ; offset to L17B0

L174E:  DEFW    L04B6                   ;
L1750:  DEFB    $54                     ; offset to L17A4

L1751:  DEFW    $0000                   ; zero end-marker

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

; default action

L1753:  CALL    L17E1                   ;

L1756:  DEC     (IX+$13)                ; LISTWS
        JR      NZ,L1712                ;
        AND     A
        RET

; ---

L175D:  LD      HL,($3C14)              ; LISTWS2
        LD      H,L
        INC     L
        JR      L1770                   ;

; ---

L1764:  LD      HL,($3C14)              ; LISTWS2
        LD      H,L
        DEC     H
        JR      L1770                   ;

; ---

L176B:  LD      HL,($3C14)              ; LISTWS2
        DEC     L
        LD      H,L

L1770:  LD      ($3C14),HL              ; LISTWS2
        LD      (IX+$13),$01            ; LISTWS
        DEC     (IX+$16)                ; LISTWSx
        JR      L1753                   ;

; ---

L177C:  CALL    L17DA                   ;

        RST     10H                     ; push word DE
        LD      DE,$09B3                ; '.' addr

L1783:  CALL    L17C1                   ; routine INDENT
        CALL    L1815                   ; pr2

        JR      L1756                   ;

; ---

L178B:  CALL    L17DA                   ;
        RST     10H                     ; push word DE
        CALL    L17DA                   ;
        RST     10H                     ; push word DE
        LD      DE,$0AAF                ; 'F.' addr
        JR      L1783                   ;

; ---

L1798:  LD      A,(BC)
        PUSH    AF

        CALL    L17E1                   ;

        POP     AF
        RST     08H                     ; print_ch

        LD      A,$20                   ; a space character
        RST     08H                     ; print_ch

        JR      L1756                   ;

; ---

L17A4:  CALL    L1808                   ; pr_inline

        DEFB    $0D                     ; newline
        DEFB    ';'                     ; ;
        DEFB    $8D                     ; inverted newline

        SCF                             ;
        RET                             ;

; ---

L17AC:  LD      A,$29                   ; character ')' - end of comment.
        JR      L17B2                   ;

L17B0:  LD      A,$22                   ; character '"' - quote

L17B2:  PUSH    AF
        PUSH    BC
        CALL    L17E1                   ;
        POP     DE
        CALL    L0979                   ; pr_string1
        LD      B,D
        LD      C,E
        POP     AF

        RST     08H                     ; print_ch

        AND     A
        RET

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

L17C1:  LD      A,($3C15)               ; LISTWS3
        AND     A
        RET     M

        PUSH    BC                      ; preserve BC
        LD      B,A                     ; transfer count to B

        LD      A,$0D                   ; carriage return.
        RST     08H                     ; print_ch

        INC     B                       ; test indentation.
        DEC     B                       ;
        JR      Z,L17D4                 ;

L17CF:  LD      A,$20                   ; a space character
        RST     08H                     ; print_ch

        DJNZ    L17CF                   ;

L17D4:  LD      (IX+$15),$FF            ; LISTWS3

        POP     BC                      ; restore BC
        RET                             ; return.

; ---

L17DA:  LD      A,(BC)
        LD      E,A
        INC     BC
        LD      A,(BC)
        LD      D,A
L17DF:  INC     BC
        RET

; ---

L17E1:  CALL    L17C1                   ; routine INDENT

L17E4:  EX      DE,HL
        DEC     HL
        LD      A,(HL)
        BIT     7,A
        JR      NZ,L17F0                ;

        CALL    L15E8                   ; routine WORDSTART

        JR      L17FB                   ;

; ---

L17F0:  EX      DE,HL

        CALL    L15A2                   ;

        INC     DE
        LD      A,(DE)
        LD      L,A
        INC     DE
        LD      A,(DE)
        LD      H,A
        ADD     HL,DE

; pr_string_sp

L17FB:  LD      A,(HL)
        AND     $7F
        RST     08H                     ; print_ch
        BIT     7,(HL)
        INC     HL
        JR      Z,L17FB                 ;

        LD      A,$20
        RST     08H                     ; print_ch
        RET

; ---------------------------------------
; THE 'INLINE PRINT STRING SPACE' ROUTINE
; ---------------------------------------
;

L1808:  EX      (SP),HL
        CALL    L17FB                   ; pr_string_sp
        EX      (SP),HL
        RET

; ---------------------------
; THE 'PRINT INTEGER' ROUTINE
; ---------------------------
; in HL

; -> called twice
L180E:  LD      DE,$09B3                ; '.' addr
        PUSH    DE                      ; but save it as we need DE?

        EX      DE,HL                   ; transfer HL to DE.
        RST     10H                     ; push word DE, was HL, on Data Stack.
        POP     DE                      ; restore L09B3 again

; -> called twice.
L1815:  PUSH    BC                      ; preserve BC.

        CALL    L04BF                   ; executes '.' word

; the '.' exits so expects another word here


L1819:  DEFW    L181B

L181B:  DEFW    L181D

L181D   POP     BC                      ;
        POP     BC                      ; restore BC.

        RET                             ; return.

; ---------------------------------
; THE 'CASSETTE INTERFACE' ROUTINES
; ---------------------------------

; ---
; tape???
; ---

L1820:  PUSH    IY

        PUSH    HL
        POP     IY

        LD      HL,L1892
        PUSH    HL

        LD      HL,$E000
        BIT     7,C
        JR      Z,L1832                 ;
        LD      H,$FC
L1832:  INC     DE
        DEC     IY
        DI
        XOR     A

L1837:  LD      B,$97

L1839:  DJNZ    L1839                   ;
        OUT     ($FE),A
        XOR     $08
        INC     L
        JR      NZ,L1843                ;
        INC     H
L1843:  JR      NZ,L1837                ;
        LD      B,$2B
L1847:  DJNZ    L1847                   ;
        OUT     ($FE),A
        LD      L,C
        LD      BC,$3B08
L184F:  DJNZ    L184F                   ;
        LD      A,C
        OUT     ($FE),A
        LD      B,$38
        JP      L188A                   ;

L1859:  LD      A,C
        BIT     7,B

L185C:  DJNZ    L185C                   ;

        JR      NC,L1864                ;

        LD      B,$3D
L1862:  DJNZ    L1862                   ;

L1864:  OUT     ($FE),A
        LD      B,$3A
        JP      NZ,L1859                ;
        DEC     B
        XOR     A
L186D:  RL      L
        JP      NZ,L185C                ;
        DEC     DE
        INC     IY
        LD      B,$2E

        LD      A,$7F
        IN      A,($FE)
        RRA
        RET     NC

        LD      A,D
        CP      $FF
        RET     NC

        OR      E
        JR      Z,L188F                 ;

        LD      L,(IY+$00)
L1887:  LD      A,H
        XOR     L
        LD      H,A
L188A:  XOR     A
        SCF
        JP      L186D                   ; JUMP back

; ---

L188F:  LD      L,H
        JR      L1887                   ;

L1892:  POP     IY                      ; restore the original IY value so that
                                        ; words can be used gain.

        EX      AF,AF'                  ;;
        LD      B,$3B                   ;

L1897:  DJNZ    L1897                   ; self-loop for delay.

        XOR     A
        OUT     ($FE),A

        LD      A,$7F                   ; read the port $7FFE
        IN      A,($FE)                 ; keyrows SPACE to V.
        RRA
        EI                              ; Enable Interrupts.

        JP      NC,L04F0                ; jump if SPACE pressed to Error 3
                                        ; 'BREAK pressed'.

        EX      AF,AF'                  ;;
        RET                             ; return.

; ---
; READ BYTES FROM TAPE
; ---

L18A7:  DI
        PUSH    IY
        PUSH    HL
        POP     IY
        LD      HL,L1892
        PUSH    HL
        LD      H,C
        EX      AF,AF'                  ; save carry
        XOR     A
        LD      C,A

L18B5:  RET     NZ

L18B6:  LD      L,$00
L18B8:  LD      B,$B8

        CALL    L1911                   ;

        JR      NC,L18B5                ;

        LD      A,$DF
        CP      B
        JR      NC,L18B6                ;

        INC     L
        JR      NZ,L18B8                ;

L18C7:  LD      B,$CF

        CALL    L1915                   ;

        JR      NC,L18B5                ;

        LD      A,B
        CP      $D8
        JR      NC,L18C7                ;

        CALL    L1915                   ;
        RET     NC

        CALL    L18FC                   ;
        RET     NC

        CCF
        RET     NZ

        JR      L18F0                   ;

; ---

L18DF:  EX      AF,AF'
        JR      NC,L18E7                ;
        LD      (IY+$00),L
        JR      L18EC                   ;

; ---

L18E7:  LD      A,(IY+$00)
        XOR     L
        RET     NZ

L18EC:  INC     IY
        DEC     DE
        EX      AF,AF'

L18F0:  CALL    L18FC                   ;

        RET     NC

        LD      A,D
        OR      E
        JR      NZ,L18DF                ;

        LD      A,H
        CP      $01
L18FB:  RET

; ---

L18FC:  LD      L,$01
L18FE:  LD      B,$C7

        CALL    L1911                   ;

        RET     NC

        LD      A,$E2
        CP      B
        RL      L
        JP      NC,L18FE                ;

        LD      A,H
        XOR     L
        LD      H,A
        SCF
        RET

; ---

L1911:  CALL    L1915                   ;
        RET     NC

L1915:  LD      A,$14
L1917:  DEC     A

        JR      NZ,L1917                ;

        AND     A

L191B:  INC     B
        RET     Z

        LD      A,$7F
        IN      A,($FE)
        RRA
        RET     NC

        XOR     C
        AND     $10
        JR      Z,L191B                 ;

        LD      A,C
        CPL
        LD      C,A
        SCF
        RET

; ---------------
; THE 'SAVE' WORD
; ---------------
; SAVE name.
; Saves entire dictionary in RAM on a dictionary type cassette file with the
; given name. Makes a noise on the internal loudspeaker.

L192D:  DEFM    "SAV"                   ; 'name field'
        DEFB    'E' + $80

        DEFW    L166F                   ; 'link field'

L1933:  DEFB    $04                     ; 'name length field'

L1934:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

        DEFW    L1A10                   ; word to pad
        DEFW    L1A4F                   ;  prep some sort of header?
        DEFW    L04B6                   ; exit

; ----------------
; THE 'BSAVE' WORD
; ----------------
; BSAVE name
; (m, n -- )
; Save n bytes to bytes type cassette file 'name' starting at
; address m.
;

L193C:  DEFM    "BSAV"                  ; 'name field'
        DEFB    'E' + $80

        DEFW    L1933                   ; 'link field'

L1943:  DEFB    $05                     ; 'name length field'

L1944:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L1946:  DEFW    L1A3D                   ; prep_header
        DEFW    L1A4F                   ; prep some sort of header?
        DEFW    L04B6                   ; exit


; ----------------
; THE 'BLOAD' WORD
; ----------------
; BLOAD name
; (m, n -- )
; Load at most n bytes of bytes type cassette file 'name' starting at
; address m. ERROR 10 if the file has more than m bytes.
;
L194C:  DEFM    "BLOA"                  ; 'name field'
        DEFB    'D' + $80

        DEFW    L1943                   ; 'link field'

L1953:  DEFB    $05                     ; 'name length field'

L1954:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

        DEFW    L1A3D                   ; prep_header
        DEFW    L1A74                   ; ld-bytes??
        DEFW    L1AB8                   ; tapeFF
        DEFW    L04B6                   ; exit

; -----------------
; THE 'VERIFY' WORD
; -----------------
; VERIFY name
; (  --  )
; Verifies dictionary on tape against dictionary in RAM.

L195E:  DEFM    "VERIF"                 ; 'name field'
        DEFB    'Y' + $80

        DEFW    L1953                   ; 'link field'

L1966:  DEFB    $06                     ; 'name length field'

L1967:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L1969:  DEFW    L1A10                   ; word to pad
        DEFW    L1271                   ; branch
L196D:  DEFW    $000F                   ; 15 bytes forward to L197D


; ------------------
; THE 'BVERIFY' WORD
; ------------------
; BVERIFY name
; (m, n -- )
; Verify at most n bytes of bytes type cassette file 'name' against
; RAM starting at address m. ERROR 10 if the file has more than m bytes.
; For BLOAD and BVERIFY, if m = 0, then starts at the address the bytes
; were saved from. If n = 0, then doesn't care about the length.
;

L196F:  DEFM    "BVERIF"                ; 'name field'
        DEFB    'Y' + $80

        DEFW    L1966                   ; 'link field'

L1978:  DEFB    $07                     ; 'name length field'

L1979:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L197B:  DEFW    L1A3D                   ; prep_header

; ->

L197D:  DEFW    L1A74                   ; ld_bytes
        DEFW    L1ABE                   ; tape00
        DEFW    L04B6                   ; exit

; ---------------
; THE 'LOAD' WORD
; ---------------
; LOAD name
; (  --  )
; Searches for a dictionary cassette file 'name' and loads it in, adding it
; to end of old dictionary. Writes to the screen all files found on tape.
; For best results turn the tone control on the tape recorder right down
; (as bass as possible) and the volume control to about three-quarters
; maximum.

L1983:  DEFM    "LOA"                   ; 'name field'
        DEFB    'D' + $80

        DEFW    L1978                   ; 'link field'

L1989:  DEFB    $04                     ; 'name length field'

L198A:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L198C:  DEFW    L1A10                   ; word to pad

        DEFW    L1A0E                   ; end-forth.

        LD      HL,($3C37)              ; STKBOT
        LD      ($230E),HL
        EX      DE,HL
        LD      HL,$FFCC
        ADD     HL,SP
        AND     A
        SBC     HL,DE
        LD      ($230C),HL

        CALL    L04B9                   ; forth

L19A4:  DEFW    L1A74                   ; ld_bytes
        DEFW    L1AB8                   ; tapeFF
        DEFW    L1A0E                   ; end-forth.

        LD      BC,($3C37)              ; STKBOT
        LD      HL,$3C50
        LD      ($2701),HL
        INC     HL
        LD      ($2709),HL
        LD      HL,($2325)
        ADD     HL,BC
        LD      ($3C37),HL              ; STKBOT
        LD      HL,$C3AF
        ADD     HL,BC
        LD      ($270B),HL
        LD      DE,($2329)
        ADD     HL,DE
        LD      DE,($3C4C)
        LD      ($3C4C),HL
        PUSH    BC
        PUSH    DE


L19D4:  LD      ($270D),SP
        CALL    L1504                   ;
        POP     BC
        POP     HL
L19DD:  BIT     7,(HL)
        INC     HL
        JR      Z,L19DD                 ;
        INC     HL
        INC     HL
        LD      (HL),C
        INC     HL
        LD      (HL),B
        LD      HL,($3C37)              ; STKBOT
        LD      BC,$000C                ; allow twelve bytes for underflow.
        ADD     HL,BC
        LD      ($3C3B),HL              ; SPARE
        JP      (IY)                    ; to 'next'.

; ---

L19F3:  DEFW    L0EC3                   ; 'code field' - docolon
        DEFW    L104B                   ; stk_data
        DEFB    $20                     ; a space delimiter
        DEFW    L05AB                   ; word          (to pad)
        DEFW    L1A0E                   ; end-forth.

; ---

L19FC:  CALL    L0F2E                   ; blank stack

L19FF:  RST     18H                     ; pop word DE

        LD      A,$20                   ;
        LD      (DE),A                  ;
        LD      DE,$270C                ;
        LD      HL,$27FF                ;

        CALL    L07FA                   ; routine SPACE_FILL

        JP      (IY)                    ; to 'next'.

; ---


L1A0E:  DEFW    L18FB                   ; location of RET instruction.

; ---

L1A10:  DEFW    L0EC3                   ; 'code field' - docolon
        DEFW    L19F3                   ; word to pad
        DEFW    L1A0E                   ; end-forth.

        XOR     A                       ;
        LD      ($2301),A               ;
        LD      HL,$3C51                ;
        LD      ($230E),HL              ;
        EX      DE,HL                   ;
        LD      HL,($3C37)              ; STKBOT
        AND     A                       ;
        SBC     HL,DE
        LD      ($230C),HL
        LD      HL,($3C4C)
        LD      ($2310),HL
        LD      HL,$3C31                ; CURRENT
        LD      DE,$2312
        LD      BC,$0008                ;

        LDIR                            ;

        JP      (IY)                    ; to 'next'.

; ---


L1A3D:  DEFW    L0EC3                   ; 'code field' - docolon
        DEFW    L19F3                   ; word to pad
        DEFW    L1011                   ; stack next word
        DEFW    $230C                   ; header location
        DEFW    L08C1                   ; !     store int at address
        DEFW    L1011                   ; stack next word
        DEFW    $230E                   ; header location
        DEFW    L08C1                   ; !     store int at address
        DEFW    L04B6                   ; exit

; ---

L1A4F:  DEFW    L1A51

L1A51:  LD      A,($2302)               ; length of word in pad
        AND     A
        JR      Z,L1AB6                 ; forward if null.

        LD      HL,($230C)
        LD      A,H
        OR      L
        JR      Z,L1AB6                 ;

        PUSH    HL
        LD      DE,$0019                ;
        LD      HL,$2301                ; pad using ROM priority
        LD      C,D                     ;

        CALL    L1820                   ;

        POP     DE
        LD      HL,($230E)              ;
        LD      C,$FF

        CALL    L1820                   ;

        JP      (IY)                    ; to 'next'.

; ---
; ld_bytes
; ---

L1A74:  DEFW    L1A76

L1A76:  LD      DE,$0019
        LD      HL,$231A
        LD      C,D

        SCF

        CALL    L18A7                   ;

        JR      NC,L1A76                ; loop back until read

        LD      DE,$231A
        LD      A,(DE)
        AND     A
        JR      NZ,L1A95                ;

        CALL    L1808                   ; pr_inline

; ---

L1A8D:  DEFB    $0D                     ; newline
        DEFM    "Dict"
        DEFB    ':' + $80               ;

L1A93:  JR      L1A9F                   ;

; ---

L1A95:  CALL    L1808                   ; pr_inline

L1A98:  DEFB    $0D                     ; newline

        DEFM    "Bytes"
        DEFB    ':' + $80               ;

; ---

L1A9F:  LD      HL,$2301
        LD      BC,$0B0B
        JR      L1AA9                   ;

; ---

L1AA7:  LD      A,(DE)
        RST     08H                     ; print_ch

L1AA9:  LD      A,(DE)
        CP      (HL)
        JR      NZ,L1AAE                ;
        DEC     C

L1AAE:  INC     HL
        INC     DE
        DJNZ    L1AA7                   ;

        JR      NZ,L1A76                ;
        JP      (IY)                    ; to 'next'.

; ---

L1AB6:  RST     20H                     ; Error 10
        DEFB    $0A                     ; Tape error

; ---
;
; ---

L1AB8:  DEFW    L1ABA                   ; headerless 'code field'

L1ABA:  LD      B,$FF
        JR      L1AD0                   ; forward to +->

; ---
;
; ---

L1ABE:  DEFW    L1AC0                   ; headerless 'code field'

L1AC0:  LD      HL,$2312
        LD      DE,$232B
        LD      B,$08

L1AC8:  LD      A,(DE)
        INC     DE
        CP      (HL)
        INC     HL
        JR      NZ,L1AB6                ; back to tape error

        DJNZ    L1AC8                   ; back for all 8

; common code - B is $00 from above or $FF from previous.

L1AD0:  LD      HL,($230C)
        LD      DE,($2325)
        LD      A,H
        OR      L
        JR      Z,L1ADF                 ; skip if zero

        SBC     HL,DE
        JR      C,L1AB6                 ; back to tape error

L1ADF:  LD      HL,($230E)
        LD      A,H
        OR      L
        JR      NZ,L1AE9                ; skip if zero
        LD      HL,($2327)

L1AE9:  LD      C,$FF
        RR      B

        CALL    L18A7                   ;

        JR      NC,L1AB6                ; back to report tape error

        JP      (IY)                    ; to 'next'.

; ==========================================================
; THE 'FLOATING POINT ARITHMETIC' ROUTINES
; ==========================================================

; ---------------------
; THE 'PREP_FP' ROUTINE
; ---------------------
; ( f1, f2 -- m1, m2 )
; -> from add/mult/div
; Entered with two floating point numbers on the stack.
; The exponents are stored in the first two bytes of FP_WS and the third byte
; is loaded with the manipulated result sign.
; the two exponent locations on the Data Stack are blanked leaving just the
; binary coded mantissas.

; Begin by clearing the first part of the workspace.

L1AF4:  LD      BC,$3C0F                ; byte 15 of the 19 bytes at FP_WS

        XOR     A                       ; clear accumulator.

L1AF8:  LD      (BC),A                  ; clear the workspace.
        DEC     C                       ; decrement low byte of address.
        JR      NZ,L1AF8                ; and back until at $3C00

;

        LD      HL,($3C3B)              ; fetch end of data stack+1 from SPARE.
        LD      DE,$FFFC                ; prepare  -4

        DEC     HL                      ; point to last byte of stack.
        LD      C,(HL)                  ; sign/exponent of (f2) to C.
        LD      (HL),A                  ; replace with zero to take overflow.

        ADD     HL,DE                   ; subtract four from address

; update system variable SPARE - this could be deferred.

        INC     HL                      ; point to location after (f1).
        LD      ($3C3B),HL              ; update system variable SPARE
        DEC     HL                      ; point to exponent of (f1)

        LD      B,(HL)                  ; sign/exponent of (f1) to B.
        LD      (HL),A                  ; replace with zero.

; At this stage we have the sign/exponent of (f1) in B and the sign/exponent
; of (f2) in C. The next section places the sign bit of (f1) in but 7 of A
; and the sign bit of (f2) in bit 6 of A. The other bits are of no importance.

        LD      A,C                     ; transfer C to A.
        RRCA                            ; rotate sign bit to bit 6.
        XOR     B                       ; XOR B
        AND     $7F                     ; mask off bits to restore
        XOR     B                       ; bit 6 as it was, bit 7 of B to A.

L1B13   LD      ($3C02),A               ; FP_WS_02             see L1C2F

        RES     7,B                     ; make both numbers
        RES     7,C                     ; positive

        LD      ($3C00),BC              ; store the exponents at start of FP_WS

        INC     HL                      ; point to (f2) again.
        EX      DE,HL                   ; transfer f2 pointer to DE, HL now -4
        ADD     HL,DE                   ; subtract four to point HL at (f1)
        RET                             ; return.

; On exit, HL -> (f1), DE -> (f2), B = exponent of (f1), C = exponent of (f2).

; -----------------------------
; THE 'SHIFT_ADDEND' SUBROUTINE
; -----------------------------

L1B22:  LD      A,$09
        CP      B
        JR      NC,L1B28                ;

        LD      B,A                     ; set shift counter to nine. i.e clear.

L1B28:  LD      C,$04                   ; four bytes
        INC     HL
        INC     HL
        INC     HL                      ; point to highest byte

        XOR     A                       ; prepare to start with a blank nibble.

L1B2E:  RRD                             ; A=0000 XXXX --> 7654->3210 =(HL)
                                        ;          \_____<-______/

        DEC     HL                      ; point to next lower byte on Data Stack
        DEC     C                       ; decrement the byte counter.
        JR      NZ,L1B2E                ; loop for all 4 bytes = 1 nibble shift

        INC     HL                      ; set pointer to start of number again
        DJNZ    L1B28                   ; decrement the shift counter and loop.

        ADD     A,$FB                   ; add minus five to last nibble lost
                                        ; will set the carry flag if 5 or more.

        PUSH    HL                      ;; preserve pointer to start of addend.

L1B3A:  LD      A,(HL)                  ; fetch the pair of BCD nibbles.

        ADC     A,B                     ; increment if carry set (B = 0)
        DAA                             ; Decimal Adjust Accumulator
                                        ; ($99 becomes $00 with carry set).

        LD      (HL),A                  ; put nibbles back.
        INC     HL                      ; point to next significant pair of
                                        ; binary coded decimal digits.
        JR      C,L1B3A                 ; and ripple any rounding through.

        POP     HL                      ;; retrieve the pointer to start.
        RET                             ; return.

; ---------------------------
; THE 'BCD NEGATE' SUBROUTINE
; ---------------------------
; Negates the four byte, 8 nibble, binary coded decimal on the Data Stack.
; For example -123.456
; is prepared as $00 $12 $34 $56
; and negated as $99 $87 $65 $34

L1B43:  PUSH    BC                      ; preserve the two
        PUSH    HL                      ; main registers used.

        LD      B,$04                   ; set byte counter to four.
        AND     A                       ; clear carry.

L1B48:  LD      A,$00                   ; set to zero without disturbing carry.

        SBC     A,(HL)                  ; subtract pair of digits
        DAA                             ; Decimal Adjust Accumulator
                                        ; adjusts as if from 100 setting carry

        LD      (HL),A                  ; place adjusted decimals back.

        INC     HL                      ; next location on Data Stack.

        DJNZ    L1B48                   ; loop for all 4 bytes.

        POP     HL                      ; restore the
        POP     BC                      ; saved registers.

        RET                             ; return.

; ------------------------------
; THE 'BCD OPERATION' SUBROUTINE
; ------------------------------
; This versatile routine performs the binary coded decimal addition of
; two floating point values with C = 1.
; The second entry point is used in multiplication.

; ->
L1B53:  LD      C,$01                   ; signal the operation is addition.

; -> (with c!=0)
L1B55:  PUSH    HL                      ; preserve the
        PUSH    DE                      ; three main
        PUSH    BC                      ; registers.

        LD      A,C                     ; treat C as a binary coded decimal.
        AND     $0F                     ; isolate the right-hand nibble.
        LD      B,A                     ; transfer R.H. nibble to B

        XOR     C                       ; A now has L.H. nibble.
        LD      C,A                     ; place in C.

; this next magical routine converts the two BCD digits to binary.
; imagine we started with ninety-nine so C = 1001 0000  and B = 0000 1001

        RRCA                            ;    0100 1000
        RRCA                            ;    0010 0100
        ADD     A,C                     ;    1011 0100
        RRCA                            ;    0101 1010
        ADD     A,B                     ;    0110 0011  = 99 binary

        LD      C,A                     ;    binary multiplier in C

; note that for simple addition C is unchanged and still contains 1.

        LD      B,$04                   ; four bytes to consider
        XOR     A                       ; clear accumulator ensuring no initial
                                        ; carry is fed into the loop.

; loop

L1B67:  PUSH    BC                      ; push the counters.
        PUSH    DE                      ; push the (f2) pointer

        PUSH    HL                      ; push the (f1) pointer.

        ADD     A,(HL)                  ; add any running carry to (f1) cell.

        DAA                             ; Decimal Adjust Accumulator
                                        ; possibly setting carry.

        LD      L,A                     ; result to L
        LD      A,(DE)                  ; fetch (f2) cell value.
        LD      H,$00                   ; set high bytes H and D to
        LD      D,H                     ; zero without disturbing carry

        RL      H                       ; now pick up any carry in H.

        AND     A                       ; test (f2) cell value.
        JR      Z,L1B91                 ; skip forward to just store the carry
                                        ; result if the addend value is zero.

        LD      E,A                     ; else DE now holds cell value.

L1B77:  SRL     C                       ; shift counter C   0->76543210->C

        JR      NC,L1B83                ; skip addition if no carry.

; else perform HL=HL+DE in BCD.

        LD      A,L                     ; fetch low byte of (f1) cell.
        ADD     A,E                     ; add to low byte of (f2) cell.
        DAA                             ; DAA.
        LD      L,A                     ; result in L and carry.

        LD      A,H                     ; fetch high byte possibly 1 from carry
        ADC     A,D                     ; add in any carry from above (D=0)
        DAA                             ; comes into play with multiplication.
        LD      H,A                     ; result to H.

L1B83:  INC     C                       ; test the counter for zero.
        DEC     C                       ; (will be if addition)
        JR      Z,L1B91                 ; forward when zero ->

; else is BCD multiplication - double the DE value.

        LD      A,E                     ;
        ADD     A,A                     ;
        DAA                             ;
        LD      E,A                     ;

        LD      A,D                     ;
        ADC     A,A                     ;
        DAA                             ;
        LD      D,A                     ;

        JR      L1B77                   ; back to continue multiplying by C.

; ---

; ->
L1B91:  EX      DE,HL                   ; transfer result to DE.

        POP     HL                      ; pop (f1) cell pointer
        LD      (HL),E                  ; insert result.
        LD      A,D                     ; transfer any carry to A
        POP     DE                      ; pop the (f2) pointer
        POP     BC                      ; pop the counter, and initial C value.

        INC     DE                      ; increment (f2) cell pointer.
        INC     HL                      ; increment (f1) cell pointer.

        DJNZ    L1B67                   ; loop back for all 4 bytes.

        POP     BC                      ; restore the
        POP     DE                      ; three main
        POP     HL                      ; registers.

        RET                             ; return.

; -------------
; THE 'F-' WORD
; -------------
; ( f1, f2 -- f1-f2 )
; Subtracts top two floating point numbers.
;
; just flip the sign and then do floating point addition.

L1B9F:  DEFB    'F'                     ; 'name field'
        DEFB    '-' + $80

        DEFW    L1989                   ; 'link field'

L1BA3:  DEFB    $02                     ; 'name length field'

L1BA4:  DEFW    L0EC3                   ; 'code field' - docolon

; ---

L1BA6:  DEFW    L1D0F                   ; fnegate
        DEFW    L1A0E                   ; end-forth.

        JR      L1BB3                   ; forward to floating point addition.

; -------------
; THE 'F+' WORD
; -------------
; ( f1, f2 -- f1+f2 )
; Adds top two floating point numbers.

L1BAC:  DEFB    'F'                     ; 'name field'
        DEFB    '+' + $80

        DEFW    L1BA3                   ; 'link field'

L1BB0:  DEFB    $02                     ; 'name length field'

L1BB1:  DEFW    L1BB3                   ; 'code field'

; ---

L1BB3:  CALL    L1AF4                   ; PREP_FP

        LD      A,C                     ; take exponent of second number (f2).
        SUB     B                       ; subtract exponent of first (f1).
        PUSH    AF                      ; save result flags.

        JR      NC,L1BC1                ; forward if second number >= first.

        EX      DE,HL                   ; else swap the pointers.
        NEG                             ; negate negative result.
        LD      (IX+$00),B              ; place B in FP_WS_0  (was C).

L1BC1:  LD      B,A                     ; put positive subtraction result in B.

        CALL    NZ,L1B22                ; routine SHIFT_ADDEND aligns digits if
                                        ; exponents are not equal.

        POP     AF                      ; retrieve subtraction result flags.
        JR      NC,L1BC9                ; forward is second number was >= first.

        EX      DE,HL                   ; else switch the pointers back.

L1BC9:  LD      B,$02                   ; two floating point numbers to consider

        LD      C,(IX+$02)              ; FP_WS_02

L1BCE:  RL      C                       ; test sign bit first bit 7 then bit 6.

        CALL    C,L1B43                 ; routine BCD neg if carry

        EX      DE,HL                   ; switch number pointers.

        DJNZ    L1BCE                   ; decrement counter and loop if second
                                        ; number still to do.

        CALL    L1B53                   ; the BCD ADDITION routine.

; The routine preserves main registers so HL->(f1), DE->(f2) and B is zero.

        DEC     DE                      ; point to highest byte of result which
                                        ; could be $99 if one negative number
                                        ; involved or $98 if two negatives.

        LD      A,(DE)                  ; fetch the result sign byte.
        ADD     A,$68                   ; add $68 causing carry if negative.
        RR      B                       ; pick up carry in bit 7 of B, which
                                        ; was zero so zero flag now set if none.

        LD      (IX+$02),B              ; place result sign in  FP_WS_02

        CALL    NZ,L1B43                ; routine BCD_NEGATE if negative result.

; if the

L1BE5:  LD      A,(DE)                  ;
        AND     A                       ;

        JR      NZ,L1C02                ;

; else A is zero.

        DEC     (IX+$00)                ; decrement the result exponent FP_WS_00
        DEC     (IX+$00)                ; as two nibbles will be moved at a time

        PUSH    DE                      ; save pointer to 4th byte

        LD      H,D                     ; make HL
        LD      L,E                     ; equal to DE
        DEC     HL                      ; minus one.

        LD      BC,$03FF                ; counter for three bytes. The $FF
                                        ; value ensures B is not affected by
                                        ; the LDD instruction. Also A is 0.

L1BF6:  OR      (HL)                    ; (detects if the three bytes are zero)

        LDD                             ; copy HL contents one location higher
                                        ; to that addressed by DE. Also dec bc.

        DJNZ    L1BF6                   ; repeat for all 3 bytes

        EX      DE,HL                   ; make HL address lowest location
        LD      (HL),B                  ; and insert a zero into vacated byte.

        POP     DE                      ; restore the pointer to the 4th byte.

        JR      NZ,L1BE5                ; jump back to the end test if something
                                        ; was being shifted through.

; else all four bytes are zero - i.e. the result of the addition is zero.

        JP      (IY)                    ; to 'next'.

; ---

; The branch was to here, from the end test above, when the 4th byte had been
; filled.
; Before joining common code, ensure that the initial block move will be
; ineffective.

L1C02:  LD      D,H                     ; make DE the same as HL - the source
        LD      E,L                     ; and the destination are the same.

; -> common code from mult and above.

L1C04:  PUSH    DE                      ; save start location.

        LD      BC,$0004                ; 4 bytes to consider.
        LDIR                            ; block move sets DE to one past dest.

        POP     HL                      ; restore start of source.

        DEC     DE                      ; DE now addresses 4th byte.

L1C0C:  LD      A,(DE)                  ; load the 4th byte to accumulator.
        AND     A                       ; test for zero.

        JR      Z,L1C21                 ; skip forward if so.

        CP      $10                     ; test if one or two nibbles populated
                                        ; setting carry for a single nibble.

        SBC     A,A                     ; $00 for two nibbles, $FF for one.
        INC     A                       ; $01                  $00
        INC     A                       ; $02 for two nibbles, $01 for one :-)

        LD      B,A                     ; nibble count to B.
        ADD     A,(IX+$00)              ; add count to FP_WS_00 the result
        LD      ($3C00),A               ; exponent and place back in FP_WS_00.

        CALL    L1B22                   ; routine 'shift_addend' moves all the
                                        ; nibbles to the right.

        JR      L1C0C                   ; back to pick up byte and then to
                                        ; next routine.

; ---

; now test for a result that is too large or too small.
; Note. these results may have arisen from multiplication or addition.

L1C21:  LD      A,($3C00)               ; fetch result exponent from FP_WS_00

        DEC     A                       ; decrement?
        CP      $BF                     ; compare lower limit
        INC     A                       ; increment?

        JR      NC,L1C3D                ; forward if less to ZERO_RSLT

        CP      $80                     ; compare upper limit
        JR      NC,L1C3B                ; forward to Error 8 - Overflow

        LD      B,A                     ; save unsigned exponent in B.

; now combine result sign and the exponent.
; for addition then FP_WS_02 contains either $80 or $00 and most of what
; follows does not apply.
; for multiplication then bit 7 is sign of (f1) bit 6 is sign of (f2).

L1C2F   LD      A,($3C02)               ; FP_WS_02           see L1B13

        LD      C,A                     ; save a copy in C
        RLA                             ; rotate bit 6 to 7
        XOR     C                       ; XOR bit 7 - minus * minus = a plus.
        AND     $80                     ; only interested in bit 7.
        XOR     B                       ; combine with exponent.
        LD      (DE),A                  ; and place in sign/exp on Data Stack.

        JP      (IY)                    ; to 'next'.

; ---

L1C3B:  RST     20H                     ; Error 8.
        DEFB    $08                     ; Overflow in floating-point arithmetic.

; ------------------------------------
; THE 'ZERO RESULT' TERMINATING BRANCH
; ------------------------------------

L1C3D:  LD      BC,$0400                ; count 4 bytes, fill byte is zero.

L1C40:  LD      (HL),C                  ; insert a zero.
        INC     HL                      ; next location.
        DJNZ    L1C40                   ; repeat for all 4 bytes.

        JP      (IY)                    ; to 'next'.




; -------------
; THE 'F*' WORD
; -------------
; (f1, f2 -- f1*f2)
; Multiplies top two floating point numbers and leaves result on the stack.

L1C46:  DEFB    'F'                     ; 'name field'
        DEFB    '*' + $80

        DEFW    L1BB0                   ; 'link field'

L1C4A:  DEFB    $02                     ; 'name length field'

L1C4B:  DEFW    L1C4D                   ; 'code field'

; ---

L1C4D:  CALL    L1AF4                   ; routine PREP_FP prepares the two
                                        ; numbers on the Data Stack placing the
                                        ; exponents and signs in FP_WS.

        XOR     A                       ; set accumulator to zero.
        CP      B                       ; compare to exponent of (f1).
        SBC     A,A                     ; $00 if zero or $FF
        AND     C                       ; combine with exponent of (f2).

        JR      Z,L1C3D                 ; back if zero to exit via ZERO_RSLT.

        PUSH    HL                      ; save pointer to first number - result.

        LD      BC,$3C02                ; set BC to location before free
                                        ; workspace set to zero by PREP_FP.

        PUSH    BC                      ; push onto machine stack.

        LD      B,$03                   ; count three bytes - six nibbles.

L1C5D:  LD      C,(HL)                  ; fetch BCD pair to C
        INC     HL                      ; address more significant pair.

        EX      (SP),HL                 ; Data Stack pointer to machine stack,
                                        ; workspace pointer to HL.
        INC     HL                      ; increment workspace pointer.

        CALL    L1B55                   ; routine BCD_OP multiplies C by each
                                        ; of the 4 bytes of (f2) laying the
                                        ; result down in workspace at HL

        EX      (SP),HL                 ; swap in multiplier pointer to HL,
                                        ; workspace pointer to machine stack.

        DJNZ    L1C5D                   ; repeat for all three bytes.

        LD      BC,($3C00)              ; fetch raw exponents from FP_WS_00/01
        LD      A,B                     ; add the exponents
        ADD     A,C                     ; together.

        SUB     $42                     ; adjust for sign

        LD      ($3C00),A               ; put the result back in FP_WS_00.

        POP     HL                      ; pop workspace pointer to HL.
        POP     DE                      ; pop result pointer to DE.

        JR      L1C04                   ; back to common code to copy the 4
                                        ; bytes from the workspace to the
                                        ; Data Stack and then set exponent
                                        ; and sign.

; -------------
; THE 'F/' WORD
; -------------
; ( f1, f2 -- f1/f2 )
; Divides two floating point numbers.

L1C76:  DEFB    'F'                     ; 'name field'
        DEFB    '/' + $80

        DEFW    L1C4A                   ; 'link field'

L1C7A:  DEFB    $02                     ; 'name length field'

L1C7B:  DEFW    L1C7D                   ; 'code field'

;---

L1C7D:  CALL    L1AF4                   ; routine PREP_FP prepares the two
                                        ; numbers (f1) and (f2) placing the
                                        ; raw exponents in the first two
                                        ; locations of workspace, the signs in
                                        ; the next location and clearing the
                                        ; sixteen remaining locations.
                                        ; This must be the one that uses them
                                        ; all.

        XOR     A                       ; set accumulator to zero.
        CP      B                       ; compare to exponent of dividend (f1).
        JR      Z,L1C3D                 ; forward if zero to ZERO_RSLT.

        CP      C                       ; compare to exponent of divisor (f2).
        JR      Z,L1C3B                 ; back if zero to Error 8 - Overflow.
                                        ; division by zero.

; HL points to first number on stack, DE to second.

        INC     DE                      ;
        INC     DE                      ;
        LD      A,(DE)                  ; get first two digits to A
        DEC     DE                      ;
        DEC     DE                      ; back to first

        ADD     A,$01                   ; add one (e.g. 99 would give 9A)
        DAA                             ; adjust  (e.g. $9A would be $00 carry)
        EX      AF,AF'                  ; save the flags
        EX      DE,HL                   ; HL now points to divisor

        CALL    L1B43                   ; routine BCD negate the divisor

        EX      DE,HL                   ; point back again.
        PUSH    HL                      ; save pointer to first - the result.

        LD      DE,$3C10                ; destination FP_WS_10
        LD      BC,$0004                ; four bytes

        LDIR                            ; copy to end of FP_WS
                                        ; (+ one byte of list_ws)

        EX      DE,HL                   ; HL points to last cell plus one.
        DEC     HL                      ; Now points to last byte copied.

        LD      B,$05                   ; count 5.

; loop

L1CA2:  PUSH    DE                      ;
        LD      A,(HL)                  ;
        DEC     HL                      ;
        LD      E,(HL)                  ;

        EX      AF,AF'                  ;
        LD      C,A                     ;
        EX      AF,AF'                  ;

        INC     C                       ;
        DEC     C                       ;
        JR      NZ,L1CB0                ;

        LD      E,A                     ;
        JR      L1CCB                   ;

; ---

L1CB0:  PUSH    BC                      ;
        LD      B,$02                   ;

L1CB3:  LD      D,$10                   ;

L1CB5:  SLA     E                       ;
        RLA                             ;
        RL      D                       ;
        JR      NC,L1CB5                ;

        INC     D                       ;

L1CBD:  SUB     C                       ;
        DAA                             ;
        INC     E                       ;
        JR      NC,L1CBD                ;

        DEC     D                       ;
        JR      NZ,L1CBD                ;

        ADD     A,C                     ;
        DAA                             ;
        DEC     E                       ;
        DJNZ    L1CB3                   ;

        POP     BC                      ;

L1CCB:  LD      C,E                     ;
        POP     DE                      ;
        INC     C                       ;
        DEC     C                       ;
        JR      Z,L1CE8                 ;

        PUSH    HL                      ;
        DEC     HL                      ;
        DEC     HL                      ;

        CALL    L1B55                   ; bcd_op mult

        PUSH    DE                      ;

        LD      DE,$FFFB                ; -4
        ADD     HL,DE                   ;

        LD      DE,$3C03                ; FP_WS_03
        LD      A,C                     ;
        LD      (DE),A                  ;

        CALL    L1B53                   ; bcd_op add

        POP     DE                      ;
        POP     HL                      ;
        INC     HL                      ;
        INC     B                       ;

L1CE8:  DJNZ    L1CA2                   ;

        LD      HL,($3C00)              ; FP_WS
        LD      A,H                     ;
        SUB     L                       ;
        ADD     A,$40                   ;

        LD      HL,$3C08                ; FP_WS
        LD      B,A                     ;
        LD      A,($3C0B)               ;
        AND     A                       ;
        JR      NZ,L1CFE                ;

        DEC     B                       ;
        DEC     B                       ;
        DEC     HL                      ;

L1CFE:  LD      (IX+$00),B              ;

        POP     DE                      ;

        JP      L1C04                   ; back to common code to copy the 4
                                        ; bytes from the workspace to the
                                        ; Data Stack and then set exponent
                                        ; and sign.

; ------------------
; THE 'FNEGATE' WORD
; ------------------
; ( f -- -f )
; Floating point negation.
; Toggle the sign bit unless the number is zero (four zero bytes).

L1D05:  DEFM    "FNEGAT"                ; 'name field'
        DEFB    'E' + $80

        DEFW    L1C7A                   ; 'link field'

L1D0E:  DEFB    $07                     ; 'name length field'

L1D0F:  DEFW    L1D11                   ; 'code field'

; ---

L1D11:  RST     18H                     ; pop word from data stack to DE.

        LD      A,D                     ; exponent byte to A.
        AND     A                       ; test for zero.
        JR      Z,L1D18                 ; forward if so to leave undisturbed.

        XOR     $80                     ; else toggle the sign bit

L1D18:  LD      D,A                     ; exponent byte to D.
        RST     10H                     ; push word DE on data stack.

        JP      (IY)                    ; to 'next'.

; --------------
; THE 'INT' WORD
; --------------
; (f -- n)
; Converts signed floating point number to signed single length integer.
; Truncates towards zero.
; Result in range -32768 to 32767

L1D1C:  DEFM    "IN"                    ; 'name field'
        DEFB    'T' + $80

        DEFW    L1D0E                   ; 'link field'

L1D21:  DEFB    $03                     ; 'name length field'

L1D22:  DEFW    L1D24                   ; 'code field'

; ---

L1D24:  LD      HL,($3C3B)              ; fetch value from SPARE.
        DEC     HL                      ; now points to end of data stack.

        LD      DE,$0000                ; initialize 16-bit result.

L1D2B:  LD      A,(HL)                  ; fetch the exponent byte.

        RLCA                            ; double exponent moving sign bit to 0.

        CP      $82                     ; compare exponent to plus 1.
        JR      C,L1D45                 ; forward if number is smaller than 1
                                        ; to return the result DE.

; else the number is >= 1.0

        XOR     A                       ; clear accumulator.
        DEC     HL                      ; point to the first pair of BCD digits.

        CALL    L0732                   ; call shift_fp

        INC     HL                      ; point to exponent.

        EX      DE,HL                   ; pointer to DE, integer to HL.

; before adding in the nibble from the mantissa, multiply any previous result
; by ten.

        LD      B,H                     ; make a copy of HL in BC.
        LD      C,L                     ;

        ADD     HL,HL                   ; * 2
        ADD     HL,HL                   ; * 4
        ADD     HL,BC                   ; * 5
        ADD     HL,HL                   ; * 10

        LD      C,A                     ; leftmost nibble from mantissa to C.
        LD      B,$00                   ; prepare to add just the nibble.
        ADD     HL,BC                   ; add into the result.
        EX      DE,HL                   ; switch back to DE

        JR      L1D2B                   ; back to loop.

; ---

L1D45:  DEC     HL                      ; skip redundant components of Floating
        DEC     HL                      ; Point number addressing the
                                        ; lower two bytes on the data stack.
        LD      (HL),D                  ; insert high-order byte first.
        DEC     HL                      ; point to location beneath.
        LD      (HL),E                  ; insert low-order byte.

        LD      DE,L0D94                ; 'pos' addr.

        JP      L04BF                   ; exit via 'pos' routine.

; -----------------
; THE 'UFLOAT' WORD
; -----------------
; (un -- f)
; Converts unsigned single length integer to floating point.
; e.g. 65535 16 bit number converted to  32-bit float 8-bit sign/exponent
; 6-nibble BCD mantissa.    $45  6 5 5 3 5 0

L1D50:  DEFM    "UFLOA"                 ; 'name field'
        DEFB    'T' +$80

        DEFW    L1D21                   ; 'link field'

L1D58:  DEFB    $06                     ; 'name length field'

L1D59:  DEFW    L1D5B                   ; 'code field'

; ---

L1D5B:  RST     18H                     ; pop word off stack to DE
        EX      DE,HL                   ; now HL

        LD      BC,$1000                ; count 16 bits, set C to zero.
        LD      D,C
        LD      E,C                     ; initialize DE to zero.

L1D62:  ADD     HL,HL                   ; double

        LD      A,E                     ;
        ADC     A,A                     ; add carry to low byte
        DAA                             ; adjust
        LD      E,A                     ;

        LD      A,D                     ;
        ADC     A,A                     ; add carry to high byte
        DAA                             ; adjust
        LD      D,A                     ;

        RL      C                       ; pick up overflow
        DJNZ    L1D62                   ; loop  back for 16 bits

        RST     10H                     ; DE to Data stack.

        LD      D,$46                   ; exponent byte   +6
        LD      E,C                     ; low byte

        RST     10H                     ; higher word of float to stack.

        DEC     HL                      ; point to
        DEC     HL                      ; lower on stack

        CALL    L0740                   ; normalize routine.

        JP      (IY)                    ; to 'next'.

; -------------------
; THE 'CHARACTER SET'
; -------------------
; The 96 ASCII character bitmaps are copied to RAM during initialization and
; the 8x8 characters can afterwards be redefined by the user.
; Some ROM space is saved by supplying the blank top line of most characters
; and in case of the middle range (capitals with no descenders) the bottom
; line as well. Only the final copyright symbol is held in ROM as an 8x8
; character.


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

L1D7B:  DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000

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

        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00000000
        DEFB    %00010000
        DEFB    %00000000

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

        DEFB    %00100100
        DEFB    %00100100
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000

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

        DEFB    %00100100
        DEFB    %01111110
        DEFB    %00100100
        DEFB    %00100100
        DEFB    %01111110
        DEFB    %00100100
        DEFB    %00000000

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

        DEFB    %00001000
        DEFB    %00111110
        DEFB    %00101000
        DEFB    %00111110
        DEFB    %00001010
        DEFB    %00111110
        DEFB    %00001000

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

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

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

        DEFB    %00010000
        DEFB    %00101000
        DEFB    %00010000
        DEFB    %00101010
        DEFB    %01000100
        DEFB    %00111010
        DEFB    %00000000

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

        DEFB    %00001000
        DEFB    %00010000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000

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

        DEFB    %00000100
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00000100
        DEFB    %00000000

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

        DEFB    %00100000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00100000
        DEFB    %00000000

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

        DEFB    %00000000
        DEFB    %00010100
        DEFB    %00001000
        DEFB    %00111110
        DEFB    %00001000
        DEFB    %00010100
        DEFB    %00000000

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

        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    %00001000
        DEFB    %00001000
        DEFB    %00010000

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

        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    %00011000
        DEFB    %00011000
        DEFB    %00000000

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

        DEFB    %00000000
        DEFB    %00000010
        DEFB    %00000100
        DEFB    %00001000
        DEFB    %00010000
        DEFB    %00100000
        DEFB    %00000000

; $30 - Character: '0'          CHR$(48)

        DEFB    %00111100
        DEFB    %01000110
        DEFB    %01001010
        DEFB    %01010010
        DEFB    %01100010
        DEFB    %00111100
        DEFB    %00000000

; $31 - Character: '1'          CHR$(49)

        DEFB    %00011000
        DEFB    %00101000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00111110
        DEFB    %00000000

; $32 - Character: '2'          CHR$(50)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %00000010
        DEFB    %00111100
        DEFB    %01000000
        DEFB    %01111110
        DEFB    %00000000

; $33 - Character: '3'          CHR$(51)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %00001100
        DEFB    %00000010
        DEFB    %01000010
        DEFB    %00111100
        DEFB    %00000000

; $34 - Character: '4'          CHR$(52)

        DEFB    %00001000
        DEFB    %00011000
        DEFB    %00101000
        DEFB    %01001000
        DEFB    %01111110
        DEFB    %00001000
        DEFB    %00000000

; $35 - Character: '5'          CHR$(53)

        DEFB    %01111110
        DEFB    %01000000
        DEFB    %01111100
        DEFB    %00000010
        DEFB    %01000010
        DEFB    %00111100
        DEFB    %00000000

; $36 - Character: '6'          CHR$(54)

        DEFB    %00111100
        DEFB    %01000000
        DEFB    %01111100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %00111100
        DEFB    %00000000

; $37 - Character: '7'          CHR$(55)

        DEFB    %01111110
        DEFB    %00000010
        DEFB    %00000100
        DEFB    %00001000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00000000

; $38 - Character: '8'          CHR$(56)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %00111100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %00111100
        DEFB    %00000000

; $39 - Character: '9'          CHR$(57)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %00111110
        DEFB    %00000010
        DEFB    %00111100
        DEFB    %00000000

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

        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00010000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00010000
        DEFB    %00000000

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

        DEFB    %00000000
        DEFB    %00010000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00100000

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

        DEFB    %00000000
        DEFB    %00000100
        DEFB    %00001000
        DEFB    %00010000
        DEFB    %00001000
        DEFB    %00000100
        DEFB    %00000000

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

        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00111110
        DEFB    %00000000
        DEFB    %00111110
        DEFB    %00000000
        DEFB    %00000000

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

        DEFB    %00000000
        DEFB    %00010000
        DEFB    %00001000
        DEFB    %00000100
        DEFB    %00001000
        DEFB    %00010000
        DEFB    %00000000

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

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %00000100
        DEFB    %00001000
        DEFB    %00000000
        DEFB    %00001000

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

        DEFB    %00111100
        DEFB    %01001010
        DEFB    %01010110
        DEFB    %01011110
        DEFB    %01000000
        DEFB    %00111100

; $41 - Character: 'A'          CHR$(65)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01111110
        DEFB    %01000010
        DEFB    %01000010

; $42 - Character: 'B'          CHR$(66)

        DEFB    %01111100
        DEFB    %01000010
        DEFB    %01111100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01111100

; $43 - Character: 'C'          CHR$(67)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %01000000
        DEFB    %01000000
        DEFB    %01000010
        DEFB    %00111100

; $44 - Character: 'D'          CHR$(68)

        DEFB    %01111000
        DEFB    %01000100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000100
        DEFB    %01111000

; $45 - Character: 'E'          CHR$(69)

        DEFB    %01111110
        DEFB    %01000000
        DEFB    %01111100
        DEFB    %01000000
        DEFB    %01000000
        DEFB    %01111110

; $46 - Character: 'F'          CHR$(70)

        DEFB    %01111110
        DEFB    %01000000
        DEFB    %01111100
        DEFB    %01000000
        DEFB    %01000000
        DEFB    %01000000

; $47 - Character: 'G'          CHR$(71)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %01000000
        DEFB    %01001110
        DEFB    %01000010
        DEFB    %00111100

; $48 - Character: 'H'          CHR$(72)

        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01111110
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010

; $49 - Character: 'I'          CHR$(73)

        DEFB    %00111110
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00111110

; $4A - Character: 'J'          CHR$(74)

        DEFB    %00000010
        DEFB    %00000010
        DEFB    %00000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %00111100

; $4B - Character: 'K'          CHR$(75)

        DEFB    %01000100
        DEFB    %01001000
        DEFB    %01110000
        DEFB    %01001000
        DEFB    %01000100
        DEFB    %01000010

; $4C - Character: 'L'          CHR$(76)

        DEFB    %01000000
        DEFB    %01000000
        DEFB    %01000000
        DEFB    %01000000
        DEFB    %01000000
        DEFB    %01111110

; $4D - Character: 'M'          CHR$(77)

        DEFB    %01000010
        DEFB    %01100110
        DEFB    %01011010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010

; $4E - Character: 'N'          CHR$(78)

        DEFB    %01000010
        DEFB    %01100010
        DEFB    %01010010
        DEFB    %01001010
        DEFB    %01000110
        DEFB    %01000010

; $4F - Character: 'O'          CHR$(79)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %00111100

; $50 - Character: 'P'          CHR$(80)

        DEFB    %01111100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01111100
        DEFB    %01000000
        DEFB    %01000000

; $51 - Character: 'Q'          CHR$(81)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01010010
        DEFB    %01001010
        DEFB    %00111100

; $52 - Character: 'R'          CHR$(82)

        DEFB    %01111100
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01111100
        DEFB    %01000100
        DEFB    %01000010

; $53 - Character: 'S'          CHR$(83)

        DEFB    %00111100
        DEFB    %01000000
        DEFB    %00111100
        DEFB    %00000010
        DEFB    %01000010
        DEFB    %00111100

; $54 - Character: 'T'          CHR$(84)

        DEFB    %11111110
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000

; $55 - Character: 'U'          CHR$(85)

        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %00111110

; $56 - Character: 'V'          CHR$(86)

        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %00100100
        DEFB    %00011000

; $57 - Character: 'W'          CHR$(87)

        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01000010
        DEFB    %01011010
        DEFB    %00100100

; $58 - Character: 'X'          CHR$(88)

        DEFB    %01000010
        DEFB    %00100100
        DEFB    %00011000
        DEFB    %00011000
        DEFB    %00100100
        DEFB    %01000010

; $59 - Character: 'Y'          CHR$(89)

        DEFB    %10000010
        DEFB    %01000100
        DEFB    %00101000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000

; $5A - Character: 'Z'          CHR$(90)

        DEFB    %01111110
        DEFB    %00000100
        DEFB    %00001000
        DEFB    %00010000
        DEFB    %00100000
        DEFB    %01111110

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

        DEFB    %00001110
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001110

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

        DEFB    %00000000
        DEFB    %01000000
        DEFB    %00100000
        DEFB    %00010000
        DEFB    %00001000
        DEFB    %00000100

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

        DEFB    %01110000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %01110000

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

        DEFB    %00010000
        DEFB    %00111000
        DEFB    %01010100
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000

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

        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %11111111

; $60 - Character:  £           CHR$(96)

        DEFB    %00011100
        DEFB    %00100010
        DEFB    %01111000
        DEFB    %00100000
        DEFB    %00100000
        DEFB    %01111110
        DEFB    %00000000

; $61 - Character: 'a'          CHR$(97)

        DEFB    %00000000
        DEFB    %00111000
        DEFB    %00000100
        DEFB    %00111100
        DEFB    %01000100
        DEFB    %00111110
        DEFB    %00000000

; $62 - Character: 'b'          CHR$(98)

        DEFB    %00100000
        DEFB    %00100000
        DEFB    %00111100
        DEFB    %00100010
        DEFB    %00100010
        DEFB    %00111100
        DEFB    %00000000

; $63 - Character: 'c'          CHR$(99)

        DEFB    %00000000
        DEFB    %00011100
        DEFB    %00100000
        DEFB    %00100000
        DEFB    %00100000
        DEFB    %00011100
        DEFB    %00000000

; $64 - Character: 'd'          CHR$(100)

        DEFB    %00000100
        DEFB    %00000100
        DEFB    %00111100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %00111110
        DEFB    %00000000

; $65 - Character: 'e'          CHR$(101)

        DEFB    %00000000
        DEFB    %00111000
        DEFB    %01000100
        DEFB    %01111000
        DEFB    %01000000
        DEFB    %00111100
        DEFB    %00000000

; $66 - Character: 'f'          CHR$(102)

        DEFB    %00001100
        DEFB    %00010000
        DEFB    %00011000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00000000

; $67 - Character: 'g'          CHR$(103)

        DEFB    %00000000
        DEFB    %00111100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %00111100
        DEFB    %00000100
        DEFB    %00111000

; $68 - Character: 'h'          CHR$(104)

        DEFB    %01000000
        DEFB    %01000000
        DEFB    %01111000
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %00000000

; $69 - Character: 'i'          CHR$(105)

        DEFB    %00010000
        DEFB    %00000000
        DEFB    %00110000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00111000
        DEFB    %00000000

; $6A - Character: 'j'          CHR$(106)

        DEFB    %00000100
        DEFB    %00000000
        DEFB    %00000100
        DEFB    %00000100
        DEFB    %00000100
        DEFB    %00100100
        DEFB    %00011000

; $6B - Character: 'k'          CHR$(107)

        DEFB    %00100000
        DEFB    %00101000
        DEFB    %00110000
        DEFB    %00110000
        DEFB    %00101000
        DEFB    %00100100
        DEFB    %00000000

; $6C - Character: 'l'          CHR$(108)

        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00001100
        DEFB    %00000000

; $6D - Character: 'm'          CHR$(109)

        DEFB    %00000000
        DEFB    %01101000
        DEFB    %01010100
        DEFB    %01010100
        DEFB    %01010100
        DEFB    %01010100
        DEFB    %00000000

; $6E - Character: 'n'          CHR$(110)

        DEFB    %00000000
        DEFB    %01111000
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %00000000

; $6F - Character: 'o'          CHR$(111)

        DEFB    %00000000
        DEFB    %00111000
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %00111000
        DEFB    %00000000

; $70 - Character: 'p'          CHR$(112)

        DEFB    %00000000
        DEFB    %01111000
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %01111000
        DEFB    %01000000
        DEFB    %01000000

; $71 - Character: 'q'          CHR$(113)

        DEFB    %00000000
        DEFB    %00111100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %00111100
        DEFB    %00000100
        DEFB    %00000110

; $72 - Character: 'r'          CHR$(114)

        DEFB    %00000000
        DEFB    %00011100
        DEFB    %00100000
        DEFB    %00100000
        DEFB    %00100000
        DEFB    %00100000
        DEFB    %00000000

; $73 - Character: 's'          CHR$(115)

        DEFB    %00000000
        DEFB    %00111000
        DEFB    %01000000
        DEFB    %00111000
        DEFB    %00000100
        DEFB    %01111000
        DEFB    %00000000

; $74 - Character: 't'          CHR$(116)

        DEFB    %00010000
        DEFB    %00111000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00010000
        DEFB    %00001100
        DEFB    %00000000

; $75 - Character: 'u'          CHR$(117)

        DEFB    %00000000
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %00111100
        DEFB    %00000000

; $76 - Character: 'v'          CHR$(118)

        DEFB    %00000000
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %00101000
        DEFB    %00101000
        DEFB    %00010000
        DEFB    %00000000

; $77 - Character: 'w'          CHR$(119)

        DEFB    %00000000
        DEFB    %01000100
        DEFB    %01010100
        DEFB    %01010100
        DEFB    %01010100
        DEFB    %00101000
        DEFB    %00000000

; $78 - Character: 'x'          CHR$(120)

        DEFB    %00000000
        DEFB    %01000100
        DEFB    %00101000
        DEFB    %00010000
        DEFB    %00101000
        DEFB    %01000100
        DEFB    %00000000

; $79 - Character: 'y'          CHR$(121)

        DEFB    %00000000
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %01000100
        DEFB    %00111100
        DEFB    %00000100
        DEFB    %00111000

; $7A - Character: 'z'          CHR$(122)

        DEFB    %00000000
        DEFB    %01111100
        DEFB    %00001000
        DEFB    %00010000
        DEFB    %00100000
        DEFB    %01111100
        DEFB    %00000000

; $7B - Character: '{'          CHR$(123)

        DEFB    %00001110
        DEFB    %00001000
        DEFB    %00110000
        DEFB    %00110000
        DEFB    %00001000
        DEFB    %00001110
        DEFB    %00000000

; $7C - Character: '|'          CHR$(124)

        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00001000
        DEFB    %00000000

; $7D - Character: '}'          CHR$(125)

        DEFB    %01110000
        DEFB    %00010000
        DEFB    %00001100
        DEFB    %00001100
        DEFB    %00010000
        DEFB    %01110000
        DEFB    %00000000

; $7E - Character: '~'          CHR$(126)

        DEFB    %00110010
        DEFB    %01001100
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000
        DEFB    %00000000

; $7F - Character:  ©           CHR$(127)

        DEFB    %00111100
        DEFB    %01000010
        DEFB    %10011001
        DEFB    %10100001
        DEFB    %10100001
        DEFB    %10011001
        DEFB    %01000010
L1
         FFB:  DEFB    %00111100


; ---------------
; THE 'SPARE' ROM
; ---------------

L1FFC:  DEFB    $FF                     ; unused

; ----------
; THE 'LINK'
; ----------

; The FORTH word copied to RAM links back to L1FFF

L1FFD:  DEFW    L1D58                   ; pointer to prev - UFLOAT
L1FFF:  DEFB    $00                     ; length of dummy word zero


.END

; -----------
;
; -----------
; ----------------------
; THE 'SYSTEM VARIABLES'
; ----------------------
; "Here is a list of system variables. We have given them all names, but that
; is just for ease of reference. The Ace will not recognize these names,
; except for a few, like 'BASE', that are FORTH words. I've written these
; FORTH words in bold type in the usual way."
;
;
; FP_WS         $3C00 (15360)   19 bytes used as work space for floating point
;                               arithmetic.
;
; LISTWS        $3C13 (15379)   5 bytes used as workspace by 'LIST' and 'EDIT'.
;
; RAMTOP        $3C18 (15384)   2 bytes - the first address past the last
;                               address in RAM.
;
; HLD           $3C1A (15386)   2 bytes. The address of the latest character
;                               held in the pad by formatted output.
;                               ('#', 'HOLD' and so on).
;
; SCRPOS        $3C1C (15388)   2 bytes. The address of the place in video RAM
;                               where the next character is to be printed
;                               (i.e. the 'print position').
;
; INSCRN        $3C1E (15390)   2 bytes. The address of the start of the
;                               current 'logical line' in the input buffer.
;
; CURSOR        $3C20 (15392)   2 bytes. The address of the cursor in the
;                               input buffer.
;
; ENDBUF        $3C22 (15394)   2 bytes. The address of the end of the current
;                               logical line in the input buffer.
;
; L_HALF        $3C24 (15396)   2 bytes. The address of the start of the the
;                               input buffer. The input buffer itself is stored
;                               in the video RAM, where you see it.
;
; KEYCOD        $3C26 (15398)   1 byte. The ASCII code of the last key pressed.
;
; KEYCNT        $3C27 (15399)   1 byte. Used by the routine that reads the
;                               keyboard.
;
; STATIN        $3C28 (15400)   1 byte. Used by the routine that reads the
;                               keyboard.
;
; EXWRCH        $3C29 (15401)   2 bytes. This is normally 0 but it can be
;                               changed to allow printing to be sent to some
;                               device other than the screen.
;
; FRAMES        $3C2B (15403)   4 bytes. These four bytes form a double length
;                               integer that counts the time since the Ace was
;                               switched on in 50ths of a second.
;
; XCOORD        $3C2F (15407)   1 byte. The x-coordinate last used by 'PLOT'.
;
; YCOORD        $3C30 (15408)   1 byte. The y-coordinate last used by 'PLOT'.
;
; CURRENT       $3C31 (15409)   2 bytes. The parameter field address for the
;                               vocabulary word of the current vocabulary.
;
; CONTEXT       $3C33 (15411)   2 bytes. The parameter field address for the
;                               vocabulary word of the context vocabulary.
;
; VOCLNK        $3C35 (15413)   2 bytes. The address of the fourth byte in the
;                               parameter field - the vocabulary linkage - of
;                               the vocabulary word of the most recently
;                               defined vocabulary.
;
; STKBOT        $3C37 (15415)   2 bytes. The address of the next byte into
;                               which anything will be enclosed in the
;                               dictionary, i.e. one byte past the present end
;                               of the dictionary.
;                               'HERE' is equivalent to 15415 @.
;
; DICT          $3C39 (15417)   2 bytes. The address of the length field in the
;                               newest word in the dictionary. If that length
;                               field is correctly filled in then DICT may
;                               be 0.
;
; SPARE         $3C3B (15419)   2 bytes. The address of the first byte past the
;                               top of the stack.
;
; ERR_NO        $3C3D (15421)   1 byte. This is usually 255, meaning "no error".
;                               If 'ABORT' is used, and ERR_NO is between 0 and
;                               127, then "ERROR" will be printed out, followed
;                               by the error number ERR_NO.
;
; FLAGS         $3C3E (15422)   1 byte. Shows the state of various parts of the
;                               system, each bit showing whether something
;                               particular is happening or not. Some of these
;                               may be useful.
;
;                               Bit 2, when 1, shows that there is an incomplete
;                               definition at the end of the dictionary.
;
;                               Bit 3, when 1, shows that output is to fed into
;                               the input buffer.
;
;                               Bit 4, when 1, shows that the Ace is in
;                               invisible mode.
;
;                               Bit 6, when 1, shows that the Ace is in compile
;                               mode.
;
; BASE          $3C3F (15423)   1 byte. The system number base.
;
;
;
; -----------------------------------------------------------------------------
;                                    ---------
;                                   -------------------------------------------
; ------------                     --------------------------------------------
; ACE KEYBOARD                    ---------
; ------------                   ---------
;
;+-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+
;|   ! | |   @ | |   # | |   $ | |   % | |   & | |   ' | |   ( | |   ) | |   _ |
;| 1 []| | 2 []| | 3 []| | 4 []| | 5 []| | 6 []| | 7 []| | 8   | | 9   | | 0 []|
;+-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+
; DELETE   CAPS            INV    <=        ^       v        =>  GRAPHIC  DELETE
;  LINE    LOCK           VIDEO
;+-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+
;|     | |     | |     | |   < | |   > | |   [ | |   ] | |   © | |   ; | |   " |
;| Q   | | W   | | E   | | R   | | T   | | Y   | | U   | | I   | | O   | | P   |
;+-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+
;
;+-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+
;|   ~ | |   | | |   \ | |   { | |   } | |   ^ | |   - | |   + | |   = | |     |
;| A   | | S   | | D   | | F   | | G   | | H   | | J   | | K   | | L   | |ENTER|
;+-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+
;
;+-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+
;|     | |   : | |   £ | |   ? | |   / | |   * | |   , | |   . | | SYM | |     |
;|SHIFT| | Z   | | X   | | C   | | V   | | B   | | N   | | M   | |SHIFT| |SPACE|
;+-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+ +-----+
;
;
;                     [] mosaic graphic          £  currency symbol
;
; -----------------------------------------------------------------------------