; 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 (c) 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 L