www.jupiter-ace.co.uk
|
www.jupiter-ace.co.uk
|
| Home > Disassembly of Jupiter Ace ROM |
|
|
Click here to go to a German text Version [ thanks to Geoff Wearmouth ]
; Disassembly of the file "C:\ACE\JupiterAce.rom"
;
; CPU Type: Z80
;
; Created with dZ80 1.50
;
; on Monday, 21 of January 2002 at 07:11 PM
;
; last updated 02-NOV-2002
;
; Cross-assembles to an 8K ROM file.
;
; Note. A Low-level Assembly Listing only.
#define DEFB .BYTE
#define DEFW .WORD
#define DEFM .TEXT
#define EQU .EQU
#define ORG .ORG
ORG $0000
; -------------------
; THE 'START' RESTART
; -------------------
L0000: DI ; disable interrupts.
LD HL,$3C00 ; start of 'User' RAM
LD A,$FC ; a test byte and 1K masking byte.
JR L0028 ; forward to continue at Part 2.
; -------------------
; THE 'PRINT' RESTART
; -------------------
L0008: EXX ; preserve main registers.
BIT 3,(IX+$3E) ; test FLAGS for print destination.
JP L03EE ; forward to
; ---------------------------
; THE 'STACK WORD DE' RESTART
; ---------------------------
L0010: LD HL,($3C3B) ; SPARE
LD (HL),E
INC HL
JP L085F ;
; -------------------------
; THE 'POP WORD DE' RESTART
; -------------------------
L0018: LD HL,($3C3B) ; SPARE
DEC HL
LD D,(HL)
JP L0859 ;
; -------------------
; THE 'ERROR' RESTART
; -------------------
L0020: POP HL
LD A,(HL)
LD ($3C3D),A ; ERR_NO
JP L00AD ;
; ------------------------------------
; THE 'INITIALIZATION ROUTINE' Part 2.
; ------------------------------------
L0028: INC H ; increase high byte
LD (HL),A ; insert A value
CP (HL) ; compare to expected
JR Z,L0028 ; loop back while RAM is populated.
AND H ; limit to nearest 1K segment.
LD H,A ; place back in H.
LD ($3C18),HL ; set system variable RAMTOP.
LD SP,HL ; initialize the stack pointer.
; the Z80 instructions CALL, PUSH and POP can now be used.
LD HL,L010D ; prepare to copy the system variables
; initial state from ROM.
JR L003B ; skip past the fixed-position restart.
; -----------------------
; THE 'INTERRUPT' RESTART
; -----------------------
L0038: JP L013A ; jump to somewhere more convenient.
;------------------------------------------------------------------------------
;
; MEMORY MAP
;
; $0000 +======================================================+
; | |
; | ROM 8K |
; | v $2300 |
; $2000 +======================================================+ - - - - - -
; | copy of $2400 |0|< cassette >|
; $2400 +-------------------------------------+-+--------------+
; | VIDEO MEMORY 768 bytes |0| PAD 254 bytes| 1K RAM
; $2800 +-------------------------------------+-+--------------+
; | copy of $2c00 ^ $2700 |
; $2C00 +------------------------------------------------------+
; | CHARACTER SET - Write-Only | 1K RAM
; $3000 +------------------------------------------------------+
; | copy of $3c00 |
; $3400 +------------------------------------------------------+
; | copy of $3c00 |
; $3800 +------------------------------------------------------+
; | copy of $3c00 |
; $3C00 +-------+----------------------------------------------+
; |SYSVARS| DICT {12} DATA STACK -> <- RET STACK | 1K RAM
; $4000 +=======+==============================================+ - - - - - -
; | |
; 48K AVAILABLE FOR EXPANSION.
; | |
; $FFFF +======================================================+
;
; The Ace had an 8K ROM and was sold with 3K of RAM each byte of which had
; at least two addresses and sometimes four addresses so the mapping of the
; 3K of RAM was as above.
; The 768 bytes of video memory is accessed by the ROM using addresses
; $2400 - $26FF. This gives priority to the video circuitry which also needs
; this information to build the TV picture. The byte at $2700 is set to zero
; so that it is easy for the ROM to detect when it is at the end of the screen.
; The 254 bytes remaining are the PAD - the workspace used by FORTH.
; This same area is used by the tape recorder routines to assemble the tape
; header information but since, for accurate tape timing, the FORTH ROM needs
; priority over the video circuitry, then the ROM uses addresses $2301 - $23FF.
;
; Similarly the Character Set is written to by the ROM (and User) at the 1K
; section starting at $2C00. The video circuitry accesses this using addresses
; $2800 - $2BFF to build the TV picture. It is not possible for the ROM or User
; to read back the information from either address so this precludes the saving
; of character sets and writing a driver for a device like the ZX Printer.
;
; The final 1K or RAM has four addresses although it is normal to use addresses
; $3C00 - $3FFF. The first sixty three bytes are the System Variables which
; hold information like the number BASE and CONTEXT, and even the plotting
; coordinates should the user wish to develop a word like DRAW to draw lines.
;
; Then comes the User Dictionary, the first word of which is "FORTH" which links
; to the Dictionary in ROM. Next a gap of 12 bytes to allow for Data Stack
; underflow and then the Data Stack itself which grows upwards.
; At the opposite end of free memory is the Return Stack (machine stack) which
; grows downwards.
; ------------------------------------
; THE 'INITIALIZATION ROUTINE' Part 3.
; ------------------------------------
L003B: LD DE,$3C24 ; destination system variable L_HALF
LD BC,$002D ; number of bytes.
LDIR ; copy initial state from ROM to RAM.
LD IX,$3C00 ; set IX to index the system variables.
LD IY,L04C8 ; set IY to the SLOW return address.
L004B: CALL L0A24 ; routine CLS.
XOR A ; clear accumulator.
LD ($2700),A ; make location after screen zero.
; There are 128 bit-mapped 8x8 characters.
; Define the 8 Battenberg graphics ($10 to $17) from low byte of address.
; This routine also sets the other characters $00 to $0F and $18 to $1F
; to copies of this range. The inverse form of character $17 is used as the
; normal cursor - character $97.
L0052: LD HL,$2C00 ; point to the start of the 1K write-
; only Character Set RAM.
L0055: LD A,L ; set A to low byte of address
AND $BF ; AND %10111111
RRCA ; rotate
RRCA ; three times
RRCA ; to test bit 2
JR NC,L005F ; forward if not set.
RRCA ; else rotate
RRCA ; twice more.
L005F: RRCA ; set carry from bit (3) or (6)
LD B,A
SBC A,A ; $00 or $FF
RR B
LD B,A
SBC A,A
XOR B
AND $F0
XOR B
LD (HL),A ; insert the byte.
INC L ; increment low byte of address
JR NZ,L0055 ; loop back until the first 256 bytes
; have been filled with 32 repeating
; characters.
; Now copy the bit patterns at the end of this ROM to the last 768 bytes of
; the Character RAM, filling in some blank bytes omitted to save ROM space.
; This process starts at high memory and works downwards.
L006E: LD DE,$2FFF ; top of destination.
LD HL,L1FFB ; end of copyright character.
LD BC,$0008 ; 8 characters
LDDR ; copy the © character
EX DE,HL ; switch pointers.
LD A,$5F ; set character counter to ninety five.
; i.e. %0101 1111
; bit 5 shows which 32-character sector
; we are in.
; enter a loop for the remaining characters supplying zero bytes as required.
L007C: LD C,$07 ; set byte counter to seven.
BIT 5,A ; test bit 5 of the counter.
JR Z,L0085 ; forward if not in middle section
; which includes "[A-Z]"
LD (HL),B ; else insert a zero byte.
DEC HL ; decrement the destination address.
DEC C ; and the byte counter.
L0085: EX DE,HL ; switch pointers.
LDDR ; copy the 5 or 6 characters.
EX DE,HL ; switch pointers.
LD (HL),B ; always insert the blank top byte.
DEC HL ; decrement the address.
DEC A ; decrement the character counter.
JR NZ,L007C ; back for all 95 characters.
IM 1 ; Select Interrupt Mode 1
JR L009B ; and then jump into the code for the
; QUIT word.
; ---------------
; THE 'QUIT' WORD
; ---------------
; ( -- )
; Clears return stack, empties input buffer and returns control to the
; keyboard.
L0092: DEFM "QUI" ; 'name field'
DEFB 'T' + $80
L0096: DEFW $0000 ; 'link field' - end of linked list.
L0098: DEFB $04 ; 'name length field'
L0099: DEFW L009B ; 'code field'
; address of machine code for routine.
; ---
L009B: LD SP,($3C18) ; set stack-pointer to RAMTOP.
EI ; Enable Interrupts.
JP L04F2 ; jump forward to the main execution
; loop.
; ----------------
; THE 'ABORT' WORD
; ----------------
; Clears the data and return stacks, deletes any incomplete definition
; left in the dictionary, prints 'ERROR' and the byte from address $3C3D
; if the byte is non-negative, empties the input buffer, and returns
; control to the keyboard.
L00A3: DEFM "ABOR" ; 'name field'
DEFB 'T' + $80
DEFW L0098 ; 'link field' to previous word QUIT.
L00AA: DEFB $05 ; 'name length field'
L00AB: DEFW L00AD ; 'code field'
; ---
; -> also continuation of the error restart.
L00AD: PUSH IY ; preserve current IY value slow/fast.
LD IY,L04B9 ; set IY to FAST
; now empty the data stack
LD HL,($3C37) ; STKBOT
LD ($3C3B),HL ; SPARE
LD HL,$3C3E ; address FLAGS
LD A,(HL) ; fetch status from FLAGS.
AND $B3 ; AND %10110011
; reset bit 2 - show definition complete
; reset bit 3 - output to screen.
; reset bit 6 - show in interpreter mode
BIT 2,(HL) ; was there an incomplete definition ?
LD (HL),A ; update FLAGS
JR Z,L00DE ; forward if no incomplete word.
L00C4: CALL L04B9 ; do forth
DEFW L0490 ; dict address of sv DICT
DEFW L08B3 ; @ value of sv DICT (d).
DEFW L104B ; stk_data d. length field
DEFB $05 ; five d, 5.
DEFW L0DD2 ; + d+5. code field
DEFW L086B ; dup d+5, d+5.
DEFW L1610 ; prvcur d+5.
DEFW L15B5 ; namefield n.
DEFW L1011 ; stackwrd n.
DEFW $3C37 ; (stkbot) n, stkbot.
DEFW L08C1 ; ! .
DEFW L1A0E ; end-forth. .
; at this stage the system variable STKBOT holds the address of the
; obsolete name field and the system variable CURRENT points to the
; address of the previous complete word - obtained from the old link field.
L00DE: BIT 7,(IX+$3D) ; test ERR_NO for normal value 255.
JR NZ,L00FF ; set-min then main-loop if OK.
CALL L1808 ; else pr-inline
; ---
L00E7: DEFM "ERRO" ; the message "ERROR" with the last
DEFB 'R' + $80 ; character inverted.
; ---
L00EC: CALL L04B9 ; forth
DEFW L1011 ; stack next word
DEFW $3C3D ; -> system variable ERR_NO
DEFW L0896 ; C@ - fetch content byte
DEFW L09B3 ; . - print it
DEFW L0A95 ; CR
DEFW L1A0E ; end-forth.
LD (IX+$3D),$FF ; set ERR_NO to 'No Error'
L00FF: LD HL,($3C37) ; fetch STKBOT
LD BC,$000C ; allow twelve bytes for stack underflow
ADD HL,BC ; add the extra
LD ($3C3B),HL ; set SPARE
POP IY ; restore previous state of IY
JR L009B ; rejoin main loop
; -------------------------
; THE 'DEFAULT ENVIRONMENT'
; -------------------------
; This is the default environment that is copied from ROM to RAM as part of
; the initialization process. This also contains the FORTH word FORTH definition
L010D: DEFW $26E0 ; L_HALF
DEFB $00 ; KEYCOD
DEFB $00 ; KEYCNT copy the 32 bytes.
DEFB $00 ; STATIN
DEFW $0000 ; EXWRCH
DEFB $00 ; FRAMES
DEFB $00 ; FRAMES
DEFB $00 ; FRAMES
DEFB $00 ; FRAMES
DEFB $00 ; XCOORD
DEFB $00 ; YCOORD
DEFW $3C4C ; CURRENT
DEFW $3C4C ; CONTEXT
DEFW $3C4F ; VOCLNK
DEFW $3C51 ; STKBOT
DEFW $3C45 ; DICT
DEFW $3C5D ; SPARE
DEFB $FF ; ERR_NO
DEFB $00 ; FLAGS
DEFB $0A ; BASE
; FORTH
DEFM "FORT" ; The 'name field'
DEFB 'H' + $80 ; FORTH
DEFW $0000 ; length field - filled when next word
; is defined.
DEFW L1FFF ; link field copied to $3C49.
DEFB $05 ; name length field
DEFW L11B5 ; code field
DEFW $3C49 ; address of parameters
DEFB $00 ; VOCLNK [$3C4F]
DEFB $00 ; - link to next vocabulary.
DEFB $00 ; last byte to be copied. to [$3C51]
; -----------------------------------------------
; THE 'CONTINUATION OF THE Z80 INTERRUPT' ROUTINE
; -----------------------------------------------
; The destination of the jump at $0038.
; Begin by saving both accumulators and the 3 main registers.
L013A: PUSH AF ; preserve both accumulators
EX AF,AF' ;
PUSH AF ;
PUSH BC ; and main registers.
PUSH DE ;
PUSH HL ;
; Now wait for 62 * 12 clock cycles. ( To avoid flicker perhaps? ).
LD B,$3E ; delay counter.
L0142: DJNZ L0142 ; self loop for delay
; Increment the 4-byte frames counter for use as a system clock.
LD HL,$3C2B ; FRAMES1
L0147: INC (HL) ; increment timer.
INC HL ; next significant byte of four.
JR Z,L0147 ; loop back if the value wrapped back
; to zero.
; Note. as manual points out, there is no actual check on this and if
; you leave your Ace switched on for 2.75 years it will advance to the
; following system variables although it takes several millennia to advance
; through the screen coordinates.
; Now read the keyboard and if no new key then exit after restoring the
; preserved registers.
CALL L0310 ; routine KEYBOARD.
LD HL,$3C28 ; address system variable STATIN
BIT 0,(HL) ; new key?
JR Z,L0176 ; forward if not to RESTORE/EXIT
AND A ; zero key code ?
JR Z,L0176 ; forward if so to EXIT.
CP $20 ; compare to SPACE
JR C,L0170 ; forward if less as an Editing Key.
BIT 1,(HL) ; CAPS shift?
CALL NZ,L0807 ; routine TO_UPPER
BIT 2,(HL) ; GRAPHICS mode?
JR Z,L0167 ; skip forward if not
AND $9F ; convert to one of 8 mosaic characters
L0167: BIT 3,(HL) ; INVERSE mode?
JR Z,L016D ; forward if not.
OR $80 ; set bit 7 to make character inverse.
L016D: CALL L0196 ; routine pr_buffer
L0170: CALL L01E6 ; routine EDIT_KEY
CALL L0282 ; routine pr_cursor
; Before exiting restore the preserved registers.
L0176: POP HL ;
POP DE ;
POP BC ;
POP AF ;
EX AF,AF' ;
POP AF ;
EI ; Enable Interrupts
RET ; return.
; -----------------------------------
; THE 'PRINT to LOWER SCREEN' ROUTINE
; -----------------------------------
L017E: CP $0D ; carriage return?
JR NZ,L0196 ; forward if not
; a carriage return to input buffer i.e. lower screen memory.
LD HL,$2700 ; set pointer to location after the
; input buffer.
LD ($3C22),HL ; set ENDBUF - end of logical line
LD ($3C20),HL ; set the CURSOR
XOR A ; clear A
CALL L0198 ; print character zero.
LD HL,$26E0 ; left hand position of bottom line.
LD ($3C1E),HL ; set INSCRN to this position.
RET ; return.
; ---------------------------------------
; THE 'PRINT CHARACTER TO BUFFER' ROUTINE
; ---------------------------------------
L0196: AND A ; check for zero character
RET Z ; return if so.
; => also called from previous routine only to print a zero skipping above test.
L0198: EX AF,AF' ; preserve the output character.
LD HL,($3C22) ; fetch ENDBUF end of logical line
LD A,(HL) ; fetch character from position
AND A ; is it zero ?
JR Z,L01A6 ; skip forward if so.
; else lower screen scrolling is required.
LD DE,$D900 ; $0000 - $2700
ADD HL,DE ; test if position is within video RAM
JR NC,L01CE ; forward if < $26FF
; now check that the limit of 22 lines in lower screen is not exceeded.
L01A6: LD DE,($3C24) ; fetch start of buffer from L_HALF
LD HL,$DBA0 ; $0000 - $2460
ADD HL,DE ;
JR NC,L01E4 ; forward to exit if buffer full.
LD HL,($3C1C) ; fetch position SCRPOS for upper screen
LD BC,$0020 ; allow an extra 32 characters - 1 line.
ADD HL,BC ;
SBC HL,DE ; subtract the start of input buffer
PUSH DE ; and save the L_HALF value
CALL NC,L0421 ; routine to scroll upper display.
CALL L02B0 ; find zerobyte loc in HL
POP DE ; retrieve the L_HALF value
CALL L042F ; routine scroll and blank
; The four system variables INSCRN, CURSOR, ENDBUF and L_HALF are each
; reduced by 32 bytes a screen line.
LD HL,$3C1E ; address INSCRN the left-hand location
; of the current input line.
LD B,$04 ; four system variables to update
L01C9: CALL L0443 ; routine SCR-PTRS
DJNZ L01C9 ; repeat for all four pointers.
; ok to print
L01CE: CALL L0302 ; routine find characters to EOL.
LD D,H ; HL is end of line
LD E,L ; transfer to DE register.
INC HL ; increment
LD ($3C22),HL ; update ENDBUF
DEC HL ; decrement
DEC HL ; so HL = DE -1
JR Z,L01DD ; skip if BC zero.
LDDR ; else move the characters.
L01DD: EX AF,AF' ; restore the output character.
LD (DE),A ; insert at screen position.
; (a zero if CR lower)
INC DE ; next character position
LD ($3C20),DE ; update CURSOR
L01E4: XOR A ; ?
RET ; return.
; -------------------------
; THE 'EDIT KEY' SUBROUTINE
; -------------------------
L01E6: LD HL,L01F0 ; address the EDIT KEYS table.
LD D,$00 ; prepare to index by one byte.
LD E,A ; character code to E.
ADD HL,DE ; index into the table.
LD E,(HL) ; pick up required offset to the
; handling routine.
ADD HL,DE ; add to the current address.
JP (HL) ; exit via the routine.
; ---------------------
; THE 'EDIT KEYS' TABLE
; ---------------------
L01F0: DEFB $20 ; L0210 $00 - RET
L01F1: DEFB $13 ; L0204 $01 - LEFT
L01F2: DEFB $0C ; L01FE $02 - CAPS
L01F3: DEFB $1E ; L0211 $03 - RIGHT
L01F4: DEFB $0A ; L01FE $04 - GRAPH
L01F5: DEFB $37 ; L022C $05 - DEL
L01F6: DEFB $1A ; L0210 $06 - RET
L01F7: DEFB $50 ; L0247 $07 - UP
L01F8: DEFB $06 ; L01FE $08 - INV
L01F9: DEFB $9C ; L0295 $09 - DOWN
L01FA: DEFB $C9 ; L02C3 $0A - DEL LINE
L01FB: DEFB $15 ; L0210 $0B - RET
L01FC: DEFB $14 ; L0210 $0C - RET
L01FD: DEFB $D3 ; L02D0 $0D - KEY-ENTER
; -------------------------------
; THE 'TOGGLE STATUS BIT' ROUTINE
; -------------------------------
; The keycodes have been cleverly mapped to individual bits of the STATIN
; system variable so this simple routine maintains all three status bits.
; KEY '2' - CAPS SHIFT, '4' - GRAPHICS, '8' - INVERSE VIDEO.
L01FE: LD HL,$3C28 ; system variable STATIN
XOR (HL) ; toggle the single relevant bit.
LD (HL),A ; put back.
RET ; return.
; ----------------------------
; THE 'CURSOR LEFT' SUBROUTINE
; ----------------------------
; this subroutine moves the cursor to the left unless the character at that
; position is zero.
L0204: LD HL,($3C20) ; fetch CURSOR.
DEC HL ; decrement value.
LD A,(HL) ; fetch character at new position.
AND A ; test for zero. (cr)
RET Z ; return if so. >>
LD ($3C20),HL ; else update CURSOR
INC HL ; step back
LD (HL),A ; and put character that was at new
; cursor position where cursor is now.
L0210: RET ; return.
; Note. various unallocated keys in the EDIT KEYS table point to the
; above RET instruction.
; -----------------------------
; THE 'CURSOR RIGHT' SUBROUTINE
; -----------------------------
L0211: LD HL,($3C20) ; fetch CURSOR position
INC HL ; and increment it.
LD DE,($3C22) ; fetch ENDBUF - end of current line.
AND A ; prepare to subtract.
SBC HL,DE ; test
RET Z ; return if zero - CURSOR is at ENDBUF
ADD HL,DE ; else reform the pointers.
LD ($3C20),HL ; update CURSOR
LD A,(HL) ; fetch character at new position.
DEC HL ; decrement
LD (HL),A ; and insert where cursor was.
RET ; ret.
; ---------------------------
; THE 'DELETE CURSOR' ROUTINE
; ---------------------------
; Moves cursor position to right and then continues into DEL-CHAR
L0225: LD HL,($3C20) ; fetch CURSOR
INC HL ; increment position.
LD ($3C20),HL ; update CURSOR
; ------------------------------
; THE 'DELETE CHARACTER' ROUTINE
; ------------------------------
L022C: CALL L0302 ; routine finds characters to EOL.
LD H,D ; transfer CURSOR position DE to HL.
LD L,E ;
DEC DE ; decrement DE
LD A,(DE) ; fetch character to left of original
; cursor.
AND A ; test for zero.
RET Z ; return if so. >>
LD ($3C20),DE ; else update CURSOR
LD A,B ; check for count of characters
OR C ; being zero
JR Z,L023F ; skip if so.
L023D: LDIR ; else shift characters to left.
L023F: DEC HL ; decrement HL so that points to end -
; last position on the logical line.
LD (HL),$20 ; insert a space.
LD ($3C22),HL ; set ENDBUF
INC C ; reset zero flag??
RET ; return.
; -----------------------
; THE 'CURSOR UP' ROUTINE
; -----------------------
; When the cursor is moved up while editing a multi-line word definition,
; then the cursor is first moved to the left of the screen abutting the
; character zeros at the leftmost position.
; These zero characters appear as spaces but mark the beginning of each logical
; line. A logical line may, for instance if it contains a text item, extend over
; several physical screen lines.
L0247: CALL L0204 ; routine CURSOR-LEFT
JR Z,L0254 ; skip forward if not possible.
; else move left by thirty two positions. This may achieve a vertical move if
; attempted when a word is first being entered. Alternatively if one of the
; calls to cursor left fails having encountered a zero, then all subsequent
; calls will fail. The routine will return with the cursor adjacent to the zero.
LD B,$1F ; count 31 decimal
L024E: CALL L0204 ; move cursor left thirty one times.
DJNZ L024E ; makes thirty two moves counting first
RET ; return.
; ---
L0254: LD HL,($3C1E) ; fetch INSCRN start of current line.
LD DE,($3C24) ; fetch L_HALF start of buffer.
AND A ; reset carry for
SBC HL,DE ; true subtraction.
RET Z ; return if at beginning of input buffer
CALL L0225 ; routine DEL-CURSOR
LD HL,($3C1E) ; fetch INSCRN leftmost location of
; current line.
LD DE,$FFE0 ; make DE minus thirty two.
XOR A ; clear accumulator to zero.
L0269: ADD HL,DE ; subtract 32
CP (HL) ; compare contents to zero
; ( i.e. prev (cr) or buffer start?)
JR NZ,L0269 ; loop back until HL holds zero.
LD ($3C1E),HL ; update INSCRN
CALL L02F4 ; find endbuf
LD ($3C20),HL ; set CURSOR
; ----------
; PR_CURSOR
; ----------
L0276: LD A,$A0 ; inverse space - so solid square
CALL L017E ; routine PR_LOWER
LD HL,($3C20) ; CURSOR
DEC HL
LD ($3C20),HL ; CURSOR
; -> from interrupt
L0282: LD HL,($3C20) ; CURSOR
LD A,($3C28) ; STATIN
RRA ; ignore bit 0
LD (HL),$97 ; pixel cursor.
RRA ; test bit 1 - CAPS
JR NC,L0290 ; forward if no CAPS SHIFT
LD (HL),$C3 ; inverse [C] cursor.
L0290: RRA ; test bit 2 - GRAPHICS.
RET NC ; return if not
L0292: LD (HL),$C7 ; inverse [G] cursor.
RET ; return
; -------------------------
; THE 'CURSOR DOWN' ROUTINE
; -------------------------
L0295: CALL L0211 ; routine CURSOR RIGHT
JR Z,L02A2 ; forward if not possible.
LD B,$1F ; set counter to thirty one.
L029C: CALL L0211 ; routine CURSOR RIGHT
DJNZ L029C ; thirty two moves altogether.
RET ; return.
; ---
L02A2: CALL L02B0 ; find zerobyte
RET PO ; return if found
PUSH HL ; save position
CALL L0225 ; routine DEL-CURSOR
POP HL ; retrieve position.
CALL L02ED ; set logical line
JR L0276 ; back to exit via pr_cursor.
; ---
; find zerobyte
; ---
; -> called 5 times
L02B0: LD HL,$2700 ; this location is always zero.
; the byte following video RAM.
LD DE,($3C1E) ; INSCRN e.g. $26E0
AND A ; prepare for true subtraction
SBC HL,DE ; subtract to give number of chars
LD B,H ; transfer count to
LD C,L ; the BC register pair.
EX DE,HL ; transfer INSCR value to HL.
INC HL ; start next location
XOR A ; search for a zero character.
CPIR ; at most BC locations.
; sets P/O flag if BC!=0
DEC HL ; step back to last non-zero
RET ; return.
; -------------------------
; THE 'DELETE LINE' ROUTINE
; -------------------------
; CHR$ 10
L02C3: LD HL,($3C22) ; ENDBUF
DEC HL ;
LD ($3C20),HL ; CURSOR
L02CA: CALL L022C ; KEY-DEL
JR NZ,L02CA ; repeat
RET ; return.
; --------------------------
; THE 'KEY-ENTER' SUBROUTINE
; --------------------------
L02D0: LD HL,$3C28 ; STATIN
SET 5,(HL) ; signal new key.
RES 0,(HL) ; reset new key flag
RET ; return.
; ------------------------
; THE 'SET BUFFER' ROUTINE
; ------------------------
; called by LIST, QUERY
L02D8: LD HL,$2700 ; one past end of screen.
LD DE,($3C24) ; fetch start of buffer from L_HALF
CALL L07FA ; routine SPACE_FILL
LD HL,$26E0 ; first location of bottom line.
LD ($3C24),HL ; set L_HALF
LD (HL),$00 ; insert a ZERO.
; -> called by retype
L02EA: LD HL,($3C24) ; fetch L_HALF
; -> from cursor down
L02ED: LD ($3C1E),HL ; set INSCRN
INC HL ; step past the zero
LD ($3C20),HL ; set CURSOR
; => from cursor up.
L02F4: CALL L02B0 ; find zerobyte
LD A,$20 ; prepare a space
L02F9: DEC HL ; move to the left.
CP (HL) ; compare to space.
JR Z,L02F9 ; back while spaces exist.
INC HL ; point to last space encountered.
LD ($3C22),HL ; set ENDBUF - end of logical line.
RET ; return.
; ----------------------------------
; THE 'COUNT TO END OF LINE' ROUTINE
; ----------------------------------
; Find the number of characters to the end of the logical line.
L0302: LD HL,($3C22) ; system variable ENDBUF
LD DE,($3C20) ; system variable CURSOR
AND A ; prepare to subtract.
SBC HL,DE ; subtract to give character places
LD B,H ; transfer result
LD C,L ; to the BC register pair.
ADD HL,DE ; reform the pointers.
RET ; return with zero flag set if cursor
; at EOL.
; ----------------------
; THE 'KEYBOARD' ROUTINE
; ----------------------
L0310: CALL L0336 ; routine KEY_SCAN
LD B,A ; save key in B
LD HL,($3C26) ; load L with KEYCOD - last key pressed
; load H with KEYCNT - debounce counter
XOR L ; compare to previous key.
JR Z,L0325 ; forward if a match.
XOR L ; reform original
JR Z,L0320 ; forward if zero - no key.
XOR A ; else clear accumulator.
CP L ; compare with last.
RET NZ ; return if not zero.
L0320: LD L,B ; set L to original keycode
LD H,$20 ; set counter to thirty two.
JR L0332 ; forward to store values and exit
; returning zero.
; ---
; Key is same as previously accepted key.
; It repeats after two interrupts
L0325: DEC H ; decrement the counter.
LD A,H ; fetch counter to A.
CP $1E ; compare to thirty.
JR Z,L0331 ; forward if so to return key in A.
XOR A ; clear accumulator.
CP H ; is counter zero?
JR NZ,L0332 ; forward if not to keep counting.
LD H,$04 ; else set counter to four.
L0331: LD A,L ; pick up previous key.
L0332: LD ($3C26),HL ; update KEYCOD/KEYCNT
RET ; return.
;----------------------------------------------------------------------------
; LOGICAL VIEW OF KEYBOARD
;
; 0 1 2 3 4 -Bits- 4 3 2 1 0
; PORT PORT
;
; F7FE [ 1 ] [ 2 ] [ 3 ] [ 4 ] [ 5 ] | [ 6 ] [ 7 ] [ 8 ] [ 9 ] [ 0 ] EFFE
; ^ | v
; FBFE [ Q ] [ W ] [ E ] [ R ] [ T ] | [ Y ] [ U ] [ I ] [ O ] [ P ] DFFE
; ^ | v
; FDFE [ A ] [ S ] [ D ] [ F ] [ G ] | [ H ] [ J ] [ K ] [ L ] [ ENT ] BFFE
; ^ | v
; FEFE [SHI] [SYM] [ Z ] [ X ] [ C ] | [ V ] [ B ] [ N ] [ M ] [ SPC ] 7FFE
; ^ v ^ v
; Start +------------>--------------------->-------------+ End
;
;
;----------------------------------------------------------------------------
; ----------------------------------
; THE 'KEYBOARD SCANNING' SUBROUTINE
; ----------------------------------
; This routine is called by the KEYBOARD routine 50 times a second and
; by the ACE FORTH 'INKEY' WORD.
; The above diagram shows the logical view of the Keyboard and PORTS.
; The physical view is similar except that the symbol shift key is to the
; left of the space key.
L0336: LD BC,$FEFE ; port address - B is also an 8 counter
IN D,(C) ; read from port to D.
; when a key is pressed, the
; corresponding bit is reset.
LD E,D ; save in E
SRL D ; read the outer SHIFT key.
SBC A,A ; $00 if SHIFT else $FF.
AND $D8 ; $00 if SHIFT else $D8.
SRL D ; read the symbol shift bit
JR C,L0347 ; skip if not pressed.
LD A,$28 ; load A with 40 decimal.
L0347: ADD A,$57 ; gives $7F SYM, $57 SHIFT, or $2F
; Since 8 will be subtracted from the initial key value there are three
; distinct ranges 0 - 39, 40 - 79, 80 - 119.
LD L,A ; save key range value in L
LD A,E ; fetch the original port reading.
OR $03 ; cancel the two shift bits.
LD E,$FF ; set a flag to detect multiple keys.
; KEY_LINE the half-row loop.
L034F: CPL ; complement bits
AND $1F ; mask off the rightmost five key bits.
LD D,A ; save a copy in D.
JR Z,L0362 ; forward if no keys pressed to do the
; next row.
LD A,L ; else fetch the key value
INC E ; test E for $FF
JR NZ,L036B ; forward if not now zero to quit
L0359: SUB $08 ; subtract 8 from key value
SRL D ; test next bit affecting zero and carry
JR NC,L0359 ; loop back until the set bit is found.
LD E,A ; transfer key value to E.
JR NZ,L036B ; forward to abort if more than one key
; is pressed in the row.
L0362: DEC L ; decrement the key value for next row.
RLC B ; rotate the 8 counter and port address
JR NC,L036D ; skip forward when all 8 rows have
; been read.
IN A,(C) ; else read the next half-row.
JR L034F ; and back to KEY_LINE.
; ---
; ABORTKEY
L036B: LD E,$FF ; signal invalid key.
; the normal exit checks if E holds a key and not $FF.
L036D: LD A,E ; fetch possible key value.
INC A ; increment
RET Z ; return if was $FF as original.
LD HL,L0376 ; else address KEY TABLE
ADD HL,DE ; index into table.
; (D is zero)
LD A,(HL) ; pick up character.
RET ; return with translated character.
; ---------------
; THE 'KEY TABLE'
; ---------------
; -----------------------
; THE '40 UNSHIFTED KEYS'
; -----------------------
L0376: DEFB $76 ; V - v
DEFB $68 ; H - h
DEFB $79 ; Y - y
DEFB $36 ; 6 - 6
DEFB $35 ; 5 - 5
DEFB $74 ; T - t
DEFB $67 ; G - g
DEFB $63 ; C - c
DEFB $62 ; B - b
DEFB $6A ; J - j
DEFB $75 ; U - u
DEFB $37 ; 7 - 7
DEFB $34 ; 4 - 4
DEFB $72 ; R - r
DEFB $66 ; F - f
DEFB $78 ; X - x
DEFB $6E ; N - n
DEFB $6B ; K - k
DEFB $69 ; I - i
DEFB $38 ; 8 - 8
DEFB $33 ; 3 - 3
DEFB $65 ; E - e
DEFB $64 ; D - d
DEFB $7A ; Z - z
DEFB $6D ; M - m
DEFB $6C ; L - l
DEFB $6F ; O - o
DEFB $39 ; 9 - 9
DEFB $32 ; 2 - 2
DEFB $77 ; W - w
DEFB $73 ; S - s
DEFB $00 ; SYMBOL
DEFB $20 ; SPACE
DEFB $0D ; ENTER
DEFB $70 ; P - p
DEFB $30 ; 0 - 0
DEFB $31 ; 1 - 1
DEFB $71 ; Q - q
DEFB $61 ; A - a
DEFB $00 ; SHIFT
; ---------------------
; THE '40 SHIFTED KEYS'
; ---------------------
DEFB $56 ; V - V
DEFB $48 ; H - H
DEFB $59 ; Y - Y
DEFB $07 ; 6 - 7 KEY-UP
DEFB $01 ; 5 - 1 KEY-LEFT
DEFB $54 ;
DEFB $47
DEFB $43
DEFB $42
DEFB $4A
DEFB $55
DEFB $09 ; 7 - 9 KEY-DOWN
DEFB $08 ; 4 - 8 INV-VIDEO
DEFB $52
DEFB $46
DEFB $58
DEFB $4E
DEFB $4B
DEFB $49
DEFB $03 ; 8 - 3 KEY-RIGHT
DEFB $33 ; 3 - 3
DEFB $45
DEFB $44
DEFB $5A
DEFB $4D
DEFB $4C
DEFB $4F
DEFB $04 ; 9 - 4 GRAPH
DEFB $02 ; 2 - 2 CAPS LOCK
DEFB $57 ; W - W
DEFB $53 ; S - S
DEFB $00 ; SYMB
DEFB $20 ; SPACE
DEFB $0D ; ENTER
DEFB $50 ; P - P
DEFB $05 ; 0 - 5 DEL
DEFB $0A ; 1 - 0A DEL_LINE
DEFB $51 ; Q - Q
DEFB $41 ; A - A
DEFB $00 ; SHIFT
; --------------------------
; THE '40 SYMBOL SHIFT KEYS'
; --------------------------
DEFB $2F ; V - /
DEFB $5E ; H - ^
DEFB $5B ; Y - [
DEFB $26 ; 6 - &
DEFB $25 ; 5 - %
DEFB $3E ; T - >
DEFB $7D ;
DEFB $3F
DEFB $2A
DEFB $2D
DEFB $5D
DEFB $27
DEFB $24
DEFB $3C
DEFB $7B
DEFB $60
DEFB $2C
DEFB $2B
DEFB $7F
DEFB $28
DEFB $23
DEFB $45
DEFB $5C
DEFB $3A
DEFB $2E
DEFB $3D
DEFB $3B
DEFB $29
DEFB $40 ; 2 - @
DEFB $57 ; W - W
DEFB $7C ; S
DEFB $00 ; SYMB
DEFB $20 ; SPACE
DEFB $0D ; ENTER
DEFB $22 ; P - "
DEFB $5F ; 0 - _
DEFB $21 ; 1 - !
DEFB $51 ; Q - Q
DEFB $7E ; A - ~
DEFB $00 ; SHIFT
; end of key tables
; ---------------------------
; THE 'PRINT ROUTINE' Part 2.
; ---------------------------
; If output is not directed into the input buffer then jump forward else
; call the routine to output to lower screen.
L03EE: JR Z,L03F5 ; forward to main screen print.
CALL L017E ; PR_LOWER
EXX ; restore main set
RET ; return. >>
; the print output is not directed to the input buffer but first check that
; the user has not set up a vector to their own routine to print characters
; for instance to a printer.
L03F5: LD B,A ; save the character in the B register.
LD HL,($3C29) ; fetch possible vector from EXWRCH
; (normally 0)
LD A,H ; test for
OR L ; the value zero.
LD A,B ; fetch the character back to A.
JR Z,L03FF ; skip forward if no user-supplied
; routine.
L03FE: JP (HL) ; else jump to user-supplied routine
; which should finish with a JP (IY)
; ---
; 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 ; |