; 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)
; ---
; 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
L1FFB: 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
;
; -----------------------------------------------------------------------------