;**************************************************************** ;* * ;* ROM OF THE JUPITER ACE * ;* * ;**************************************************************** ;* * ;* 1996-09-23 BODO WENZEL DISASSEMBLED AND COMMENTED * ;* 2008-06-03 KIO CLEANED AND TRANSLATED * ;* 2008-06-12 KIO LAST CHANGE * ;* * ;**************************************************************** #target rom ;================================================================ ; Constants ; Character codes KLT EQU 001H ; cursor left LOK EQU 002H ; CAPS LOCK KRT EQU 003H ; cursor right GFX EQU 004H ; graphics CDL EQU 005H ; delete character KUP EQU 007H ; cursor up INV EQU 008H ; inverted KDN EQU 009H ; cursor down LDL EQU 00AH ; clear line CCR EQU 00DH ; go to line end PND EQU 060H ; pound sterling CPR EQU 07FH ; COPYRIGHT CINV EQU 080H ; bit for inverted character CLAST EQU 080H ; bit for last character of text string IMM EQU 040H ; immediate word SAFETY EQU 12 ; minimum space for argument stack FSIGN EQU 080H ; float sign FEOFFS EQU 040H ; float exponent offset ;================================================================ ; input and output, only address bit A0 is decoded by the hardware IO EQU 0FEH ; input resets speaker FF ; D0..4 keys from selected keyboard row ; row: A15..A8 ; D5 casette recorder EAR-IN ; output sets speaker FF ; D3 cassette recorder MIC-OUT ;================================================================ ; 1K video ram ; ; character rows: 24 + 4/7 + 1 + 4/7 (60/50 HZ) ; characters: 32 + 8 + 4 + 8 ; screen + lower border + vsync + upper border SCREEN EQU 02400H ; 24 rows à 32 characters SCREND EQU SCREEN+24*32 PADMEM EQU 02701H ; scratch FPADMEM EQU PADMEM & ~0400h ; no wait states SCRMEND EQU 02800H ; end ;================================================================ ; 1K character ram CHRSET EQU 02C00H ; 128 characters à 8 bytes ;================================================================ ; main memory: min. 1K; up to 49K MEMBEG EQU 03C00H ; start of ram address FPWS EQU 03C00H ; scratch for floating point calculations LISTWS EQU 03C13H LPICNT EQU 03C13H ; LIST/EDIT word counter LPIBUF EQU 03C14H ; LIST/EDIT indent buffer LPIACT EQU 03C15H ; LIST/EDIT indent current LPLCNT EQU 03C16H ; LIST/EDIT line counter RAMTOP EQU 03C18H ; end of ram +1 address HLD EQU 03C1AH ; pointer during "#" SCRPOS EQU 03C1CH ; output field cursor INSCRN EQU 03C1EH ; input field start CURSOR EQU 03C20H ; input field cursor ENDBUF EQU 03C22H ; input field end RAMVAR EQU 03C24H ; initialised starting from here ------- LHALF EQU 03C24H ; output field end KEYCOD EQU 03C26H ; pressed key KEYCNT EQU 03C27H ; timer STATIN EQU 03C28H ; 0 release input ; 1 caps lock ; 2 graphics ; 3 inverse ; 5 "ENTER" pressed EXWRCH EQU 03C29H ; alternative output FRAMES EQU 03C2BH ; VSYNC counter XCOORD EQU 03C2FH ; PLOT coordinates YCOORD EQU 03C30H ; VCURRENT EQU 03C31H ; address of current dictionary VCONTEXT EQU 03C33H ; address of searched dict. VOCLNK EQU 03C35H ; address of last dict. STKBOT EQU 03C37H ; address of free ram DICT EQU 03C39H ; pointer in dict. SPARE EQU 03C3BH ; pointer to argument stack ((WERTESTACK)) ERRNO EQU 03C3DH ; error number FLAGS EQU 03C3EH ; 2 compile mode ; 3 edit mode ; 4 invisible input ; 6 compiler ("[","]") VBASE EQU 03C3FH ; number base DICT1ST EQU 03C40H ; dictionary "FORTH" ;================================================================ ; Structures: ; ; Dictionary: ; DB... name (ASCII), last character flagged with bit 7 set ; DW link to previous dict. ; DW last address ; DB name length ; DW,DW Forth words for switching ; DB always 0 ; DW first address ; ; Rom words: ; DB... name (ASCII), last character flagged with bit 7 set ; DW link to previous word ; DB name length ; DW first code address ; ... more data ; ; Ram words: ; DB... name (ASCII), last character flagged with bit 7 set ; DW byte offset to end of word ; DW link to previous word ; DB name length (bit 6 = "immediate") ; DW first code address ; ... more data ; ; floating point numbers: ; 3 bytes mantissa BCD ; 1 byte exponent, offset 40H, bit 7=mantissa sign ; ;================================================================ ; Error numbers ERRNONE EQU -1 ; ok ERRMEM EQU 1 ; out of memory ERRSTK EQU 2 ; stack underflow ERRBRK EQU 3 ; user breaked ERRIMM EQU 4 ; immediate mode in interpreting mode ERRBLK EQU 5 ; nesting error (e.g. "IF" - "ENDIF") ERRNAME EQU 6 ; name too long for "CRHEADER" ERRPICK EQU 7 ; bad stack offset (e.g. "PICK") ERRFLT EQU 8 ; float overflow ERRAT EQU 9 ; error in "AT" ERRREAD EQU 10 ; error in "?READ" or "?VERIFY" ERRDICT EQU 11 ; error in dict. in "REDEFINE" & "FORGET" ERRMODE EQU 12 ; compile mode in "LINKHERE" ERRFIND EQU 13 ; word not found ERRLIST EQU 14 ; word can't be listed in "LIST" ;================================================================ ; RESET ORG 00000H DI ; disable interrupts LD HL,MEMBEG LD A,0FCH ; test value and mask JR RMEMLP ;================================================================ ; print one character ORG 00008H RSTEMIT: EXX BIT 3,(IX+FLAGS-MEMBEG) JP REMIT ;================================================================ ; push value in DE on argument stack ORG 00010H RSTPUSH: LD HL,(SPARE) LD (HL),E INC HL JP RPUSH ;================================================================ ; pop value from argument stack to DE ORG 00018H RSTPULL: LD HL,(SPARE) DEC HL LD D,(HL) JP RPULL ;================================================================ ; display error ORG 00020H RSTERR: POP HL LD A,(HL) LD (ERRNO),A ; fetch error number JP RABORT ;================================================================ RMEMLP: INC H LD (HL),A CP (HL) JR Z,RMEMLP ; search ram end AND H LD H,A ; only full kbytes LD (RAMTOP),HL ; store ram end address LD SP,HL ; initialise stack pointer LD HL,ROMVAR JR RGOON ;================================================================ ; VSYNC interrupt ORG 00038H JP VSYNC ;================================================================ RGOON: LD DE,RAMVAR LD BC,ROMVEND-ROMVAR LDIR ; preset variables LD IX,MEMBEG LD IY,RSLNEXT ; set pointer CALL CCLS XOR A LD (SCREEN+24*32),A ; set screen end marker ;---------------------------------------------------------------- LD HL,CHRSET RGFXLP: LD A,L AND 0BFH ; 4 block graphic sets RRCA RRCA ; XX0000XX 00 RRCA ; XX0001XX 00 JR NC,RGFXM ; XX0010XX 0F RRCA ; XX0011XX 00 RRCA ; XX0100XX F0 RGFXM: ; XX0101XX 00 RRCA ; XX0110XX FF LD B,A ; XX0111XX 00 SBC A,A ; XX1000XX 00 RR B ; XX1001XX 0F LD B,A ; XX1010XX 0F SBC A,A ; XX1011XX 0F XOR B ; XX1100XX F0 AND 0F0H ; XX1101XX 0F XOR B ; XX1110XX FF LD (HL),A ; XX1111XX 0F INC L JR NZ,RGFXLP ; more graphic symbols? LD DE,CHRSET+128*8-1 LD HL,ROMCHR-1 LD BC,8 ; 8 rows LDDR ; copyright sign EX DE,HL LD A,128-020H-1 ; count of remaining characters RCHRLP: LD C,7 ; 7 rows BIT 5,A JR Z,RCHR7 ; character with 7 rows? LD (HL),B DEC HL DEC C ; bottom row is background only RCHR7: EX DE,HL LDDR ; copy glyph EX DE,HL LD (HL),B DEC HL ; top row is background only DEC A JR NZ,RCHRLP ; more characters? IM 1 ; set interrupt mode for VSYNC: RST 38H JR RQUIT ;================================================================ DB 'QUI','T' | CLAST DW 0 DB 4 QUIT: DW $+2 RQUIT: LD SP,(RAMTOP) ; restore stack pointer EI ; enable interrupt JP QUITLOOP ; doit! ;================================================================ DB 'ABOR','T' | CLAST DW QUIT-1 DB 5 ABORT: DW $+2 RABORT: PUSH IY LD IY,NEXT ; standard error checking LD HL,(STKBOT) LD (SPARE),HL ; reset data stack LD HL,FLAGS LD A,(HL) AND NOT ((1 SHL 6) OR (1 SHL 3) OR (1 SHL 2)) BIT 2,(HL) LD (HL),A ; switch off compiler and editor JR Z,ABGOON ; not in compiler mode? CALL NEXT DW DP,AT,GETBYTE DB 5 DW PLUS,DUP,RESCURR ; reset 'CURRENT' DW NFA,GETWORD,STKBOT DW EXCLAM ; reset stack DW SEMICODE ABGOON: BIT 7,(IX+ERRNO-MEMBEG) JR NZ,ABORTEND ; no error set? CALL ROMTXT DB 'ERRO','R' | CLAST CALL NEXT DW GETWORD,ERRNO,CAT,PNT,CR DW SEMICODE ; display error LD (IX+ERRNO-MEMBEG),ERRNONE ; no more error ABORTEND: LD HL,(STKBOT) LD BC,SAFETY ADD HL,BC LD (SPARE),HL POP IY JR RQUIT ;================================================================ ROMVAR: DW SCREEN+23*32 ;LHALF DB 0,0 ;KEYCOD DB 0 ;STATIN DW 0 ;EXWRCH DB 0,0,0,0 ;FRAMES DB 0,0 ;XCOORD/YCOORD DW FORTH+2+RAMVAR-ROMVAR ;VCURRENT DW FORTH+2+RAMVAR-ROMVAR ;VCONTEXT DW FORTH+5+RAMVAR-ROMVAR ;VOCLNK DW FREEMEM ;STKBOT DW FORTH-5+RAMVAR-ROMVAR ;DICT DW FREEMEM+SAFETY ;SPARE DB -1 ;ERRNO DB 0 ;FLAGS DB 10 ;VBASE DB 'FORT','H' | CLAST ;DICT1ST DW 0000H,1FFFH DB 5 FORTH: DW SETCONTEXT DW FORTH-1+RAMVAR-ROMVAR ; FORTH IS CONTEXT DB 0 DW 0 ROMVEND: FREEMEM EQU ROMVEND+RAMVAR-ROMVAR ; free ram ;================================================================ VSYNC: PUSH AF EX AF,AF' PUSH AF PUSH BC PUSH DE PUSH HL ; save registers LD B,62 VDELAY: DJNZ VDELAY ; wait some time: the interrupt signal ; remains active for 1 character row == 1/39 frame !! LD HL,FRAMES VSCNT: INC (HL) INC HL JR Z,VSCNT ; increment VSYNC counter CALL VKEY ; get key with auto repeat LD HL,STATIN BIT 0,(HL) JR Z,VSEND ; input disabled? AND A JR Z,VSEND ; no key pressed? CP ' ' JR C,VSCTRL ; control code? BIT 1,(HL) CALL NZ,TOUPPER ; "CAPS LOCK" ? BIT 2,(HL) JR Z,VSNOGRF AND 09FH ; "GRAPHICS" ? VSNOGRF: BIT 3,(HL) JR Z,VSNOINV OR CINV ; "INVERSE" ? VSNOINV: CALL DCDCNORM ; printable character VSCTRL: CALL DOCTRL ; control code CALL DCSETCUR ; locate cursor VSEND: POP HL POP DE POP BC POP AF EX AF,AF' POP AF ; restore registers EI ; re-enable interrupts RET ; return to interrupted programme ;================================================================ DCDOCHAR: CP CCR JR NZ,DCDCNORM ; not "ENTER" ? LD HL,SCREEN+24*32 LD (ENDBUF),HL LD (CURSOR),HL ; move cursor to frame end XOR A CALL DCDCINS ; set new input end LD HL,SCREEN+23*32 LD (INSCRN),HL ; one line input RET DCDCNORM: AND A RET Z ; no key? DCDCINS: EX AF,AF' ; remember character LD HL,(ENDBUF) LD A,(HL) AND A JR Z,DCDCSCROL LD DE,-(SCREEN+24*32) ADD HL,DE JR NC,DCDCEND ; input end before screen end? DCDCSCROL: LD DE,(LHALF) LD HL,-(SCREEN+3*32) ADD HL,DE JR NC,DCDCQUIT ; output end within first 3 lines? LD HL,(SCRPOS) LD BC,32 ADD HL,BC SBC HL,DE PUSH DE CALL NC,SCROLLUP ; output cursor in last line? CALL DCSTREND POP DE CALL INSLINE ; scroll up input LD HL,INSCRN LD B,4 ; 4 times DCDCSLOOP: CALL DECLINE DJNZ DCDCSLOOP ; scroll up input start DCDCEND: CALL DCGETCIN LD D,H LD E,L INC HL LD (ENDBUF),HL ; scroll input end DEC HL DEC HL JR Z,DCDCSTORE ; input cursor at end? LDDR ; shift remaining input DCDCSTORE: EX AF,AF' LD (DE),A ; store character INC DE LD (CURSOR),DE ; store new input address DCDCQUIT: XOR A ; set Z flag, no more chacters RET ;================================================================ DOCTRL: LD HL,DCJMPTAB LD D,0 LD E,A ADD HL,DE ; pointer to table entry LD E,(HL) ADD HL,DE JP (HL) ; jump to address DCJMPTAB: DB DCNOP-$ ; 0 (no key) DB DCLEFT-$ ; 1 cursor left DB DCFLAG-$ ; 2 caps lock DB DCRIGHT-$ ; 3 cursor right DB DCFLAG-$ ; 4 graphic symbol DB DCCHARDEL-$ ; 5 delete character DB DCNOP-$ ; 6 (unused) DB DCUP-$ ; 7 cursor up DB DCFLAG-$ ; 8 inverted DB DCDOWN-$ ; 9 cursor down DB DCLINEDEL-$ ; A clear line DB DCNOP-$ ; B (unused) DB DCNOP-$ ; C (unused) DB DCENTER-$ ; D end of line ;---------------------------------------------------------------- DCFLAG: LD HL,STATIN XOR (HL) LD (HL),A ; toggle flag RET ;---------------------------------------------------------------- DCLEFT: LD HL,(CURSOR) DEC HL LD A,(HL) AND A RET Z ; at input start? LD (CURSOR),HL ; store new address INC HL LD (HL),A ; move character DCNOP: RET ;---------------------------------------------------------------- DCRIGHT: LD HL,(CURSOR) INC HL LD DE,(ENDBUF) AND A SBC HL,DE RET Z ; at input end? ADD HL,DE LD (CURSOR),HL ; store new address LD A,(HL) DEC HL LD (HL),A ; move character RET ;---------------------------------------------------------------- DCCURDEL: LD HL,(CURSOR) INC HL LD (CURSOR),HL ; increment input address DCCHARDEL: CALL DCGETCIN LD H,D LD L,E DEC DE LD A,(DE) AND A RET Z ; at input start? LD (CURSOR),DE LD A,B OR C JR Z,DCCDGOON ; at input end? LDIR ; delete character to the left DCCDGOON: DEC HL LD (HL),' ' ; delete last character LD (ENDBUF),HL ; (superfluxuous?) INC C ; clear Z flag RET ;---------------------------------------------------------------- DCUP: CALL DCLEFT JR Z,DCUSCROLL ; at input start? LD B,31 DCUPLOOP: CALL DCLEFT DJNZ DCUPLOOP ; at most one line back RET DCUSCROLL: LD HL,(INSCRN) LD DE,(LHALF) AND A SBC HL,DE RET Z ; input start at output end? CALL DCCURDEL LD HL,(INSCRN) LD DE,-32 XOR A DCUSLOOP: ADD HL,DE CP (HL) JR NZ,DCUSLOOP ; search next tag LD (INSCRN),HL CALL DCSETEND LD (CURSOR),HL ; store new input end ;---------------------------------------------------------------- DCOUTCUR: LD A,' ' OR CINV CALL DCDOCHAR ; print cursor blob LD HL,(CURSOR) DEC HL LD (CURSOR),HL ; update address DCSETCUR: LD HL,(CURSOR) LD A,(STATIN) RRA LD (HL),017H OR CINV ; "NORMAL" RRA JR NC,SCNOCAPS LD (HL),'C' OR CINV ; "CAPS LOCK" SCNOCAPS: RRA RET NC LD (HL),'G' OR CINV ; "GRAFIK" RET ;---------------------------------------------------------------- DCDOWN: CALL DCRIGHT JR Z,DCDSCROLL ; at input end? LD B,31 DCDNLOOP: CALL DCRIGHT DJNZ DCDNLOOP ; at most one line down RET DCDSCROLL: CALL DCSTREND RET PO ; end found? PUSH HL CALL DCCURDEL POP HL CALL DCSETBEG ; store new input start JR DCOUTCUR ;---------------------------------------------------------------- DCSTREND: LD HL,SCREEN+24*32 LD DE,(INSCRN) AND A SBC HL,DE LD B,H LD C,L ; calculate count EX DE,HL INC HL ; pointer behind start XOR A CPIR ; search end of text DEC HL ; back one charatcer RET ;---------------------------------------------------------------- DCLINEDEL: LD HL,(ENDBUF) DEC HL LD (CURSOR),HL ; pointer to input end DCLDLOOP: CALL DCCHARDEL JR NZ,DCLDLOOP ; clear to start RET ;---------------------------------------------------------------- DCENTER: LD HL,STATIN SET 5,(HL) ; print "ENTER" RES 0,(HL) ; disable input RET ;---------------------------------------------------------------- DCCLEAR: LD HL,SCREEN+24*32 LD DE,(LHALF) CALL BLANKS ; clear input area LD HL,SCREEN+23*32 LD (LHALF),HL LD (HL),0 ; set text end marker DCRETYPE: LD HL,(LHALF) DCSETBEG: LD (INSCRN),HL ; store input start INC HL LD (CURSOR),HL ; store cursor address DCSETEND: CALL DCSTREND LD A,' ' DCSELOOP: DEC HL CP (HL) JR Z,DCSELOOP ; search input end INC HL LD (ENDBUF),HL ; store input end RET ;---------------------------------------------------------------- DCGETCIN: LD HL,(ENDBUF) LD DE,(CURSOR) AND A SBC HL,DE LD B,H LD C,L ; calculate count ADD HL,DE ; restore pointer RET ;---------------------------------------------------------------- VKEY: CALL KEYGET LD B,A ; get pressed key LD HL,(KEYCOD) XOR L JR Z,VKAGAIN ; still same key? XOR L JR Z,VKNEW ; no key pressed? XOR A CP L RET NZ ; now different key? VKNEW: LD L,B ; save key LD H,32 ; load timer count JR VKQUIT VKAGAIN: DEC H ; decrement timer count LD A,H CP 30 JR Z,VKPRESS ; key debounced? XOR A CP H JR NZ,VKQUIT ; reached auto-repeat time? LD H,4 ; reset timer count VKPRESS: LD A,L ; get key VKQUIT: LD (KEYCOD),HL RET ;---------------------------------------------------------------- KEYGET: LD BC,IO OR (0FEH SHL 8) ; masl and address IN D,(C) ; line with "SHIFT" and "SYMBOL" LD E,D ; save SRL D SBC A,A AND -40 ; offset for "no shift" SRL D JR C,KEYGNC ; no "SYMBOL"? LD A,40 ; key count KEYGNC: ADD A,2*40+7 ; NORMAL "SHIFT" "SYMBOL" LD L,A ; 47 87 127 LD A,E OR 3 ; line without "SHIFT" and "SYMBOL" LD E,0FFH ; key not yet found KEYGLP: CPL AND 1FH LD D,A ; mask key JR Z,KEYGNK ; no key pressed? LD A,L INC E JR NZ,KEYGQU ; already key pressed? KEYGSC: SUB 8 ; adjust offset SRL D JR NC,KEYGSC ; key not yet found? LD E,A ; save offset JR NZ,KEYGQU ; one more key pressed? KEYGNK: DEC L ; adjust offset RLC B JR NC,KEYGQU2 ; keyboard completed? IN A,(C) ; get next key JR KEYGLP KEYGQU: LD E,-1 ; no key pressed KEYGQU2: LD A,E INC A RET Z ; no key pressed? LD HL,KEYTBL ADD HL,DE LD A,(HL) ; get key code RET KEYTBL: DB 'v','h','y','6','5','t','g','c' ; NORMAL DB 'b','j','u','7','4','r','f','x' DB 'n','k','i','8','3','e','d','z' DB 'm','l','o','9','2','w','s',0 DB ' ',CCR,'p','0','1','q','a',0 DB 'V','H','Y',KUP,KLT,'T','G','C' ; with "SHIFT" DB 'B','J','U',KDN,INV,'R','F','X' DB 'N','K','I',KRT,'3','E','D','Z' DB 'M','L','O',GFX,LOK,'W','S',0 DB ' ',CCR,'P',CDL,LDL,'Q','A',0 DB '/','^','[','&','%','>','}','?' ; with "SYMBOL" DB '*','-',']','''','$','<','{',PND DB ',','+',CPR,'(','#','E','\',':' DB '.','=',';',')','@','W','|',0 DB ' ',CCR,'"','_','!','Q','~',0 ;================================================================ REMIT: JR Z,RENORM ; not "EDIT" ? CALL DCDOCHAR EXX RET RENORM: LD B,A LD HL,(EXWRCH) LD A,H OR L LD A,B JR Z,EMITSCR JP (HL) ; use output vector? EMITSCR: LD HL,(SCRPOS) LD DE,(LHALF) EX DE,HL SCF SBC HL,DE EX DE,HL CALL C,SCROLLUP ; scroll up one line if needed CP CCR JR Z,ESENTER ; "ENTER" ? LD (HL),A ; store character INC HL ; next address JR ESQUIT ESENTER: INC HL LD A,L AND 32-1 JR NZ,ESENTER ; move pointer to start of next line ESQUIT: LD (SCRPOS),HL ; store cursor address EXX RET ;---------------------------------------------------------------- SCROLLUP: PUSH AF LD HL,SCRPOS CALL DECLINE ; adjust cursor address POP AF LD HL,(LHALF) LD DE,SCREEN+32 ; scroll up output area INSLINE: AND A SBC HL,DE LD B,H LD C,L ; character count LD HL,-32 ADD HL,DE EX DE,HL LDIR ; scroll screen up LD B,32 ILLOOP: DEC HL LD (HL),' ' DJNZ ILLOOP ; clear new line RET ;---------------------------------------------------------------- DECLINE: LD A,(HL) SUB 32 LD (HL),A INC HL JR NC,DLEND DEC (HL) DLEND: INC HL RET ;================================================================ GETVAR: EX DE,HL LD E,(HL) LD D,0 ; get offset LD HL,MEMBEG ADD HL,DE EX DE,HL RST RSTPUSH ; address on stack JP (IY) ;================================================================ DB 'HER','E' | CLAST DW ABORT-1 DB 4 HERE: DW $+2 LD DE,(STKBOT) RST RSTPUSH JP (IY) ;================================================================ DB 'CONTEX','T' | CLAST DW HERE-1 DB 7 CONTEXT: DW GETVAR DB VCONTEXT-MEMBEG ;================================================================ DB 'CURREN','T' | CLAST DW CONTEXT-1 DB 7 CURRENT: DW GETVAR DB VCURRENT-MEMBEG ;================================================================ DB 'BAS','E' | CLAST DW CURRENT-1 DB 4 BASE: DW GETVAR DB VBASE-MEMBEG ;================================================================ GETFLAGS: DW GETVAR DB FLAGS-MEMBEG ;================================================================ DP: DW GETVAR DB DICT-MEMBEG ;================================================================ DB 'PA','D' | CLAST DW BASE-1 DB 3 PAD: DW DOCONSTANT,PADMEM ;================================================================ NSEMICOLON: DB ';' | CLAST DW PAD-1 DB 1 OR IMM SEMICOLON: DW DOCOMPILER,SEMIS DW ASSERT DB 10 ; test test value DW SEMICODE LD HL,FLAGS LD A,(HL) AND NOT ((1 SHL 6) OR (1 SHL 2)) LD (HL),A ; switch off compiler JP (IY) ;================================================================ DB 0 DW NSEMICOLON-$-1 SEMIS: DW RSEMIS RSEMIS: POP HL ; dispose off current pointer NEXT: POP HL ; get pointer NEXTSUB: LD E,(HL) INC HL LD D,(HL) INC HL PUSH HL ; get next Forth address NEXTDE: EX DE,HL LD E,(HL) INC HL LD D,(HL) INC HL EX DE,HL JP (HL) ; jump to machine code ;================================================================ SLNEXT: DW RSLNEXT RSLNEXT: LD BC,11 LD DE,(SPARE) LD HL,(STKBOT) ADD HL,BC SBC HL,DE JR C,RSLNGOON ; still enough room between stacks? ERRORSTK: RST RSTERR DB ERRSTK RSLNGOON: LD BC,0 CALL MEMCHECK CALL USERBREAK JR NEXT ;================================================================ USERBREAK: LD A,0FEH IN A,(IO) ; read keyboard row RRA RET C ;"SHIFT" not pressed? LD A,7FH IN A,(IO) ; read keyboard row RRA RET C ;"BREAK" not pressed? BREAK: RST RSTERR DB ERRBRK ;================================================================ QUITLOOP: CALL NEXT QLLOOP: DW QUERY ; get one line DW LINE ; and interpret DW OK ; and print "OK" DW DOREPEAT,QLLOOP-$-1 ; infinite loop ;================================================================ DB 'LIN','E' | CLAST DW SEMICOLON-1 DB 4 LINE: DW DOCOL LINELOOP: DW SLNEXT ; check all DW FIND,QDUP ; search word DW DOIF,LINENUM-$-1 ; not found? DW CHKIMM ; execute word DW DOREPEAT,LINELOOP-$-1 LINENUM: DW NUMBER,QDUP ; search number DW DOIF,LINESTR-$-1 ; not found? DW CHKNUMBER ; execute number DW DOREPEAT,LINELOOP-$-1 LINESTR: DW CHKSTRING,ZEROEQ ; search text DW DOIF,LINEERR-$-1 ; not found? DW SEMIS LINEERR: DW RETYPE ; display error DW DOREPEAT,LINELOOP-$-1 ;================================================================ OK: DW $+2 LD A,(FLAGS) BIT 6,A JR NZ,OKQUIT ; is the compiler still ON? BIT 4,A JR NZ,OKQUIT ; input invisible? CALL ROMTXT DB ' OK',' ' | CLAST LD A,CCR RST RSTEMIT OKQUIT: JP (IY) ;================================================================ CHKIMM: DW $+2 RST RSTPULL ; code array address DEC DE LD A,(DE) CPL AND (IX+FLAGS-MEMBEG) AND 1 SHL 6 INC DE JR Z,CHKIQUIT ; compiler OFF or immediate? RST RSTPUSH LD DE,KOMMA CHKIQUIT: JP NEXTDE ;---------------------------------------------------------------- CHKNUMBER: DW $+2 RST RSTPULL BIT 6,(IX+FLAGS-MEMBEG) JR NZ,CHKIQUIT ; compiler ON? JP (IY) ;================================================================ DB 'RETYP','E' | CLAST DW QUERY-1 DB 6 RETYPE: DW $+2 CALL DCRETYPE CALL DCOUTCUR LD (HL),'?' OR CINV ; change cursor JR QSTART ;================================================================ DB 'QUER','Y' | CLAST DW LINE-1 DB 5 QUERY: DW $+2 CALL DCCLEAR CALL DCOUTCUR QSTART: LD HL,STATIN SET 0,(HL) ; release input RES 5,(HL) ; no "ENTER" yet QLOOP: BIT 5,(HL) JR Z,QLOOP ; wait for "ENTER" CALL DCCURDEL JP (IY) ;================================================================ DB 'WOR','D' | CLAST DW RETYPE-1 DB 4 WORD: DW $+2 RST RSTPULL ; get delimiter LD HL,SCRMEND-2 LD B,SCRMEND-SCREND-3 WCLLOOP: LD (HL),' ' DEC HL DJNZ WCLLOOP ;clear buffer PUSH DE EX DE,HL RST RSTPUSH POP DE CALL CWORD ; read text INC B DEC B JR Z,WGOON1 LD BC,255 ; limit count to 255 WGOON1: LD HL,PADMEM LD (HL),C ; store count INC HL LD A,252 CP C JR NC,WGOON2 LD C,A ;limit count WGOON2: INC C PUSH DE PUSH BC EX DE,HL LDIR ; move input POP BC POP DE DEC C CALL BLWORD ; clear input JP (IY) ;================================================================ GETSTRING: LD E,' ' ; space character is delimiter CWORD: LD HL,(LHALF) LD (INSCRN),HL LD BC,0 ; no character yet CWLOOP1: INC HL LD A,(HL) CP E JR Z,CWLOOP1 ; search start AND A JR Z,CWNFND PUSH HL ; save start CWLOOP2: INC BC ; count INC HL LD A,(HL) AND A JR Z,CWEND ;end of text? CP E JR NZ,CWLOOP2 ; search end CWEND: POP DE ; restore start XOR A CP B RET ; test for count == 256 CWNFND: PUSH DE CALL DCSTREND JP PO,CWERR ; input end found? LD DE,(LHALF) CALL BLANKS ; clear input area LD (LHALF),HL POP DE JR CWORD ; next word CWERR: EX DE,HL ; pointer to end (???) POP BC LD BC,0 SCF ; flag no success RET ;================================================================ CHKSTRING: DW $+2 CALL GETSTRING LD D,B LD E,C RST RSTPUSH JP (IY) ;================================================================ DB 'VLIS','T' | CLAST DW WORD-1 DB 5 VLIST: DW $+2 LD A,CCR RST RSTEMIT LD C,0 ; find all words JR RFIND ;================================================================ DB 'FIN','D' | CLAST DW VLIST-1 DB 4 FIND: DW $+2 CALL GETSTRING JR C,RZERO ; no word entered? RFIND: LD HL,(VCONTEXT) LD A,(HL) INC HL LD H,(HL) LD L,A ; get first pointer FLOOP: LD A,(HL) AND 3FH JR Z,FNEXT2 ; no more words? XOR C JR Z,FTEST ; same length? LD A,C AND A JR NZ,FNEXT2 ; searching one single word? FTEST: PUSH DE PUSH HL CALL PTR2NAME OR C JR Z,FPRINT ; print word immediately? LD B,C ; get word length FCOMPARE: LD A,(DE) CALL TOUPPER INC DE XOR (HL) AND NOT CLAST INC HL JR NZ,FNEXT1 ; different word? DJNZ FCOMPARE ; not yet all characters? POP DE INC DE RST RSTPUSH ; pointer to code area POP DE CALL BLWORD ; clear input if required JP (IY) FPRINT: CALL OUTTXT HALT ; wait for VSYNC CALL USERBREAK FNEXT1: POP HL POP DE FNEXT2: DEC HL LD A,(HL) DEC HL LD L,(HL) LD H,A ; next pointer OR L JR NZ,FLOOP ; not yet all words? DB 0C3H ; JP RZERO (HRM-HRM...) ;================================================================ ZERO: DW $+2 RZERO: LD DE,0 RST RSTPUSH JP (IY) ;================================================================ DB 'EXECUT','E' | CLAST DW FIND-1 DB 7 EXECUTE: DW $+2 RST RSTPULL JP NEXTDE ;================================================================ DB 'NUMBE','R' | CLAST DW EXECUTE-1 DB 6 NUMBER: DW $+2 CALL GETSTRING JR C,RZERO ; no word entered? PUSH BC PUSH DE CALL CNVINT JR NZ,NFLOAT ; no gap? LD DE,LITERAL JR NUMBERQUIT ; 16 bit integer NFLOAT: RST RSTPULL LD DE,0 RST RSTPUSH LD DE,0 OR ((FEOFFS+5) SHL 8) POP BC PUSH BC LD A,(BC) CP '-' JR NZ,NFGOON ; positive number? LD D,FSIGN OR (FEOFFS+5) INC BC NFGOON: RST RSTPUSH LD D,B LD E,C DEC HL DEC HL NFLOOP1: CALL DECGET INC HL INC (HL) DEC HL JR NC,NFLOOP1 ; convert integer portion CP '.'-'0' JR NZ,NUMBERERR ; not decimal point? NFLOOP2: CALL DECGET JR NC,NFLOOP2 ; convert fractional part ADD A,'0' CALL CNVEND JR NZ,NFEXP ; no gap? LD E,0 JR NFEGOON NFEXP: AND NOT 020H CP 'E' JR NZ,NUMBERERR ; no exponent? PUSH HL CALL CNVINT RST RSTPULL POP HL JR NZ,NUMBERERR ; no gap? NFEGOON: CALL FZEROEQ JR Z,NFQUIT ; number value = 0 ? INC HL LD A,(HL) AND 7FH ADD A,E JP M,NUMBERERR JR Z,NUMBERERR ; exponent out of range? XOR (HL) AND 7FH XOR (HL) ; keep sign LD (HL),A ; store exponent NFQUIT: LD DE,LITFLOAT NUMBERQUIT: RST RSTPUSH POP DE POP BC CALL BLWORD JP (IY) NUMBERERR: POP HL POP HL RST RSTPULL RST RSTPULL JP RZERO ;---------------------------------------------------------------- DECGET: LD A,(DE) INC DE SUB '0' RET C CP 10 CCF RET C ; character < '0' or > '9' ? DECSHIN: LD C,A LD A,(HL) AND 0F0H RET NZ ; highest digit != 0 ? LD A,C DECSTORE: DEC HL DEC HL LD C,3 DSLOOP: RLD INC HL DEC C JR NZ,DSLOOP ; lowest digit DEC (HL) DEC HL CP A RET ; inserted digit, test for 0 ;---------------------------------------------------------------- FZEROEQ: LD B,6 FZEQLP: XOR A CALL DECSHIN RET NZ ; digit != 0 found? DJNZ FZEQLP ; at most all digits INC HL LD (HL),B ; clear exponent RET ;---------------------------------------------------------------- CNVINT: RST RSTPUSH CALL NEXT DW DUP,CAT,GETBYTE DB '-' DW EQ ; negative sign? DW DUP,NEGATE,GTR DW PLUS,ONEMINUS ; update pointer DW ZERO,ZERO,ROT DW CONVERT ; convert number DW ROT,RGT,IFN0NEG ; invert sign if required DW ROT,DROP ; dispose off high word DW SWAP DW SEMICODE RST RSTPULL LD A,(DE) CNVEND: CP ' ' RET Z AND A RET ; test for gap ;================================================================ DB 'CONVER','T' | CLAST DW NUMBER-1 DB 7 CONVERT: DW DOCOL CNVTLOOP: DW ONEPLUS,DUP,GTR ; remember address DW CAT,CNVDIGIT ; convert one character DW DOIF,CNVTEND-$-1 ; no numeric character? DW SWAP DW BASE,CAT,UMUL DW DROP,ROT DW BASE,CAT,UMUL DW DPLUS ; insert number character DW RGT ; restore address DW DOREPEAT,CNVTLOOP-$-1 CNVTEND: DW RGT ; adjust stack DW SEMIS ;---------------------------------------------------------------- CNVDIGIT: DW $+2 RST RSTPULL LD A,E CALL TOUPPER ; get character ADD A,-'0' JR NC,CNVDQUIT ; character < '0' ? CP 10 JR C,CNVDOK ; character < '9' ? ADD A,'0'-'A' JR NC,CNVDQUIT ; character < 'A' ? ADD A,10 ; adjust value CNVDOK: CP (IX+VBASE-MEMBEG) JR NC,CNVDQUIT ; character too large? LD D,0 LD E,A RST RSTPUSH ; store digit SCF CNVDQUIT: JP CMPPUSH ; test store ;================================================================ BLWORD: LD H,D LD L,E ; pointer to start INC BC ADD HL,BC PUSH HL ; pointer behind separator BIT 4,(IX+FLAGS-MEMBEG) CALL Z,CTYPE ; input visible? CALL DCSTREND ; search input end POP DE AND A SBC HL,DE LD B,H LD C,L ; calculate remaining characters LD HL,(INSCRN) INC HL EX DE,HL JR C,BLANKS2 JR Z,BLANKS LDIR ; erase input ;---------------------------------------------------------------- BLANKS: AND A BLANKS2: SBC HL,DE EX DE,HL ; calculate count BLLOOP: LD A,D OR E RET Z ; everything erased? LD (HL),' ' INC HL ; erase next character DEC DE JR BLLOOP ;================================================================ TOUPPER: AND 7FH CP 'a' RET C CP 'z'+1 RET NC AND 5FH RET ;================================================================ DB 'VI','S' | CLAST DW CONVERT-1 DB 3 VIS: DW $+2 RES 4,(IX+FLAGS-MEMBEG) ; input visible JP (IY) ;================================================================ DB 'INVI','S' | CLAST DW VIS-1 DB 5 INVIS: DW $+2 SET 4,(IX+FLAGS-MEMBEG) ; input invisible JP (IY) ;================================================================ DB 'FAS','T' | CLAST DW INVIS-1 DB 4 FAST: DW $+2 LD IY,NEXT JP (IY) ;================================================================ DB 'SLO','W' | CLAST DW FAST-1 DB 4 SLOW: DW $+2 LD IY,RSLNEXT JP (IY) ;================================================================ PULLBC: LD HL,(SPARE) DEC HL LD B,(HL) DEC HL LD C,(HL) LD (SPARE),HL RET ;================================================================ RPULL: DEC HL LD E,(HL) LD (SPARE),HL RET ;================================================================ RPUSH: LD (HL),D INC HL LD (SPARE),HL RET ;================================================================ DB 'DU','P' | CLAST DW SLOW-1 DB 3 DUP: DW $+2 RST RSTPULL RST RSTPUSH RST RSTPUSH JP (IY) ;================================================================ DB 'DRO','P' | CLAST DW DUP-1 DB 4 DROP: DW $+2 RST RSTPULL JP (IY) ;================================================================ DB 'SWA','P' | CLAST DW DROP-1 DB 4 SWAP: DW $+2 RST RSTPULL CALL PULLBC RST RSTPUSH LD D,B LD E,C RST RSTPUSH JP (IY) ;================================================================ DB 'C','@' | CLAST DW SWAP-1 DB 2 CAT: DW $+2 RST RSTPULL LD A,(DE) LD E,A LD D,0 RST RSTPUSH JP (IY) ;================================================================ DB 'C','!' | CLAST DW CAT-1 DB 2 CEXCLAM: DW $+2 RST RSTPULL CALL PULLBC LD A,C LD (DE),A JP (IY) ;================================================================ DB '@' | CLAST DW CEXCLAM-1 DB 1 AT: DW $+2 RST RSTPULL EX DE,HL LD E,(HL) INC HL LD D,(HL) RST RSTPUSH JP (IY) ;================================================================ DB '!' | CLAST DW AT-1 DB 1 EXCLAM: DW $+2 RST RSTPULL CALL PULLBC EX DE,HL LD (HL),C INC HL LD (HL),B JP (IY) ;================================================================ DB '>','R' | CLAST DW EXCLAM-1 DB 2 GTR: DW $+2 RST RSTPULL POP BC PUSH DE PUSH BC JP (IY) ;================================================================ DB 'R','>' | CLAST DW GTR-1 DB 2 RGT: DW $+2 POP BC POP DE PUSH BC RST RSTPUSH JP (IY) ;================================================================ DB '?DU','P' | CLAST DW RGT-1 DB 4 QDUP: DW $+2 RST RSTPULL RST RSTPUSH LD A,D OR E CALL NZ,RSTPUSH JP (IY) ;================================================================ DB 'RO','T' | CLAST DW QDUP-1 DB 3 ROT: DW DOCOL DW GTR,SWAP,RGT,SWAP DW SEMIS ;================================================================ DB 'OVE','R' | CLAST DW ROT-1 DB 4 OVER: DW DOCOL DW GTR,DUP,RGT,SWAP DW SEMIS ;================================================================ DB 'PIC','K' | CLAST DW OVER-1 DB 4 PICK: DW $+2 CALL CPICK JP (IY) ;================================================================ DB 'ROL','L' | CLAST DW PICK-1 DB 4 ROLL: DW $+2 CALL CPICK EX DE,HL LD HL,(STKBOT) SBC HL,DE JP NC,ERRORSTK ; stack too small? LD H,D LD L,E INC HL INC HL LDIR ; move stack LD (SPARE),DE JP (IY) ;================================================================ CPICK: CALL PULLBC DEC BC SLA C RL B INC BC INC BC JR NC,CPKGOON ; offset ok? RST RSTERR DB ERRPICK CPKGOON: LD HL,(SPARE) SBC HL,BC PUSH HL LD E,(HL) INC HL LD D,(HL) RST RSTPUSH ; get value from argument stack POP HL RET ;================================================================ DB 'TYP','E' | CLAST DW ROLL-1 DB 4 TYPE: DW $+2 CALL PULLBC RST RSTPULL CALL CTYPE JP (IY) ;================================================================ TYPEDE: LD A,(DE) LD C,A INC DE LD A,(DE) LD B,A INC DE ;---------------------------------------------------------------- CTYPE: LD A,B OR C RET Z LD A,(DE) INC DE DEC BC RST RSTEMIT JR CTYPE ;================================================================ DB '<','#' | CLAST DW TYPE-1 DB 2 LTNUM: DW $+2 LD HL,SCRMEND-1 LD (HLD),HL ; prepare pointer JP (IY) ;================================================================ DB '#','>' | CLAST DW LTNUM-1 DB 2 NUMGT: DW $+2 RST RSTPULL RST RSTPULL ;clean stack LD DE,(HLD) RST RSTPUSH ; get pointer LD HL,SCRMEND-1 AND A SBC HL,DE EX DE,HL RST RSTPUSH ;calculate length JP (IY) ;================================================================ DB '.' | CLAST DW SIGN-1 DB 1 PNT: DW DOCOL DW LTNUM,DUP ; start conversion DW ABS,ZERO ; create double word DW NUMS ; convert absolute value DW ROT,SIGN ; handle sign PNTLEFT: DW NUMGT ; finish conversion DW TYPE,SPACE ; print DW SEMIS ;================================================================ DB 'U','.' | CLAST DW PNT-1 DB 2 UPNT: DW DOCOL DW ZERO,LTNUM,NUMS ; start conversion DW DOREPEAT,PNTLEFT-$-1 ;================================================================ DB '#','S' | CLAST DW UPNT-1 DB 2 NUMS: DW DOCOL NUMSLP: DW NUM ; convert one digit DW OVER,OVER,LOR,ZEROEQ DW DOUNTIL,NUMSLP-$-1 ; remainder != 0? DW SEMIS ;================================================================ DB '#' | CLAST DW NUMS-1 DB 1 NUM: DW DOCOL DW BASE,CAT,DIV32BY16,ROT ; modulo "BASE" DW NIBASC,HOLD ; store as character DW SEMIS ;================================================================ NIBASC: DW $+2 RST RSTPULL LD A,E ; get nibble ADD A,'0' CP '0'+10 JR C,NADEC ; adjustment for 'A'... ADD A,7 NADEC: LD E,A RST RSTPUSH ; store ASCII character JP (IY) ;================================================================ DB 'CL','S' | CLAST DW NUM-1 DB 3 CLS: DW $+2 CALL CCLS JP (IY) CCLS: LD DE,SCREEN+24*32-1 LD HL,(LHALF) LD BC,32 ADD HL,BC DEC HL LDDR ; last output line to screen end LD (XCOORD),BC ; clear plot position LD HL,SCREEN LD (SCRPOS),HL ; cursor home INC DE EX DE,HL LD (LHALF),HL ; set output end JP BLANKS ; erase output area ;================================================================ DB 'SIG','N' | CLAST DW NUMGT-1 DB 4 SIGN: DW $+2 RST RSTPULL RL D LD E,'-' JR C,RHOLD ; store '-' if required JP (IY) ;================================================================ DB 'HOL','D' | CLAST DW CLS-1 DB 4 HOLD: DW $+2 RST RSTPULL RHOLD: LD HL,(HLD) DEC L JR Z,HOLDQUIT ; buffer full? LD (HLD),HL LD (HL),E ; store character HOLDQUIT: JP (IY) ;================================================================ DB 'SPAC','E' | CLAST DW HOLD-1 DB 5 SPACE: DW $+2 LD A,' ' RST RSTEMIT SPACEQUIT: JP (IY) ;================================================================ DB 'SPACE','S' | CLAST DW SPACE-1 DB 6 SPACES: DW $+2 RST RSTPULL SPCLOOP: DEC DE BIT 7,D JR NZ,SPACEQUIT ; all printed? LD A,' ' RST RSTEMIT JR SPCLOOP ;================================================================ DB 'C','R' | CLAST DW SPACES-1 DB 2 CR: DW $+2 LD A,CCR RST RSTEMIT JP (IY) ;================================================================ DB 'EMI','T' | CLAST DW CR-1 DB 4 EMIT: DW $+2 RST RSTPULL LD A,E RST RSTEMIT JP (IY) ;================================================================ DB 'F','.' | CLAST DW EMIT-1 DB 2 FPNT: DW $+2 LD HL,(SPARE) DEC HL BIT 7,(HL) RES 7,(HL) JR Z,FPGOON1 LD A,'-' RST RSTEMIT ; print negative sign FPGOON1: LD E,0 ; no exponent until now LD A,(HL) DEC A CP FEOFFS+9 JR NC,FPGOON2 CP FEOFFS-4 JR NC,FPGOON3 ; no exponent required? FPGOON2: LD (HL),FEOFFS+1 INC A LD E,A ; remember exponent FPGOON3: LD A,FEOFFS SUB (HL) JR C,FPMLOOP ; exponent negative? LD B,A INC B LD A,'.' FPH0: RST RSTEMIT LD A,'0' DJNZ FPH0 ; print leading zeros FPMLOOP: LD A,'@' CP (HL) SBC A,A DEC HL OR (HL) DEC HL OR (HL) DEC HL OR (HL) INC HL INC HL JR Z,FP0 ; number = 0? XOR A CALL DECSTORE ADD A,'0' RST RSTEMIT ; print next numeric character INC HL LD A,(HL) CP FEOFFS JR NZ,FPMLOOP ; value < 0.1 or value >= 1.0 ? LD A,'.' RST RSTEMIT JR FPMLOOP ; print decimal point FP0: LD A,E AND A JR NZ,FPEXP ; exponent must be printed? LD A,' ' RST RSTEMIT JR FPQUIT FPEXP: SUB FEOFFS+1 LD L,A SBC A,A LD H,A LD A,'E' RST RSTEMIT CALL PNTHL ; print exponent FPQUIT: RST RSTPULL RST RSTPULL JP (IY) ;================================================================ DB 'A','T' | CLAST DW FPNT-1 DB 2 ATPOS: DW $+2 RST RSTPULL ; column CALL PULLBC ; row LD A,C CALL CATPOS LD (SCRPOS),HL JP (IY) CATPOS: ADD A,32 LD L,A LD H,1 ; screen / 32 ADD HL,HL ADD HL,HL ADD HL,HL ADD HL,HL ADD HL,HL ; screen + row LD D,0 LD A,E AND 1FH LD E,A ADD HL,DE ; screen + row + column LD DE,(LHALF) SBC HL,DE ADD HL,DE RET C ; not behind output area? RST RSTERR DB ERRAT ;================================================================ DB 'PLO','T' | CLAST DW ATPOS-1 DB 4 PLOT: DW $+2 CALL PULLBC ; 0/1/2/3 = RES/SET/NOP/XOR RST RSTPULL ; y position LD (IX+YCOORD-MEMBEG),E SRL E RL C ;LSB of Y LD A,22 SUB E ; Y position as line number RST RSTPULL ; X position LD (IX+XCOORD-MEMBEG),E SRL E RL C ;LSB of X CALL CATPOS ; pointer in screen LD A,(HL) ; get current character AND 78H CP 10H LD A,(HL) JR Z,PLGOON ; already a graphics character? LD A,10H ; empty graphics character PLGOON: LD E,A ; remember initial character code LD D,87H ; set mask LD A,C AND 3 LD B,A JR Z,PLX0Y0 ; X=0 and Y=0 ? CPL ADD A,2 ADC A,3 LD D,A LD B,E ; bit masks for X!=0 and Y!=0 PLX0Y0: LD A,C RRCA RRCA RRCA SBC A,A ; clear or set mask BIT 3,C JR NZ,PLXOR ; NOP/XOR ? XOR E RLCA SBC A,A XOR B ; prepare clear/set PLXOR: AND D XOR E LD (HL),A ; store new character code JP (IY) ;================================================================ DB 'BEE','P' | CLAST DW PLOT-1 DB 4 BEEP: DW DOCOL DW OVER,GETBYTE DB 125 DW SWAP,MULDIV ; adjust value DW SEMICODE RST RSTPULL CALL PULLBC LD HL,250-1 ADD HL,BC INC L ; (rounding?) DI BLOOP: LD A,7FH IN A,(IO) RRCA JR NC,BDBREAK ; breaked? CALL BEEPDELAY DEC DE LD A,D OUT (IO),A CALL BEEPDELAY OR E JP NZ,BLOOP ; duration not yet expired? EI JP (IY) BDBREAK: RST RSTERR DB ERRBRK BEEPDELAY: LD B,L LD C,H BDLOOP: DJNZ BDLOOP DEC B DEC C JP NZ,BDLOOP ; wait a moment... RET ;================================================================ DB 'INKE','Y' | CLAST DW BEEP-1 DB 5 INKEY: DW $+2 CALL KEYGET LD E,A LD D,0 RST RSTPUSH JP (IY) ;================================================================ DB 'I','N' | CLAST DW INKEY-1 DB 2 IN: DW $+2 CALL PULLBC LD D,0 IN E,(C) RST RSTPUSH JP (IY) ;================================================================ DB 'OU','T' | CLAST DW IN-1 DB 3 OUT: DW $+2 CALL PULLBC RST RSTPULL OUT (C),E JP (IY) ;================================================================ DB 'AB','S' | CLAST DW OUT-1 DB 3 ABS: DW DOCOL DW DUP,IFN0NEG DW SEMIS ;================================================================ DB '0','=' | CLAST DW ABS-1 DB 2 ZEROEQ: DW $+2 RST RSTPULL LD A,D OR E CP 1 ;C, if A=0 CMPPUSH: LD A,0 LD D,A RLA LD E,A RST RSTPUSH ; if C, then value = 1, else 0 JP (IY) ;================================================================ DB '0','<' | CLAST DW ZEROEQ-1 DB 2 ZEROLT: DW $+2 RST RSTPULL RL D ; get number sign JR CMPPUSH ;================================================================ DB '0','>' | CLAST DW ZEROLT-1 DB 2 ZEROGT: DW $+2 RST RSTPULL LD A,D OR E JR Z,CMPPUSH ; = 0 ? RL D CCF JR CMPPUSH ;get inverted number sign ;================================================================ DB '=' | CLAST DW ZEROGT-1 DB 1 EQ: DW DOCOL DW MINUS,ZEROEQ DW SEMIS ;================================================================ DB '>' | CLAST DW EQ-1 DB 1 GT: DW $+2 RST RSTPULL PUSH DE RST RSTPULL POP HL CALL GREATER JR CMPPUSH ;================================================================ DB '<' | CLAST DW GT-1 DB 1 LT: DW DOCOL DW SWAP,GT DW SEMIS ;================================================================ DB 'U','<' | CLAST DW LT-1 DB 2 ULT: DW $+2 CALL PULLBC UCMP: RST RSTPULL EX DE,HL AND A SBC HL,BC ; C = (BC > HL) JR CMPPUSH ;================================================================ DB 'D','<' | CLAST DW ULT-1 DB 2 DLT: DW $+2 RST RSTPULL PUSH DE CALL PULLBC RST RSTPULL POP HL AND A SBC HL,DE JR Z,UCMP ; upper words equal? ADD HL,DE EX DE,HL CALL GREATER ; compare only upper words RST RSTPULL JR CMPPUSH ;================================================================ GREATER: LD A,H XOR D JP M,GRTRQUIT ; different number sign? SBC HL,DE GRTRQUIT: RL H ; number sign in C RET ;================================================================ DB 'U','*' | CLAST DW DLT-1 DB 2 UMUL: DW $+2 RST RSTPULL CALL PULLBC LD HL,0 LD A,16 ; set bit counter UMULLOOP: ADD HL,HL EX DE,HL ADC HL,HL EX DE,HL JR NC,UMULNEXT ; multiplicator bit = 0 ? ADD HL,BC JR NC,UMULNEXT ; no overflow? INC DE UMULNEXT: DEC A JR NZ,UMULLOOP ; not yet all bits? EX DE,HL JR PUSHDEHL ;================================================================ DIV32BY16: DW $+2 RST RSTPULL ; divisor EXX RST RSTPULL ; dividend H PUSH DE RST RSTPULL ; dividend L POP HL LD A,H OR L LD A,33 ; usual bit counter JR NZ,D32GOON ; dividend > 65535? EX DE,HL LD A,17 ; shorten calculation D32GOON: EXX LD B,A XOR A LD H,A LD L,A LD C,A ; prepare calculation D32LOOP: ADC HL,HL SBC A,A AND A SBC HL,DE ; test subtraction SBC A,C JR NC,D32NEXT ADD HL,DE ; undo subtraction D32NEXT: CCF EXX EX DE,HL ADC HL,HL EX DE,HL ADC HL,HL EXX DJNZ D32LOOP ; not yet all bits? EX DE,HL RST RSTPUSH ; store remainder EXX ; get quotient PUSHDEHL: PUSH HL RST RSTPUSH POP DE RST RSTPUSH JP (IY) ;================================================================ DB '/MO','D' | CLAST DW UMUL-1 DB 4 DIVMOD: DW DOCOL DW SWAP,GTR,I,ABS ; prepare dividend DW GETBYTE DB 0 DIVMOD2: DW ROT,DUP,I DW LXOR ; calculate number sign DW GTR,ABS ; prepare divisor DW UDIVMOD DW RGT,IFN0NEG,SWAP ; number sign of quotient DW RGT,IFN0NEG,SWAP ; number sign of remainder DW SEMIS ;================================================================ DB '*/MO','D' | CLAST DW DIVMOD-1 DB 5 MULDIVMOD: DW DOCOL DW ROT,GTR,I,ABS ; prepare first multiplier DW ROT,DUP,RGT,LXOR ; calculate number sign DW GTR,ABS ; prepare second multiplier DW UMUL DW DOREPEAT,DIVMOD2-$-1 ;================================================================ DB '/' | CLAST DW MULDIVMOD-1 DB 1 DIV: DW DOCOL DW DIVMOD DW SWAP,DROP ; clear remainder DW SEMIS ;================================================================ DB 'MO','D' | CLAST DW DIV-1 DB 3 MOD: DW DOCOL DW DIVMOD DW DROP ; clear quotient DW SEMIS ;================================================================ DB '*' | CLAST DW MOD-1 DB 1 MUL: DW DOCOL DW UMUL,DROP ; clear upper word DW SEMIS ;================================================================ DB '*','/' | CLAST DW MUL-1 DB 2 MULDIV: DW DOCOL DW MULDIVMOD ; */MOD DW SWAP,DROP ; clear remainder DW SEMIS ;================================================================ DB 'U/MO','D' | CLAST DW MULDIV-1 DB 5 UDIVMOD: DW DOCOL DW DIV32BY16,DROP DW SEMIS ;================================================================ IFN0NEG: DW DOCOL DW ZEROLT,DOIF,I0NEND-$-1 DW NEGATE ; same sign as TOS I0NEND: DW SEMIS ;================================================================ DB 'NEGAT','E' | CLAST DW UDIVMOD-1 DB 6 NEGATE: DW $+2 LD BC,2 ; 2 bytes JR DONEGATE ;================================================================ DB 'DNEGAT','E' | CLAST DW NEGATE-1 DB 7 DNEGATE: DW $+2 LD BC,4 ; 4 bytes DONEGATE: LD HL,(SPARE) AND A SBC HL,BC ; pointer to number in value stack DNLOOP: LD A,B ; load 0, don't clear C SBC A,(HL) LD (HL),A ; negate byte INC HL DEC C JR NZ,DNLOOP ; not yet all bytes? JP (IY) ;================================================================ DB '+' | CLAST DW DNEGATE-1 DB 1 PLUS: DW $+2 RST RSTPULL PUSH DE RST RSTPULL POP HL ADD HL,DE EX DE,HL RST RSTPUSH JP (IY) ;================================================================ DB '-' | CLAST DW PLUS-1 DB 1 MINUS: DW DOCOL DW NEGATE,PLUS DW SEMIS ;================================================================ DB 'D','+' | CLAST DW MINUS-1 DB 2 DPLUS: DW $+2 RST RSTPULL PUSH DE CALL PULLBC RST RSTPULL PUSH DE RST RSTPULL EX DE,HL ADD HL,BC EX DE,HL RST RSTPUSH POP BC POP HL ADC HL,BC EX DE,HL RST RSTPUSH JP (IY) ;================================================================ DB '1','+' | CLAST DW DPLUS-1 DB 2 ONEPLUS: DW $+2 RST RSTPULL JR XPLUS ;================================================================ DB '2','+' | CLAST DW ONEPLUS-1 DB 2 TWOPLUS: DW $+2 RST RSTPULL INC DE XPLUS: INC DE JR XPLUSMINUS ;================================================================ DB '1','-' | CLAST DW TWOPLUS-1 DB 2 ONEMINUS: DW $+2 RST RSTPULL JR XMINUS ;================================================================ DB '2','-' | CLAST DW ONEMINUS-1 DB 2 TWOMINUS: DW $+2 RST RSTPULL DEC DE XMINUS: DEC DE XPLUSMINUS: RST RSTPUSH JP (IY) ;================================================================ DB 'O','R' | CLAST DW TWOMINUS-1 DB 2 LOR: DW $+2 RST RSTPULL CALL PULLBC LD A,E OR C LD E,A LD A,D OR B LD D,A RST RSTPUSH JP (IY) ;================================================================ DB 'AN','D' | CLAST DW LOR-1 DB 3 LAND: DW $+2 RST RSTPULL CALL PULLBC LD A,E AND C LD E,A LD A,D AND B LD D,A RST RSTPUSH JP (IY) ;================================================================ DB 'XO','R' | CLAST DW LAND-1 DB 3 LXOR: DW $+2 RST RSTPULL CALL PULLBC LD A,E XOR C LD E,A LD A,D XOR B LD D,A RST RSTPUSH JP (IY) ;================================================================ DB 'MA','X' | CLAST DW LXOR-1 DB 3 MAX: DW DOCOL DW OVER,OVER,LT ; compare numbers DW DOELSE,MINMAX-$-1 ;================================================================ DB 'MI','N' | CLAST DW MAX-1 DB 3 MIN: DW DOCOL DW OVER,OVER,GT ; compare numbers MINMAX: DW DOIF,MINMAXEND-$-1 DW SWAP ; swap if required MINMAXEND: DW DROP ; erase other number DW SEMIS ;================================================================ DB 'DECIMA','L' | CLAST DW MIN-1 DB 7 DECIMAL: DW $+2 LD (IX+VBASE-MEMBEG),10 JP (IY) ;================================================================ NCOLON: DB ':' | CLAST DW DECIMAL-1 DB 1 COLON: DW DODEFINER,DOCOL DW GETBYTE DB 10 ; store test value DW SEMICODE LD HL,FLAGS LD A,(HL) OR (1 SHL 6) OR (1 SHL 2) LD (HL),A ; switch on compiler JP (IY) ;================================================================ DW NCOLON-$-1 DOCOL: EX DE,HL ; current pointer for stack JP NEXTSUB ;================================================================ NCREATE: DB 'CREAT','E' | CLAST DW COLON-1 DB 6 CREATE: DW DOCOL DW GETBYTE DB ' ' DW WORD,CRHEADER ; prepare header DW ZERO,KOMMA DW CURRENT,AT DW DUP,AT,KOMMA ; create link DW HERE,SWAP,EXCLAM ; remember address DW PAD,CAT,CKOMMA DW GETWORD,DOCREATE,KOMMA ; store first word DW SEMIS ;================================================================ CRHEADER: DW $+2 CALL LINKHERE RST RSTPULL LD A,(DE) ; get name length DEC A CP 03FH JR C,CHGOON ; name short enough? RST RSTERR DB ERRNAME CHGOON: ADD A,8 ; links, length byte and first word LD C,A LD B,0 CALL MEMCHECK LD A,(DE) LD C,A LD HL,(STKBOT) PUSH DE CALL ALLOC ; allocate memory POP DE LD A,(DE) LD B,A ; character count CHLOOP: INC DE LD A,(DE) CALL TOUPPER LD (HL),A INC HL DJNZ CHLOOP ; store name LD (DICT),HL DEC HL SET 7,(HL) ; tag end of name JP (IY) ;================================================================ LINKHERE: BIT 2,(IX+FLAGS-MEMBEG) JR Z,LHGOON ; not compile mode? RST RSTERR DB ERRMODE LHGOON: LD HL,(STKBOT) LD DE,(DICT) XOR A SBC HL,DE EX DE,HL LD (HL),E INC HL LD (HL),D ; create link LD H,A LD L,A LD (DICT),HL RET ;================================================================ DB ',' | CLAST DW CREATE-1 DB 1 KOMMA: DW DOCOL DW ALLOT2,HERE,TWOMINUS,EXCLAM DW SEMIS ;================================================================ DB 'C',',' | CLAST DW KOMMA-1 DB 2 CKOMMA: DW DOCOL DW GETBYTE DB 1 DW ALLOT,HERE,ONEMINUS,CEXCLAM DW SEMIS ;================================================================ DB 'ALLO','T' | CLAST DW CKOMMA-1 DB 5 ALLOT: DW $+2 CALL PULLBC LD HL,(STKBOT) CALL ALLOC JP (IY) ;================================================================ ALLOT2: DW DOCOL DW GETBYTE DB 2 DW ALLOT DW SEMIS ;================================================================ MEMCHECK: LD HL,30 MEMCHECK2: PUSH BC ADD HL,BC LD BC,(SPARE) ADD HL,BC ; new end address POP BC JR C,MCERROR ; memory overflow? SBC HL,SP RET C ; no overflow into stack? MCERROR: RST RSTERR DB ERRMEM ;================================================================ ALLOC: EX DE,HL LD HL,40 CALL MEMCHECK2 ; some more testing LD HL,(STKBOT) ADD HL,BC LD (STKBOT),HL LD HL,(SPARE) PUSH HL ADD HL,BC LD (SPARE),HL ; advance pointer EX (SP),HL PUSH HL AND A SBC HL,DE LD B,H LD C,L ; distance = old space - DE POP HL POP DE RET Z ; nothing to move? DEC HL DEC DE LDDR INC HL ; move argument stack RET ;================================================================ NVARIABLE: DB 'VARIABL','E' | CLAST DW ALLOT-1 DB 8 VARIABLE: DW DODEFINER,DOVARIABLE DW KOMMA DW SEMIS ;================================================================ NCONSTANT: DB 'CONSTAN','T' | CLAST DW VARIABLE-1 DB 8 CONSTANT: DW DODEFINER,DOCONSTANT DW KOMMA DW SEMIS ;================================================================ DW NCREATE-$-1 DOCREATE: JR DOVARIABLE ;================================================================ DW NVARIABLE-$-1 DOVARIABLE: RST RSTPUSH JP (IY) ;================================================================ DW NCONSTANT-$-1 DOCONSTANT: EX DE,HL LD E,(HL) INC HL LD D,(HL) RST RSTPUSH ; value on stack JP (IY) ;================================================================ DB 'LITERA','L' | CLAST DW CONSTANT-1 DB 7 OR IMM LITERAL: DW DOCOMPILER,GETWORD DW KOMMA DW SEMIS ;================================================================ DB 2 DW -1 GETWORD: DW $+2 LD B,1 ; only one word GWLOOP: POP HL LD E,(HL) INC HL LD D,(HL) ; get word GWGOON: INC HL PUSH HL RST RSTPUSH ; word on stack DJNZ GWLOOP GWQUIT: JP (IY) ;================================================================ NASCII: DB 'ASCI','I' | CLAST DW LITERAL-1 DB 5 OR IMM ASCII: DW DOCOL DW GETBYTE DB ' ' DW WORD,ONEPLUS,CAT DW SEMICODE BIT 6,(IX+FLAGS-MEMBEG) JR Z,GWQUIT ; compiler off? CALL NEXT DW GETWORD,GETBYTE,KOMMA DW CKOMMA DW SEMIS ;================================================================ DB 1 DW NASCII-$-1 GETBYTE: DW $+2 POP HL LD E,(HL) LD D,0 LD B,1 JR GWGOON ;================================================================ LITFLOAT: DW DOCOMPILER,GETFLOAT DW SWAP,KOMMA,KOMMA DW SEMIS ;================================================================ DB 4 DW -1 GETFLOAT: DW $+2 LD B,2 JR GWLOOP ;================================================================ NDEFINER: DB 'DEFINE','R' | CLAST DW ASCII-1 DB 7 DEFINER: DW DODEFINER,DODEFINER DW HERE,GETBYTE DB 12 DW ALLOT2 DW DOREPEAT,0EB6H-$-1 ;================================================================ DW NDEFINER-$-1 DODEFINER: CALL DOVARIABLE DW CREATE ; creaste header DW DUP,AT DW HERE,TWOMINUS,EXCLAM ; create link DW TWOPLUS,DROPGOON DW SEMIS ;---------------------------------------------------------------- DROPGOON: DW $+2 RST RSTPULL JP DOCOL ;================================================================ DB 'CAL','L' | CLAST DW DEFINER-1 DB 4 CALL: DW $+2 RST RSTPULL ; get target address EX DE,HL JP (HL) ;================================================================ NDOESGT: DB 'DOES','>' | CLAST DW COMPILER-1 DB 5 OR IMM DOESGT: DW DOCOMPILER,DODOESGT DW ASSERT DB 12 ; test test value DW DOESPATCH DW GETBYTE DB 0CDH DW CKOMMA DW GETWORD,DOVARIABLE,KOMMA ; "CALL DOVARIABLE" DW GETBYTE DB 10 ; set etst value DW SEMIS ;================================================================ DOESPATCH: DW DOCOL DW DUP,TWOMINUS,NFA DW HERE,MINUS,ONEMINUS,KOMMA DW HERE,SWAP,EXCLAM ; adjust link DW SEMIS ;================================================================ DB 5 DW NDOESGT-$-1 DODOESGT: DW RSEMIS ;================================================================ NCOMPILER: DB 'COMPILE','R' | CLAST DW CALL-1 DB 8 COMPILER: DW DODEFINER,DOCOMPILER DW IMMEDIATE DW HERE DW GETBYTE DB 11 DW ALLOT2 DW DOREPEAT,0EB6H-$-1 ;================================================================ DW NCOMPILER-$-1 DOCOMPILER: BIT 6,(IX+FLAGS-MEMBEG) JR NZ,DOCOMGOON ; compiler ON? RST RSTERR DB ERRIMM DOCOMGOON: CALL DOVARIABLE DW DUP,AT,KOMMA DW DOREPEAT,1094H-$-1 ;================================================================ NRUNSGT: DB 'RUNS','>' | CLAST DW DOESGT-1 DB 5 OR IMM RUNSGT: DW DOCOMPILER,DORUNSGT DW ASSERT DB 11 ; test test value DW SWAP,CKOMMA DW DOESPATCH DW GETWORD,RUNSCORR,KOMMA DW GETBYTE DB 10 ; set test value DW SEMIS ;---------------------------------------------------------------- DB 5 DW NRUNSGT-$-1 DORUNSGT: DW RSEMIS ;---------------------------------------------------------------- RUNSCORR: POP HL PUSH DE EX DE,HL RST RSTPUSH LD B,D LD C,E POP DE PUSH DE DEC DE DEC DE CALL SKIPOFFS ; next Forth address POP DE PUSH BC JP DOCOL ;================================================================ DB 'IMMEDIAT','E' | CLAST DW RUNSGT-1 DB 9 IMMEDIATE: DW DOCOL DW CURRENT,AT,AT DW SEMICODE RST RSTPULL EX DE,HL SET 6,(HL) ; set 'immediate' bit JP (IY) ;================================================================ DB 'VOCABULAR','Y' | CLAST DW IMMEDIATE-1 DB 10 VOCABULARY: DW DODEFINER,SETCONTEXT DW CURRENT,AT DW TWOPLUS,KOMMA DW ZERO,CKOMMA ; prepare link DW HERE,GETWORD,VOCLNK DW DUP,AT,KOMMA,EXCLAM ; toggle compiler DW SEMIS ;================================================================ DB 'DEFINITION','S' | CLAST DW VOCABULARY-1 DB 11 DEFINITIONS: DW $+2 LD HL,(VCONTEXT) LD (VCURRENT),HL JP (IY) ;---------------------------------------------------------------- SETCONTEXT: LD (VCONTEXT),DE JP (IY) ;================================================================ NIF: DB 'I','F' | CLAST DW RSQRBR-1 DB 2 OR IMM IF: DW DOCOMPILER,DOIF DW HERE,GETBYTE DB 2 DW ALLOT2 DW SEMIS ;================================================================ NWHILE: DB 'WHIL','E' | CLAST DW IF-1 DB 5 OR IMM WHILE: DW DOCOMPILER,DOWHILE DW ASSERT DB 1 ; test test value DW HERE,GETBYTE DB 4 DW ALLOT2 DW SEMIS ;================================================================ NELSE: DB 'ELS','E' | CLAST DW WHILE-1 DB 4 OR IMM ELSE: DW DOCOMPILER,DOELSE DW ASSERT DB 2 ; test test value DW ALLOT2 DW DOFPATCH DW HERE,TWOMINUS DW GETBYTE DB 2 ; set test value DW SEMIS ;================================================================ NTHEN: DB 'THE','N' | CLAST DW ELSE-1 DB 4 OR IMM THEN: DW DOCOMPILER,DOTHEN DW ASSERT DB 2 ; test test value DW DOFPATCH DW SEMIS ;================================================================ NBEGIN: DB 'BEGI','N' | CLAST DW THEN-1 DB 5 OR IMM BEGIN: DW DOCOMPILER,DOBEGIN DW HERE DW GETBYTE DB 1 ; set test value DW SEMIS ;================================================================ DOFPATCH: DW DOCOL DW DUP,HERE,SWAP,MINUS DW ONEMINUS,SWAP,EXCLAM ; patch jump address DW SEMIS ;================================================================ DORPATCH: DW DOCOL DW HERE,MINUS,ONEMINUS DW KOMMA ; patch jump address DW SEMIS ;================================================================ NREPEAT: DB 'REPEA','T' | CLAST DW BEGIN-1 DB 6 OR IMM REPEAT: DW DOCOMPILER,DOREPEAT DW ASSERT DB 4 ; test test value DW SWAP DW DORPATCH DW DOFPATCH DW SEMIS ;================================================================ NUNTIL: DB 'UNTI','L' | CLAST DW REPEAT-1 DB 5 OR IMM UNTIL: DW DOCOMPILER,DOUNTIL DW ASSERT DB 1 ; test test value DW DORPATCH DW SEMIS ;================================================================ DB 2 DW NELSE-$-1 DOELSE: DW FJUMP ;================================================================ DB 2 DW NREPEAT-$-1 DOREPEAT: DW FJUMP ;================================================================ FJUMP: POP HL LD E,(HL) INC HL LD D,(HL) ; get offset OFFSJUMP: ADD HL,DE JP NEXTSUB ; set new Forth pointer ;================================================================ DB 2 DW NIF-$-1 DOIF: DW IF0JUMP ;================================================================ DB 2 DW NWHILE-$-1 DOWHILE: DW IF0JUMP ;================================================================ DB 2 DW NUNTIL-$-1 DOUNTIL: DW IF0JUMP ;---------------------------------------------------------------- IF0JUMP: CALL PULLBC LD A,B OR C ; test for 0 EQUJUMP: JR Z,FJUMP ; condition true? POP HL INC HL INC HL JP NEXTSUB ; skip offset ;================================================================ DB 0 DW NBEGIN-$-1 DOBEGIN: DW NEXT ;================================================================ DB 0 DW NTHEN-$-1 DOTHEN: DW NEXT ;================================================================ NDO: DB 'D','O' | CLAST DW UNTIL-1 DB 2 OR IMM DO: DW DOCOMPILER,DODO DW HERE DW GETBYTE DB 3 ; set test value DW SEMIS ;================================================================ NLOOP: DB 'LOO','P' | CLAST DW DO-1 DB 4 OR IMM LOOP: DW DOCOMPILER,DOLOOP LOOPGOON: DW ASSERT DB 3 ; test test value DW DORPATCH DW SEMIS ;================================================================ NPLUSLOOP: DB '+LOO','P' | CLAST DW LOOP-1 DB 5 OR IMM PLUSLOOP: DW DOCOMPILER,DOPLUSLOOP DW DOREPEAT,LOOPGOON-$-1 ;================================================================ ASSERT: DW $+2 RST RSTPULL POP HL LD A,(HL) INC HL PUSH HL ; test value SUB E OR D JR Z,JNEXT4 ; same as value on stack? RST RSTERR DB ERRBLK ;================================================================ DB 'I' | CLAST DW DEFINITIONS-1 DB 1 I: DW $+2 POP BC POP DE ; loop counter or "R" PUSH DE PUSH BC RST RSTPUSH JP (IY) ;================================================================ DB 'I','''' | CLAST DW I-1 DB 2 ITICK: DW $+2 LD HL,4 ;"R2" (see "I") JR RGET ;================================================================ DB 'J' | CLAST DW ITICK-1 DB 1 J: DW $+2 LD HL,6 ;"R3" (see "I") RGET: ADD HL,SP LD E,(HL) INC HL LD D,(HL) ; get value from return stack RST RSTPUSH JP (IY) ;================================================================ DB 'LEAV','E' | CLAST DW J-1 DB 5 LEAVE: DW $+2 POP BC POP HL POP HL PUSH HL PUSH HL ; counter := end value PUSH BC JP (IY) ;================================================================ DB 0 DW NDO-$-1 DODO: DW $+2 CALL PULLBC RST RSTPULL POP HL PUSH DE PUSH BC ; remember counter and end value PUSH HL JNEXT4: JP (IY) ;================================================================ DB 2 DW NLOOP-$-1 DOLOOP: DW $+2 LD DE,1 JR LOOPADD ;================================================================ DB 2 DW NPLUSLOOP-$-1 DOPLUSLOOP: DW $+2 RST RSTPULL LOOPADD: POP BC POP HL ; get counter AND A ADC HL,DE ; increment (??? UMSTAENDLICH) LD A,D POP DE ; get end value SCF JP PE,LOOPEND ; overflow? => end PUSH DE PUSH HL ; store back values RLCA JR NC,LOOPCMP EX DE,HL LOOPCMP: CALL GREATER CCF JR NC,LOOPEND ; not yet finished? POP HL POP HL ; discard loop values LOOPEND: PUSH BC SBC A,A JP EQUJUMP ;================================================================ NLBRACKET: DB '(' | CLAST DW LSQRBR-1 DB 1 OR IMM LBRACKET: DW DOCOMPILER,DOLBRACKET DW GETBYTE DB ')' LBREND: DW HERE,SWAP,ALLOT2,SAVETEXT DW SWAP,EXCLAM ; store text DW SEMIS ;================================================================ DB -1 DW NLBRACKET-$-1 DOLBRACKET: DW $+2 POP HL LD E,(HL) INC HL LD D,(HL) ; get offset INC DE JP OFFSJUMP ;================================================================ NPTSTR: DB '.','"' | CLAST DW LBRACKET-1 DB 2 OR IMM PTSTR: DW DOCOMPILER,DOPTSTR DW GETBYTE DB '"' DW DOREPEAT,LBREND-$-1 ;================================================================ DB -1 DW NPTSTR-$-1 DOPTSTR: DW $+2 POP DE CALL TYPEDE ; print string PUSH DE JP (IY) ;================================================================ SAVETEXT: DW $+2 STLOOP: RST RSTPULL PUSH DE CALL CWORD ; search end LD H,D LD L,E ADD HL,BC LD A,(HL) POP HL CP L JR Z,STFND ; end found? EX DE,HL RST RSTPUSH LD DE,RETYPE CALL EXECDE JR STLOOP ; try again STFND: PUSH DE PUSH BC LD HL,(STKBOT) ; limit against spare CALL ALLOC ; get memory POP BC POP DE PUSH DE PUSH BC EX DE,HL LDIR ; copy text POP BC LD D,B LD E,C RST RSTPUSH POP DE CALL BLWORD ; erase input JP (IY) ;================================================================ DB '[' | CLAST DW PLUSLOOP-1 DB 1 OR IMM LSQRBR: DW $+2 RES 6,(IX+FLAGS-MEMBEG) ; switch off compiler JP (IY) ;================================================================ DB ']' | CLAST DW LEAVE-1 DB 1 RSQRBR: DW $+2 SET 6,(IX+FLAGS-MEMBEG) ; switch on compiler JP (IY) ;================================================================ DB 'EXI','T' | CLAST DW PTSTR-1 DB 4 EXIT: DW RSEMIS ;================================================================ RDONAME EQU 0 ; pointer to name of old word RDOCODE EQU 2 ; pointer to code field of old word RDNCODE EQU 4 ; pointer to code field of new word RDDNAME EQU 4 ; difference in name lengths RDNRUN EQU 6 ; 0 / run address of new word RDOEND EQU 8 ; pointer behind old word RDNEND EQU 10 ; pointer behind new word RDDLEN EQU 10 ; difference in length RDNNAME EQU 12 ; pointer to name of new word ;================================================================ DB 'REDEFIN','E' | CLAST DW EXIT-1 DB 8 REDEFINE: DW $+2 CALL LINKHERE LD HL,(VCURRENT) LD E,(HL) INC HL LD D,(HL) EX DE,HL INC HL LD (PADMEM+RDNCODE),HL ; code field new word PUSH HL CALL PTR2ADDR LD (PADMEM+RDNNAME),HL LD (PADMEM+RDNRUN),BC LD (PADMEM+RDNEND),DE ; get address LD HL,(STKBOT) SBC HL,DE JP NZ,DICTERR ; not newest word? POP DE RST RSTPUSH ; word to be redefined CALL NEXT DW RESCURR,FIND,SEMICODE RST RSTPULL ; code field address of old word LD HL,-FREEMEM ADD HL,DE JP NC,REDEFABORT ; word not in ram? EX DE,HL LD (PADMEM+RDOCODE),HL CALL PTR2ADDR ; get address LD (PADMEM+RDONAME),HL PUSH HL ; (see below!) LD (PADMEM+RDOEND),DE LD A,B OR C LD DE,(PADMEM+RDNRUN) JR Z,RDGOON1 ; old without special run part? LD A,D OR E JR Z,REDEFABORT ; new without special run part? RDGOON1: POP HL LD BC,(PADMEM+RDNNAME) SBC HL,BC EX DE,HL ADD HL,DE LD (PADMEM+RDNRUN),HL ; update run address LD HL,(PADMEM+RDNEND) ADD HL,DE LD BC,(PADMEM+RDOEND) AND A SBC HL,BC LD (PADMEM+RDDLEN),HL ; calculate length difference LD BC,46 ADD HL,BC BIT 7,H JR NZ,RDGOON2 ; at least 47 bytes shorter? LD BC,(SPARE) ADD HL,BC JR C,REDEFABORT SBC HL,SP JR NC,REDEFABORT ; out of memory? RDGOON2: LD HL,(PADMEM+RDOCODE) PUSH HL DEC HL DEC HL LD B,(HL) DEC HL LD C,(HL) LD HL,(PADMEM+RDNCODE) PUSH HL DEC HL DEC HL LD (HL),B DEC HL LD (HL),C ; link words POP HL ADD HL,DE POP BC AND A SBC HL,BC LD (PADMEM+RDDNAME),HL ; calculate name length difference LD DE,(PADMEM+RDONAME) LD HL,(PADMEM+RDOEND) AND A SBC HL,DE LD B,H LD C,L PUSH DE PUSH BC CALL DELWORD ; erase old word LD HL,(PADMEM+RDDLEN) POP BC ADD HL,BC LD B,H LD C,L POP HL PUSH BC CALL ALLOC ; get memory for new word EX DE,HL LD HL,(PADMEM+RDNNAME) LD BC,(PADMEM+RDDLEN) ADD HL,BC ; adjust start address POP BC PUSH BC PUSH HL LDIR ; copy new word POP DE POP BC CALL DELWORD ; erase original data CALL CORRCURR ; adjust pointer JP (IY) REDEFABORT: LD HL,(VCURRENT) LD DE,(PADMEM+RDNCODE) DEC DE LD (HL),E INC HL LD (HL),D ; set 'current dictionary' DICTERR: RST RSTERR DB ERRDICT ;================================================================ DELWORD: LD HL,(STKBOT) AND A SBC HL,BC LD (STKBOT),HL ; lower 'HERE' LD HL,(SPARE) SBC HL,BC LD (SPARE),HL ; lower 'SPARE' SBC HL,DE RET Z ; was this the last word? PUSH BC LD B,H LD C,L POP HL ADD HL,DE LDIR ; move remainder RET ;---------------------------------------------------------------- CORRCURR: LD BC,VCURRENT CALL CORRPTR CALL CORRPTR ; adjust 'CURRENT' pointer LD BC,DICT1ST CORRDICT: LD HL,(STKBOT) SCF SBC HL,BC RET C ; reached end? CDLOOP: LD A,(BC) RLA INC BC JR NC,CDLOOP ; skip name INC BC INC BC CALL CORRPTR ; adjust end address INC BC CALL CORRPTR ; first word of dictionary CALL JUMPDE DW DOCOL DB CDCOLON-$ DW DODEFINER DB CDDEFCOM-$ DW DOCOMPILER DB CDDEFCOM-$ DW SETCONTEXT DB CDSETCTXT-$ DW 0 LD HL,-7 ADD HL,BC LD C,(HL) INC HL LD B,(HL) DEC HL ADD HL,BC ; link to previous dictionary LD B,H LD C,L JR CORRDICT CDDEFCOM: CALL CORRPTR CDCOLON: CALL CORRWORD JR CORRDICT CDSETCTXT: CALL CORRPTR INC BC CALL CORRPTR JR CORRDICT ;---------------------------------------------------------------- CORRWORD: CALL CORRPTR LD HL,SEMIS AND A SBC HL,DE RET Z ; Forth word end found? CALL SKIPOFFS JR CORRWORD ;---------------------------------------------------------------- CORRPTR: LD A,(BC) LD E,A INC BC LD A,(BC) LD D,A DEC BC ; get address CALL CORRADDR EX DE,HL LD A,E LD (BC),A INC BC LD A,D LD (BC),A ; store back adjusted value INC BC RET ;---------------------------------------------------------------- CORRADDR: LD HL,(PADMEM+RDONAME) AND A SBC HL,DE LD H,D LD L,E RET NC ; older word => no adjustment LD HL,(PADMEM+RDOEND) SBC HL,DE JR NC,CAWORD ; redefined word? LD HL,(PADMEM+RDNNAME) SBC HL,DE JR C,CADICT ; other dictionary? LD HL,(PADMEM+RDDLEN) ADD HL,DE RET ; newer => adjust with offset CAWORD: LD HL,(PADMEM+RDOCODE) SBC HL,DE LD HL,(PADMEM+RDNRUN) RET C ; has run part => new address LD HL,(PADMEM+RDDNAME) ADD HL,DE RET ; adjust with name difference CADICT: LD HL,(PADMEM+RDONAME) ADD HL,DE LD DE,(PADMEM+RDNNAME) AND A SBC HL,DE RET ; adjust with length difference ;---------------------------------------------------------------- SKIPOFFS: DEC DE LD A,(DE) RLA RET NC ; plain Forth word? SKOFFS2: DEC DE DEC DE LD A,(DE) ; get offset LD L,A LD H,0 INC A JR NZ,SKOGOON ; offset byte valid? LD A,(BC) LD L,A INC BC LD A,(BC) LD H,A INC BC ; get offset from code SKOGOON: ADD HL,BC LD B,H LD C,L ; remember new address RET ;---------------------------------------------------------------- NFA: DW $+2 RST RSTPULL EX DE,HL CALL FPTR2NAME EX DE,HL RST RSTPUSH JP (IY) ;---------------------------------------------------------------- PTR2ADDR: PUSH HL LD E,(HL) INC HL LD D,(HL) ; get first word address CALL JUMPDE DW DOCOMPILER DB P2ARUN-$ DW DODEFINER DB P2ARUN-$ DW 0 LD BC,0 ; no special run part JR P2AGOON P2ARUN: POP HL PUSH HL INC HL INC HL LD C,(HL) INC HL LD B,(HL) ;get runtime address P2AGOON: POP HL PUSH HL DEC HL DEC HL DEC HL DEC HL LD D,(HL) DEC HL LD E,(HL) ADD HL,DE EX DE,HL ;calculate pointer behind word POP HL ;---------------------------------------------------------------- FPTR2NAME: DEC HL PTR2NAME: LD A,H CP MEMBEG SHR 8 LD A,(HL) RES 6,A ; clear 'immediate' bit JR C,P2NGOON ADD A,2 ; more for words in ram P2NGOON: DEC HL DEC HL ; skip link pointer P2NLOOP: DEC HL DEC A JR NZ,P2NLOOP ; point to start of name RET ;=============================================================== JDELOOP: INC HL ; skip offset PUSH HL JUMPDE: POP HL LD A,(HL) INC HL PUSH HL LD H,(HL) LD L,A ; get next pointer OR H RET Z ; 0 ? (HRM-HRM, AUF "NOP" !!!) SBC HL,DE POP HL INC HL JR NZ,JDELOOP ;pointer not yet reached? PUSH DE LD D,0 LD E,(HL) ; get offset ADD HL,DE POP DE JP (HL) ;jump to code ;================================================================ RESCURR: DW DOCOL DW ONEMINUS,TWOMINUS,AT DW CURRENT,AT,EXCLAM ; reset 'CURRENT' DW SEMIS ;================================================================ FINDWORD: CALL NEXT DW FIND DW SEMICODE RST RSTPULL ; address of code field LD HL,-FREEMEM ADD HL,DE RET C ; word found? RST RSTERR DB ERRFIND ;================================================================ DB 'FORGE','T' | CLAST DW REDEFINE-1 DB 6 FORGET: DW $+2 LD HL,(VCURRENT) LD DE,(VCONTEXT) AND A SBC HL,DE JP NZ,DICTERR ; different dictionaries? CALL FINDWORD LD HL,-5 ADD HL,DE LD (DICT),HL SET 2,(IX+FLAGS-MEMBEG) ;switch on compile mode RST RSTERR DB ERRNONE ;================================================================ DB 'EDI','T' | CLAST DW FORGET-1 DB 4 EDIT: DW $+2 CALL FINDWORD SET 3,(IX+FLAGS-MEMBEG) ; remember "EDIT" JR EDITLIST ;================================================================ DB 'LIS','T' | CLAST DW EDIT-1 DB 4 LIST: DW $+2 CALL FINDWORD ;---------------------------------------------------------------- EDITLIST: LD A,CCR RST RSTEMIT BIT 3,(IX+FLAGS-MEMBEG) PUSH DE CALL NZ,DCCLEAR ; "EDIT" ? POP BC LD A,(BC) LD E,A INC BC LD A,(BC) LD D,A DEC BC CALL JUMPDE DW DOCOL DB ELCOLON-$ DW DOCOMPILER DB ELCOMPILER-$ DW DODEFINER DB ELDEFINER-$ DW 0 RST RSTERR DB ERRLIST ;---------------------------------------------------------------- ELCOLON: LD HL,2 JR ELOUT ;---------------------------------------------------------------- ELCOMPILER: PUSH DE LD HL,2 ADD HL,BC LD A,(HL) INC HL LD H,(HL) LD L,A ; address behind "DOCOMPILER" DEC HL DEC HL DEC HL LD L,(HL) LD A,L RLCA SBC A,A LD H,A ; code byte (???) to 16 bit CALL PNTHL POP DE ;---------------------------------------------------------------- ELDEFINER: LD HL,4 ;---------------------------------------------------------------- ELOUT: ADD HL,BC PUSH HL PUSH BC CALL OUTWORD ; print ":" etc. POP DE POP BC CALL OUTWORD ; print name LD (IX+LPIBUF-MEMBEG),1 ; indent 1 character ELMLOOP: LD (IX+LPLCNT-MEMBEG),16 ; 16 rows ELLLOOP: CALL LISTPGM JR C,ELREADY ; finished listing of word? DEC (IX+LPLCNT-MEMBEG) JP P,ELLLOOP ; not yet all rows used? ELREADY: BIT 3,(IX+FLAGS-MEMBEG) JR NZ,ELEDIT ; "EDIT" ? JR C,ELQUIT ; finished listing of word? LD HL,KEYCOD LD (HL),0 ELACK: LD A,(HL) AND A JR Z,ELACK ; wait for confirmation CALL USERBREAK JR ELMLOOP ; resume ELEDIT: PUSH AF RES 3,(IX+FLAGS-MEMBEG) ; short no "EDIT" PUSH BC CALL NEXT DW RETYPE,LINE DW SEMICODE ; edit SET 3,(IX+FLAGS-MEMBEG) ; again "EDIT" CALL DCCLEAR POP BC POP AF JR NC,ELMLOOP ; listing of word not yet completed? ELQUIT: RES 3,(IX+FLAGS-MEMBEG) ; no more "EDIT" JP (IY) ;---------------------------------------------------------------- LISTPGM: LD A,(LPIBUF) LD (LPIACT),A ; get indent LD (IX+LPICNT-MEMBEG),5 ; start with 5 words LPLOOP: LD A,(BC) LD E,A INC BC LD A,(BC) LD D,A INC BC CALL JUMPDE ; get next word DW DOIF DB LPIINC-$ DW DOELSE DB LPILEFT-$ DW DOTHEN DB LPIDEC-$ DW DOBEGIN DB LPIINC-$ DW DOUNTIL DB LPIDEC-$ DW DOWHILE DB LPILEFT-$ DW DOREPEAT DB LPIDEC-$ DW DODO DB LPIINC-$ DW DOLOOP DB LPIDEC-$ DW DOPLUSLOOP DB LPIDEC-$ DW DODOESGT DB LPILEFT-$ DW DORUNSGT DB LPILEFT-$ DW GETWORD DB LPWORD-$ DW GETFLOAT DB LPFLOAT-$ DW GETBYTE DB LPBYTE-$ DW DOLBRACKET DB LPLBRACKET-$ DW DOPTSTR DB LPPTSTR-$ DW SEMIS DB LPSEMIS-$ DW 0 LPOUT: CALL OUTWORDI LPNEXT: DEC (IX+LPICNT-MEMBEG) JR NZ,LPLOOP ; limit number of words AND A ; listing of word not yet finished RET LPIINC: LD HL,(LPIBUF) LD H,L INC L ; increase indent JR LPINDENT LPILEFT: LD HL,(LPIBUF) LD H,L DEC H ; decrease indent JR LPINDENT LPIDEC: LD HL,(LPIBUF) DEC L LD H,L ; decrease indent LPINDENT: LD (LPIBUF),HL LD (IX+LPICNT-MEMBEG),1 ; last word for now DEC (IX+LPLCNT-MEMBEG) ; row finished JR LPOUT LPWORD: CALL LPNXTWRD RST RSTPUSH LD DE,PNT LPNUMBER: CALL OUTINDENT CALL EXECDE ; print number JR LPNEXT LPFLOAT: CALL LPNXTWRD RST RSTPUSH CALL LPNXTWRD RST RSTPUSH LD DE,FPNT JR LPNUMBER LPBYTE: LD A,(BC) PUSH AF CALL OUTWORDI POP AF RST RSTEMIT LD A,' ' RST RSTEMIT JR LPNEXT LPSEMIS: CALL ROMTXT DB CCR,';',CCR | CLAST SCF ; finished listing of word RET LPLBRACKET: LD A,')' JR LPSTRING LPPTSTR: LD A,'"' LPSTRING: PUSH AF PUSH BC CALL OUTWORDI POP DE CALL TYPEDE ; print text string LD B,D LD C,E POP AF RST RSTEMIT ; print delimiter character AND A ; listing of word not yet finished RET ;---------------------------------------------------------------- OUTINDENT: LD A,(LPIACT) AND A RET M ; no new line and indent? PUSH BC LD B,A LD A,CCR RST RSTEMIT INC B DEC B JR Z,OIQUIT ; indent = 0 ? OILOOP: LD A,' ' RST RSTEMIT DJNZ OILOOP ; print indent OIQUIT: LD (IX+LPIACT-MEMBEG),-1 ; no more indent POP BC RET ;---------------------------------------------------------------- LPNXTWRD: LD A,(BC) LD E,A INC BC LD A,(BC) LD D,A INC BC ; get next word RET ;---------------------------------------------------------------- OUTWORDI: CALL OUTINDENT OUTWORD: EX DE,HL DEC HL LD A,(HL) BIT 7,A JR NZ,OWDOXX ; no simple Forth word? CALL PTR2NAME JR OUTTXT OWDOXX: EX DE,HL CALL SKOFFS2 INC DE LD A,(DE) LD L,A INC DE LD A,(DE) LD H,A ADD HL,DE ; pointer to name OUTTXT: LD A,(HL) AND 7FH ; get character RST RSTEMIT BIT 7,(HL) INC HL JR Z,OUTTXT ; not yet finished? LD A,' ' RST RSTEMIT RET ;---------------------------------------------------------------- ROMTXT: EX (SP),HL ; get pointer CALL OUTTXT EX (SP),HL ; set return address RET ;================================================================ PNTHL: LD DE,PNT PUSH DE EX DE,HL RST RSTPUSH POP DE ;---------------------------------------------------------------- EXECDE: PUSH BC CALL NEXTDE DW $+2 DW $+2 POP BC POP BC RET ;================================================================ TXALL: PUSH IY PUSH HL POP IY ; get address LD HL,TXRXQUIT PUSH HL ; set return address LD HL,-2000H BIT 7,C JR Z,TAGOON1 ; long pilot? LD H,-0400H SHR 8 TAGOON1: INC DE DEC IY ; adjust pointer and count DI XOR A ; prepare TALOOP1: LD B,151 TADEL1: DJNZ TADEL1 ; wait long OUT (IO),A ; toggle level XOR 8 INC L JR NZ,TAGOON2 INC H TAGOON2: JR NZ,TALOOP1 ; emit pilot LD B,43 TADEL2: DJNZ TADEL2 ; wait short OUT (IO),A ; level = 0 LD L,C ; get start byte LD BC,8 + (59 SHL 8) TADEL3: DJNZ TADEL3 ; wait short LD A,C OUT (IO),A ; level = 1 LD B,56 JP TASTART ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - TALOOP2: LD A,C ; get 1 level BIT 7,B ; set Z flag TADEL4: DJNZ TADEL4 ; wait short JR NC,TABIT0 ; bit = 0 ? LD B,61 TADEL5: DJNZ TADEL5 ; wait short TABIT0: OUT (IO),A ; set level LD B,58 JP NZ,TALOOP2 ; sent first half of bit? DEC B ; cycle adjustment XOR A ; get 0 level TANEXT: RL L JP NZ,TADEL4 ; not yet sent all 8 bits? DEC DE ; decrement counter INC IY ; increment pointer LD B,46 LD A,7FH IN A,(IO) RRA RET NC ; user breaked? LD A,D CP 0FFH RET NC ; sent test value? OR E JR Z,TAEND ; sent all bytes? LD L,(IY+0) ; get next byte TACHECK: LD A,H XOR L LD H,A ; calculate test value TASTART: XOR A SCF ; for the bit count JP TANEXT TAEND: LD L,H ; send test value JR TACHECK ;---------------------------------------------------------------- TXRXQUIT: POP IY EX AF,AF' LD B,59 TRQDEL6: DJNZ TRQDEL6 ; wait short XOR A OUT (IO),A ; level = 0 LD A,7FH IN A,(IO) RRA EI JP NC,BREAK ; user breaked? EX AF,AF' RET ;---------------------------------------------------------------- RXALL: DI PUSH IY PUSH HL POP IY ; get pointer LD HL,TXRXQUIT PUSH HL ; set return address LD H,C ; remember start byte EX AF,AF' ; remember read/verify flag XOR A LD C,A ; 'til now 0level RASYNC: RET NZ ; user breaked? RALOOP1: LD L,0 RALOOP2: LD B,-72 CALL RXBIT JR NC,RASYNC ; breaked? LD A,-33 CP B JR NC,RALOOP1 ; no sync bit found? INC L JR NZ,RALOOP2 ; not yet 256 pulses received? RALOOP3: LD B,-49 CALL RXLEVEL JR NC,RASYNC ; abort? LD A,B CP -40 JR NC,RALOOP3 ; still sync pulses? CALL RXLEVEL RET NC ; abort? CALL RXBYTE RET NC ; abort? CCF RET NZ ; wrong first byte? JR RASTART ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RALOOP: EX AF,AF' JR NC,RAVERIFY ; verify only? LD (IY+0),L ; store byte JR RAGOON RAVERIFY: LD A,(IY+0) XOR L RET NZ ; bytes differ? RAGOON: INC IY ; increment pointer DEC DE ; decrement count EX AF,AF' RASTART: CALL RXBYTE RET NC ; break? LD A,D OR E JR NZ,RALOOP ; not yet all bytes received? LD A,H CP 1 ; raise C if test value is ok RETURN: RET ;---------------------------------------------------------------- RXBYTE: LD L,1 ; for the bit count RB8LOOP: LD B,-57 CALL RXBIT RET NC ; abort? LD A,-30 CP B ; long duration = bit 1 RL L JP NC,RB8LOOP ; not yet 8 bits? LD A,H XOR L LD H,A ; calculate etst value SCF ; receive byte RET ;---------------------------------------------------------------- RXBIT: CALL RXLEVEL RET NC ; abort? RXLEVEL: LD A,20 RBDELAY: DEC A JR NZ,RBDELAY ; wait short AND A ; clear C RBLOOP: INC B RET Z ; timeout? LD A,7FH IN A,(IO) RRA RET NC ; user breaked? XOR C AND 020H SHR 1 JR Z,RBLOOP ; level still the same? LD A,C CPL LD C,A ; remember level SCF ; all ok RET ;================================================================ FFLAG EQU 0 ; 00/FF = dictionary / binary data FNLEN EQU 1 ; length of name ; 2 ; file name FLEN EQU 11 ; byte count FSTART EQU 13 ; start address FDICT EQU 15 ; dictionary FCURR EQU 17 ; VCURRENT ; 19 ; VCONTEXT ; 21 ; VOCLNK ; 23 ; STKBOT FSIZE EQU 25 ; size of this block ;================================================================ DB 'SAV','E' | CLAST DW LIST-1 DB 4 SAVE: DW DOCOL DW FILEFHEAD,DOSAVE DW SEMIS ;================================================================ DB 'BSAV','E' | CLAST DW SAVE-1 DB 5 BSAVE: DW DOCOL DW FILEBHEAD,DOSAVE DW SEMIS ;================================================================ DB 'BLOA','D' | CLAST DW BSAVE-1 DB 5 BLOAD: DW DOCOL DW FILEBHEAD,READHEADER,DOBLOAD DW SEMIS ;================================================================ DB 'VERIF','Y' | CLAST DW BLOAD-1 DB 6 VERIFY: DW DOCOL DW FILEFHEAD DW DOELSE,DOVERIFY-$-1 ;================================================================ DB 'BVERIF','Y' | CLAST DW VERIFY-1 DB 7 BVERIFY: DW DOCOL DW FILEBHEAD DOVERIFY: DW READHEADER,DOBVERIFY DW SEMIS ;================================================================ DB 'LOA','D' | CLAST DW BVERIFY-1 DB 4 LOAD: DW DOCOL DW FILEFHEAD DW SEMICODE LD HL,(STKBOT) LD (FPADMEM+FSTART),HL ; start EX DE,HL LD HL,-52 ADD HL,SP AND A SBC HL,DE LD (FPADMEM+FLEN),HL ; size of free memory CALL NEXT DW READHEADER,DOBLOAD DW SEMICODE LD BC,(STKBOT) LD HL,FREEMEM-1 LD (PADMEM+RDONAME),HL INC HL LD (PADMEM+RDOEND),HL ; prepare adjustment LD HL,(FPADMEM+FSIZE+FLEN) ADD HL,BC LD (STKBOT),HL ; allocate mamory LD HL,-FREEMEM ADD HL,BC LD (PADMEM+RDDLEN),HL LD DE,(FPADMEM+FSIZE+FDICT) ADD HL,DE LD DE,(FORTH+2+RAMVAR-ROMVAR) LD (FORTH+2+RAMVAR-ROMVAR),HL ; new end PUSH BC PUSH DE LD (PADMEM+RDNNAME),SP CALL CORRDICT ; link loaded dictionary POP BC POP HL LDNLOOP: BIT 7,(HL) INC HL JR Z,LDNLOOP ; skip name INC HL INC HL LD (HL),C INC HL LD (HL),B ; store length of dictionary LD HL,(STKBOT) LD BC,SAFETY ADD HL,BC LD (SPARE),HL ; setup argument stack JP (IY) ;================================================================ FILENAME: DW DOCOL DW GETBYTE DB ' ' DW WORD DW SEMICODE ; get name CALL LINKHERE RST RSTPULL LD A,' ' LD (DE),A ; replace name length with ' ' LD DE,PADMEM+FLEN LD HL,SCRMEND-1 CALL BLANKS ; erase buffer JP (IY) ;================================================================ SEMICODE: DW RETURN ;================================================================ FILEFHEAD: DW DOCOL DW FILENAME DW SEMICODE XOR A LD (FPADMEM+FFLAG),A LD HL,FREEMEM LD (FPADMEM+FSTART),HL EX DE,HL LD HL,(STKBOT) AND A SBC HL,DE LD (FPADMEM+FLEN),HL LD HL,(FORTH+2+RAMVAR-ROMVAR) LD (FPADMEM+FDICT),HL LD HL,VCURRENT LD DE,FPADMEM+FCURR LD BC,8 LDIR ; prepeare header JP (IY) ;================================================================ FILEBHEAD: DW DOCOL DW FILENAME DW GETWORD,FPADMEM+FLEN,EXCLAM DW GETWORD,FPADMEM+FSTART,EXCLAM DW SEMIS ;================================================================ DOSAVE: DW $+2 LD A,(FPADMEM+FNLEN) AND A JR Z,RXERROR ; no name? LD HL,(FPADMEM+FLEN) LD A,H OR L JR Z,RXERROR ; length = 0 ? PUSH HL LD DE,25 LD HL,FPADMEM+FFLAG LD C,D CALL TXALL ; send header POP DE LD HL,(FPADMEM+FSTART) LD C,-1 CALL TXALL ; send data JP (IY) ;---------------------------------------------------------------- READHEADER: DW $+2 RHLOOP: LD DE,25 LD HL,FPADMEM+FSIZE+FFLAG LD C,D SCF CALL RXALL ; read header JR NC,RHLOOP ; not yet ok? LD DE,FPADMEM+FSIZE+FFLAG LD A,(DE) AND A JR NZ,RHBINARY ; binary data? CALL ROMTXT DB CCR,'Dict',':' | CLAST JR RHCHECK RHBINARY: CALL ROMTXT DB CCR,'Bytes',':' | CLAST RHCHECK: LD HL,FPADMEM+FFLAG LD BC,11 + (11 SHL 8) JR RHCSTART RHCLOOP: LD A,(DE) RST RSTEMIT ; print name RHCSTART: LD A,(DE) CP (HL) JR NZ,RHCNEXT ; characters not the same? DEC C RHCNEXT: INC HL INC DE DJNZ RHCLOOP ; not yet all characters? JR NZ,RHLOOP ; names not the same? JP (IY) ;---------------------------------------------------------------- RXERROR: RST RSTERR DB ERRREAD ;---------------------------------------------------------------- DOBLOAD: DW $+2 LD B,-1 ; read JR DOBREAD ;---------------------------------------------------------------- DOBVERIFY: DW $+2 LD HL,FPADMEM+FCURR LD DE,FPADMEM+FSIZE+FCURR LD B,8 DBVLOOP: LD A,(DE) INC DE CP (HL) INC HL JR NZ,RXERROR DJNZ DBVLOOP ; compare variables DOBREAD: LD HL,(FPADMEM+FLEN) LD DE,(FPADMEM+FSIZE+FLEN) LD A,H OR L JR Z,DBRGOON1 ; do not test length? SBC HL,DE JR C,RXERROR DBRGOON1: LD HL,(FPADMEM+FSTART) LD A,H OR L JR NZ,DBRGOON2 ; use start address? LD HL,(FPADMEM+FSIZE+FSTART) DBRGOON2: LD C,-1 RR B ; get read/verify flag CALL RXALL ; read data JR NC,RXERROR ; break? JP (IY) ;================================================================ FEXP1 EQU 0 ; exponent upper number / result FEXP2 EQU 1 ; exponent lower number FSGN EQU 2 ; number sign 7=lower 6=upper number FACCU EQU 3 ; akkumulator FQUO EQU 7 ; quotient FDIVOR EQU 16 ; divisor ;================================================================ FINIT: LD BC,FPWS+FDIVOR-1 XOR A FICLEAR: LD (BC),A DEC C ;(slightly dirty!!!) JR NZ,FICLEAR ;clear buffer LD HL,(SPARE) LD DE,-4 DEC HL LD C,(HL) ; remember exponent of upper number LD (HL),A ; and clear ADD HL,DE INC HL LD (SPARE),HL ; clear "TOS" DEC HL LD B,(HL) ; remember exponent of lower number LD (HL),A ; and clear LD A,C RRCA XOR B AND NOT FSIGN XOR B LD (FPWS+FSGN),A ; remember number sign RES 7,B RES 7,C LD (FPWS+FEXP1),BC ; store exponent INC HL EX DE,HL ; pointer to upper number ADD HL,DE ; pointer to lower number RET ;---------------------------------------------------------------- FADJUST: LD A,9 CP B JR NC,FADJLP1 ; limit difference of exponents LD B,A FADJLP1: LD C,4 INC HL INC HL INC HL XOR A FADJLP2: RRD DEC HL DEC C JR NZ,FADJLP2 ; divide smaller number INC HL DJNZ FADJLP1 ; until difference equals ADD A,-5 ; was last digit >= 5 ? PUSH HL FADJLP3: LD A,(HL) ADC A,B DAA LD (HL),A INC HL JR C,FADJLP3 ; round POP HL RET ;---------------------------------------------------------------- FNEG: PUSH BC PUSH HL LD B,4 AND A FNLOOP: LD A,0 SBC A,(HL) DAA LD (HL),A INC HL DJNZ FNLOOP ; negate all digits POP HL POP BC RET ;---------------------------------------------------------------- FADDITION: LD C,1 ; multiplicator 1 FMULADD: PUSH HL PUSH DE PUSH BC LD A,C AND 0FH LD B,A XOR C LD C,A RRCA RRCA ADD A,C RRCA ADD A,B LD C,A ; convert BCD to binary LD B,4 XOR A FMLOOP1: PUSH BC PUSH DE PUSH HL ADD A,(HL) DAA LD L,A LD A,(DE) LD H,0 LD D,H RL H ; overflow from addition AND A JR Z,FMNEXT ; digit = 0 ? LD E,A FMLOOP2: SRL C JR NC,FMNOADD ; multiplicator bit = 0 ? LD A,L ADD A,E DAA LD L,A LD A,H ADC A,D DAA LD H,A ; add FMNOADD: INC C DEC C JR Z,FMNEXT ; multiplicator = 0 ? LD A,E ADD A,A DAA LD E,A LD A,D ADC A,A DAA LD D,A ; shift result JR FMLOOP2 ; again FMNEXT: EX DE,HL POP HL LD (HL),E LD A,D POP DE POP BC INC DE INC HL DJNZ FMLOOP1 ; not yet all bytes? POP BC POP DE POP HL RET ;================================================================ DB 'F','-' | CLAST DW LOAD-1 DB 2 FMINUS: DW DOCOL DW FNEGATE DW SEMICODE JR FADDSUB ;================================================================ DB 'F','+' | CLAST DW FMINUS-1 DB 2 FPLUS: DW FADDSUB FADDSUB: CALL FINIT ; prepare LD A,C SUB B PUSH AF JR NC,FASGOON1 ; lower exponent <= upper exponent? EX DE,HL NEG LD (IX+FPWS+FEXP1-MEMBEG),B ; swap numbers FASGOON1: LD B,A CALL NZ,FADJUST ; adjust other number if required POP AF JR NC,FASGOON2 ; lower exponent <= upper exponent? EX DE,HL FASGOON2: LD B,2 LD C,(IX+FPWS+FSGN-MEMBEG) FASLP1: RL C CALL C,FNEG EX DE,HL DJNZ FASLP1 ; negate numbers if required CALL FADDITION DEC DE LD A,(DE) ADD A,-98H RR B LD (IX+FPWS+FSGN-MEMBEG),B ; remember new sign CALL NZ,FNEG ; negate if required FASLP2: LD A,(DE) AND A JR NZ,FASGOON3 ;most significant digits != 0 ? DEC (IX+FPWS+FEXP1-MEMBEG) DEC (IX+FPWS+FEXP1-MEMBEG) ; adjust exponent PUSH DE LD H,D LD L,E DEC HL LD BC,255+(3 SHL 8) ; load C for "LDD" FASLP3: OR (HL) LDD DJNZ FASLP3 ; shift digits EX DE,HL LD (HL),B POP DE JR NZ,FASLP2 ; number != 0 ? JP (IY) FASGOON3: LD D,H LD E,L ; do not yet shift number ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - FCORR: PUSH DE LD BC,4 LDIR ; shift number POP HL DEC DE FCLP: LD A,(DE) AND A JR Z,FCQUIT ; digits = 0? CP 10H SBC A,A INC A INC A LD B,A ADD A,(IX+FPWS+FEXP1-MEMBEG) LD (FPWS+FEXP1),A ; adjust exponent CALL FADJUST JR FCLP FCQUIT: LD A,(FPWS+FEXP1) DEC A CP -FEOFFS-1 INC A JR NC,FLT0 ; number too small? CP +FEOFFS+64 JR NC,FLTERR ; number to big? LD B,A LD A,(FPWS+FSGN) LD C,A RLA XOR C AND FSIGN XOR B LD (DE),A ; number sign and exponent JP (IY) FLTERR: RST RSTERR DB ERRFLT FLT0: LD BC,0+(4 SHL 8) FLT0LP: LD (HL),C INC HL DJNZ FLT0LP ; set result to 0 JP (IY) ;================================================================ DB 'F','*' | CLAST DW FPLUS-1 DB 2 FMUL: DW $+2 CALL FINIT ; prepare XOR A CP B SBC A,A AND C JR Z,FLT0 ; one of both numbers = 0? PUSH HL LD BC,FPWS+FACCU-1 PUSH BC LD B,3 FMLOOP: LD C,(HL) INC HL EX (SP),HL INC HL CALL FMULADD EX (SP),HL DJNZ FMLOOP ; multiply all double digits LD BC,(FPWS+FEXP1) LD A,B ADD A,C SUB FEOFFS+2 LD (FPWS+FEXP1),A ; calculate exponent POP HL POP DE JR FCORR ;================================================================ DB 'F','/' | CLAST DW FMUL-1 DB 2 FDIV: DW $+2 CALL FINIT ; prepare XOR A CP B JR Z,FLT0 ; dividend = 0 ? CP C JR Z,FLTERR ; divisor = 0 ? INC DE INC DE LD A,(DE) DEC DE DEC DE ADD A,1 DAA EX AF,AF' ; test for 0.99????E?? EX DE,HL CALL FNEG ; negate upper number for subtraction EX DE,HL PUSH HL LD DE,FPWS+FDIVOR LD BC,4 LDIR ; save lower number EX DE,HL DEC HL LD B,5 ; count divisor digits FDLOOP1: PUSH DE LD A,(HL) DEC HL LD E,(HL) EX AF,AF' LD C,A EX AF,AF' INC C DEC C JR NZ,FDGOON1 ; was number < 0.990000EXX ? LD E,A JR FDGOON2 FDGOON1: PUSH BC LD B,2 ; 2 digits per byte FDLOOP2: LD D,10H FDLOOP3: SLA E RLA RL D JR NC,FDLOOP3 ; shift D-A-E by 1 digit INC D FDLOOP4: SUB C DAA INC E JR NC,FDLOOP4 DEC D JR NZ,FDLOOP4 ; partial division by subtraction ADD A,C DAA DEC E DJNZ FDLOOP2 ; calculate single quotient POP BC FDGOON2: LD C,E POP DE INC C DEC C JR Z,FDNEXT ; single quotient = 0? PUSH HL DEC HL DEC HL CALL FMULADD ; subtract PUSH DE LD DE,FQUO-FDIVOR+4 ADD HL,DE ; align pointers LD DE,FPWS+FACCU LD A,C LD (DE),A CALL FADDITION ; akkumulate quotient POP DE POP HL INC HL INC B FDNEXT: DJNZ FDLOOP1 ; and another go... LD HL,(FPWS+FEXP1) LD A,H SUB L ADD A,FEOFFS LD HL,FPWS+FQUO+1 LD B,A LD A,(FPWS+FQUO+4) AND A JR NZ,FDGOON3 DEC B DEC B DEC HL ; adjust exponent FDGOON3: LD (IX+FPWS+FEXP1-MEMBEG),B ; new exponent POP DE JP FCORR ; adjust result ;================================================================ DB 'FNEGAT','E' | CLAST DW FDIV-1 DB 7 FNEGATE: DW $+2 RST RSTPULL LD A,D AND A JR Z,FNQUIT XOR 80H ; negate numbers != 0 FNQUIT: LD D,A RST RSTPUSH JP (IY) ;================================================================ DB 'IN','T' | CLAST DW FNEGATE-1 DB 3 INT: DW $+2 LD HL,(SPARE) DEC HL LD DE,0 ; erase value INTLOOP: LD A,(HL) ; get exponent RLCA CP 0+(FEOFFS+1) SHL 1 JR C,INTQUIT ; ABS(number) < 1.0 ? XOR A DEC HL CALL DECSTORE ; shift left 1 digit INC HL EX DE,HL LD B,H LD C,L ADD HL,HL ADD HL,HL ADD HL,BC ADD HL,HL ; value * 10 LD C,A LD B,0 ADD HL,BC ; add overflow digit EX DE,HL JR INTLOOP INTQUIT: DEC HL DEC HL LD (HL),D DEC HL LD (HL),E LD DE,IFN0NEG JP NEXTDE ; adjust number sign ;================================================================ DB 'UFLOA','T' | CLAST DW INT-1 DB 6 UFLOAT: DW $+2 RST RSTPULL EX DE,HL LD BC,0 OR (16 SHL 8) LD D,C LD E,C UFLOOP: ADD HL,HL LD A,E ADC A,A DAA LD E,A LD A,D ADC A,A DAA LD D,A RL C DJNZ UFLOOP ; convert to BCD RST RSTPUSH LD D,FEOFFS+6 LD E,C RST RSTPUSH ; store number DEC HL DEC HL CALL FZEROEQ ; adjust exponent if 0 JP (IY) ;================================================================ ; Character Set DB 000H,000H,000H,000H DB 000H,000H,000H ;........ ;........ ;........ ;........ ;........ ;........ ;........ DB 010H,010H,010H,010H DB 000H,010H,000H ;...*.... ;...*.... ;...*.... ;...*.... ;........ ;...*.... ;........ DB 024H,024H,000H,000H DB 000H,000H,000H ;..*..*.. ;..*..*.. ;........ ;........ ;........ ;........ ;........ DB 024H,07EH,024H,024H DB 07EH,024H,000H ;..*..*.. ;.******. ;..*..*.. ;..*..*.. ;.******. ;..*..*.. ;........ DB 008H,03EH,028H,03EH DB 00AH,03EH,008H ;....*... ;..*****. ;..*.*... ;..*****. ;....*.*. ;..*****. ;....*... DB 062H,064H,008H,010H DB 026H,046H,000H ;.**...*. ;.**..*.. ;....*... ;...*.... ;..*..**. ;.*...**. ;........ DB 010H,028H,010H,02AH DB 044H,03AH,000H ;...*.... ;..*.*... ;...*.... ;..*.*.*. ;.*...*.. ;..***.*. ;........ DB 008H,010H,000H,000H DB 000H,000H,000H ;....*... ;...*.... ;........ ;........ ;........ ;........ ;........ DB 004H,008H,008H,008H DB 008H,004H,000H ;.....*.. ;....*... ;....*... ;....*... ;....*... ;.....*.. ;........ DB 020H,010H,010H,010H DB 010H,020H,000H ;..*..... ;...*.... ;...*.... ;...*.... ;...*.... ;..*..... ;........ DB 000H,014H,008H,03EH DB 008H,014H,000H ;........ ;...*.*.. ;....*... ;..*****. ;....*... ;...*.*.. ;........ DB 000H,008H,008H,03EH DB 008H,008H,000H ;........ ;....*... ;....*... ;..*****. ;....*... ;....*... ;........ DB 000H,000H,000H,000H DB 008H,008H,010H ;........ ;........ ;........ ;........ ;....*... ;....*... ;...*.... DB 000H,000H,000H,03EH DB 000H,000H,000H ;........ ;........ ;........ ;..*****. ;........ ;........ ;........ DB 000H,000H,000H,000H DB 018H,018H,000H ;........ ;........ ;........ ;........ ;...**... ;...**... ;........ DB 000H,002H,004H,008H DB 010H,020H,000H ;........ ;......*. ;.....*.. ;....*... ;...*.... ;..*..... ;........ DB 03CH,046H,04AH,052H DB 062H,03CH,000H ;..****.. ;.*...**. ;.*..*.*. ;.*.*..*. ;.**...*. ;..****.. ;........ DB 018H,028H,008H,008H DB 008H,03EH,000H ;...**... ;..*.*... ;....*... ;....*... ;....*... ;..*****. ;........ DB 03CH,042H,002H,03CH DB 040H,07EH,000H ;..****.. ;.*....*. ;......*. ;..****.. ;.*...... ;.******. ;........ DB 03CH,042H,00CH,002H DB 042H,03CH,000H ;..****.. ;.*....*. ;....**.. ;......*. ;.*....*. ;..****.. ;........ DB 008H,018H,028H,048H DB 07EH,008H,000H ;....*... ;...**... ;..*.*... ;.*..*... ;.******. ;....*... ;........ DB 07EH,040H,07CH,002H DB 042H,03CH,000H ;.******. ;.*...... ;.*****.. ;......*. ;.*....*. ;..****.. ;........ DB 03CH,040H,07CH,042H DB 042H,03CH,000H ;..****.. ;.*...... ;.*****.. ;.*....*. ;.*....*. ;..****.. ;........ DB 07EH,002H,004H,008H DB 010H,010H,000H ;.******. ;......*. ;.....*.. ;....*... ;...*.... ;...*.... ;........ DB 03CH,042H,03CH,042H DB 042H,03CH,000H ;..****.. ;.*....*. ;..****.. ;.*....*. ;.*....*. ;..****.. ;........ DB 03CH,042H,042H,03EH DB 002H,03CH,000H ;..****.. ;.*....*. ;.*....*. ;..*****. ;......*. ;..****.. ;........ DB 000H,000H,010H,000H DB 000H,010H,000H ;........ ;........ ;...*.... ;........ ;........ ;...*.... ;........ DB 000H,010H,000H,000H DB 010H,010H,020H ;........ ;...*.... ;........ ;........ ;...*.... ;...*.... ;..*..... DB 000H,004H,008H,010H DB 008H,004H,000H ;........ ;.....*.. ;....*... ;...*.... ;....*... ;.....*.. ;........ DB 000H,000H,03EH,000H DB 03EH,000H,000H ;........ ;........ ;..*****. ;........ ;..*****. ;........ ;........ DB 000H,010H,008H,004H DB 008H,010H,000H ;........ ;...*.... ;....*... ;.....*.. ;....*... ;...*.... ;........ DB 03CH,042H,004H,008H DB 000H,008H ;..****.. ;.*....*. ;.....*.. ;....*... ;........ ;....*... DB 03CH,04AH,056H,05EH DB 040H,03CH ;..****.. ;.*..*.*. ;.*.*.**. ;.*.****. ;.*...... ;..****.. DB 03CH,042H,042H,07EH DB 042H,042H ;..****.. ;.*....*. ;.*....*. ;.******. ;.*....*. ;.*....*. DB 07CH,042H,07CH,042H DB 042H,07CH ;.*****.. ;.*....*. ;.*****.. ;.*....*. ;.*....*. ;.*****.. DB 03CH,042H,040H,040H DB 042H,03CH ;..****.. ;.*....*. ;.*...... ;.*...... ;.*....*. ;..****.. DB 078H,044H,042H,042H DB 044H,078H ;.****... ;.*...*.. ;.*....*. ;.*....*. ;.*...*.. ;.****... DB 07EH,040H,07CH,040H DB 040H,07EH ;.******. ;.*...... ;.*****.. ;.*...... ;.*...... ;.******. DB 07EH,040H,07CH,040H DB 040H,040H ;.******. ;.*...... ;.*****.. ;.*...... ;.*...... ;.*...... DB 03CH,042H,040H,04EH DB 042H,03CH ;..****.. ;.*....*. ;.*...... ;.*..***. ;.*....*. ;..****.. DB 042H,042H,07EH,042H DB 042H,042H ;.*....*. ;.*....*. ;.******. ;.*....*. ;.*....*. ;.*....*. DB 03EH,008H,008H,008H DB 008H,03EH ;..*****. ;....*... ;....*... ;....*... ;....*... ;..*****. DB 002H,002H,002H,042H DB 042H,03CH ;......*. ;......*. ;......*. ;.*....*. ;.*....*. ;..****.. DB 044H,048H,070H,048H DB 044H,042H ;.*...*.. ;.*..*... ;.***.... ;.*..*... ;.*...*.. ;.*....*. DB 040H,040H,040H,040H DB 040H,07EH ;.*...... ;.*...... ;.*...... ;.*...... ;.*...... ;.******. DB 042H,066H,05AH,042H DB 042H,042H ;.*....*. ;.**..**. ;.*.**.*. ;.*....*. ;.*....*. ;.*....*. DB 042H,062H,052H,04AH DB 046H,042H ;.*....*. ;.**...*. ;.*.*..*. ;.*..*.*. ;.*...**. ;.*....*. DB 03CH,042H,042H,042H DB 042H,03CH ;..****.. ;.*....*. ;.*....*. ;.*....*. ;.*....*. ;..****.. DB 07CH,042H,042H,07CH DB 040H,040H ;.*****.. ;.*....*. ;.*....*. ;.*****.. ;.*...... ;.*...... DB 03CH,042H,042H,052H DB 04AH,03CH ;..****.. ;.*....*. ;.*....*. ;.*.*..*. ;.*..*.*. ;..****.. DB 07CH,042H,042H,07CH DB 044H,042H ;.*****.. ;.*....*. ;.*....*. ;.*****.. ;.*...*.. ;.*....*. DB 03CH,040H,03CH,002H DB 042H,03CH ;..****.. ;.*...... ;..****.. ;......*. ;.*....*. ;..****.. DB 0FEH,010H,010H,010H DB 010H,010H ;*******. ;...*.... ;...*.... ;...*.... ;...*.... ;...*.... DB 042H,042H,042H,042H DB 042H,03EH ;.*....*. ;.*....*. ;.*....*. ;.*....*. ;.*....*. ;..*****. DB 042H,042H,042H,042H DB 024H,018H ;.*....*. ;.*....*. ;.*....*. ;.*....*. ;..*..*.. ;...**... DB 042H,042H,042H,042H DB 05AH,024H ;.*....*. ;.*....*. ;.*....*. ;.*....*. ;.*.**.*. ;..*..*.. DB 042H,024H,018H,018H DB 024H,042H ;.*....*. ;..*..*.. ;...**... ;...**... ;..*..*.. ;.*....*. DB 082H,044H,028H,010H DB 010H,010H ;*.....*. ;.*...*.. ;..*.*... ;...*.... ;...*.... ;...*.... DB 07EH,004H,008H,010H DB 020H,07EH ;.******. ;.....*.. ;....*... ;...*.... ;..*..... ;.******. DB 00EH,008H,008H,008H DB 008H,00EH ;....***. ;....*... ;....*... ;....*... ;....*... ;....***. DB 000H,040H,020H,010H DB 008H,004H ;........ ;.*...... ;..*..... ;...*.... ;....*... ;.....*.. DB 070H,010H,010H,010H DB 010H,070H ;.***.... ;...*.... ;...*.... ;...*.... ;...*.... ;.***.... DB 010H,038H,054H,010H DB 010H,010H ;...*.... ;..***... ;.*.*.*.. ;...*.... ;...*.... ;...*.... DB 000H,000H,000H,000H DB 000H,000H,0FFH ;........ ;........ ;........ ;........ ;........ ;........ ;******** DB 01CH,022H,078H,020H DB 020H,07EH,000H ;...***.. ;..*...*. ;.****... ;..*..... ;..*..... ;.******. ;........ DB 000H,038H,004H,03CH DB 044H,03EH,000H ;........ ;..***... ;.....*.. ;..****.. ;.*...*.. ;..*****. ;........ DB 020H,020H,03CH,022H DB 022H,03CH,000H ;..*..... ;..*..... ;..****.. ;..*...*. ;..*...*. ;..****.. ;........ DB 000H,01CH,020H,020H DB 020H,01CH,000H ;........ ;...***.. ;..*..... ;..*..... ;..*..... ;...***.. ;........ DB 004H,004H,03CH,044H DB 044H,03EH,000H ;.....*.. ;.....*.. ;..****.. ;.*...*.. ;.*...*.. ;..*****. ;........ DB 000H,038H,044H,078H DB 040H,03CH,000H ;........ ;..***... ;.*...*.. ;.****... ;.*...... ;..****.. ;........ DB 00CH,010H,018H,010H DB 010H,010H,000H ;....**.. ;...*.... ;...**... ;...*.... ;...*.... ;...*.... ;........ DB 000H,03CH,044H,044H DB 03CH,004H,038H ;........ ;..****.. ;.*...*.. ;.*...*.. ;..****.. ;.....*.. ;..***... DB 040H,040H,078H,044H DB 044H,044H,000H ;.*...... ;.*...... ;.****... ;.*...*.. ;.*...*.. ;.*...*.. ;........ DB 010H,000H,030H,010H DB 010H,038H,000H ;...*.... ;........ ;..**.... ;...*.... ;...*.... ;..***... ;........ DB 004H,000H,004H,004H DB 004H,024H,018H ;.....*.. ;........ ;.....*.. ;.....*.. ;.....*.. ;..*..*.. ;...**... DB 020H,028H,030H,030H DB 028H,024H,000H ;..*..... ;..*.*... ;..**.... ;..**.... ;..*.*... ;..*..*.. ;........ DB 010H,010H,010H,010H DB 010H,00CH,000H ;...*.... ;...*.... ;...*.... ;...*.... ;...*.... ;....**.. ;........ DB 000H,068H,054H,054H DB 054H,054H,000H ;........ ;.**.*... ;.*.*.*.. ;.*.*.*.. ;.*.*.*.. ;.*.*.*.. ;........ DB 000H,078H,044H,044H DB 044H,044H,000H ;........ ;.****... ;.*...*.. ;.*...*.. ;.*...*.. ;.*...*.. ;........ DB 000H,038H,044H,044H DB 044H,038H,000H ;........ ;..***... ;.*...*.. ;.*...*.. ;.*...*.. ;..***... ;........ DB 000H,078H,044H,044H DB 078H,040H,040H ;........ ;.****... ;.*...*.. ;.*...*.. ;.****... ;.*...... ;.*...... DB 000H,03CH,044H,044H DB 03CH,004H,006H ;........ ;..****.. ;.*...*.. ;.*...*.. ;..****.. ;.....*.. ;.....**. DB 000H,01CH,020H,020H DB 020H,020H,000H ;........ ;...***.. ;..*..... ;..*..... ;..*..... ;..*..... ;........ DB 000H,038H,040H,038H DB 004H,078H,000H ;........ ;..***... ;.*...... ;..***... ;.....*.. ;.****... ;........ DB 010H,038H,010H,010H DB 010H,00CH,000H ;...*.... ;..***... ;...*.... ;...*.... ;...*.... ;....**.. ;........ DB 000H,044H,044H,044H DB 044H,03CH,000H ;........ ;.*...*.. ;.*...*.. ;.*...*.. ;.*...*.. ;..****.. ;........ DB 000H,044H,044H,028H DB 028H,010H,000H ;........ ;.*...*.. ;.*...*.. ;..*.*... ;..*.*... ;...*.... ;........ DB 000H,044H,054H,054H DB 054H,028H,000H ;........ ;.*...*.. ;.*.*.*.. ;.*.*.*.. ;.*.*.*.. ;..*.*... ;........ DB 000H,044H,028H,010H DB 028H,044H,000H ;........ ;.*...*.. ;..*.*... ;...*.... ;..*.*... ;.*...*.. ;........ DB 000H,044H,044H,044H DB 03CH,004H,038H ;........ ;.*...*.. ;.*...*.. ;.*...*.. ;..****.. ;.....*.. ;..***... DB 000H,07CH,008H,010H DB 020H,07CH,000H ;........ ;.*****.. ;....*... ;...*.... ;..*..... ;.*****.. ;........ DB 00EH,008H,030H,030H DB 008H,00EH,000H ;....***. ;....*... ;..**.... ;..**.... ;....*... ;....***. ;........ DB 008H,008H,008H,008H DB 008H,008H,000H ;....*... ;....*... ;....*... ;....*... ;....*... ;....*... ;........ DB 070H,010H,00CH,00CH DB 010H,070H,000H ;.***.... ;...*.... ;....**.. ;....**.. ;...*.... ;.***.... ;........ DB 032H,04CH,000H,000H DB 000H,000H,000H ;..**..*. ;.*..**.. ;........ ;........ ;........ ;........ ;........ DB 03CH,042H,099H,0A1H DB 0A1H,099H,042H,03CH ;..****.. ;.*....*. ;*..**..* ;*.*....* ;*.*....* ;*..**..* ;.*....*. ;..****.. ROMCHR: ;================================================================ DB 0FFH DW UFLOAT-1 DB 000H ;================================================================ #END #if 0 ; Symbols: 00DE' ABGOON 00AB' ABORT 00FF' ABORTEND 0C0D' ABS 0F9E' ALLOC 0F76' ALLOT 0F83' ALLOT2 1028' ASCII 12D8' ASSERT 08B3' AT 0B19' ATPOS 048A' BASE 0BC7' BDBREAK 0BCB' BDLOOP 0B98' BEEP 0BC9' BEEPDELAY 121A' BEGIN 07FA' BLANKS 07FB' BLANKS2 07FE' BLLOOP 1954' BLOAD 0BAF' BLOOP 07DA' BLWORD 04F0' BREAK 1944' BSAVE 1979' BVERIFY 1592' CADICT 10A7' CALL 0896' CAT 0B28' CATPOS 1584' CAWORD 0A24' CCLS 000D CCR 153A' CDCOLON 1537' CDDEFCOM 0005 CDL 150B' CDLOOP 153F' CDSETCTXT 08A5' CEXCLAM 0F09' CHGOON 054F' CHKIMM 0561' CHKIQUIT 0564' CHKNUMBER 061B' CHKSTRING 0F1D' CHLOOP 2C00 CHRSET 0080 CINV 0F5F' CKOMMA 0080 CLAST 0A1D' CLS 0C21' CMPPUSH 07B8' CNVDIGIT 07CD' CNVDOK 07D7' CNVDQUIT 077B' CNVEND 074C' CNVINT 07B4' CNVTEND 078C' CNVTLOOP 0EAF' COLON 10F5' COMPILER 0FE2' CONSTANT 0473' CONTEXT 078A' CONVERT 1568' CORRADDR 14F8' CORRCURR 1504' CORRDICT 1557' CORRPTR 1548' CORRWORD 094D' CPICK 095B' CPKGOON 007F CPR 0A95' CR 0ED0' CREATE 0EFB' CRHEADER 097F' CTYPE 0480' CURRENT 3C20 CURSOR 05FC' CWEND 0614' CWERR 05EA' CWLOOP1 05F3' CWLOOP2 0600' CWNFND 05E1' CWORD 0CD5' D32GOON 0CDB' D32LOOP 0CE5' D32NEXT 1ADF' DBRGOON1 1AE9' DBRGOON2 1AC8' DBVLOOP 023F' DCCDGOON 022C' DCCHARDEL 02D8' DCCLEAR 0225' DCCURDEL 01CE' DCDCEND 0198' DCDCINS 0196' DCDCNORM 01E4' DCDCQUIT 01A6' DCDCSCROL 01C9' DCDCSLOOP 01DD' DCDCSTORE 029C' DCDNLOOP 017E' DCDOCHAR 0295' DCDOWN 02A2' DCDSCROLL 02D0' DCENTER 01FE' DCFLAG 0302' DCGETCIN 01F0' DCJMPTAB 02CA' DCLDLOOP 0204' DCLEFT 02C3' DCLINEDEL 0210' DCNOP 0276' DCOUTCUR 02EA' DCRETYPE 0211' DCRIGHT 02F9' DCSELOOP 02ED' DCSETBEG 0282' DCSETCUR 02F4' DCSETEND 02B0' DCSTREND 0247' DCUP 024E' DCUPLOOP 0254' DCUSCROLL 0269' DCUSLOOP 0723' DECGET 0EA3' DECIMAL 0443' DECLINE 072C' DECSHIN 0732' DECSTORE 1074' DEFINER 11AB' DEFINITIONS 14DC' DELWORD 3C39 DICT 3C40 DICT1ST 14DA' DICTERR 0D51' DIV 0CC4' DIV32BY16 0D00' DIVMOD 0D0D' DIVMOD2 044B' DLEND 0C83' DLT 0DBA' DNEGATE 0DC5' DNLOOP 12AB' DO 129F' DOBEGIN 1AB8' DOBLOAD 1AD0' DOBREAD 1ABE' DOBVERIFY 0EC3' DOCOL 1110' DOCOMGOON 1108' DOCOMPILER 0FF5' DOCONSTANT 0FEC' DOCREATE 01E6' DOCTRL 1085' DODEFINER 1323' DODO 10E8' DODOESGT 1271' DOELSE 10B4' DOESGT 10CD' DOESPATCH 1225' DOFPATCH 1283' DOIF 1379' DOLBRACKET 1332' DOLOOP 0DBF' DONEGATE 133C' DOPLUSLOOP 1396' DOPTSTR 1276' DOREPEAT 1237' DORPATCH 1140' DORUNSGT 1A4F' DOSAVE 12A4' DOTHEN 128D' DOUNTIL 0FF0' DOVARIABLE 197D' DOVERIFY 1288' DOWHILE 0490' DP 0DEE' DPLUS 0879' DROP 109A' DROPGOON 0736' DSLOOP 086B' DUP 165E' EDIT 1675' EDITLIST 16DF' ELACK 1697' ELCOLON 169C' ELCOMPILER 16B1' ELDEFINER 16E8' ELEDIT 16C7' ELLLOOP 16C3' ELMLOOP 16B4' ELOUT 1702' ELQUIT 16D2' ELREADY 11EC' ELSE 0AA3' EMIT 03FF' EMITSCR 3C22 ENDBUF 0C4A' EQ 1294' EQUJUMP 0009 ERRAT 0005 ERRBLK 0003 ERRBRK 000B ERRDICT 000D ERRFIND 0008 ERRFLT 0004 ERRIMM 000E ERRLIST 0001 ERRMEM 000C ERRMODE 0006 ERRNAME 3C3D ERRNO FFFF ERRNONE 04D7' ERRORSTK 0007 ERRPICK 000A ERRREAD 0002 ERRSTK 0416' ESENTER 041C' ESQUIT 08C1' EXCLAM 1815' EXECDE 069A' EXECUTE 13F0' EXIT 3C29 EXWRCH 0003 FACCU 1B53' FADDITION 1BB3' FADDSUB 1B28' FADJLP1 1B2E' FADJLP2 1B3A' FADJLP3 1B22' FADJUST 1BC1' FASGOON1 1BC9' FASGOON2 1C02' FASGOON3 1BCE' FASLP1 1BE5' FASLP2 1BF6' FASLP3 0837' FAST 1C0C' FCLP 0660' FCOMPARE 1C04' FCORR 1C21' FCQUIT 0011 FCURR 1CB0' FDGOON1 1CCB' FDGOON2 1CFE' FDGOON3 000F FDICT 1C7B' FDIV 0010 FDIVOR 1CA2' FDLOOP1 1CB3' FDLOOP2 1CB5' FDLOOP3 1CBD' FDLOOP4 1CE8' FDNEXT 0040 FEOFFS 0000 FEXP1 0001 FEXP2 0000 FFLAG 1AF8' FICLEAR 1A3D' FILEBHEAD 1A10' FILEFHEAD 19F3' FILENAME 063D' FIND 1620' FINDWORD 1AF4' FINIT 1278' FJUMP 3C3E FLAGS 000B FLEN 064B' FLOOP 1C3D' FLT0 1C40' FLT0LP 1C3B' FLTERR 1BA4' FMINUS 1C5D' FMLOOP 1B67' FMLOOP1 1B77' FMLOOP2 1B91' FMNEXT 1B83' FMNOADD 1C4B' FMUL 1B55' FMULADD 1B43' FNEG 1D0F' FNEGATE 067D' FNEXT1 067F' FNEXT2 0001 FNLEN 1B48' FNLOOP 1D18' FNQUIT 1638' FORGET 0133' FORTH 0AFC' FP0 2301 FPADMEM 0B05' FPEXP 0ABE' FPGOON1 0ACA' FPGOON2 0ACE' FPGOON3 0AD7' FPH0 1BB1' FPLUS 0ADC' FPMLOOP 0AAF' FPNT 0B10' FPQUIT 0676' FPRINT 15E7' FPTR2NAME 3C00 FPWS 0007 FQUO 3C2B FRAMES 3C51 FREEMEM 0002 FSGN 0080 FSIGN 0019 FSIZE 000D FSTART 0657' FTEST 0742' FZEQLP 0740' FZEROEQ 104B' GETBYTE 048D' GETFLAGS 1064' GETFLOAT 05DF' GETSTRING 044D' GETVAR 1011' GETWORD 0004 GFX 0C99' GREATER 0CA0' GRTRQUIT 0C56' GT 08D2' GTR 1019' GWGOON 1015' GWLOOP 101E' GWQUIT 0460' HERE 3C1A HLD 0A5C' HOLD 0A69' HOLDQUIT 12E9' I 0D9E' I0NEND 11C0' IF 128F' IF0JUMP 0D94' IFN0NEG 043D' ILLOOP 0040 IMM 1160' IMMEDIATE 0BEB' IN 0BDB' INKEY 3C1E INSCRN 042F' INSLINE 1D22' INT 1D2B' INTLOOP 1D45' INTQUIT 0008 INV 0828' INVIS 00FE IO 12F7' ITICK 1302' J 15F9' JDELOOP 132D' JNEXT4 15FB' JUMPDE 0009 KDN 3C27 KEYCNT 3C26 KEYCOD 0336' KEYGET 034F' KEYGLP 0347' KEYGNC 0362' KEYGNK 036B' KEYGQU 036D' KEYGQU2 0359' KEYGSC 0376' KEYTBL 0001 KLT 0F4E' KOMMA 0003 KRT 0007 KUP 0E4B' LAND 1361' LBRACKET 1368' LBREND 000A LDL 19DD' LDNLOOP 1316' LEAVE 3C24 LHALF 0F36' LHGOON 0506' LINE 0530' LINEERR 0508' LINELOOP 0518' LINENUM 0526' LINESTR 0F2E' LINKHERE 1670' LIST 1708' LISTPGM 3C13 LISTWS 1006' LITERAL 1055' LITFLOAT 198A' LOAD 0002 LOK 12BD' LOOP 133F' LOOPADD 1350' LOOPCMP 1358' LOOPEND 12C1' LOOPGOON 0E36' LOR 1798' LPBYTE 178B' LPFLOAT 3C15 LPIACT 3C14 LPIBUF 3C13 LPICNT 176B' LPIDEC 175D' LPIINC 1764' LPILEFT 1770' LPINDENT 17AC' LPLBRACKET 3C16 LPLCNT 1712' LPLOOP 1756' LPNEXT 1783' LPNUMBER 17DA' LPNXTWRD 1753' LPOUT 17B0' LPPTSTR 17A4' LPSEMIS 17B2' LPSTRING 177C' LPWORD 13D5' LSQRBR 0C65' LT 098D' LTNUM 0E60' LXOR 0E75' MAX 0F9C' MCERROR 3C00 MEMBEG 0F8C' MEMCHECK 0F8F' MEMCHECK2 0E87' MIN 0E8F' MINMAX 0E95' MINMAXEND 0DE1' MINUS 0D61' MOD 0D6D' MUL 0D7A' MULDIV 0D31' MULDIVMOD 0A13' NADEC 1020' NASCII 1212' NBEGIN 0EAB' NCOLON 10EA' NCOMPILER 0FD7' NCONSTANT 0EC7' NCREATE 106A' NDEFINER 12A6' NDO 10AC' NDOESGT 0DA9' NEGATE 11E5' NELSE 04B9' NEXT 04BF' NEXTDE 04BA' NEXTSUB 15B5' NFA 06FD' NFEGOON 06EF' NFEXP 06CE' NFGOON 06BC' NFLOAT 06D3' NFLOOP1 06DF' NFLOOP2 0711' NFQUIT 0A07' NIBASC 11BB' NIF 135D' NLBRACKET 12B6' NLOOP 12C8' NPLUSLOOP 1383' NPTSTR 1243' NREPEAT 111D' NRUNSGT 049D' NSEMICOLON 1200' NTHEN 09F7' NUM 06A9' NUMBER 071C' NUMBERERR 0714' NUMBERQUIT 099C' NUMGT 09E1' NUMS 09E3' NUMSLP 125B' NUNTIL 0FC4' NVARIABLE 11CD' NWHILE 127C' OFFSJUMP 17CF' OILOOP 17D4' OIQUIT 0536' OK 054D' OKQUIT 0E1F' ONEMINUS 0E09' ONEPLUS 0BFD' OUT 17C1' OUTINDENT 17FB' OUTTXT 17E4' OUTWORD 17E1' OUTWORDI 0912' OVER 17F0' OWDOXX 15DB' P2AGOON 15D4' P2ARUN 15F2' P2NGOON 15F4' P2NLOOP 0499' PAD 2701 PADMEM 0925' PICK 0B6F' PLGOON 0B4A' PLOT 0DD2' PLUS 12D0' PLUSLOOP 0B7F' PLX0Y0 0B8C' PLXOR 0060 PND 09B3' PNT 180E' PNTHL 09C3' PNTLEFT 15C0' PTR2ADDR 15E8' PTR2NAME 1388' PTSTR 084E' PULLBC 0CF3' PUSHDEHL 08EE' QDUP 04F5' QLLOOP 059B' QLOOP 0594' QSTART 058C' QUERY 0099' QUIT 04F2' QUITLOOP 00AD' RABORT 18EC' RAGOON 18DF' RALOOP 18B6' RALOOP1 18B8' RALOOP2 18C7' RALOOP3 3C18 RAMTOP 3C24 RAMVAR 18F0' RASTART 18B5' RASYNC 18E7' RAVERIFY 18FE' RB8LOOP 1917' RBDELAY 191B' RBLOOP 0085' RCHR7 007C' RCHRLP 000A RDDLEN 0004 RDDNAME 1452' RDGOON1 147F' RDGOON2 0004 RDNCODE 000A RDNEND 000C RDNNAME 0006 RDNRUN 0002 RDOCODE 0008 RDOEND 0000 RDONAME 1A74' READHEADER 14CF' REDEFABORT 13FD' REDEFINE 03EE' REMIT 03F5' RENORM 124C' REPEAT 1610' RESCURR 18FB' RETURN 0578' RETYPE 0644' RFIND 1307' RGET 0055' RGFXLP 005F' RGFXM 003B' RGOON 08DF' RGT 1A95' RHBINARY 1A9F' RHCHECK 1AA7' RHCLOOP 1AAE' RHCNEXT 1AA9' RHCSTART 1A76' RHLOOP 0A5F' RHOLD 0028' RMEMLP 0933' ROLL 1FFC' ROMCHR 1808' ROMTXT 010D' ROMVAR 013A' ROMVEND 08FF' ROT 0859' RPULL 085F' RPUSH 009B' RQUIT 04B8' RSEMIS 04C8' RSLNEXT 04D9' RSLNGOON 13E1' RSQRBR 1142' RUNSCORR 1125' RUNSGT 18A7' RXALL 1911' RXBIT 18FC' RXBYTE 1AB6' RXERROR 1915' RXLEVEL 068A' RZERO 000C SAFETY 1934' SAVE 139F' SAVETEXT 0290' SCNOCAPS 2400 SCREEN 2700 SCREND 2800 SCRMEND 0421' SCROLLUP 3C1C SCRPOS 1A0E' SEMICODE 04A1' SEMICOLON 04B6' SEMIS 11B5' SETCONTEXT 0A4A' SIGN 159E' SKIPOFFS 15A2' SKOFFS2 15B1' SKOGOON 04C6' SLNEXT 0846' SLOW 0A73' SPACE 0A78' SPACEQUIT 0A83' SPACES 3C3B SPARE 0A86' SPCLOOP 3C28 STATIN 13B8' STFND 3C37 STKBOT 13A1' STLOOP 0885' SWAP 1864' TABIT0 1887' TACHECK 1839' TADEL1 1847' TADEL2 184F' TADEL3 185C' TADEL4 1862' TADEL5 188F' TAEND 1832' TAGOON1 1843' TAGOON2 1837' TALOOP1 1859' TALOOP2 186D' TANEXT 188A' TASTART 1207' THEN 0807' TOUPPER 1897' TRQDEL6 0E29' TWOMINUS 0E13' TWOPLUS 1820' TXALL 1892' TXRXQUIT 096E' TYPE 0979' TYPEDE 0C77' UCMP 0D8C' UDIVMOD 1D59' UFLOAT 1D62' UFLOOP 0C72' ULT 0CA8' UMUL 0CB3' UMULLOOP 0CBE' UMULNEXT 1263' UNTIL 09D0' UPNT 04E4' USERBREAK 0FCF' VARIABLE 3C3F VBASE 3C33 VCONTEXT 3C31 VCURRENT 0142' VDELAY 1967' VERIFY 0818' VIS 0325' VKAGAIN 0310' VKEY 0320' VKNEW 0331' VKPRESS 0332' VKQUIT 062D' VLIST 117D' VOCABULARY 3C35 VOCLNK 0147' VSCNT 0170' VSCTRL 0176' VSEND 0167' VSNOGRF 016D' VSNOINV 013A' VSYNC 05B3' WCLLOOP 05C6' WGOON1 05D1' WGOON2 11D5' WHILE 05AB' WORD 3C2F XCOORD 0E2D' XMINUS 0E17' XPLUS 0E2E' XPLUSMINUS 3C30 YCOORD 0688' ZERO 0C1A' ZEROEQ 0C3A' ZEROGT 0C2E' ZEROLT #endif