; ; Copyright (c) 1991-1996 Paul Campbell ; (for the monitor) ; All Rights Reserved ; THIS IS UNPUBLISHED PROPRIETARY SOURCE CODE OF Paul Campbell ; The copyright notice above does not evidence any ; actual or intended publication of such source code. ; ; Basic and EForth are (as far as I know) in the public ; domain ; NL = 0xd LF = 0xa BS = 8 DEL = 0x7f ;; ;; lo-core data memory ;; vint0l = 0x30 ;; interrupt 0 vector vint0h = 0x31 vint1l = 0x32 ;; interrupt 1 vector vint1h = 0x33 vtint0l = 0x34 ;; timer interrupt 0 vector vtint0h = 0x35 vtint1l = 0x36 ;; timer interrupt 1 vector vtint1h = 0x37 vtint2l = 0x38 ;; timer interrupt 1 vector vtint2h = 0x39 vserl = 0x3a ;; serial interrupt vector vserh = 0x3b timel = 0x3c ;; time counter timem = 0x3d timeh = 0x3e buffp = 0x3f ;; pointer to buffer base tcountl = 0x40 ;; down counter tcounth = 0x41 ;; ;; Main memory addresses ;; poll_vector = 0x80 ;; pointer to serial poll routine idle_vector = 0x82 ;; pointer to idle routine cli_vector = 0x84 ;; pointer to cli routine send_vector = 0x86 ;; pointer to send routine prompt_vector = 0x88 ;; pointer to prompt routine utility_vector = 0x8a ;; pointer to generic utility vector ;; to be used for adding drivers for external hardware old_addr = 0x8c ;; previous display address old_type = 0x8e ;; previous display type (0 = ram, 1 = ext) buff = 0x8f ;; ;; Interrupt vectors ;; . = 0x0000 ajmp reset nop push vint0l ; vector through low core pointers without push vint0h ; trashing any registers ret nop nop nop push vtint0l push vtint0h ret nop nop nop push vint1l push vint1h ret nop nop nop push vtint1l push vtint1h ret nop nop nop push vserl push vserh ret nop nop nop push vtint2l push vtint2h ret ; nop ; nop ; nop reset: mov p3, #0xc7 ;; turn off pyro channels asap ; ; p2 is always 0 (so software can depend on it) ; mov ie, #0 mov p2, #0 mov psw, #0 mov pcon, #0x00 mov ip, #0 ; ; set up default vectors ; mov r2, #noint&0xff mov r3, #noint>>8 mov r0, #vint0l mov r4, #(vtint2h-vint0l+1)>>1 l1: mov @r0, r2_0 inc r0 mov @r0, r3_0 inc r0 djnz r4, l1 ; ; set up OS dependant vectors ; mov timel, #0 mov timem, #0 mov timeh, #0 mov tcountl, #0 mov tcounth, #0 mov 0x20, #0 ; interupt flags mov r0, #idle_vector mov a, #idle&0xff mov @r0, a inc r0 mov a, #idle>>8 mov @r0, a mov r0, #poll_vector mov a, #pollv&0xff mov @r0, a inc r0 mov a, #pollv>>8 mov @r0, a mov r0, #send_vector mov a, #sendv&0xff mov @r0, a inc r0 mov a, #sendv>>8 mov @r0, a mov r0, #prompt_vector mov a, #promptv&0xff mov @r0, a inc r0 mov a, #promptv>>8 mov @r0, a mov r0, #utility_vector mov a, #entry_nvram&0xff mov @r0, a inc r0 mov a, #entry_nvram>>8 mov @r0, a mov r0, #cli_vector mov a, #cliv&0xff mov @r0, a inc r0 mov a, #cliv>>8 mov @r0, a clr a mov r0, #old_addr mov @r0, a inc r0 mov @r0, a inc r0 mov @r0, a ; ; ; set up watch-dog timer interrupt, tick counter ; ; mov vtint2l, #timer2&0xff mov vtint2h, #timer2>>8 ; ; set up the serial port ; mov tmod, #0x0 mov tcon, #0x0 mov t2con, #0x00 mov tl1, #0xfd ; 9600 baud @11MHz mov th1, #0xfd mov tmod, #0x22 mov tcon, #0x40 mov scon, #0x50 ; xmit only mov rcap2h, #0xfc ; 1mS mov rcap2l, #0x6c ;mov t2mod, #0x00 mov t2con, #0x04 setb ti mov buffp, #buff ; reset buffer ; ; set up sp ; mov sp, #0xd0 ; ; Print startup message ; mov dptr, #DO_NL acall DisplayC mov dptr, #RESET_MSG acall DisplayC ; ; check to see if we should auto-start ; jb p3.0, no_auto ; check the rcv bit - if it's pulled low autostart lcall check_eeprom mov a, r7_3 cjne a, #0, L97 ajmp L98 L97: lcall eeprom_load L98: no_auto: ; ; turn on interrupts ; mov ie, #0xa0 ; ; Now start main loop ; acall prompt main: acall poll M1: jz M2 mov r2, a acall send ; echo the char mov r0, buffp ; put it in a buffer mov a, r2 mov @r0, a cjne a, #':', M4 ; is it a ':'? mov a, buffp cjne a, #buff, M3 acall i_hex acall prompt ajmp main M4: cjne a, #BS, M6 ; is it a BS? M8: mov r6, a cjne r0, #buff, M9 ajmp M2 M9: dec r0 mov buffp, r0 mov a, #' ' acall send mov a, r6 acall send ajmp M2 M6: cjne a, #DEL, M7 ; is it a DEL? ajmp M8 M7: cjne a, #LF, M10 ; is it a DEL? ajmp M2 M10: cjne a, #NL, M3 ; is it a CR? mov a, #LF ; echo a LF acall send mov r0, buffp mov @r0, #0 ; 0 terminate it mov buffp, #buff ; reset buffer acall cli acall prompt ajmp M2 M3: inc r0 mov buffp, r0 M2: mov r0, #idle_vector acall icall ajmp main icall: mov a, @r0 mov dpl, a inc r0 mov a, @r0 mov dph, a clr a jmp @a+dptr timer2: clr tf2 xch a, timel inc a jnz noover xch a, timel xch a, timem inc a jnz noover2 inc timeh noover2: xch a, timem ajmp noover3 noover: xch a, timel noover3: ; ; Do the down counter - note nothing here touches C ; xch a, tcounth ; is the high byte 0? jz t0_1 xch a, tcounth ; no then check out then low byte xch a, tcountl jnz t0_3 dec a ; if it's 0 decrement the low byte to 0xff xch a, tcountl ; and the high byte dec tcounth reti t0_1: xch a, tcounth ; if the high byte is 0 ... xch a, tcountl jz t0_2 ; if the low byte is non-zero t0_3: dec a ; decrement it t0_2: xch a, tcountl ; and put it back noint: ; come here to do nothing reti idle: ret poll: mov r0, #poll_vector ajmp icall pollv: jb ri, got1 clr a ret got1: mov a, sbuf clr ri ret ; ; here's where we will add drivers for stuff like A/D and NVRAM in the future ; ; you enter here with registers a and r0 available for use ; other registers may contain parameters - it's routine specific ; unless specified utilioty routines must preserve all registers ; r2 contains the routine selector ; c is set on return if the selected utility was present ; utilityv: clr c cjne r2, #0, ut1 ; is it the NULL routine? ret ; yes just return ut1: utbad: setb c ; not a registered selector? bugout with an error ret prompt: mov r0, #prompt_vector ajmp icall promptv: mov a, #':' acall send mov a, #'-' acall send mov a, #')' acall send mov a, #' ' send: mov r1, a mov r0, #send_vector ajmp icall sendv: jnb ti, sendv clr ti mov sbuf, r1 ret ; ; Simple CLI: ; ; Commands: ; ; D addr - display address ; S addr val - set address ; G addr - goto address ; :intelhex - load intel hex ; cli: mov r0, #cli_vector ajmp icall cliv: mov r1, #buff mov a, @r1 cjne a, #0, C0 mov r0, #old_addr mov a, @r0 mov r6, a inc r0 mov a, @r0 mov r7, a inc r0 mov a, @r0 cjne a, #2, CX13 ajmp do_dis CX13: cjne a, #3, CX14 ajmp do_disl CX14: cjne a, #5, CX14a ljmp do_dump_eeprom CX14a: cjne a, #4, CX15 ajmp do_code CX15: jz do_ram ajmp do_ext C1a: ajmp C1 C0: cjne a, #'d', C1a C3: ;; do display inc r1 mov a, @r1 cjne a, #'r', CA1 ;; do DR addr CA2: acall get_addr jc fail_addr mov a, r7 jnz fail_addr do_ram: mov a, r6 acall disp_byte mov a, #':' acall send mov a, #' ' acall send mov r5, #8 CB1: mov r1_0, r6 inc r6 mov a, @r1 acall disp_byte mov a, #' ' acall send djnz r5, CB1 mov a, #'"' acall send mov a, r6 add a, #0xf8 mov r6, a mov r5, #8 CB2: mov r1_0, r6 inc r6 mov a, @r1 acall disp_char djnz r5, CB2 mov a, #'"' acall send mov a, #NL acall send mov a, #LF acall send mov r0, #old_addr mov a, r6 mov @r0, a inc r0 inc r0 clr a mov @r0, a ret fail_addr: mov dptr, #ERR2 ajmp DisplayC CA1: cjne a, #'R', CA3 ajmp CA2 CA3: cjne a, #'b', CCA4 CCA2: acall get_addr jc fail_addr mov r5, #0 CCB3: mov dpl, r6 mov dph, r7 movx a, @dptr inc dptr mov r6, dpl mov r7, dph acall disp_byte djnz r5, CCB3 mov a, #NL acall send mov a, #LF acall send ret CCA4: cjne a, #'B', CCA3 ajmp CCA2 CCA3: cjne a, #'E', CEA1 ajmp CCA3A CEA1: cjne a, #'e', CEA2 CCA3A: ljmp dump_eeprom CEA2: cjne a, #'i', CIA4 CIA2: acall get_addr jc fail_addr mov a, #':' acall send mov a, #0x20 acall disp_byte clr a acall disp_byte mov a, #0x20 add a, r6 add a, r7 mov r4, a mov a, r7 acall disp_byte mov a, r6 acall disp_byte mov r5, #0x20 CIB3: mov dpl, r6 mov dph, r7 movx a, @dptr add a, r4 mov r4, a movx a, @dptr inc dptr mov r6, dpl mov r7, dph acall disp_byte djnz r5, CIB3 clr a clr c subb a, r4 acall disp_byte mov a, #NL acall send mov a, #LF acall send ret CIA4: cjne a, #'I', CIA3 ajmp CIA2 CIA3: cjne a, #'m', CA4 ;; do DM addr CA5: acall get_addr jc fail_addr2y do_ext: mov a, r7 acall disp_byte mov a, r6 acall disp_byte mov a, #':' acall send mov a, #' ' acall send mov r5, #8 push r6_0 push r7_0 CB3: mov dpl, r6 mov dph, r7 movx a, @dptr inc dptr mov r6, dpl mov r7, dph acall disp_byte mov a, #' ' acall send djnz r5, CB3 mov a, #'"' acall send pop r7_0 pop r6_0 mov r5, #8 CB4: mov dpl, r6 mov dph, r7 movx a, @dptr inc dptr mov r6, dpl mov r7, dph acall disp_char djnz r5, CB4 mov a, #'"' acall send mov a, #NL acall send mov a, #LF acall send mov r0, #old_addr mov a, r6 mov @r0, a inc r0 mov a, r7 mov @r0, a inc r0 mov a, #1 mov @r0, a ret CA4: cjne a, #'M', CD3 ajmp CA5 fail_addr2y: ajmp fail_addr CD3: cjne a, #'c', CD4 ;; do DM addr CD5: acall get_addr jc fail_addr2y do_code: mov a, r7 acall disp_byte mov a, r6 acall disp_byte mov a, #':' acall send mov a, #' ' acall send mov r5, #8 push r6_0 push r7_0 CE3: mov dpl, r6 mov dph, r7 clr a movc a, @a+dptr inc dptr mov r6, dpl mov r7, dph acall disp_byte mov a, #' ' acall send djnz r5, CE3 mov a, #'"' acall send pop r7_0 pop r6_0 mov r5, #8 CE4: mov dpl, r6 mov dph, r7 clr a movc a, @a+dptr inc dptr mov r6, dpl mov r7, dph acall disp_char djnz r5, CE4 mov a, #'"' acall send mov a, #NL acall send mov a, #LF acall send mov r0, #old_addr mov a, r6 mov @r0, a inc r0 mov a, r7 mov @r0, a inc r0 mov a, #4 mov @r0, a ret CD4: cjne a, #'C', fail2 ajmp CD5 C1: cjne a, #'D', C2 ajmp C3 fail2: ajmp fail C2: cjne a, #'s', C4 C5: ;; do set inc r1 mov a, @r1 cjne a, #'r', CC1 ;; do SR addr byte byte byte CC2: acall get_addr jc fail_addr2 mov a, r7 jnz fail_addr2 mov r0, #old_addr ; save address mov a, r6 mov @r0, a inc r0 inc r0 clr a mov @r0, a mov r3_0, r6 ; move address registers to saved location CD1: acall get_addr jnc CD0 mov a, r6 jnz fail_data ret CD0: dec r1 mov r0_0, r3 mov a, r6 mov @r0, a inc r3 ajmp CD1 CC1: cjne a, #'R', CC3 ajmp CC2 CC3: cjne a, #'m', CC4 ;; do SM addr byte byte byte CC5: acall get_addr jc fail_addr2 mov r0, #old_addr ; save address mov a, r6 mov @r0, a inc r0 mov a, r7 mov @r0, a inc r0 mov a, #1 mov @r0, a mov r3_0, r6 ; move address registers to saved location mov r4_0, r7 CD11: acall get_addr jnc CD10 mov a, r6 jnz fail_data ret CD10: dec r1 mov dpl, r3 mov dph, r4 mov a, r6 movx @dptr, a inc dptr mov r3, dpl mov r4, dph ajmp CD11 CC4: cjne a, #'M', CC6 ajmp CC5 CC6: cjne a, #'E', CC6a ljmp write_eeprom CC6a: cjne a, #'e', CC6b ljmp write_eeprom CC6b: cjne a, #'F', CC6c ljmp write_eeprom_f CC6c: cjne a, #'f', failx ljmp write_eeprom_f failx: ajmp fail fail_addrx: ajmp fail_addr fail_data: mov dptr, #ERR3 ajmp DisplayC C4: cjne a, #'S', C6 ajmp C5 fail_addr2: ajmp fail_addr C6: cjne a, #'r', CF6 CF5: ljmp registers CF6:cjne a, #'R', CF7 ajmp CF5 CF7: cjne a, #'l', CF7a CF7c: inc r1 mov a, @r1 cjne a, #'e', CF7d ljmp load_eeprom CF7d: cjne a, #'E', CF7e ljmp load_eeprom CF7e: ajmp failx CF7a: cjne a, #'L', CF7b ajmp CF7c CF7b: cjne a, #'g', C7 C8: ;; do go acall get_addr jc fail_addr2 mov dpl, r6 mov dph, r7 mov r6_3, #0x00 ; SP for compiler mov r7_3, #0xff ; SP for compiler clr a jmp @a+dptr C7: cjne a, #'G', C9 ajmp C8 C9: cjne a, #'?', C11 C10: mov dptr, #HELP1 acall DisplayC mov dptr, #HELP1a acall DisplayC mov dptr, #HELP1b acall DisplayC mov dptr, #HELP1c acall DisplayC mov dptr, #HELP1d acall DisplayC mov dptr, #HELP1e acall DisplayC mov dptr, #HELP2 acall DisplayC mov dptr, #HELP3 acall DisplayC mov dptr, #HELP3a acall DisplayC mov dptr, #HELP4 acall DisplayC mov dptr, #HELP4a acall DisplayC mov dptr, #HELP4b acall DisplayC mov dptr, #HELP5 acall DisplayC mov dptr, #HELP5a acall DisplayC mov dptr, #HELP6 acall DisplayC mov dptr, #HELP7 acall DisplayC mov dptr, #HELP8 acall DisplayC mov dptr, #HELP9 acall DisplayC mov dptr, #HELP10 acall DisplayC mov dptr, #HELP11 acall DisplayC mov dptr, #HELP12 ajmp DisplayC C11:cjne a, #'h', C12 ajmp C10 C12:cjne a, #'H', C13 ajmp C10 C13: CX0:cjne a, #'i', CX1 CX2: inc r1 mov a, @r1 cjne a, #0, CX7 ajmp fail_addrx CX7: cjne a, #'l', CX4 ajmp do_disli CX4: cjne a, #'L', CX5 ajmp do_disli CX5: dec r1 acall get_addr jc fail_addrx2 mov r0, #old_addr+2 mov @r0, #2 do_dis: lcall decode CX8: mov r0, #old_addr mov a, r6 mov @r0, a inc r0 mov a, r7 mov @r0, a ret do_disli: acall get_addr jc fail_addrx2 mov r0, #old_addr+2 mov @r0, #3 do_disl: mov r2_1, #15 CX6: lcall decode djnz r2_1, CX6 ajmp CX8 CX1: cjne a, #'I', CG3 ajmp CX2 CG3: cjne a, #'T', CG4 mov r7_3, #0 ljmp START_BASIC CG4: cjne a, #'t', CG5 mov r7_3, #0 ljmp START_BASIC CG5: cjne a, #'F', CG6 mov r7_3, #0 ljmp EFORTH_START CG6: cjne a, #'f', NA2 mov r7_3, #0 ljmp EFORTH_START NA2: cjne a, #'A', NA1 ajmp AA1 NA1: cjne a, #'a', NA3 ajmp AA1 NA3: cjne a, #'e', NA4 ljmp ee_dir NA4: cjne a, #'E', fail ljmp ee_dir fail_addrx2: ajmp fail_addr fail: mov dptr, #ERR1 ajmp DisplayC DisplayC: dc: clr a movc a, @a+dptr jz disp_done inc dptr mov r6, dpl mov r7, dph acall send mov dpl, r6 mov dph, r7 ajmp dc disp_done: mov a, #NL acall send mov a, #LF ajmp send get_addr: mov r6, #0 mov r7, #0 gnxt1: inc r1 mov a, @r1 cjne a, #' ', G1 ajmp gnxt1 G1: cjne a, #8, G2 ajmp gnxt1 G2: cjne a, #0, G3 G30: setb c mov r6, a ret G3: cjne a, #'9'+1, G7 G7: jc G4 cjne a, #'A', G8 G8: jc G6 cjne a, #'F'+1, G11 G11: jnc G12 clr c subb a, #'A' add a, #10 ajmp G5 G12: cjne a, #'a', G13 G13: jc G6 cjne a, #'f'+1, G14 G14: jnc G6 clr c subb a, #'a' add a, #10 ajmp G5 G4: cjne a, #'0', G10 G10:jc G6 clr c subb a, #'0' G5: mov r2, a ; save the new nibble mov a, r7 ; shift nibble 2 to nibble 3, discard old nibble 3 swap a anl a, #0xf0 mov r7, a mov a, r6 ; shift nibble 1 to nibble 2 swap a anl a, #0x0f orl a, r7 mov r7, a mov a, r6 ; shift nibble 0 to nibble 1 swap a anl a, #0xf0 orl a, r2 ; insert nibble 0 mov r6, a inc r1 mov a, @r1 ajmp G3 G6: cjne a, #0, G20 G21: dec dpl mov a, dpl cjne a, #0xff, G23 dec dph G23:clr c ; return success ret G20:cjne a, #' ', G22 ajmp G21 G22:cjne a, #8, G30 ajmp G21 disp_byte: push acc swap a acall disp_b pop acc disp_b: anl a, #0x0f cjne a, #0xa, DB1 DB1:jc DB2 add a, #('A'-'0')-0xa DB2:add a, #'0' ajmp send disp_char: cjne a, #' ', DB3 DB3:jc DB4 cjne a, #0x7f, DB5 DB5:jc DB6 DB4:mov a, #'.' DB6:ajmp send ; code for 'a' and 'arm' AA1: inc r1 mov a, @r1 cjne a, #' ', AA2 ajmp AA1 AA2: cjne a, #'r', AA3 ajmp AB1 AA3: cjne a, #'R', AA4 ajmp AB1 AA4: cjne a, #0, AA5 mov a, #3 ajmp AA6 AA5: clr c subb a, #'0' anl a, #7 AA6: mov r0, a acall get_adc mov r4, r1 mov r3, r0 lcall put16 ajmp disp_done get_adc: mov r2, #'A' mov r1, #utility_vector mov a, @r1 mov dpl, a inc r1 mov a, @r1 mov dph, a clr a jmp @a+dptr ; ; arm +/- AB1: inc r1 mov a, @r1 cjne a, #'M', AB2 ajmp AB3 AB2 cjne a, #'m', AB4 ajmp AB3 AB4: ajmp fail AB3: inc r1 mov a, @r1 cjne a, #' ', AB5 ajmp AB3 AB5: cjne a, #'+', AB6 clr p3.2 mov dptr, #ARMED ajmp DisplayC AB6: cjne a, #'-', AB4 setb p3.2 mov dptr, #UNARMED ajmp DisplayC i_hex: acall get_hex_byte ; read length jc hexbad mov r5, a mov r3, a acall get_hex_byte ; read 1st address byte jc hexbad mov r7, a add a, r3 mov r3, a acall get_hex_byte ; read 2nd address byte jc hexbad mov r6, a add a, r3 mov r3, a acall get_hex_byte ; read flag byte jc hexbad jz loop add a, r3 mov r3, a acall get_hex_byte ; read sum byte jc hexbad add a, r3 jnz hexbad acall get_char cjne a, #NL, el3 el4: mov dptr, #DO_LOADED lcall Display mov a, r7_3 acall disp_byte mov a, r6_3 acall disp_byte mov dptr, #DO_NL ajmp DisplayC el3: cjne a, #LF, hexbad ajmp el4 loop: mov a, r5 jz end_loop acall get_hex_byte ; read sum byte jc hexbad mov dpl, r6 mov dph, r7 movx @dptr, a add a, r3 mov r3, a inc dptr dec r5 mov r6, dpl mov r7, dph ajmp loop end_loop: mov r6_3, r6 ; save last address mov r7_3, r7 acall get_hex_byte ; read sum byte jc hexbad add a, r3 jnz hexbad el6: acall get_char cjne a, #NL, el1 ajmp el6 el1: cjne a, #LF, el2 ajmp el6 el2: cjne a, #':', hexbad ajmp i_hex hexbad: mov dptr, #ERR4 ajmp DisplayC get_hex_byte: acall get_hex jc gbad swap a anl a, #0xf0 mov r2, a acall get_hex jc gbad orl a, r2 gbad:ret get_char: acall poll jz get_char ret get_hex: acall poll jz get_hex cjne a, #'0', Z1 Z1: jc Zbad cjne a, #'9'+1, Z2 Z2: jc Z3 cjne a, #'A', Z4 Z4: jc Zbad cjne a, #'F'+1, Z5 Z5: jnc Z6 Z9: add a, #9 Z3: anl a, #0xf clr c ret Z6: cjne a, #'a', Z7 Z7: jc Zbad cjne a, #'f'+1, Z8 Z8: jc Z9 Zbad:setb c ret ex0_handler: clr ex0 reti tab5: word t_p0, t_sp, t_dpl, t_dph, 0, 0, 0, t_pcon word t_tcon, t_tmod, t_tl0, t_tl1, t_th0, t_th1, t_auxr, 0 word t_p1, 0, 0, 0, 0, 0, 0, t_acon word t_scon, t_sbuf, 0, 0, 0, 0, 0, t_c1mod word t_p2, 0, 0, 0, 0, 0, 0, 0 word t_ie, t_saddr,0, 0, 0, 0, 0, t_cl1 word t_p3, 0, 0, 0, 0, 0, 0, 0 word t_ip, t_saden,0, 0, 0, 0, 0, t_ch1 word 0, 0, 0, 0, 0, 0, t_exicon,t_acmp word t_t2con,t_t2mod,t_rcap2l,t_rcap2h,t_tl2,t_th2, 0, 0 word t_psw, 0, 0, 0, 0, 0, 0, 0 word t_ccon, t_cmod, 0, 0, 0, 0, 0, 0 word t_acc, 0, 0, 0, 0, 0, 0, 0 word 0, t_cl, 0, 0, 0, 0, 0, 0 word t_b, 0, 0, 0, 0, 0, 0, 0 word 0, t_ch, 0, 0, 0, 0, 0, 0 tab6: word 0, 0, 0, 0, 0, 0, 0, 0 word t_it0, t_ie0, t_it1, t_ie1, t_tr0, t_tf0, t_tr1, t_tf1 word 0, 0, 0, 0, 0, 0, 0, 0 word t_ri, t_ti, t_rb8, t_tb8, t_ren, t_sm2, t_sm1, t_sm0_fe word 0, 0, 0, 0, 0, 0, 0, 0 word t_ex0, t_et0, t_ex1, t_et1, t_es, t_et2, t_ec, t_ez word 0, 0, 0, 0, 0, 0, 0, 0 word t_px0, t_pt0, t_px1, t_pt1, t_ps, t_pt2, t_pc, 0 word 0, 0, 0, 0, 0, 0, 0, 0 word t_cp_rl2,t_c_t2,t_tr2, t_exen2,t_tclk, t_rclk, t_exf2, t_tf2 word t_p, 0, t_ov, t_rs0, t_rs1, t_f0, t_ac, t_cy word 0, 0, 0, 0, 0, 0, 0, 0 word 0, 0, 0, 0, 0, 0, 0, 0 word 0, 0, 0, 0, 0, t_cre, t_cr1, t_cf1 word 0, 0, 0, 0, 0, 0, 0, 0 word 0, 0, 0, 0, 0, 0, 0, 0 t_it0: byte "IT0" t_ie0: byte "IE0" t_it1: byte "IT1" t_ie1: byte "IE1" t_tr0: byte "TR0" t_tf0: byte "TF0" t_tr1: byte "TR1" t_tf1: byte "TF1" t_ri: byte "RI" t_ti: byte "TI" t_rb8: byte "RB8" t_tb8: byte "TB8" t_ren: byte "REN" t_sm2: byte "SM2" t_sm1: byte "SM1" t_sm0_fe: byte "SM0/FE" t_ex0: byte "EX0" t_et0: byte "ET0" t_ex1: byte "EX1" t_et1: byte "ET1" t_es: byte "ES" t_et2: byte "ET2" t_ec: byte "EC" t_ez: byte "EZ" t_px0: byte "PX0" t_pt0: byte "PT0" t_px1: byte "PX1" t_pt1: byte "PT1" t_ps: byte "PS" t_pt2: byte "PT2" t_pc: byte "PC" t_cp_rl2: byte "CP/RL2" t_c_t2: byte "C/T2" t_tr2: byte "TR2" t_exen2: byte "EXEN2" t_tclk: byte "TCLK" t_rclk: byte "RCLK" t_exf2: byte "EXF2" t_tf2: byte "TF2" t_p: byte "P" t_ov: byte "OV" t_rs0: byte "RS0" t_rs1: byte "RS1" t_f0: byte "F0" t_ac: byte "AC" t_cy: byte "CY" t_cre: byte "CRE" t_cr1: byte "CR1" t_cf1: byte "CF1" t_p0: byte "P0" t_sp: byte "SP" t_dpl: byte "DPL" t_dph: byte "DPH" t_pcon: byte "PCON" t_tcon: byte "TCON" t_tmod: byte "TMOD" t_tl0: byte "TL0" t_tl1: byte "TL1" t_th0: byte "TH0" t_th1: byte "TH1" t_auxr: byte "AUXR" t_p1: byte "P1" t_acon: byte "ACON" t_scon: byte "SCON" t_sbuf: byte "SBUF" t_c1mod: byte "C1MOD" t_p2: byte "P2" t_ie: byte "IE" t_saddr: byte "SADDR" t_cl1: byte "CL1" t_p3: byte "P3" t_ip: byte "IP" t_saden: byte "SADEN" t_ch1: byte "CH1" t_exicon: byte "EXICON" t_acmp: byte "ACMP" t_t2con: byte "T2CON" t_t2mod: byte "T2MOD" t_rcap2l: byte "RCAP2L" t_rcap2h: byte "RCAP2H" t_tl2: byte "TL2" t_th2: byte "TH2" t_psw: byte "PSW" t_ccon: byte "CCON" t_cmod: byte "CMOD" t_acc: byte "ACC" t_cl: byte "CL" t_b: byte "B" t_ch: byte "CH" DO_LOADED: byte NL, LF, "Last address loaded: " t_dptr: byte "dptr" t_acall: byte "acall " t_add: byte "add " t_addc: byte "addc " t_ajmp: byte "ajmp " t_anl: byte "anl " t_cjne: byte "cjne " t_clr: byte "clr " t_cpl: byte "cpl " t_da: byte "da " t_dec: byte "dec " t_mul_ab: byte "mul ab" t_div_ab: byte "div ab" t_djnz: byte "djnz " t_invalid: byte "invalid" t_inc: byte "inc " t_jb: byte "jb " t_jbc: byte "jbc " t_jc: byte "jc " t_jmp: byte "jmp " t_jnb: byte "jnb " t_jnc: byte "jnc " t_jnz: byte "jnz " t_jz: byte "jz " t_lcall: byte "lcall " t_ljmp: byte "ljmp " t_mov: byte "mov " t_nop: byte "nop" t_orl: byte "orl " t_pop: byte "pop " t_push: byte "push " t_ret: byte "ret" t_reti: byte "reti" t_rl: byte "rl " t_rlc: byte "rlc " t_rr: byte "rr " t_rrc: byte "rrc " t_setb: byte "setb " t_sjmp: byte "sjmp " t_subb: byte "subb " t_swap: byte "swap " t_xch: byte "xch " t_xrl: byte "xrl " tab1: word t_inc word t_dec word t_add word t_addc word t_orl word t_anl word t_xrl word t_mov word t_mov word t_subb word t_mov word t_cjne word t_xch word t_djnz word t_mov word t_mov ; ; 0: 'op' indexed by top nibble ; 1: ajmp ; 2: ljmp ; 3: 'op a' indexed by top nibble ; 4: 'op a' indexed by top nibble (same op as 5) ; 5: 'op a, ??' indexed by top nibble ; 6: 'j? bit, addr' indexed by top nibble ; 7: acall ; 8: lcall ; 9: 'j? addr' indexed by top nibble ; 10: 'op data, a' indexed by top nibble ; 11: 'op data, #data' indexed by top nibble ; 12: 'op c, addr' indexed by top nibble ; 13: 'jmp @a+dptr' ; 14: 'mov ??, #data' ; 15: 'mov data, ??' ; 16: 'movc a,@a+pc' ; 17: 'mov a, #data' ; 18: 'mov dptr, #data' ; 19: 'mov addr, c' ; 20: 'movc a,@a+dptr' ; 21: 'op c,/bitaddr' ; 22: 'inc dptr' ; 23: 'mov ??, data' ; 24: 'op bitaddr' ; 25: 'op c' ; 26: 'cjne ??, #data, addr' ; 27: 'cjne a, data, addr' ; 28: 'push/pop data' ; 29: 'djnz ??, addr' ; 30: 'xchd @??' ; 31: 'movx a,@a+dptr' ; 32: 'movx a,@r?' ; 33: 'movx @a+dptr,a' ; 34: 'movx @r?,a' ; 35: 'mov ??, a' ; 36: 'op ??' indexed by top nibble ; 37: 'cjne a, #data, addr' ; 38: 'mov data, data' ; tab0: byte 0, 1, 2, 3, 4, 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, 36 byte 6, 7, 8, 3, 4, 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, 36 byte 6, 1, 0, 3, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5 byte 6, 7, 0, 3, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5 byte 9, 1, 10, 11, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5 byte 9, 7, 10, 11, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5 byte 9, 1, 10, 11, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5 byte 9, 7, 12, 13, 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14 byte 9, 1, 12, 16, 0, 38, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15 byte 18, 7, 19, 20, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5 byte 21, 1, 12, 22, 0, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23 byte 21, 7, 24, 25, 37, 26, 27, 26, 26, 26, 26, 26, 26, 26, 26, 26 byte 28, 1, 24, 25, 3, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5 byte 28, 7, 24, 25, 3, 29, 30, 30, 29, 29, 29, 29, 29, 29, 29, 29 byte 31, 1, 32, 32, 3, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5 byte 33, 7, 34, 34, 3, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35 tab2: word t_rr, t_rrc, t_rl, t_rlc word 0, 0, 0, 0 word 0, 0, 0, 0 word t_swap, t_da, t_clr, t_cpl RESET_MSG: byte NL, LF, "Monitor V2.20 'Plugh' Copyright Taniwha Systems 1991-1996" HELP1: byte "Commands: A <0-3> - display analog channel N" HELP1a: byte " ARM +/- - arm pyro channels" HELP1b: byte " DB - display external memory as hex" HELP1c: byte " DC - display program memory" HELP1d: byte " DE - display eeprom" HELP1e: byte " DI - display external memory as Intel Hex" HELP2: byte " DM - display external memory" HELP3: byte " DR - display internal memory" HELP3a: byte " ED - eeprom directory" HELP4: byte " SE - copies bytes (from 8000) to eeprom (to 0)" HELP4a: byte " SF - as above - but marks it as Forth" HELP4b: byte " SM - set external memory" HELP5: byte " SR - set internal memory" HELP5a: byte " LE - loads a saved program from eeprom" HELP6: byte " G - call subroutine at address" HELP7: byte " I - disassemble code at address" HELP8: byte " IL - disassemble page of code at address" HELP9: byte " R - display selected registers" HELP10: byte " : - load an Intel Hex record" HELP11: byte " T - Enter Tiny Basic" HELP12: byte " F - Enter EForth" ARMED: byte "Armed" UNARMED:byte "Not Armed" ERR1: byte "?Unknown command" ERR2: byte "?Bad address" ERR3: byte "?Bad data" ERR4: byte NL, LF, "?Bad download" DO_NL: byte 0 do_DisplayC: acall Display mov a, #NL acall Send mov a, #LF ajmp Send Display: clr a movc a, @a+dptr inc dptr cjne a, #0, DD0 ret DD0: acall Send ajmp Display Send: mov r1, a mov a, dpl mov r0_1, a mov a, dph mov r1_1, a mov r0, #send_vector mov a, @r0 inc r0 mov dpl, a mov a, @r0 mov dph, a clr a acall s2 mov a, r0_1 mov dpl, a mov a, r1_1 mov dph, a ret s2: jmp @a+dptr X18_0: byte "mov dptr, #" X5_0: byte "a, " X13_0: byte "jmp @a+dptr" X16_0: byte "movc a, @a+pc" X17_0: byte "mov a, " X20_0: byte "movc a, @a+dptr" X21_0: byte "c, /" X22_0: byte "inc dptr" X30_0: byte "xchd a, @r" X31_0: byte "movx a, @a+dptr" X32_0: byte "movx a, @r" X33_0: byte "movx @a+dptr, a" X34_0: byte "movx @r" decode: mov r3_0, r6 mov r4_0, r7 acall put16 mov a, #':' acall Send mov a, #' ' acall Send acall get_next mov r5, a mov dptr, #tab0 ; get type movc a, @a+dptr rl a mov b, a mov dptr, #jump_tab movc a, @a+dptr xch a, b inc dptr movc a, @a+dptr mov dpl, b mov dph, a clr a jmp @a+dptr .even jump_tab: dw X0 dw X1 dw X2 dw X3 dw X4 dw X5 dw X6 dw X7 dw X8 dw X9 dw X10 dw X11 dw X12 dw X13 dw X14 dw X15 dw X16 dw X17 dw X18 dw X19 dw X20 dw X21 dw X22 dw X23 dw X24 dw X25 dw X26 dw X27 dw X28 dw X29 dw X30 dw X31 dw X32 dw X33 dw X34 dw X35 dw X36 dw X37 dw X38 ; 0: 'op' indexed by top nibble X0: mov a, r5 cjne a, #0x00, X0_0 mov dptr, #t_nop ajmp do_DisplayC X0_0: cjne a, #0x22, X0_1 mov dptr, #t_ret ajmp do_DisplayC X0_1: cjne a, #0x32, X0_2 mov dptr, #t_reti ajmp do_DisplayC X0_2: cjne a, #0xa4, X0_3 mov dptr, #t_mul_ab ajmp do_DisplayC X0_3: cjne a, #0xa5, X0_4 mov dptr, #t_invalid ajmp do_DisplayC X0_4: mov dptr, #t_div_ab ajmp do_DisplayC ; ; 1: ajmp ; X1: mov dptr, #t_ajmp X1_0: acall Display mov a, r5 swap a rr a anl a, #0x07 mov r5, a acall get_next mov r3, a mov a, r7 anl a, #0xf8 orl a, r5 mov r4, a acall put16 idone: mov dptr, #DO_NL ajmp do_DisplayC ; ; 2: ljmp ; X2: mov dptr, #t_ljmp X2_0: acall Display acall get_next mov r4, a acall get_next mov r3, a acall put16 ajmp idone ; ; 3: 'op a' indexed by top nibble ; X3: mov dptr, #tab2 X3_1: mov a, r5 swap a anl a, #0x0f rl a mov r0, a movc a, @a+dptr mov r1, a mov a, r0 add a, #1 movc a, @a+dptr mov dph, a mov dpl, r1 acall Display mov a, #'a' acall Send ajmp idone ; ; 4: 'op a' indexed by top nibble (same op as 5) ; X4: mov dptr, #tab1 ajmp X3_1 ; ; 5: 'op a, ??' indexed by top nibble ; X5: mov dptr, #tab1 mov a, r5 swap a anl a, #0x0f rl a mov r0, a movc a, @a+dptr mov r1, a mov a, r0 inc a movc a, @a+dptr mov dph, a mov dpl, r1 acall Display mov dptr, #X5_0 acall Display acall operand ajmp idone ; ; 6: 'j? bit, addr' indexed by top nibble ; X6: cjne r5, #0x10, X6_0 mov dptr, #t_jbc ajmp X6_1 X6_0: cjne r5, #0x20, X6_2 mov dptr, #t_jb ajmp X6_1 X6_2: mov dptr, #t_jnb X6_1: acall Display acall directb acall comma acall put_rel ajmp idone ; ; 7: acall ; X7: mov dptr, #t_acall ajmp X1_0 ; ; 8: lcall ; X8: mov dptr, #t_lcall ajmp X2_0 ; ; 9: 'j? addr' indexed by top nibble ; X9: cjne r5, #0x40, X9_0 mov dptr, #t_jc ajmp X9_1 X9_0: cjne r5, #0x50, X9_2 mov dptr, #t_jnc ajmp X9_1 X9_2: cjne r5, #0x60, X9_3 mov dptr, #t_jz ajmp X9_1 X9_3: cjne r5, #0x70, X9_4 mov dptr, #t_jnz ajmp X9_1 X9_4: mov dptr, #t_sjmp X9_1: acall Display acall put_rel ajmp idone ; ; 10: 'op data, a' indexed by top nibble ; X10: mov r2, #0 X10_0: mov a, r5 anl a, #0xfe cjne a, #0x52, X10_5 mov dptr, #t_anl ajmp X10_1 X10_5: cjne a, #0x42, X10_2 mov dptr, #t_orl ajmp X10_1 X10_2: mov dptr, #t_xrl X10_1: acall Display acall direct acall comma cjne r2, #0, X10_3 mov a, #'a' acall Send ajmp idone X10_3: acall immed ajmp idone ; ; 11: 'op data, #data' indexed by top nibble ; X11: mov r2, #1 ajmp X10_0 ; ; 12: 'op c, addr' indexed by top nibble ; X12: cjne r5, #0x82, X12_5 mov dptr, #t_anl ajmp X12_1 X12_5: cjne r5, #0x72, X12_4 mov dptr, #t_orl ajmp X12_1 X12_4: mov dptr, #t_mov X12_1: acall Display mov a, #'c' acall Send acall comma acall directb ajmp idone ; ; 13: 'jmp @a+dptr' ; X13: mov dptr, #X13_0 ajmp do_DisplayC ; ; 14: 'mov ??, #data' ; X14: mov dptr, #t_mov acall Display acall operand acall comma acall immed ajmp idone ; ; 15: 'mov data, ??' ; X15: mov dptr, #t_mov acall Display acall direct acall comma acall operand ajmp idone ; ; 16: 'movc a,@a+pc' ; X16: mov dptr, #X16_0 ajmp do_DisplayC ; ; 17: 'mov a,#data' ; X17: mov dptr, #X17_0 acall Display acall immed ajmp idone ; ; 18: 'mov dptr, #data' ; X18: mov dptr, #X18_0 acall Display acall get_next mov r4, a acall get_next mov r3, a acall put16 ajmp idone ; ; 19: 'mov addr, c' ; X19: mov dptr, #t_mov acall Display acall directb acall comma mov a, #'c' acall Send ajmp idone ; ; 20: 'movc a,@a+dptr' ; X20: mov dptr, #X20_0 ajmp do_DisplayC ; ; 21: 'op c,/bitaddr' ; X21: cjne r5, #0xa0, X21_2 mov dptr, #t_orl ajmp X21_1 X21_2: mov dptr, #t_anl X21_1: acall Display mov dptr, #X21_0 acall Display acall directb ajmp idone ; ; 22: 'inc dptr' ; X22: mov dptr, #X22_0 ajmp do_DisplayC ; ; 23: 'mov ??, data' ; X23 mov dptr, #t_mov acall Display acall operand acall comma acall direct ajmp idone ; ; 24: 'op bitaddr' ; X24: mov r2, #0 x24_9: mov a, r5 anl a, #0xfe cjne a, #0xc2, X24_5 mov dptr, #t_clr ajmp X24_1 X24_5: cjne a, #0xd2, X24_2 mov dptr, #t_setb ajmp X24_1 X24_2: mov dptr, #t_cpl X24_1: acall Display cjne r2, #1, X24_3 mov a, #'c' acall Send ajmp idone X24_3: acall directb ajmp idone ; ; 25: 'op c' ; X25: mov r2, #1 ajmp x24_9 ; ; 26: 'cjne ??, #data, addr' ; X26: mov dptr, #t_cjne acall Display acall operand acall comma acall immed acall comma acall put_rel ajmp idone ; ; 27: 'cjne a, data, addr' ; X27: mov dptr, #t_cjne acall Display mov a, #'a' acall Send acall comma acall direct acall comma acall put_rel ajmp idone ; ; 28: 'push/pop data' ; X28: cjne r5, #0xc0, X28_2 mov dptr, #t_push ajmp X28_1 X28_2: mov dptr, #t_pop X28_1: acall Display acall direct ajmp idone ; ; 29: 'djnz ??, addr' ; X29: mov dptr, #t_djnz acall Display acall operand acall comma acall put_rel ajmp idone ; ; 30: 'xchd @??' ; X30: mov dptr, #X30_0 X30_1: acall Display mov a, r5 anl a, #1 add a, #'0' acall Send ajmp idone ; ; 31: 'movx a,@a+dptr' ; X31: mov dptr, #X31_0 ajmp do_DisplayC ; ; 32: 'movx a,@r?' ; X32: mov dptr, #X32_0 ajmp X30_1 ; ; 33: 'movx @a+dptr,a' ; X33: mov dptr, #X33_0 ajmp do_DisplayC ; ; 34: 'movx @r?,a' ; X34: mov dptr, #X34_0 acall Display mov a, r5 anl a, #1 add a, #'0' acall Send acall comma mov a, #'a' acall Send ajmp idone ; ; 35: 'mov ??, a' ; X35: mov dptr, #t_mov acall Display acall operand acall comma mov a, #'a' acall Send ajmp idone ; ; 36: 'op ??' indexed by top nibble ; X36: mov dptr, #tab1 mov a, r5 swap a anl a, #0x0f rl a mov r0, a movc a, @a+dptr mov r1, a mov a, r0 inc a movc a, @a+dptr mov dph, a mov dpl, r1 acall Display acall operand ajmp idone ; ; 37: 'cjne a, #data, addr' ; X37: mov dptr, #t_cjne acall Display mov a, #'a' acall Send acall comma acall immed acall comma acall put_rel ajmp idone ; ; 38: 'mov data, data' ; X38: mov dptr, #t_mov acall Display acall get_next push acc acall direct acall comma pop acc acall direct2 ajmp idone operand: mov a, r5 anl a, #0x0f cjne a, #4, op1 op3: mov a, #'#' acall Send acall get_next ajmp put8 op1: cjne a, #5, op2 ajmp direct op2: cjne a, #6, op4 mov r5, #0 op5: mov a, #'@' acall Send op7: mov a, #'r' acall Send mov a, r5 add a, #'0' ajmp Send op4: cjne a, #7, op6 mov r5, #1 ajmp op5 op6: anl a, #0x07 mov r5, a ajmp op7 get_next: clr a mov dpl, r6 mov dph, r7 movc a, @a+dptr inc dptr mov r6, dpl mov r7, dph ret put16: mov a, r4 acall put8 mov a, r3 put8: mov r0, a push r0_0 swap a acall xhex pop r0_0 mov a, r0 xhex: anl a, #0x0f cjne a, #10, xh2 xh2: jnc xh1 add a, #'0' ajmp Send xh1: add a, #'A'-10 ajmp Send comma: mov a, #',' acall Send mov a, #' ' ajmp Send immed: mov a, #'#' acall Send acall get_next ajmp put8 direct: acall get_next direct2: mov r0, a rlc a jnc dok anl a, #0xfe dname: mov dptr, #tab5 mov r1, a movc a, @a+dptr mov r3, a mov a, r1 inc a movc a, @a+dptr mov r4, a cjne r3, #0, dcont cjne r4, #0, dcont ajmp dfail dcont: mov dpl, r3 mov dph, r4 ajmp Display dok: dfail: mov a, r0 ajmp put8 directb: acall get_next mov r0, a rlc a jnc dok push r0_0 anl a, #0xf0 acall dname mov a, #'.' acall Send pop r0_0 mov a, r0 rl a anl a, #0xfe mov dptr, #tab6 mov r1, a movc a, @a+dptr mov r3, a mov a, r1 inc a movc a, @a+dptr mov r4, a cjne r3, #0, dcont2 cjne r4, #0, dcont2 ajmp dc1 dcont2: mov dpl, r3 mov dph, r4 ajmp Display dc1: mov a, r0 anl a, #7 add a, #'0' ajmp Send put_rel: acall get_next mov r5, a add a, r6 mov r3, a mov a, r5 rlc a jc prl2 rrc a clr a ajmp prl1 prl2: rrc a mov a, #0xff prl1: addc a, r7 mov r4, a ajmp put16 rdisp: acall Display mov a, #':' acall Send mov a, #' ' acall Send mov a, r7 acall put8 mov a, #' ' ajmp Send registers: mov dptr, #DO_NL acall do_DisplayC ; ; ; mov dptr, #t_sp mov r7, sp acall rdisp mov dptr, #t_b mov r7, b acall rdisp mov dptr, #t_dptr acall Display mov a, #':' acall Send mov a, #' ' acall Send mov r3, dpl mov r4, dph acall put16 mov dptr, #DO_NL acall do_DisplayC mov dptr, #t_p1 mov r7, p1 acall rdisp mov dptr, #t_psw mov r7, psw acall rdisp mov dptr, #t_scon mov r7, scon acall rdisp mov dptr, #t_sbuf mov r7, sbuf acall rdisp mov dptr, #DO_NL acall do_DisplayC mov dptr, #t_p2 mov r7, p2 acall rdisp mov dptr, #t_tcon mov r7, tcon acall rdisp mov dptr, #t_tmod mov r7, tmod acall rdisp mov dptr, #DO_NL acall do_DisplayC mov dptr, #t_p3 mov r7, p3 acall rdisp mov dptr, #t_t2con mov r7, t2con acall rdisp mov dptr, #DO_NL acall do_DisplayC mov dptr, #t_ip mov r7, ip acall rdisp mov dptr, #t_ie mov r7, ie acall rdisp mov dptr, #DO_NL acall do_DisplayC mov dptr, #DO_NL acall do_DisplayC mov dptr, #t_pcon mov r7, pcon acall rdisp mov dptr, #DO_NL acall do_DisplayC mov dptr, #DO_NL ajmp do_DisplayC ;; ;; Next - Intel's Basic ;; ; December 18, 1986 ; MS-DOS compatible Source code for MCS BASIC-52 (tm) ; Assembles with ASM51 Macro Assembler Version 2.2 ; ; The following source code does not include the floating point math ; routines. These are seperately compiled using FP52.SRC. ; ; Both the BASIC.SRC and FP52.SRC programs assemble into ABSOLUTE ; object files, and do not need to be relocated or linked. The FP52 ; object code and the BASIC object code, when compiled without modification ; of the source listings, create the same object code that is found on ; the MCS BASIC-52 Version 1.1 microcontrollers. ; ; The original source code had 7 "include" files that have been incorporated ; into this file for ease of assembly. ; These 7 files are: LOOK52.SRC, BAS52.RST, BAS52.PGM, BAS52.TL, BAS52.OUT, ; BAS52.PWM, and BAS52.CLK. ; ; ; Intel Corporation, Embedded Controller Operations ;$EJECT ;; ;; NOTE: in this environment (embedded in the flight computer) ;; this stuff doesn't exist .... all references to it ;; have been commented out ;; ;************************************************************** ; ; TRAP VECTORS TO MONITOR ; ; RESET TAG (0AAH) ---------2001H ; ; TAG LOCATION (5AH) ------ 2002H ; ; EXTERNAL INTERRUPT 0 ---- 2040H ; ; COMMAND MODE ENTRY ------ 2048H ; ; SERIAL PORT ------------- 2050H ; ; MONITOR (BUBBLE) OUTPUT - 2058H ; ; MONITOR (BUBBLE) INPUT -- 2060H ; ; MONITOR (BUBBLE) CSTS --- 2068H ; ; GET USER JUMP VECTOR ---- 2070H ; ; GET USER LOOKUP VECTOR -- 2078H ; ; PRINT AT VECTOR --------- 2080H ; ; INTERRUPT PWM ----------- 2088H ; ; EXTERNAL RESET ---------- 2090H ; ; USER OUTPUT-------------- 4030H ; ; USER INPUT -------------- 4033H ; ; USER CSTS --------------- 4036H ; ; USER RESET -------------- 4039H ; ; USER DEFINED PRINT @ --- 403CH ; ;*************************************************************** ; ;$INCLUDE(:F2:LOOK52.SRC) ; INCLUDED BELOW ; ;************************************************************** ; ; This is the equate table for 8052 basic. ; ;************************************************************** ; ; The register to direct equates for cjne instructions. ; R0B0 = 0 R1B0 = 1 R2B0 = 2 R3B0 = 3 R4B0 = 4 R5B0 = 5 R6B0 = 6 R7B0 = 7 ; ; Register bank 1 contains the text pointer ; and the arg stack pointer. ; TXAL = 8 ;r0 BANK 1 = TEXT POINTER LOW ASTKA = 9 ;r1 BANK 1 = ARG STACK TXAH = 10 ;r2 BANK 1 = TEXT POINTER HIGH ; ; Now five temporary locations that are used by basic. ; TEMP1 = 11 TEMP2 = 12 TEMP3 = 13 TEMP4 = 14 TEMP5 = 15 ; ;$EJECT ; Register bank 2 contains the read text pointer ; and the control stack pointer. ; RTXAL = 16 ;r0 BANK 2 = READ TEXT POINTER LOW CSTKA = 17 ;r1 BANK 2 = CONTROL STACK POINTER RTXAH = 18 ;r2 BANK 2 = READ TEXT POINTER HIGH ; ; Now some internal system equates. ; BOFAH = 19 ;START OF THE BASIC PROGRAM, HIGH BYTE BOFAL = 20 ;START OF THE BASIC PROGRAM, LOW BYTE NULLCT = 21 ;NULL COUNT PHEAD = 22 ;PRINT HEAD POSITION FORMAT = 23 ; ; Register bank 3 is for the user and can be loaded ; by basic ; ; ; ; Now everything else is used by basic. ; First the bit locations, these use bytes 34, 35, 36, 37 and 38 ; ;$EJECT OTS = 34.0 ;34.0-ON TIME INSTRUCTION EXECUTED INPROG = 34.1 ;34.1-INTERRUPT IN PROCESS INTBIT = 34.2 ;34.2-INTERRUPT SET BIT ON_ERR = 34.3 ;34.3-ON ERROR EXECUTED OTI = 34.4 ;34.4-ON TIME INTERRUPT IN PROGRESS LINEB = 34.5 ;34.5-LINE CHANGE OCCURED INTPEN = 34.6 ;34.6-INTERRUPT PENDING BIT CONB = 34.7 ;34.7-CAN CONTINUE IF SET GTRD = 35.0 ;35.0-READ GET LOCATION LPB = 35.1 ;35.1-PRINT TO LINE PRINTER PORT CKS_B = 35.2 ;35.2-FOR PWM INTERRUPT COB = 35.3 ;35.3-CONSOLE OUT BIT ; 0 = SERIAL PORT ; 1 = LINE PRINTER COUB = 35.4 ;35.4-USER CONSOLE OUT BIT ; 0 = SERIAL PORT ; 1 = USER DRIVER INBIT = 35.5 ;35.5-INITIALIZATION BIT CIUB = 35.6 ;35.6-USER CONSOLE IN BIT ; 0 = SERIAL PORT ; 1 = USER ROUTINE SPINT = 35.7 ;35.7-SERIAL PORT INTERRUPT STOPBIT = 36.0 ;36.0-PROGRAM STOP ENCOUNTERED U_IDL = 36.1 ;36.1-USER IDLE BREAK INP_B = 36.2 ;36.2-SET DURING INPUT INSTRUCTION ;DCMPXZ = 36.3 ;36.3-DCMPX ZERO FLAG ARGF = 36.4 ;36.4-ARG STACK HAS a VALUE RETBIT = 36.5 ;36.5-ret FROM INTERRUPT EXECUTED I_T0 = 36.6 ;36.6-TRAP INTERRUPT ZERO TO MON UPB = 36.7 ;36.7-SET WHEN @ IS VALID JKBIT = 37.0 ;37.0-WB TRIGGER ENDBIT = 37.1 ;37.1-GET END OF PROGRAM UBIT = 37.2 ;37.2-FOR DIM STATEMENT ISAV = 37.3 ;37.3-SAVE INTERRUPT STATUS BO = 37.4 ;37.4-BUBBLE OUTPUT XBIT = 37.5 ;37.5-EXTERNAL PROGRAM PRESENT C_BIT = 37.6 ;37.6-SET WHEN CLOCK RUNNING DIRF = 37.7 ;37.7-DIRECT INPUT MODE NO_C = 38.0 ;38.0-NO CONTROL c DRQ = 38.1 ;38.1-DMA ENABLED BI = 38.2 ;38.2-BUBBLE INPUT INTELB = 38.3 ;38.3-INTELLIGENT PROM PROGRAMMING C0ORX1 = 38.4 ;38.4-PRINT FROM ROM OR RAM CNT_S = 38.5 ;38.5-CONTROL S ENCOUNTERED ZSURP = 38.6 ;38.6-ZERO SUPRESS HMODE = 38.7 ;38.7-HEX MODE PRINT LP = P1.7 ;SOFTWARE LINE PRINTER ;DACK = P1.6 ;DMA ACK ;PROMV = P1.5 ;TURN ON PROM VOLTAGE ;PROMP = P1.4 ;PROM PULSE ;ALED = P1.3 ;ALE DISABLE T_BIT = P1.2 ;I/O TOGGLE BIT ; ;$EJECT ; ; The next location is a bit addressable byte counter ; BABC = 39 ; ; Now floating point and the other temps ; ; FP Uses to locations 03CH ; ; Now the stack designators. ; SPSAV = 0x3e S_LEN = 0x3f T_HH = 0x40 T_LL = 0x41 INTXAH = 0x42 INTXAL = 0x43 MT1 = 0x45 MT2 = 0x46 MILLIV = 0x47 ;TIMER LOCATIONS TVH = 0x48 TVL = 0x49 SAVE_T = 0x4a SP_H = 0x4b ;SERIAL PORT TIME OUT SP_L = 0x4C UV_H = 0x4d ; copy of the utility vector UV_L = 0x4e CMNDSP = 0x4f ;SYSTEM STACK POINTER IRAMTOP = 0xff ;TOP OF RAM STACKTP = 0xfe ;ARG AND CONTROL STACK TOPS ; ; The character equates ; SCR = 0x0d ;CARRIAGE RETURN LF = 0x0a ;LINE FEED BELL = 0x07 ;BELL CHARACTER BS = 0x08 ;BACK SPACE CNTRLC = 0x03 ;CONTROL c CNTRLD = 0x04 ;CONTROL D NULL = 0x00 ;NULL ; ;$EJECT ; ; The internal system equates ; LINLEN = 73 ;THE LENGTH OF AN INPUT LINE EOF = 01 ;END OF FILE CHARACTER ASTKAH = 0x81 ;ASTKA IS IN PAGE 1 OF RAM CSTKAH = 0x80 ;CSTKA IS IN PAGE 0 OF RAM FTYPE = 01 ;CONTROL STACK "FOR" GTYPE = 02 ;CONTROL STACK "GOSUB" DTYPE = 03 ;DO-WHILE/UNTIL TYPE ROMADR = 0x8000 ;LOCATION OF ROM RAM_TOP = 0xff00 ; ; The floating point equates ; FPSIZ = 6 ;NO. OF BYTES IN a FLOATING NUM XDIGIT = FPSIZ-2 ;THE MANTISSA OF a FLOATING NUM STESIZ = FPSIZ+3 ;SIZE OF SYMBOL ADJUSTED TABLE ELEMENT ;FP_BASE = 0x1993 ;BASE OF FLOATING POINT ROUTINES PSTART = 0x8200 ;START OF a PROGRAM IN RAM FSIZE = FPSIZ+FPSIZ+2+2+1 ; ;$EJECT ;*************************************************************** ; ; MCS - 51 - 8K BASIC VERSION 1.1 ; ;*************************************************************** ; ; ljmp CRST ;START THE PROGRAM ; ; ORG 3H ; ;*************************************************************** ; ;EXTERNAL INTERRUPT 0 ; ;*************************************************************** ; BINT0: ajmp STQ ; jb DRQ,STQ ;SEE IF DMA IS SET ; push PSW ;SAVE THE STATUS ; ljmp 0x4003 ;JUMP TO USER IF NOT SET ; ; ORG 0BH ; ;*************************************************************** ; ;TIMER 0 OVERFLOW INTERRUPT ; ;*************************************************************** ; BTINT0: push PSW ;SAVE THE STATUS ljmp I_DR ; jb C_BIT,STJ ;SEE IF USER WANTS INTERRUPT ; ljmp 0x400B ;EXIT IF USER WANTS INTERRUPTS ; ; ORG 0x13 ; ;*************************************************************** ; ;EXTERNAL INTERRUPT 1 ; ;*************************************************************** ; BINT1: ajmp STK ; jb INTBIT,STK ; push PSW ; ljmp 0x4013 ; ;$EJECT ; ; ORG 1BH ; ;*************************************************************** ; ;TIMER 1 OVERFLOW INTERRUPT ; ;*************************************************************** ; ; push PSW ; ljmp CKS_I ; ;STJ: ljmp I_DR ;DO THE INTERRUPT ; ;*************************************************************** ; ;SERIAL PORT INTERRUPT ; ;*************************************************************** ; ; ORG 0x23 ; ; push PSW ; jb SPINT,STU ;SEE IF MONITOR EANTS INTERRUPT ; ljmp 0x4023 ; ; ORG 2BH ; ;************************************************************** ; ;TIMER 2 OVERFLOW INTERRUPT ; ;************************************************************** ; ; push PSW ; ljmp 0x402B ; ;$EJECT ;************************************************************** ; ;USER ENTRY ; ;************************************************************** ; ; ORG 30H ; ; ljmp IBLK ;LINK TO USER BLOCK ; STQ: ;jb I_T0,STS ;SEE IF MONITOR WANTS IT ;clr DACK ;jnb p3.2, . ;WAIT FOR DMA TO END ;setb DACK reti ; ;STS: ljmp 0x2040 ;GO TO THE MONITOR ; STK: setb INTPEN ;TELL BASIC AN INTERRUPT WAS RECEIVED reti ; ;STU: ljmp 0x2050 ;SERIAL PORT INTERRUPT ; ;$EJECT ;$EJECT ;************************************************************** ; USENT: ; User entry jump table ; ;************************************************************** ; dx CMND1 ;(00, 0x00)COMMAND MODE JUMP dx IFIX ;(01, 0x01)CONVERT FP TO INT dx PUSHAS ;(02, 0x02)push VALUE ONTO ARG STACK dx POPAS ;(03, 0x03)pop VALUE OFF ARG STACK dx CNULL;PG1 ;(04, 0x04)PROGRAM a PROM dx INLINE ;(05, 0x05)INPUT a LINE dx UPRNT ;(06, 0x06)PRINT a LINR dx CRLF ;(07, 0x07)OUTPUT a CRLF ; ;************************************************************** ; ; This is the operation jump table for arithmetics ; ;************************************************************** ; OPTAB: dx ALPAR ;(08, 0x08)LEFT PAREN dx AEXP ;(09, 09H)EXPONENTAION dx AMUL ;(10, 0x0a)FP mul dx AADD ;(11, 0BH)FLOATING POINT add dx ADIV ;(12, 0CH)FLOATING POINT DIVIDE dx ASUB ;(13, 0DH)FLOATING POINT SUBTRACTION dx Axrl ;(14, 0EH)XOR dx AANL ;(15, 0x0f)AND dx AORL ;(16, 0x10)OR dx ANEG ;(17, 11H)NEGATE dx AEQ ;(18, 0x12)EQUAL dx AGE ;(19, 0x13)GREATER THAN OR EQUAL dx ALE ;(20, 14H)LESS THAN OR EQUAL dx ANE ;(21, 15H)NOT EQUAL dx ALT ;(22, 0x16)LESS THAN dx AGT ;(23, 0x17)GREATER THAN ; ;$EJECT ;*************************************************************** ; ; This is the jump table for unary operators ; ;*************************************************************** ; dx AABS ;(24, 18H)ABSOLUTE VALUE dx AINT ;(25, 0x19)INTEGER OPERATOR dx ASGN ;(26, 1AH)SIGN OPERATOR dx ANOT ;(27, 1BH)ONE"S COMPLEMENT dx ACOS ;(28, 1CH)COSINE dx ATAN ;(29, 1DH)TANGENT dx ASIN ;(30, 1EH)SINE dx ASQR ;(31, 1FH)SQUARE ROOT dx ACBYTE ;(32, 20H)READ CODE dx AETOX ;(33, 0x21)E TO THE X dx AATAN ;(34, 0x22)ARC TANGENT dx ALN ;(35, 0x23)NATURAL LOG dx AP3B ; read p3 bit dx AP1B ; read p1 bit dx AAB ; read A(x) bit dx EE_RD ; read A(x) bit dx ADBYTE ;(36, 24H)READ DATA MEMORY dx AXBYTE ;(37, 0x25)READ EXTERNAL MEMORY dx PIPI ;(38, 26H)PI dx ARND ;(39, 0x27)RANDOM NUMBER dx AGET ;(40, 0x28)GET INPUT CHARACTER dx AFREE ;(41, 29H)COMPUTE #BYTES FREE dx ALEN ;(42, 2AH) COMPUTE LEN OF PORGRAM dx AXTAL ;(43, 2BH) CRYSTAL dx PMTOP ;(44, 2CH)TOP OF MEMORY dx ATIME ;(45, 2DH) TIME dx A_IE ;(46, 2EH) IE dx A_IP ;(47, 2FH) IP dx ATIM0 ;(48, 30H) TIMER 0 dx ATIM1 ;(49, 31H) TIMER 1 dx ATIM2 ;(50, 32H) TIMER 2 dx AT2CON ;(51, 0x33) T2CON dx ATCON ;(52, 34H) TCON dx ATMOD ;(53, 0x35) ATMOD dx ARCAP2 ;(54, 36H) RCAP2 dx AP1 ;(55, 0x37) P1 dx APCON ;(56, 38H) PCON dx AP3 ; P3 dx E1XX_2 ; set ARM bit dx EXPRB ;(57, 39H) EVALUATE AN EXPRESSION dx AXTAL1 ;(58, 3AH) CALCULATE CRYSTAL dx LINE ;(59, 3BH) EDIT a LINE dx PP ;(60, 3CH) PROCESS a LINE dx UPPL_3 ;(61, 3DH) UNPROCESS a LINE dx VAR ;(62, 0x3e) FIND a VARIABLE dx GC ;(63, 0x3f) GET a CHARACTER dx GCI ;(64, 40H) GET CHARACTER AND INCREMENT dx INCHAR ;(65, 41H) INPUT a CHARACTER dx CRUN ;(66, 42H) RUN a PROGRAM ;$EJECT OPBOL: db 1 ; ; db 15 ;LEFT PAREN db 14 ;EXPONENTIAN ** db 10 ;mul db 8 ;add db 10 ;DIVIDE db 8 ;SUB db 3 ;XOR db 5 ;AND db 4 ;OR db 12 ;NEGATE db 6 ;EQ db 6 ;GT db 6 ;LT db 6 ;NE db 6 ;LE db 6 ;GE ; UOPBOL: db 15 ;AABS db 15 ;AAINT db 15 ;ASGN db 15 ;ANOT db 15 ;ACOS db 15 ;ATAN db 15 ;ASIN db 15 ;ASQR db 15 ;ACBYTE db 15 ;E TO THE X db 15 ;AATAN db 15 ;NATURAL LOG db 15 ;P1B db 15 ;P3B db 15 ;A(x) db 15 ;EE(x) db 15 ;DBYTE db 15 ;XBYTE ; ;$EJECT ;*************************************************************** ; ; The ASCII printed messages. ; ;*************************************************************** ; STP: db "STOP" ; IAN: db "TRY AGAIN" ; RDYS: db "READY" ; INS: db " - IN LINE " ; ;************************************************************** ; ; This is the command jump table ; ;************************************************************** ; CMNDD: dx CRUN ;RUN dx CLIST ;LIST dx CNULL ;NULL dx CNEW ;NEW dx CCONT ;CONTINUE dx CPROG ;PROGRAM a PROM dx CXFER ;TRANSFER FROM ROM TO RAM dx CNULL;CRAM ;RAM MODE dx CNULL;CROM ;ROM MODE dx CNULL;CIPROG ;INTELLIGENT PROM PROGRAMMING ; ;$EJECT ;*************************************************************** ; ; This is the statement jump table. ; ;************************************************************** ; STATD: ; dx SLET ;LET 0x80 dx SCLR ;CLEAR 0x81 dx SPUSH ;push VAR 0x82 dx SGOTO ;GO TO 0x83 dx STONE ;TONE 0x84 dx SPH0 ;PRINT MODE 0 0x85 dx CNULL;SUI ;USER INPUT 0x86 ;dx CNULL;SUO ;USER OUTPUT 0x87 dx SBYE ;quit 0x87 dx SPOP ;pop VAR 0x88 dx SPRINT ;PRINT 0x89 dx SCALL ;lcall 0x8a dx SDIMX ;DIMENSION 0x8b dx STRING ;STRING ALLO 0x8c dx SBAUD ;SET BAUD 0x8d dx SCLOCK ;CLOCK 0x8e dx SPH1 ;PRINT MODE 1 0x8f ; ; No direct mode from here on ; dx SSTOP ;STOP 0x90 dx SOT ;ON TIME 0x91 dx SONEXT ;ON EXT INT 0x92 dx SRETI ;ret FROM INT 0x93 dx S_DO ;DO 0x94 dx SRESTR ;RESTOR 0x95 dx WCR ;REM 0x96 dx SNEXT ;NEXT 0x97 dx SONERR ;ON ERROR 0x98 dx S_ON ;ON 0x99 dx SINPUT ;INPUT 0x9a dx SREAD ;READ 0x9b dx FINDCR ;DATA 0x9c dx SRETRN ;RETURN 0x9d dx SIF ;IF 0x9e dx SGOSUB ;GOSUB 0x9f dx SFOR ;FOR 0xa0 dx SWHILE ;WHILE 0xa1 dx SUNTIL ;UNTIL 0xa2 dx CMND1 ;END 0xa3 dx I_DL ;IDLE 0xa4 dx ST_A ;STORE AT 0xa5 dx LD_A ;LOAD AT 0xa6 dx CNULL;PGU ;PGM 0xa7 dx CNULL;RROM ;RUN a ROM 0xa9 ; ;$EJECT ;************************************************************** ; TOKTAB: ; This is the basic token table ; ;************************************************************** ; ; First the tokens for statements ; db 0x80 ;LET TOKEN db "LET\z" ; db 0x81 ;CLEAR TOKEN db "CLEAR\z" ; db 0x82 ;push TOKEN db "PUSH\z" ; T_GOTO = 0x83 ; db 0x83 ;GO TO TOKEN db "GOTO\z" ; db 0x84 ;TOGGLE TOKEN db "PWM\z" ; db 0x85 ;PRINT HEX MODE 0 db "PH0.\z" ; ; db 0x86 ;USER IN TOKEN ; db "UI\z" ; ; db 0x87 ;USER OUT TOKEN ; db "UO\z" ; db 0x87 ;quit back to monitor db "BYE\z" ; db 0x88 ;pop TOKEN db "POP\z" ; ;$EJECT db 0x89 ;PRINT TOKEN db "PRINT\z" db 0x89 db "P.\z" ;P. ALSO MEANS PRINT db 0x89 ;? ALSO db "?\z" ; db 0x8a ;lcall TOKEN db "LCALL\z" ; db 0x8b ;DIMENSION TOKEN db "DIM\z" ; db 0x8c ;STRING TOKEN db "STRING\z" ; db 0x8d ;SET BAUD RATE db "BAUD\z" ; db 0x8e ;CLOCK db "CLOCK\z" ; db 0x8f ;PRINT HEX MODE 1 db "PH1.\z" ; T_STOP = 0x90 ;STOP TOKEN db T_STOP db "STOP\z" ; T_DIR = T_STOP ;NO DIRECT FROM HERE ON ; db T_STOP+1 ;ON TIMER INTERRUPT db "ONTIME\z" ; db T_STOP+2 ;ON EXTERNAL INTERRUPT db "ONEX1\z" ; db T_STOP+3 ;RETURN FROM INTERRUPT db "RETI\z" ; db T_STOP+4 ;DO TOKEN db "DO\z" ; db T_STOP+5 ;RESTORE TOKEN db "RESTORE\z" ; ;$EJECT T_REM = T_STOP+6 ;REMARK TOKEN db T_REM db "REM\z" ; db T_REM+1 ;NEXT TOKEN db "NEXT\z" ; db T_REM+2 ;ON ERROR TOKEN db "ONERR\z" ; db T_REM+3 ;ON TOKEN db "ON\z" ; db T_REM+4 ;INPUT db "INPUT\z" ; db T_REM+5 ;READ db "READ\z" ; T_DATA = T_REM+6 ;DATA db T_DATA db "DATA\z" ; db T_DATA+1 ;RETURN db "RETURN\z" ; db T_DATA+2 ;IF db "IF\z" ; T_GOSB = T_DATA+3 ;GOSUB db T_GOSB db "GOSUB\z" ; db T_GOSB+1 ;FOR db "FOR\z" ; db T_GOSB+2 ;WHILE db "WHILE\z" ; db T_GOSB+3 ;UNTIL db "UNTIL\z" ; db T_GOSB+4 ;END db "END\z" ; ;$EJECT T_LAST = T_GOSB+5 ;LAST INITIAL TOKEN ; T_TAB = T_LAST ;TAB TOKEN db T_TAB db "TAB\z" ; T_THEN = T_LAST+1 ;THEN TOKEN db T_THEN db "THEN\z" ; T_TO = T_LAST+2 ;TO TOKEN db T_TO db "TO\z" ; T_STEP = T_LAST+3 ;STEP TOKEN db T_STEP db "STEP\z" ; T_ELSE = T_LAST+4 ;ELSE TOKEN db T_ELSE db "ELSE\z" ; T_SPC = T_LAST+5 ;SPACE TOKEN db T_SPC db "SPC\z" ; T_CR = T_LAST+6 db T_CR db "CR\z" ; db T_CR+1 db "IDLE\z" ; db T_CR+2 db "ST@\z" ; db T_CR+3 db "LD@\z" ; ;db T_CR+4 ;db "PGM\z" ; ;db T_CR+5 ;db "RROM\z" ; ;$EJECT ; Operator tokens ; T_LPAR = 0xE0 ;LEFT PAREN db T_LPAR db "(\z" ; db T_LPAR+1 ;EXPONENTIAN db "**\z" ; db T_LPAR+2 ;FP MULTIPLY db "*\z" ; T_ADD = T_LPAR+3 db T_LPAR+3 ;add TOKEN db "+\z" ; db T_LPAR+4 ;DIVIDE TOKEN db "/\z" ; T_SUB = T_LPAR+5 ;SUBTRACT TOKEN db T_SUB db "-\z" ; db T_LPAR+6 ;LOGICAL EXCLUSIVE OR db ".XOR.\z" ; db T_LPAR+7 ;LOGICAL AND db ".AND.\z" ; db T_LPAR+8 ;LOGICAL OR db ".OR.\z" ; T_NEG = T_LPAR+9 ; T_EQU = T_LPAR+10 ;EQUAL db T_EQU db "=\z" ; db T_LPAR+11 ;GREATER THAN OR EQUAL db ">=\z" ; db T_LPAR+12 ;LESS THAN OR EQUAL db "<=\z" ; db T_LPAR+13 ;NOT EQUAL db "<>\z" ; db T_LPAR+14 ;LESS THAN db "<\z" ; db T_LPAR+15 ;GREATER THAN db ">\z" ; ; T_UOP = 0xB0 ;UNARY OP BASE TOKEN ; db T_UOP ;ABS TOKEN db "ABS\z" ; db T_UOP+1 ;INTEGER TOKEN db "INT\z" ; db T_UOP+2 ;SIGN TOKEN db "SGN\z" ; db T_UOP+3 ;GET TOKEN db "NOT\z" ; db T_UOP+4 ;COSINE TOKEN db "COS\z" ; db T_UOP+5 ;TANGENT TOKEN db "TAN\z" ; db T_UOP+6 ;SINE TOKEN db "SIN\z" ; db T_UOP+7 ;SQUARE ROOT TOKEN db "SQR\z" ; db T_UOP+8 ;CBYTE TOKEN db "CBY\z" ; db T_UOP+9 ;EXP (E TO THE X) TOKEN db "EXP\z" ; db T_UOP+10 db "ATN\z" ; db T_UOP+11 db "LOG\z" ; T_P3B = T_UOP+12 db T_UOP+12 ;T_P3B TOKEN db "P3B\z" ; T_P1B = T_UOP+13 db T_UOP+13 ;T_P1B TOKEN db "P1B\z" ; T_A = T_UOP+14 db T_UOP+14 ;T_ALG(x) TOKEN db "ALG\z" ; T_EE = T_UOP+15 db T_UOP+15 ;T_EE(x) TOKEN db "EE\z" ; ; db T_UOP+16 ;DBYTE TOKEN db "DBY\z" ; db T_UOP+17 ;XBYTE TOKEN db "XBY\z" ; T_ULAST = T_UOP+18 ;LAST OPERATOR NEEDING PARENS ; db T_ULAST db "PI\z" ; db T_ULAST+1 ;RND TOKEN db "RND\z" ; db T_ULAST+2 ;GET TOKEN db "GET\z" ; db T_ULAST+3 ;FREE TOKEN db "FREE\z" ; db T_ULAST+4 ;LEN TOKEN db "LEN\z" ; T_XTAL = T_ULAST+5 ;CRYSTAL TOKEN db T_XTAL db "XTAL\z" ; T_MTOP = T_ULAST+6 ;MTOP db T_MTOP db "MTOP\z" ; T_IE = T_ULAST+8 ;IE REGISTER db T_IE db "IE\z" ; T_IP = T_ULAST+9 ;IP REGISTER db T_IP db "IP\z" ; TMR0 = T_ULAST+10 ;TIMER 0 db TMR0 db "TIMER0\z" ; TMR1 = T_ULAST+11 ;TIMER 1 db TMR1 db "TIMER1\z" ; TMR2 = T_ULAST+12 ;TIMER 2 db TMR2 db "TIMER2\z" ; T_TIME = T_ULAST+7 ;TIME db T_TIME db "TIME\z" ; TT2C = T_ULAST+13 ;T2CON db TT2C db "T2CON\z" ; TTC = T_ULAST+14 ;TCON db TTC db "TCON\z" ; TTM = T_ULAST+15 ;TMOD db TTM db "TMOD\z" ; TRC2 = T_ULAST+16 ;RCAP2 db TRC2 db "RCAP2\z" ; T_P1 = T_ULAST+17 ;P1 db T_P1 db "P1\z" db T_P1 db "PORT1\z" ; T_PC = T_ULAST+18 ;PCON db T_PC db "PCON\z" ; T_P3 = T_ULAST+19 ;P3 db T_P3 db "P3\z" db T_P3 db "PORT3\z" T_ARM = T_ULAST+20 ;ARM db T_ARM db "ARM\z" ; T_ASC = T_ULAST+21 ;ASC TOKEN db T_ASC db "ASC(\z" ; T_USE = T_ULAST+22 ;USING TOKEN db T_USE db "USING(\z" db T_USE db "U.(\z" ; T_CHR = T_ULAST+23 ;CHR TOKEN db T_CHR db "CHR(\z" ; ;$EJECT T_CMND = 0xf0 ;COMMAND BASE ; db 0xf0 ;RUN TOKEN db "RUN\z" ; db 0xF1 ;LIST TOKEN db "LIST\z" ; db 0xF2 ;NULL TOKEN db "NULL\z" ; db 0xF3 ;NEW TOKEN db "NEW\z" ; db 0xF4 ;CONTINUE TOKEN db "CONT\z" db 0xF5 ;PROGRAM TOKEN db "PROG\z" db 0xF6 ;TRANSFER TOKEN db "XFER\z" ; ;db 0xF7 ;RAM MODE ;db "RAM\z" ; ;db 0xF8 ;ROM MODE ;db "ROM\z" ; ;db 0xF9 ;INTELLIGENT PROM PROGRAMMING ;db "FPROG\z" ; db 0xff ;END OF TABLE ; ; END OF INCLUDE LOOK52 ;$INCLUDE(:F2:LOOK52.SRC) ; EIG: db "EXTRA IGNORED" ; EXA: db "a-STACK" ; EXC: db "c-STACK" ; ;$EJECT ;$INCLUDE(:F2:BAS52.RST) ; BEGINNING START_BASIC: ;************************************************************** ; CRST: ; This performs system initialzation, it was moved here so the ; new power on reset functions could be tested in an 8751. ; ;************************************************************** ; ; First, initialize SFR"s ; jnb ti, . ; finish echoing text mov IE, #0 mov SCON,#0x52 ;INITIALIZE SFR"S mov TMOD,#0x10 mov TCON,#0x54 mov T2CON, #0x34 ; ; ; mov dptr,#0x2001 ;READ CODE AT 2001H ; clr a ; movc a,@a+dptr ; cjne a,#0xAA,.+6 ;IF IT IS AN AAH, DO USER RESET ; lcall 0x2090 ; mov r0, #utility_vector ; save the utility vector mov a, @r0 mov dpl, a inc r0 mov a, @r0 mov dph, a ; ; clear ram ; mov r0,#IRAMTOP ;PUT THE TOP OF RAM IN r0 mov a, r7_3 ; save the auto-start flag - at the end mov @r0, a dec r0 clr a ;ZERO THE ACC ; Q1: mov @r0,a ;CLEAR INTERNAL MEMORY djnz r0,Q1 ;LOOP TIL DONE mov UV_H, dph ; restore the utility vector mov UV_L, dpl ; ; mov vtint0l, #BTINT0&0xff ; hook into the main ISRs mov vtint0h, #BTINT0>>8 mov vint0l, #BINT0&0xff mov vint0h, #BINT0>>8 mov vint1l, #BINT1&0xff mov vint1h, #BINT1>>8 ; ; Now, test the external memory ; mov SPSAV,#CMNDSP ;SET UP THE STACK mov SP,SPSAV ; ; mov BOFAH,#ROMADR>>8 ; mov BOFAL,#(ROMADR&0xff)+17 ; mov dptr,#ROMADR ;GET THE BYTE AT 8000H ; movx a,@dptr ; clr c ; subb a,#0x31 ;FOR BIAS mov a, #0xff ; - mark it invalid mov MT1,a ;SAVE IN DIRECT MATH LOC clr ACC.2 ;SAVE FOR RESET mov r7,a ;SAVE IT IN r7 ; inc dptr ; lcall L31DPI ;SAVE BAUD RATE ; lcall RCL mov RCAP2H, #0xff ; 9600 baud mov RCAP2L, #0xdd ; inc dptr ;GET MEMTOP ; lcall L31DPI ; mov dptr,#0x0x805F ;READ THE EXTERNAL BYTE ; movx a,@dptr mov dptr,#0x8000 ;ESTABLISH BASE FOR CLEAR ; cjne a,#0xA5,CRS ; mov a,MT1 ; clr ACC.0 ;CLEAR BIT ONE ; xrl a,#4 ; jz CR2 ; ;CRS: cjne r7,#2,Q20 ; ajmp Q21 ;Q20: cjne r7,#3,CR0x ;Q21: lcall CL_1 ; ajmp CR1x ; CR0x: mov r3,DPH ;SAVE THE dptr mov r1,DPL inc dptr mov a,#0x5A movx @dptr,a movx a,@dptr cjne a,#0x5A,CR1x clr a movx @dptr,a cjne r3,#0xff,CR0x ; CR1x: cjne r3,#0x83,Q22 ;NEED THIS MUCH RAM Q22: jc CRST mov dptr,#MEMTOP ;SAVE MEMTOP acall S31DP2 ;SAVE MEMTOP AND SEED RCELL acall CNEW ;CLEAR THE MEMORY AND SET UP POINTERS ; CR2: acall RC1 ;SET UP STACKS IF NOT DONE ; lcall AXTAL0 ;DO THE CRYSTAL ; mov a,MT1 ;GET THE RESET BYTE ; cjne a,#5,Q23 ; lcall 0x4039 Q23:; jnc BG1 ;CHECK FOR 0,1,2,3, OR 4 ; jnb ACC.0,BG3 ;NO RUN IF WRONG TYPE ; mov dptr,#ROMADR+16 ; movx a,@dptr ;READ THE BYTE ; cjne a,#0x55,BG3 ; ljmp CRUN ; ;BG1: clr a ;DO BAUD RATE ; mov r3,a ; mov r1,a ; mov r0,#4 ; jb ri,. ;LOOP UNTIL a CHARACTER IS RECEIVED ; ;BG2: djnz r0,. ;FOUR CLOCKS, IN LOOP ; lcall DEC3210_4 ;NINE CLOCKS ; mov r0,#2 ;ONE CLOCK ; jnb ri,BG2 ;TWO CLOCKS, LOOP UNTIL DONE ; jb ri,. ;WAIT FOR STOP CHARACTER TO END ; jnb ri,. ; lcall RCL ;LOAD THE TIMER ; mov RCAP2H, #0xff ; 9600 baud ; mov RCAP2L, #0xdd ; BG3: mov dptr,#S_N ;GET THE MESSAGE acall CRP ;PRINT IT mov r0, #0xff mov a, @r0 cjne a, #'B', BG4 mov r7_3, #1 lcall x_load_eeprom clr CONB ;CAN"T CONTINUE IF MODE CHANGE mov BOFAH,#PSTART>>8 mov BOFAL,#PSTART&0xff ajmp CRUN BG4: ljmp CRAM ; END ;$INCLUDE(:F2:BAS52.RST) ; ;$EJECT ;*************************************************************** ; ; CIPROG AND CPROG - Program a prom ; ;*************************************************************** ; ;$INCLUDE(:F2:BAS52.PGM) ;BEGINNING ;PG8: mov r7,#0x00 ;PROGRAM ONE BYTE AT a TIME ; mov r6,#0x01 ; mov r2,#(ROMADR-1)>>8 ; mov r0,#(ROMADR-1)&0xff ;LOAD PROM ADDRESS ; acall PG1_3 ; inc r6 ; mov a, RCAP2H ; acall PG1_3 ; mov a, RCAP2L ; mov r6,#3 ; mov r1,#(MEMTOP-1)&0xff ; mov r3,#MEMTOP>>8 ; acall PG1_3 ;SAVE MEMTOP ; ajmp PGR ; ; ;CIPROG: mov dptr,#IPROGS ;LOAD IPROG LOCATION ; setb INTELB ; ajmp Q24 ;GO DO PROG ; ; CPROG: ;mov dptr,#PROGS ;LOAD PROG LOCATION ;Q24: clr INTELB ; ; ; lcall LD_T ;LOAD THE TIMER ; clr PROMV ;TURN ON THE PROM VOLTAGE ; lcall DELTST ;SEE IF a CR ; jnz PG8 ;SAVE TIMER IF SO ;mov r4,#0xFE setb INBIT ;acall ROMFD ;GET THE ROM ADDRESS OF THE LAST LOCATION ;lcall TEMPD ;SAVE THE ADDRESS ;mov a,r4 ;GET COUNT ;cpl a ;lcall TWO_R2 ;PUT IT ON THE STACK ;lcall FLOATING_POINT_OUTPUT ;OUTPUT IT acall CCAL ;GET THE PROGRAM ;acall CRLF ;DO CRLF ;mov r0,TEMP4 ;GET ADDRESS ;mov r2,TEMP5 ;mov a,#0x55 ;LOAD SIGNIFIER ;inc r6 ;LOAD LEN + 1 ;cjne r6,#00,Q25 ;inc r7 Q25: push r1_0 push r3_0 push r6_0 push r7_0 mov r2, r7 mov r0, r6 lcall TWO_EY lcall FLOATING_POINT_OUTPUT ;OUTPUT IT acall CRLF ;DO CRLF pop r7_0 pop r6_0 pop r3_0 pop r1_0 lcall b_eeprom_header ;Q25: acall PG2_2 ; ; ;$EJECT ;PGR: setb PROMV ; ljmp C_K ; ; PG1: mov P2,r3 ;GET THE BYTE TO PROGRAM movx a,@r1 PG1_3: lcall INC3210 ;BUMP POINTERS ;PG2_2: mov r5,#1 ;SET UP INTELLIGENT COUMTER ; ; PG2: ;mov r4,a ;SAVE THE BYTE IN r4 lcall b_eeprom_byte ; acall PG7 ;PROGRAM THE BYTE ; acall PG9 ; jb INTELB,PG4 ;SEE IF INTELLIGENT PROGRAMMING ; ; ;PG3: xrl a,r4 ; jnz PG6 ;ERROR IF NOT THE SAME lcall DEC76 ;BUMP THE COUNTERS jnz PG1 ;LOOP IF NOT DONE ; anl PSW,#0xe7 ;INSURE RB0 lcall b_eeprom_end ljmp CL3 ; ;PG4: xrl a,r4 ;SEE IF PROGRAMMED ; jnz PG5 ;JUMP IF NOT ; mov a,r4 ;GET THE DATA BACK ; acall PG7 ;PROGRAM THE LOCATION ;Q2: acall ZRO ;AGAIN ; acall ZRO ;AND AGAIN ; acall ZRO ;AND AGAIN ; djnz r5,Q2 ;KEEP DOING IT ; acall PG9 ;RESET PROG ; ajmp PG3 ;FINISH THE LOOP ; ; ;PG5: inc r5 ;BUMP THE COUNTER ; mov a,r4 ;GET THE BYTE ; cjne r5,#25,PG2 ;SEE IF TRIED 25 TIMES ; ; ;PG6: setb PROMV ;TURN OFF PROM VOLTAGE ; mov PSW,#0 ;INSURE RB0 ; jnb DIRF,Q922 ;EXIT IF IN RUN MODE ; mov dptr,#E16X ;PROGRAMMING ERROR ; ; ;ERRLK: ljmp ERROR ;PROCESS THE ERROR ; ; ;;$EJECT ;PG7: mov P0,r0 ;SET UP THE PORTS ; mov P2,r2 ;LATCH LOW ORDER ADDRESS ; acall PG11 ;DELAY FOR 8748/9 ; clr ALED ; mov P0,a ;PUT DATA ON THE PORT ; ; ZRO: nop ;SETTLEING TIME + FP ZERO nop nop nop nop nop ; acall PG11 ;DELAY a WHILE ; clr PROMP ;START PROGRAMMING ; acall TIMER_LOAD ;START THE TIMER ; jnb TF1,. ;WAIT FOR PART TO PROGRAM ; ret ;EXIT ; ; ;PG9: setb PROMP ; acall PG11 ;DELAY FOR a WHILE ; jnb P3.2,. ;LOOP FOR EEPROMS ; mov P0,#0xff ; clr P3.7 ;LOWER READ ; acall PG11 ; mov a,P0 ;READ THE PORT ; setb P3.7 ; setb ALED ; ret ; ; ;PG11: mov TEMP5,#12 ;DELAY 30uS AT 12 MHZ ; djnz TEMP5,. ; ret ; ; ;END ;$INCLUDE(:F2:BAS52.PGM) ;$EJECT ; ;************************************************************** ; ; ;PGU: ;PROGRAM a PROM FOR THE USER ; ; ; ;************************************************************** ; ; ; clr PROMV ;TURN ON THE VOLTAGE ; mov PSW,#0x18 ;SELECT RB3 ; acall PG1 ;DO IT ; setb PROMV ;TURN IT OFF ; ret ; ; ; ; ; ;************************************************************* ; ; CCAL: ; Set up for prom moves ; r3:r1 gets source ; r7:r6 gets # of bytes ; ;************************************************************* ; acall GETEND ;GET THE LAST LOCATION inc dptr ;BUMP TO LOAD EOF mov r3,BOFAH mov r1,BOFAL ;RESTORE START clr c ;PREPARE FOR subb mov a,DPL ;SUB dptr - BOFA > r7:r6 subb a,r1 mov r6,a mov a,DPH subb a,r3 mov r7,a ret ; ; ; ; ;;$INCLUDE(:F2:BAS52.TL) ;BEGINNING ; ; ;************************************************************** ; TIMER_LOAD:; Load the timer ; ;************************************************************* ; acall Q3 ;DELAY FOUR CLOCKS TIMER_LOAD_2: clr TR1 ;STOP IT WHILE IT"S LOADED mov TH1,T_HH mov TL1,T_LL clr TF1 ;CLEAR THE OVERFLOW FLAG setb TR1 ;START IT NOW Q3: ret ; ;END ;$INCLUDE(:F2:BAS52.TL) ;$EJECT ; ;*************************************************************** ; ; ;CROM: ; The command action routine - ROM - Run out of rom ; ; ; ;*************************************************************** ; ; ; clr CONB ;CAN"T CONTINUE IF MODE CHANGE ; acall RO1 ;DO IT ; ; ;C_K: ljmp CL3 ;EXIT ; ; ;RO1: lcall INTGER ;SEE IF INTGER PRESENT ; mov r4,R0B0 ;SAVE THE NUMBER ; jnc Q26 ; mov r4,#0x01 ;ONE IF NO INTEGER PRESENT ;Q26: acall ROMFD ;FIND THE PROGRAM ; cjne r4,#0,RFX ;EXIT IF r4 <> 0 ; inc dptr ;BUMP PAST TAG ; mov BOFAH,DPH ;SAVE THE ADDRESS ; mov BOFAL,DPL ; ret ; ; ROMFD: mov dptr,#ROMADR+16 ;START OF USER PROGRAM ; RF1: movx a,@dptr ;GET THE BYTE cjne a,#0x55,RF3 ;SEE IF PROPER TAG djnz r4,RF2 ;BUMP COUNTER ; RFX: ret ;dptr HAS THE START ADDRESS ;; ; RF2: inc dptr ;BUMP PAST TAG acall XXG5 inc dptr ;BUMP TO NEXT PROGRAM ajmp RF1 ;DO IT AGAIN ; ; RF3: jbc INBIT,RFX ;EXIT IF SET ; ; NOGO: mov dptr,#NOROM ljmp ERROR ; ;$EJECT ;*************************************************************** ; L20DPI: ; load r2:r0 with the location the dptr is pointing to ; ;*************************************************************** ; movx a,@dptr mov r2,a inc dptr movx a,@dptr mov r0,a ret ;DON"T BUMP dptr ; ;*************************************************************** ; X31DP: ; swap r3:r1 with dptr ; ;*************************************************************** ; xch a,r3 xch a,DPH xch a,r3 xch a,r1 xch a,DPL xch a,r1 ret ; ;*************************************************************** ; LD_T: ; Load the timer save location with the value the dptr is ; pointing to. ; ;**************************************************************** ; movx a,@dptr mov T_HH,a inc dptr movx a,@dptr mov T_LL,a ret ; ;$EJECT ; ;*************************************************************** ; ;GETLIN - FIND THE LOCATION OF THE LINE NUMBER IN r3:r1 ; IF ACC = 0 THE LINE WAS NOT FOUND I.E. r3:r1 ; WAS TOO BIG, ELSE ACC <> 0 AND THE dptr POINTS ; AT THE LINE THAT IS GREATER THAN OR EQUAL TO THE ; VALUE IN r3:r1. ; ;*************************************************************** ; GETEND: setb ENDBIT ;GET THE END OF THE PROGRAM ; GETLIN: lcall DP_B ;GET BEGINNING ADDRESS ; XXG1: lcall B_C jz XXG3 ;EXIT WITH a ZERO IN a IF AT END inc dptr ;POINT AT THE LINE NUMBER jb ENDBIT,XXG2 ;SEE IF WE WANT TO FIND THE END acall DCMPX ;SEE IF (dptr) = r3:r1 acall DECDP ;POINT AT LINE COUNT movx a,@dptr ;PUT LINE LENGTH INTO ACC jb UBIT,XXG3 ;EXIT IF EQUAL jc XXG3 ;SEE IF LESS THAN OR ZERO ; XXG2: acall ADdptr ;add IT TO DPTR ajmp XXG1 ;LOOP ; XXG3: clr ENDBIT ;RESET ENDBIT ret ;EXIT ; XXG4: mov dptr,#PSTART ;DO RAM ; XXG5: setb ENDBIT ajmp XXG1 ;NOW DO TEST ; ;$EJECT ;*************************************************************** ; ; LdptrI - Load the DATA POINTER with the value it is pointing ; to - DPH = (dptr) , DPL = (DPTR+1) ; ; acc gets wasted ; ;*************************************************************** ; LdptrI: movx a,@dptr ;GET THE HIGH BYTE push ACC ;SAVE IT inc dptr ;BUMP THE POINTER movx a,@dptr ;GET THE LOW BYTE mov DPL,a ;PUT IT IN DPL pop DPH ;GET THE HIGH BYTE ret ;GO BACK ; ;*************************************************************** ; ;L31DPI - LOAD r3 WITH (dptr) AND r1 WITH (DPTR+1) ; ;ACC GETS CLOBBERED ; ;*************************************************************** ; L31DPI: movx a,@dptr ;GET THE HIGH BYTE mov r3,a ;PUT IT IN THE REG inc dptr ;BUMP THE POINTER movx a,@dptr ;GET THE NEXT BYTE mov r1,a ;SAVE IT ret ; ;*************************************************************** ; ;DECDP - DECREMENT THE DATA POINTER - USED TO SAVE SPACE ; ;*************************************************************** ; DECDP2: acall DECDP ; DECDP: xch a,DPL ;GET DPL jnz Q27 ;BUMP IF ZERO dec DPH Q27: dec a ;DECREMENT IT xch a,DPL ;GET a BACK ret ;EXIT ; ;$EJECT ;*************************************************************** ; ;DCMPX - DOUBLE COMPARE - COMPARE (dptr) TO r3:r1 ;r3:r1 - (dptr) = SET CARRY FLAG ; ;IF r3:r1 > (dptr) THEN c = 0 ;IF r3:r1 < (dptr) THEN c = 1 ;IF r3:r1 = (dptr) THEN c = 0 ; ;*************************************************************** ; DCMPX: clr UBIT ;ASSUME NOT EQUAL movx a,@dptr ;GET THE BYTE cjne a,R3B0,D1 ;IF a IS GREATER THAN r3 THEN NO CARRY ;WHICH IS r3<@dptr = NO CARRY AND ;r3>@dptr CARRY IS SET inc dptr ;BUMP THE DATA POINTER movx a,@dptr ;GET THE BYTE acall DECDP ;PUT dptr BACK cjne a,R1B0,D1 ;DO THE COMPARE cpl c ;FLIP CARRY ; cpl UBIT ;SET IT D1: cpl c ;GET THE CARRY RIGHT ret ;EXIT ; ;*************************************************************** ; ; ADdptr - Add acc to the dptr ; ; acc gets wasted ; ;*************************************************************** ; ADdptr: add a,DPL ;add THE ACC TO DPL mov DPL,a ;PUT IT IN DPL jnc Q29 ;JUMP IF NO CARRY inc DPH ;BUMP DPH Q29: ret ;EXIT ; ;$EJECT ;************************************************************* ; LCLR: ; Set up the storage allocation ; ;************************************************************* ; acall ICLR ;CLEAR THE INTERRUPTS acall XXG4 ;PUT END ADDRESS INTO dptr mov a,#6 ;ADJUST MATRIX SPACE acall ADdptr ;add FOR PROPER BOUNDS acall X31DP ;PUT MATRIX BOUNDS IN r3:r1 mov dptr,#MT_ALL ;SAVE r3:r1 IN MATRIX FREE SPACE acall S31DP ;dptr POINTS TO MEMTOP acall L31DPI ;LOAD MEMTOP INTO r3:r1 mov dptr,#STR_AL ;GET MEMORY ALLOCATED FOR STRINGS acall LdptrI acall DUBSUB ;r3:r1 = MEMTOP - STRING ALLOCATION mov dptr,#VARTOP ;SAVE r3:r1 IN VARTOP ; ; FALL THRU TO S31DP2 ; ;*************************************************************** ; ;S31DP - STORE r3 INTO (dptr) AND r1 INTO (DPTR+1) ; ;ACC GETS CLOBBERED ; ;*************************************************************** ; S31DP2: acall S31DP ;DO IT TWICE ; S31DP: mov a,r3 ;GET r3 INTO ACC movx @dptr,a ;STORE IT inc dptr ;BUMP DPTR mov a,r1 ;GET r1 movx @dptr,a ;STORE IT inc dptr ;BUMP IT AGAIN TO SAVE PROGRAM SPACE ret ;GO BACK ; ; ;*************************************************************** ; STRING: ; Allocate memory for strings ; ;*************************************************************** ; lcall TWO ;r3:r1 = NUMBER, r2:r0 = LEN mov dptr,#STR_AL ;SAVE STRING ALLOCATION acall S31DP inc r6 ;BUMP mov S_LEN,r6 ;SAVE STRING LENGTH ajmp RCLEAR ;CLEAR AND SET IT UP ; ;$EJECT ;*************************************************************** ; ; F_VAR - Find the variable in symbol table ; r7:r6 contain the variable name ; If not found create a zero entry and set the carry ; r2:r0 has the address of variable on return ; ;*************************************************************** ; F_VAR: mov dptr,#VARTOP ;PUT VARTOP IN DPTR acall LdptrI acall DECDP2 ;ADJUST dptr FOR LOOKUP ; F_VAR0: movx a,@dptr ;LOAD THE VARIABLE jz F_VAR2 ;TEST IF AT THE END OF THE TABLE inc dptr ;BUMP FOR NEXT BYTE cjne a,R7B0,F_VAR1 ;SEE IF MATCH movx a,@dptr ;LOAD THE NAME cjne a,R6B0,F_VAR1 ; ; Found the variable now adjust and put in r2:r0 ; DLD: mov a,DPL ;r2:r0 = dptr-2 subb a,#2 mov r0,a mov a,DPH subb a,#0 ;CARRY IS CLEARED mov r2,a ret ; F_VAR1: mov a,DPL ;SUBTRACT THE STACK SIZE+ADJUST clr c subb a,#STESIZ mov DPL,a ;RESTORE DPL jnc F_VAR0 dec DPH ajmp F_VAR0 ;CONTINUE COMPARE ; ;$EJECT ; ; Add the entry to the symbol table ; F_VAR2: lcall R76S ;SAVE r7 AND r6 clr c acall DLD ;BUMP THE POINTER TO GET ENTRY ADDRESS ; ; Adjust pointer and save storage allocation ; and make sure we aren"t wiping anything out ; First calculate new storage allocation ; mov a,r0 subb a,#STESIZ-3 ;NEED THIS MUCH RAM mov r1,a mov a,r2 subb a,#0 mov r3,a ; ; Now save the new storage allocation ; mov dptr,#ST_ALL acall S31DP ;SAVE STORAGE ALLOCATION ; ; Now make sure we didn"t blow it, by wiping out MT_ALL ; acall DCMPX ;COMPARE STORAGE ALLOCATION jc CCLR3 ;ERROR IF CARRY setb c ;DID NOT FIND ENTRY ret ;EXIT IF TEST IS OK ; ;$EJECT ;*************************************************************** ; ; Command action routine - NEW ; ;*************************************************************** ; CNEW: mov dptr,#PSTART ;SAVE THE START OF PROGRAM mov a,#EOF ;END OF FILE movx @dptr,a ;PUT IT IN MEMORY ; ; falls thru ; ;***************************************************************** ; ; The statement action routine - CLEAR ; ;***************************************************************** ; RCLEAR_2: clr LINEB ;SET UP FOR RUN AND GOTO ; RCLEAR: acall LCLR ;CLEAR THE INTERRUPTS, SET UP MATRICES mov dptr,#MEMTOP ;PUT MEMTOP IN r3:r1 acall L31DPI acall XXG4 ;dptr GETS END ADDRESS acall CL_1 ;CLEAR THE MEMORY ; RC1: mov dptr,#(CSTKAH<<8)+STACKTP ;POINT AT CONTROL STACK TOP clr a ;CONTROL UNDERFLOW ; RC2: movx @dptr,a ;SAVE IN MEMORY mov CSTKA,#STACKTP mov ASTKA,#STACKTP clr CONB ;CAN"T CONTINUE ret ; ;$EJECT ;*************************************************************** ; ; Loop until the memory is cleared ; ;*************************************************************** ; CL_1: inc dptr ;BUMP MEMORY POINTER clr a ;CLEAR THE MEMORY movx @dptr,a ;CLEAR THE RAM movx a,@dptr ;READ IT jnz CCLR3 ;MAKE SURE IT IS CLEARED mov a,r3 ;GET POINTER FOR COMPARE cjne a,DPH,CL_1 ;SEE TO LOOP mov a,r1 ;NOW TEST LOW BYTE cjne a,DPL,CL_1 ; CL_2: ret ; CCLR3: ljmp TB ;ALLOCATED MEMORY DOESN"T EXSIST ; ;************************************************************** ; SCLR: ;Entry point for clear return ; ;************************************************************** ; lcall DELTST ;TEST FOR a CR jnc RCLEAR lcall GCI1 ;BUMP THE TEST POINTER cjne a,#'I',RC1 ;SEE IF I, ELSE RESET THE STACK ; ;************************************************************** ; ICLR: ; Clear interrupts and system garbage ; ;************************************************************** ; jnb INTBIT,Q30 ;SEE IF BASIC HAS INTERRUPTS clr EX1 ;IF SO, CLEAR INTERRUPTS Q30: anl 34,#0x20 ;SET INTERRUPTS + CONTINUE reti ; ;$EJECT ;*************************************************************** ; ;OUTPUT ROUTINES ; ;*************************************************************** ; CRLF2: acall CRLF ;DO TWO CRLF"S ; CRLF: mov r5,#SCR ;LOAD THE CR acall TEROT ;lcall TERMINAL OUT mov r5,#LF ;LOAD THE LF ajmp TEROT ;OUTPUT IT AND RETURN ; ;PRINT THE MESSAGE ADDRESSED IN ROM OR RAM BY THE dptr ;ENDS WITH THE CHARACTER IN r4 ;dptr HAS THE ADDRESS OF THE TERMINATOR ; CRP: acall CRLF ;DO a CR THEN PRINT ROM ; ROM_P: clr a ;CLEAR a FOR LOOKUP movc a,@a+dptr ;GET THE CHARACTER clr ACC.7 ;CLEAR MS BIT cjne a,#'"',Q31 ;EXIT IF TERMINATOR ret Q31: cjne a, #0, Q310 ret Q310; setb C0ORX1 ; PN1: mov r5,a ;OUTPUT THE CHARACTER acall TEROT inc dptr ;BUMP THE POINTER ajmp PN0 ; UPRNT: acall X31DP ; PRNTCR: mov r4,#SCR ;OUTPUT UNTIL a CR ; PN0: jbc C0ORX1,ROM_P movx a,@dptr ;GET THE RAM BYTE jz Q33 cjne a,R4B0,Q34 ;SEE IF THE SAME AS TERMINATOR Q33: ret ;EXIT IF THE SAME Q34: cjne a,#SCR,PN1 ;NEVER PRINT a CR IN THIS ROUTINE ljmp E1XX ;BAD SYNTAX ; ;$EJECT ;*************************************************************** ; ; INLINE - Input a line to IBUF, exit when a CR is received ; ;*************************************************************** ; INL2: cjne a,#CNTRLD,INL2B ;SEE IF a CONTROL D ; INL0: acall CRLF ;DO a CR ; INLINE: mov P2,#IBUF>>8 ;IBUF IS IN THE ZERO PAGE mov r0,#IBUF&0xff ;POINT AT THE INPUT BUFFER ; INL1: acall INCHAR ;GET a CHARACTER mov r5,a ;SAVE IN r5 FOR OUTPUT cjne a,#0x7f,INL2XX ;SEE IF a DELETE CHARACTER Q791: cjne r0,#IBUF&0xff,INL6 INLX_2: mov r5,#BELL ;OUTPUT a BELL ; INLX: acall TEROT ;OUTPUT CHARACTER ajmp INL1 ;DO IT AGAIN INL2XX: cjne a,#BS,INL2 ajmp Q791 ; INL2B: movx @r0,a ;SAVE THE CHARACTER cjne a,#SCR,Q35 ;IS IT a CR ajmp CRLF ;OUTPUT a CRLF AND EXIT Q35: cjne a,#0x20,Q36 Q36: jc INLX ;ONLY ECHO CONTROL CHARACTERS inc r0 ;BUMP THE POINTER cjne r0,#(IBUF+79)&0xff,INLX dec r0 ;FORCE 79 ajmp INLX_2 ;OUTPUT a BELL ; INL6: dec r0 ;dec THE RAM POINTER mov r5,#BS ;OUTPUT a BACK SPACE acall TEROT acall STEROT ;OUTPUT a SPACE mov r5,#BS ;ANOTHER BACK SPACE ajmp INLX ;OUTPUT IT ; PTIME: db 128-2 ; PROM PROGRAMMER TIMER db 0x00 db 0x00 db 0x50 db 0x67 db 0x41 ; ;$EJECT ;$INCLUDE(:F2:BAS52.OUT) ;BEGINNING ;*************************************************************** ; ; TEROT - Output a character to the system console ; update PHEAD position. ; ;*************************************************************** ; STEROT: mov r5,#' ' ;OUTPUT a SPACE ; TEROT: push ACC ;SAVE THE ACCUMULATOR push DPH ;SAVE THE dptr push DPL Q4: jnb CNT_S,Q38 ;WAIT FOR a CONTROL Q acall BCK ;GET SERIAL STATUS ajmp Q4 Q38: mov a,r5 ;PUT OUTPUT BYTE IN a ; jnb BO,Q39 ;CHECK FOR MONITOR ; lcall 0x2040 ;DO THE MONITOR ; ljmp TEROT1 ;CLEAN UP ;Q39: jnb COUB,Q40 ;SEE IF USER WANTS OUTPUT ; lcall 0x4030 ; ljmp TEROT1 ;Q40: jnb UPB,T_1 ;NO AT IF NO XBIT ; jnb LPB,T_1 ;AT PRINT ; lcall 0x403C ;lcall AT LOCATION ; ljmp TEROT1 ;FINISH OFF OUTPUT ; T_1: jnb COB,TXX ;SEE IF LIST SET mov dptr,#SPV ;LOAD BAUD RATE acall LD_T clr LP ;OUTPUT START BIT acall TIMER_LOAD ;LOAD AND START THE TIMER mov a,r5 ;GET THE OUTPUT BYTE setb c ;SET CARRY FOR LAST OUTPUT mov r5,#9 ;LOAD TIMER COUNTDOWN ; LTOUT1: rrc a ;ROTATE a jnb TF1,. ;WAIT TILL TIMER READY mov LP,c ;OUTPUT THE BIT acall TIMER_LOAD ;DO THE NEXT BIT djnz r5,LTOUT1 ;LOOP UNTIL DONE jnb TF1,. ;FIRST STOP BIT acall TIMER_LOAD jnb TF1,. ;SECOND STOP BIT mov r5,a ;RESTORE r5 ajmp TEROT1 ;BACK TO TEROT ; ;$EJECT TXX: jnb TI,. ;WAIT FOR TRANSMIT READY clr TI mov SBUF,r5 ;SEND OUT THE CHARACTER ; TEROT1: cjne r5,#SCR,Q41 ;SEE IF a CR mov PHEAD,#0x00 ;IF a CR, RESET PHEAD AND ; Q41: cjne r5,#LF,NLC ;SEE IF a LF mov a,NULLCT ;GET THE NULL COUNT jz NLC ;NO NULLS IF ZERO ; TEROT2: mov r5,#NULL ;PUT THE NULL IN THE OUTPUT REGISTER acall TEROT ;OUTPUT THE NULL dec a ;DECREMENT NULL COUNT jnz TEROT2 ;LOOP UNTIL DONE ; NLC: cjne r5,#BS,Q42 ;dec PHEAD IF a BACKSPACE dec PHEAD Q42: cjne r5,#0x20,Q43 ;IS IT a PRINTABLE CHARACTER? Q43: jc Q44 ;DON"T INCREMENT PHEAD IF NOT PRINTABLE inc PHEAD ;BUMP PRINT HEAD Q44: pop DPL ;RESTORE dptr pop DPH pop ACC ;RESTORE ACC ret ;EXIT ; ;END ;$INCLUDE(:F2:BAS52.OUT) ; BCK: acall CSTS ;CHECK STATUS jnc Q491 ;EXIT IF NO CHARACTER ; ;$EJECT ;*************************************************************** ; ;INPUTS a CHARACTER FROM THE SYSTEM CONSOLE. ; ;*************************************************************** ; INCHAR:; jnb BI,Q45 ;CHECK FOR MONITOR (BUBBLE) ; lcall 0x2060 ; ljmp INCH1 ;Q45: jnb CIUB,Q46 ;CHECK FOR USER ; lcall 0x4033 ; ljmp INCH1 Q46: jnb RI,. ;WAIT FOR RECEIVER READY. mov a,SBUF clr RI ;RESET READY clr ACC.7 ;NO BIT 7 ; INCH1: cjne a,#0x13,Q47 setb CNT_S Q47: cjne a,#0x11,Q48 clr CNT_S Q48: cjne a,#CNTRLC,Q49 jnb NO_C,C_EX ;TRAP NO CONTROL c ret ; Q49: clr JKBIT cjne a,#0x17,CI_RET ;CONTROL W setb JKBIT ; CI_RET: setb c ;CARRY SET IF a CHARACTER Q491: ret ;EXIT ; ;************************************************************* ; ;RROM - The Statement Action Routine RROM ; ;************************************************************* ; ;RROM: setb INBIT ;SO NO ERRORS ; acall RO1 ;FIND THE LINE NUMBER ; jbc INBIT,CRUN ; ret ;EXIT ; ;$EJECT ;*************************************************************** ; CSTS: ; RETURNS CARRY = 1 IF THERE IS a CHARACTER WAITING FROM ; THE SYSTEM CONSOLE. IF NO CHARACTER THE READY CHARACTER ; WILL BE CLEARED ; ;*************************************************************** ; ; jnb BI,.+6 ;BUBBLE STATUS ; ljmp 0x2068 ; jnb CIUB,.+6 ;SEE IF EXTERNAL CONSOLE ; ljmp 0x4036 mov c,RI ret ; Q926: mov dptr,#WB ;EGO MESSAGE acall ROM_P ; C_EX: clr CNT_S ;NO OUTPUT STOP lcall SPRINT4 ;ASSURE CONSOLE acall CRLF jbc JKBIT,Q926 ; jnb DIRF,xx3 ljmp CL3 ;CLEAR COB AND EXIT xx3: ajmp SSTOP0 ; T_CMP: mov a,TVH ;COMPARE TIMER TO SP_H AND SP_L mov r1,TVL cjne a,TVH,T_CMP xch a,r1 subb a,SP_L mov a,r1 subb a,SP_H ret ; ;************************************************************* ; BR0: ; Trap the timer interrupt ; ;************************************************************* ; acall T_CMP ;COMPARE TIMER jc BCHR_6 ;EXIT IF TEST FAILS setb OTI ;DOING THE TIMER INTERRUPT clr OTS ;CLEAR TIMER BIT mov c,INPROG ;SAVE IN PROGRESS mov ISAV,c mov dptr,#TIV ajmp BR2 ; ;$EJECT ;*************************************************************** ; ; The command action routine - RUN ; ;*************************************************************** ; CRUN: acall RCLEAR_2 ;CLEAR THE STORAGE ARRAYS lcall SRESTR_2 ;GET THE STARTING ADDRESS lcall B_C jz CMNDLK ;IF NULL GO TO COMMAND MODE ; lcall T_DP lcall B_TXA ;BUMP TO STARTING LINE ; CILOOP: lcall SP0 ;DO a CR AND a LF ILOOP_2: clr DIRF ;NOT IN DIRECT MODE ; ;INTERPERTER DRIVER ; ILOOP: mov SP,SPSAV ;RESTORE THE STACK EACH TIME jb DIRF,Q50 ;NO INTERRUPTS IF IN DIRECT MODE mov INTXAH,TXAH ;SAVE THE TEXT POINTER mov INTXAL,TXAL Q50: acall BCK ;GET CONSOLE STATUS jb DIRF,I_L ;DIRECT MODE anl c,/GTRD ;SEE IF CHARACTER READY jnc BCHR ;NO CHARACTER = NO CARRY ; ; DO TRAP OPERATION ; mov dptr,#GTB ;SAVE TRAP CHARACTER movx @dptr,a setb GTRD ;SAYS READ a BYTE ; BCHR: jb OTI,I_L ;EXIT IF TIMER INTERRUPT IN PROGRESS jb OTS,BR0 ;TEST TIMER VALUE IF SET BCHR_6: jnb INTPEN,I_L ;SEE IF INTERRUPT PENDING jb INPROG,I_L ;DON"T DO IT AGAIN IF IN PROGRESS mov dptr,#INTLOC ;POINT AT INTERRUPT LOCATION ; BR2: mov r4,#GTYPE ;SETUP FOR a FORCED GOSUB lcall SGS1 ;PUT TXA ON STACK setb INPROG ;INTERRUPT IN PROGRESS ; ERL4: acall L20DPI ljmp D_L1 ;GET THE LINE NUMBER ; I_L: acall ISTAT ;LOOP lcall CLN_UP ;FINISH IT OFF jnc ILOOP ;LOOP ON THE DRIVER jnb DIRF,CMNDLK ;CMND1 IF IN RUN MODE ljmp CMNDR ;DON"T PRINT READY ; CMNDLK: ljmp CMND1 ;DONE ;$EJECT ;************************************************************** ; ; The Statement Action Routine - STOP ; ;************************************************************** ; SSTOP: lcall CLN_UP ;FINISH OFF THIS LINE mov INTXAH,TXAH ;SAVE TEXT POINTER FOR CONT mov INTXAL,TXAL ; SSTOP0: setb CONB ;CONTINUE WILL WORK mov dptr,#STP ;PRINT THE STOP MESSAGE setb STOPBIT ;SET FOR ERROR ROUTINE ljmp ERRS ;JUMP TO ERROR ROUTINE ; ;$EJECT ;************************************************************** ; ; ITRAP - Trap special function register operators ; ;************************************************************** ; ITRAP: cjne a,#TMR0,Q51 ;TIMER 0 mov TH0,r3 mov TL0,r1 ret ; Q51: cjne a,#TMR1,Q52 ;TIMER 1 mov TH1,r3 mov TL1,r1 ret ; Q52: cjne a,#TMR2,Q53 ;TIMER 2 mov TH2, r3 mov TL2, r1 ret ; Q53: cjne a,#TRC2,Q54 ;RCAP2 TOKEN RCL: mov RCAP2H, r3 mov RCAP2L, r1 ret ; Q54: acall R3CK ;MAKE SURE THAT r3 IS ZERO cjne a,#TT2C,Q55 mov T2CON, r1 ret ; Q55: cjne a,#T_IE,Q56 ;IE TOKEN mov IE,r1 ret ; Q56: cjne a,#T_IP,Q57 ;IP TOKEN mov IP,r1 ret ; Q57: cjne a,#TTC,Q58 ;TCON TOKEN mov TCON,r1 ret ; Q58: cjne a,#TTM,Q59 ;TMOD TOKEN mov TMOD,r1 ret ; Q59: cjne a,#T_P1,Q591 ;P1 TOKEN mov P1,r1 ret Q591: cjne a,#T_P3,Q632a ;P3 TOKEN mov P3,r1 ret Q632a: cjne a,#T_ARM, T_T2 ; ARM token mov a, r1 rrc a cpl c mov P3.2, c ret ; ;*************************************************************** ; ; T_TRAP - Trap special operators ; ;*************************************************************** ; T_T: mov TEMP5,a ;SAVE THE TOKEN lcall GCI1 ;BUMP POINTER acall SLET2 ;EVALUATE AFTER = mov a,TEMP5 ;GET THE TOKEN BACK cjne a,#T_XTAL,Q60 ljmp AXTAL1 ;SET UP CRYSTAL ; Q60: lcall IFIXL ;r3:r1 HAS THE TOS mov a,TEMP5 ;GET THE TOKEN AGAIN cjne a,#T_MTOP,T_T1 ;SEE IF MTOP TOKEN mov dptr,#MEMTOP acall S31DP ajmp RCLEAR ;CLEAR THE MEMORY ; T_T1: cjne a,#T_TIME,ITRAP ;SEE IF a TIME TOKEN mov c,EA ;SAVE INTERRUPTS clr EA ;NO TIMER 0 INTERRUPTS DURING LOAD mov TVH,r3 ;SAVE THE TIME mov TVL,r1 mov EA,c ;RESTORE INTERRUPTS ret ;EXIT ; T_T2: cjne a,#T_PC,INTERX ;PCON TOKEN mov PCON, r1 ret ;EXIT ; T_TRAP: cjne a,#T_ASC,T_T ;SEE IF ASC TOKEN lcall IGC ;EAT IT AND GET THE NEXT CHARACTER cjne a,#'$',INTERX ;ERROR IF NOT a STRING acall CSY ;CALCULATE ADDRESS lcall X3120 lcall TWO_EY acall SPEOP_4 ;EVALUATE AFTER EQUALS ajmp ISTAX1 ;SAVE THE CHARACTER ; ;$EJECT ;************************************************************** ; ;INTERPERT THE STATEMENT POINTED TO BY TXAL AND TXAH ; ;************************************************************** ; ISTAT: lcall GC ;GET THR FIRST CHARACTER ; jnb XBIT,IAT ;TRAP TO EXTERNAL RUN PACKAGE ; cjne a,#0x20,Q61 ;Q61: jnc IAT ; lcall 0x2070 ;LET THE USER SET UP THE dptr ; lcall GCI1 ; anl a,#0x0F ;STRIP OFF BIAS ; ljmp ISTA1 ; IAT: cjne a,#T_XTAL,Q62 Q62: jnc T_TRAP cjne a,#T_P1B, Q631 ajmp P1B_R Q631: cjne a,#T_P3B, Q631a ajmp P3B_R Q631a: cjne a,#T_EE, Q632 ajmp EE_WR Q632: jnb ACC.7,GSLET ;IMPLIED LET IF BIT 7 NOT SET cjne a,#T_UOP+12,ISTAX ;DBYTE TOKEN acall SPEOP ;EVALUATE SPECIAL OPERATOR acall R3CK ;CHECK LOCATION mov @r1,a ;SAVE IT ret GSLET: ajmp SLET ; ISTAX: cjne a,#T_UOP+13,ISTAY ;XBYTE TOKEN acall SPEOP ; ISTAX1: mov P2,r3 movx @r1,a ret ; ISTAY: cjne a,#T_CR+1,Q63 ;TRAP NEW OPERATORS Q63: jc I_S cjne a,#0xB0,Q64 ;SEE IF TOO BIG Q64: jnc INTERX add a,#0xF9 ;BIAS FOR LOOKUP TABLE ajmp ISTA0 ;DO THE OPERATION ; I_S: cjne a,#T_LAST,Q65 ;MAKE SURE AN INITIAL RESERVED WORD Q65: jc Q66 ;ERROR IF NOT ; INTERX: ljmp E1XX ;SYNTAX ERROR ; Q66: jnb DIRF,ISTA0 ;EXECUTE ALL STATEMENTS IF IN RUN MODE cjne a,#T_DIR,Q67 ;SEE IF ON TOKEN Q67: jc ISTA0 ;OK IF DIRECT cjne a,#T_GOSB+1,Q68 ;SEE IF FOR ajmp ISTA0 ;FOR IS OK Q68: cjne a,#T_REM+1,Q69 ;NEXT IS OK ajmp ISTA0 Q69: cjne a,#T_STOP+6,INTERX ;SO IS REM ; ;$EJECT ISTA0: lcall GCI1 ;ADVANCE THE TEXT POINTER mov dptr,#STATD ;POINT DPTR TO LOOKUP TABLE cjne a,#T_GOTO-3,Q70 ;SEE IF LET TOKEN ajmp ISTAT ;WASTE LET TOKEN Q70: anl a,#0x3f ;STRIP OFF THE GARBAGE ; ISTA1: rl a ;ROTATE FOR OFFSET add a,DPL ;BUMP mov DPL,a ;SAVE IT jnc Q823 inc DPH Q823: clr a movc a,@a+dptr ;GET HIGH BYTE push ACC ;SAVE IT inc dptr clr a movc a,@a+dptr ;GET LOW BYTE pop DPH mov DPL,a ; AC1: clr a jmp @a+dptr ;GO DO IT ; EE_WR: lcall GCI1 ;BUMP POINTER mov r7,#T_LPAR ;WASTE THE open paren lcall EATC lcall ONE ;GET THE NEXT EXPRESSION push r3_0 ; push the address push r1_0 mov r7,#')' ;WASTE THE open paren lcall EATC acall SLET2 ;EVALUATE AFTER = lcall IFIX ;r3:r1 HAS THE TOS mov r6_3, r1 pop r0_0 pop r2_0 push r7_0 push r6_0 push r5_0 push r4_0 mov r6, r2 mov r7, r0 mov r3, #1 mov r0, #r6_3 mov r2, #'W' lcall b_do_ut pop r4_0 pop r5_0 pop r6_0 pop r7_0 ret ; ; ; code to write an arbitrary bit to a port ; ; P3B_R: lcall GCI1 ;BUMP POINTER mov r7,#T_LPAR ;WASTE THE open paren lcall EATC lcall ONE ;GET THE NEXT EXPRESSION mov a,r1 ;CHECK FOR BOUNDS push acc mov r7,#')' ;WASTE THE open paren lcall EATC acall SLET2 ;EVALUATE AFTER = lcall IFIXL ;r3:r1 HAS THE TOS rrc a pop acc jb acc.2, aP3_4 jb acc.1, aP3_2 jb acc.0, aP3_1 mov P3.0, c ret aP3_1: mov P3.1, c ret aP3_2: jb acc.0, aP3_3 mov P3.2, c ret aP3_3: mov P3.3, c ret aP3_4: jb acc.1, aP3_6 jb acc.0, aP3_5 mov P3.4, c ret aP3_5: mov P3.5, c ret aP3_6: jb acc.0, aP3_7 mov P3.6, c ret aP3_7: mov P3.7, c ret P1B_R: lcall GCI1 ;BUMP POINTER mov r7,#T_LPAR ;WASTE THE open paren lcall EATC lcall ONE ;GET THE NEXT EXPRESSION mov a,r1 push acc mov r7,#')' ;WASTE THE open paren lcall EATC acall SLET2 ;EVALUATE AFTER = lcall IFIXL ;r3:r1 HAS THE TOS rrc a pop acc jb acc.2, aP1_4 jb acc.1, aP1_2 jb acc.0, aP1_1 mov P1.0, c ret aP1_1: mov P1.1, c ret aP1_2: jb acc.0, aP1_3 mov P1.2, c ret aP1_3: mov P1.3, c ret aP1_4: jb acc.1, aP1_6 jb acc.0, aP1_5 mov P1.4, c ret aP1_5: mov P1.5, c ret aP1_6: jb acc.0, aP1_7 mov P1.6, c ret aP1_7: mov P1.7, c ret ;$EJECT ;*************************************************************** ; ; The statement action routine - LET ; ;*************************************************************** ; SLET: lcall S_C ;CHECK FOR POSSIBLE STRING jc SLET0 ;NO STRING clr LINEB ;USED STRINGS ; acall X31DP ;PUT ADDRESS IN dptr mov r7,#T_EQU ;WASTE = lcall EATC lcall GC ;GET THE NEXT CHARACTER cjne a,#'"',S_3 ;CHECK FOR a " mov r7,S_LEN ;GET THE STRING LENGTH ; S_0: lcall GCI1 ;BUMP PAST " lcall DELTST ;CHECK FOR DELIMITER jz GIN ;EXIT IF CARRIAGE RETURN movx @dptr,a ;SAVE THE CHARACTER cjne a,#'"',S_1 ;SEE IF DONE ; S_E: mov a,#SCR ;PUT a CR IN a movx @dptr,a ;SAVE CR ljmp GCI1 GIN: ajmp GIN ; S_3: push DPH push DPL ;SAVE DESTINATION lcall S_C ;CALCULATE SOURCE jc GIN ;ERROR IF CARRY pop R0B0 ;GET DESTINATION BACK pop R2B0 ; SSOOP: mov r7,S_LEN ;SET UP COUNTER ; S_4: lcall TBYTE ;TRANSFER THE BYTE cjne a,#SCR,Q72 ;EXIT IF a CR ret Q72: djnz r7,S_5 ;BUMP COUNTER mov a,#SCR ;SAVE a CR movx @r0,a ljmp EIGP ;PRINT EXTRA IGNORED ; ;$EJECT ; S_5: lcall INC3210 ;BUMP POINTERS ajmp S_4 ;LOOP ; S_1: djnz r7,Q73 ;SEE IF DONE acall S_E lcall EIGP ;PRINT EXTRA IGNORED ljmp FINDCR ;GO FIND THE END Q73: inc dptr ;BUMP THE STORE POINTER ajmp S_0 ;CONTINUE TO LOOP ; E3XX: mov dptr,#E3X ;BAD ARG ERROR ljmp EK ; SLET0: acall SLET1 ljmp POPAS ;COPY EXPRESSION TO VARIABLE ; SLET1: lcall VAR_ER ;CHECK FOR a"VARIABLE" ; SLET2: push R2B0 ;SAVE THE VARIABLE ADDRESS push R0B0 mov r7,#T_EQU ;GET EQUAL TOKEN lcall WE pop R1B0 ;pop VARIABLE TO r3:r1 pop R3B0 ret ;EXIT ; R3CK: cjne r3,#0x00,E3XX ;CHECK TO SEE IF r3 IS ZERO ret ; SPEOP: lcall GCI1 ;BUMP TXA lcall P_E ;EVALUATE PAREN SPEOP_4: acall SLET2 ;EVALUATE AFTER = lcall TWOL ;r7:r6 GETS VALUE, r3:r1 GETS LOCATION mov a,r6 ;SAVE THE VALUE ; cjne r7,#0x00,E3XX ;r2 MUST BE = 0 ret ; ;$EJECT ;************************************************************** ; ; ST_CAL - Calculate string Address ; ;************************************************************** ; IST_CAL:; ; lcall I_PI ;BUMP TEXT, THEN EVALUATE acall R3CK ;ERROR IF r3 <> 0 inc r1 ;BUMP FOR OFFSET mov a,r1 ;ERROR IF r1 = 255 jz E3XX mov dptr,#VARTOP ;GET TOP OF VARIABLE STORAGE mov B,S_LEN ;MULTIPLY FOR LOCATION acall VARD ;CALCULATE THE LOCATION mov dptr,#MEMTOP ;SEE IF BLEW IT lcall FUL1 mov DPL,S_LEN ;GET STRING LENGTH, DPH = 0x00 mov DPH, #0 ;DPH = 0 ; DUBSUB: clr c mov a,r1 subb a,DPL mov r1,a mov a,r3 subb a,DPH mov r3,a orl a,r1 ret ; ;*************************************************************** ; ;VARD - Calculate the offset base ; ;*************************************************************** ; VARB: mov B,#FPSIZ ;SET UP FOR OPERATION ; VARD: acall LdptrI ;LOAD DPTR mov a,r1 ;MULTIPLY BASE mul ab add a,DPL mov r1,a mov a,B addc a,DPH mov r3,a ret ; ;$EJECT ;************************************************************* ; CSY: ; Calculate a biased string address and put in r3:r1 ; ;************************************************************* ; acall IST_CAL ;CALCULATE IT push R3B0 ;SAVE IT push R1B0 mov r7,#',' ;WASTE THE COMMA lcall EATC lcall ONE ;GET THE NEXT EXPRESSION mov a,r1 ;CHECK FOR BOUNDS cjne a,S_LEN,Q74 Q74: jnc Q775 ;MUST HAVE a CARRY dec r1 ;BIAS THE POINTER pop ACC ;GET VALUE LOW add a,r1 ;add IT TO BASE mov r1,a ;SAVE IT pop R3B0 ;GET HIGH ADDRESS jnc Q75 ;PROPAGATE THE CARRY inc r3 Q75: ljmp ERPAR ;WASTE THE RIGHT PAREN Q775: ajmp E3XX ; ;$EJECT ;*************************************************************** ; ; The statement action routine FOR ; ;*************************************************************** ; SFOR: acall SLET1 ;SET UP CONTROL VARIABLE push R3B0 ;SAVE THE CONTROL VARIABLE LOCATION push R1B0 lcall POPAS ;pop ARG STACK AND COPY CONTROL VAR mov r7,#T_TO ;GET TO TOKEN lcall WE lcall GC ;GET NEXT CHARACTER cjne a,#T_STEP,SF2 lcall GCI1 ;EAT THE TOKEN lcall EXPRB ;EVALUATE EXPRESSION ajmp Q76 ;JUMP OVER ; SF2: lcall PUSH_ONE ;PUT ONE ON THE STACK ; Q76: mov a,#(-FSIZE)&0xff;ALLOCATE FSIZE BYTES ON THE CONTROL STACK lcall PUSHCS ;GET CS IN r0 lcall CSC ;CHECK CONTROL STACK mov r3,#CSTKAH ;IN CONTROL STACK mov r1,R0B0 ;STACK ADDRESS lcall POPAS ;PUT STEP ON STACK lcall POPAS ;PUT LIMIT ON STACK lcall DP_T ;dptr GETS TEXT mov r0,R1B0 ;GET THE POINTER lcall T_X_S ;SAVE THE TEXT pop TXAL ;GET CONTROL VARIABLE pop TXAH mov r4,#FTYPE ;AND THE TYPE lcall T_X_S ;SAVE IT ; SF3: lcall T_DP ;GET THE TEXT POINTER ljmp ILOOP ;CONTINUE TO PROCESS ; ;$EJECT ;************************************************************** ; ; The statement action routines - push and pop ; ;************************************************************** ; SPUSH: acall EXPRB ;PUT EXPRESSION ON STACK acall C_TST ;SEE IF MORE TO DO jnc SPUSH ;IF a COMMA push ANOTHER ret ; ; SPOP: acall VAR_ER ;GET VARIABLE acall XPOP ;FLIP THE REGISTERS FOR POPAS acall C_TST ;SEE IF MORE TO DO jnc SPOP ; Q950: ret ; ;*************************************************************** ; ; The statement action routine - IF ; ;*************************************************************** ; SIF: acall RTST ;EVALUATE THE EXPRESSION mov r1,a ;SAVE THE RESULT acall GC ;GET THE CHARACTER AFTER EXPR cjne a,#T_THEN,Q78 ;SEE IF THEN TOKEN acall GCI1 ;WASTE THEN TOKEN Q78: cjne r1,#0,T_F1 ;CHECK R_OP RESULT ; E_FIND: mov r7,#T_ELSE ;FIND ELSE TOKEN acall FINDC jz Q950 ;EXIT IF a CR acall GCI1 ;BUMP PAST TOKEN cjne a,#T_ELSE,E_FIND;WASTE IF NO ELSE ; T_F1: acall INTGER ;SEE IF NUMBER jnc D_L1 ;EXECUTE LINE NUMBER ljmp ISTAT ;EXECUTE STATEMENT IN NOT ; B_C: movx a,@dptr dec a jb ACC.7,Q6 ret ; ;$EJECT ;*************************************************************** ; ; The statement action routine - GOTO ; ;*************************************************************** ; SGOTO: acall RLINE ;r2:r0 AND dptr GET INTGER ; SGT1: acall T_DP ;TEXT POINTER GETS dptr ; jbc RETBIT,SGT2 ;SEE IF reti EXECUTED ; jnb LINEB,SGT2 ;SEE IF a LINE WAS EDITED lcall RCLEAR_2 ;CLEAR THE MEMORY IF SET ljmp ILOOP_2 ;CLEAR DIRF AND LOOP ; SGT2: jbc OTI,Q79 ;SEE IF TIMER INTERRUPT anl 34,#0xBD ;CLEAR INTERRUPTS ljmp ILOOP ;EXECUTE Q79: mov c,ISAV mov INPROG,c ljmp ILOOP ;RESTORE INTERRUPTS AND ret ; ; ;************************************************************* ; RTST: ; Test for ZERO ; ;************************************************************* ; acall EXPRB ;EVALUATE EXPRESSION acall INC_ASTKA ;BUMP ARG STACK jz Q80 ;EXIT WITH ZERO OR 0xff mov a,#0xff Q80: ret ; ;$EJECT ; ;************************************************************** ; ; GLN - get the line number in r2:r0, return in dptr ; ;************************************************************** ; GLN: acall DP_B ;GET THE BEGINNING ADDRESS ; FL1: movx a,@dptr ;GET THE LENGTH mov r7,a ;SAVE THE LENGTH djnz r7,FL3 ;SEE IF END OF FILE ; Q6: mov dptr,#E10X ;NO LINE NUMBER ajmp EK ;HANDLE THE ERROR ; D_L1: acall GLN ;GET THE LINE ajmp SGT1 ;EXECUTE THE LINE ; FL3: jb ACC.7,Q6 ;CHECK FOR BIT 7 inc dptr ;POINT AT HIGH BYTE movx a,@dptr ;GET HIGH BYTE cjne a,R2B0,FL2 ;SEE IF MATCH inc dptr ;BUMP TO LOW BYTE dec r7 ;ADJUST AGAIN movx a,@dptr ;GET THE LOW BYTE cjne a,R0B0,FL2 ;SEE IF LOW BYTE MATCH inc dptr ;POINT AT FIRST CHARACTER ret ;FOUND IT ; FL2: mov a,r7 ;GET THE LENGTH COUNTER lcall ADdptr ;add a TO DATA POINTER ajmp FL1 ;LOOP ; ; ;************************************************************* ; ;RLINE - Read in ASCII string, get line, and clean it up ; ;************************************************************* ; RLINE: acall INTERR ;GET THE INTEGER ; RL1: acall GLN ajmp CLN_UP ; ; ;$EJECT ;*************************************************************** ; ; The statement action routines WHILE and UNTIL ; ;*************************************************************** ; SWHILE: acall RTST ;EVALUATE RELATIONAL EXPRESSION cpl a ajmp S_WU ; SUNTIL: acall RTST ;EVALUATE RELATIONAL EXPRESSION ; S_WU: mov r4,#DTYPE ;DO EXPECTED mov r5,a ;SAVE R_OP RESULT ajmp SR0 ;GO PROCESS ; ; ;*************************************************************** ; CNULL: ; The Command Action Routine - NULL ; ;*************************************************************** ; acall INTERR ;GET AN INTEGER FOLLOWING NULL mov NULLCT,r0 ;SAVE THE NULLCOUNT ljmp CMNDLK ;JUMP TO COMMAND MODE ; ;$EJECT ;*************************************************************** ; ; The statement action routine - reti ; ;*************************************************************** ; SRETI: setb RETBIT ;SAYS THAT reti HAS BEEN EXECUTED ; ;*************************************************************** ; ; The statement action routine - RETURN ; ;*************************************************************** ; SRETRN: mov r4,#GTYPE ;MAKE SURE OF GOSUB mov r5,#0x55 ;TYPE RETURN TYPE ; SR0: acall CSETUP ;SET UP CONTROL STACK movx a,@r0 ;GET RETURN TEXT ADDRESS mov DPH,a inc r0 movx a,@r0 mov DPL,a inc r0 ;pop CONTROL STACK movx a,@dptr ;SEE IF GOSUB WAS THE LAST STATEMENT cjne a,#EOF,Q81 ljmp CMNDLK Q81: mov a,r5 ;GET TYPE jz QQ99 ;EXIT IF ZERO mov CSTKA,r0 ;pop THE STACK cpl a ;OPTION TEST, 0x00, 0x55, 0xff, NOW 0x55 jnz QQ99 ;MUST BE GOSUB ret ;NORMAL FALL THRU EXIT FOR NO MATCH QQ99: ajmp SGT1 ; ;$EJECT ;*************************************************************** ; ; The statement action routine - GOSUB ; ;*************************************************************** ; SGOSUB: acall RLINE ;NEW TXA IN dptr ; SGS0: mov r4,#GTYPE acall SGS1 ;SET EVERYTHING UP ljmp SF3 ;EXIT ; SGS1: mov a,#(-3)&0xff ;ALLOCATE 3 BYTES ON CONTROL STACK acall PUSHCS ; T_X_S: mov P2,#CSTKAH ;SET UP PORT FOR CONTROL STACK mov a,TXAL ;GET RETURN ADDRESS AND SAVE IT movx @r0,a dec r0 mov a,TXAH movx @r0,a dec r0 mov a,r4 ;GET TYPE movx @r0,a ;SAVE TYPE ret ;EXIT ; ; CS1: mov a,#3 ;pop 3 BYTES acall PUSHCS ; CSETUP: mov r0,CSTKA ;GET CONTROL STACK mov P2,#CSTKAH movx a,@r0 ;GET BYTE cjne a,R4B0,Q82 ;SEE IF TYPE MATCH inc r0 ret Q82: jz E4XX ;EXIT IF STACK UNDERFLOW cjne a,#FTYPE,CS1 ;SEE IF FOR TYPE acall PUSHCS_2 ;WASTE THE FOR TYPE ajmp CSETUP ;LOOP ; ;$EJECT ;*************************************************************** ; ; The statement action routine - NEXT ; ;*************************************************************** ; SNEXT: mov r4,#FTYPE ;FOR TYPE acall CSETUP ;SETUP CONTROL STACK mov TEMP5,r0 ;SAVE CONTROL VARIABLE ADDRESS mov r1,#TEMP1 ;SAVE VAR + RETURN IN TEMP1-4 ; XXI: movx a,@r0 ;LOOP UNTIL DONE mov @r1,a inc r1 inc r0 cjne r1,#TEMP5,XXI ; acall VAR ;SEE IF THE USER HAS a VARIABLE jnc Q83 mov r2,TEMP1 mov r0,TEMP2 Q83: mov a,r2 ;SEE IF VAR"S AGREE cjne a,TEMP1,E4XX mov a,r0 cjne a,TEMP2,E4XX acall PUSHAS ;PUT CONTROL VARIABLE ON STACK mov a,#FPSIZ+FPSIZ+2;COMPUTE ADDRESS TO STEP VALUE SIGN add a,TEMP5 ;add IT TO BASE OF STACK mov r0,a ;SAVE IN r0 mov r2,#CSTKAH ;SET UP TO push STEP VALUE mov P2,r2 ;SET UP PORT movx a,@r0 ;GET SIGN inc r0 ;BACK TO EXPONENT push ACC ;SAVE SIGN OF STEP acall PUSHAS ;PUT STEP VALUE ON STACK push R0B0 ;SAVE LIMIT VALUE LOCATION lcall AADD ;add STEP VALUE TO VARIABLE lcall CSTAKA ;COPY STACK mov r3,TEMP1 ;GET CONTROL VARIABLE mov r1,TEMP2 acall POPAS ;SAVE THE RESULT mov r2,#CSTKAH ;RESTORE LIMIT LOCATION pop R0B0 acall PUSHAS ;PUT LIMIT ON STACK lcall FLOATING_COMP ;DO THE COMPARE pop ACC ;GET LIMIT SIGN BACK jz Q84 ;IF SIGN NEGATIVE, TEST "BACKWARDS" cpl c Q84: orl c,F0 ;SEE IF EQUAL jc N4 ;STILL SMALLER THAN LIMIT? PUSHCS_2: mov a,#FSIZE ;REmovE CONTROL STACK ENTRY ; ; Fall thru to PUSHCS ; ;$EJECT ;*************************************************************** ; ; PUSHCS - push frame onto control stack ; acc has - number of bytes, also test for overflow ; ;*************************************************************** ; PUSHCS: add a,CSTKA ;BUMP CONTROL STACK cjne a,#(CONVT+17)&0xff,Q85 ;SEE IF OVERFLOWED Q85: jc E4XX ;EXIT IF STACK OVERFLOW xch a,CSTKA ;STORE NEW CONTROL STACK VALUE, GET OLD dec a ;BUMP OLD VALUE mov r0,a ;PUT OLD-1 IN r0 ; Q951: ret ;EXIT ; CSC: acall CLN_UP ;FINISH OFF THE LINE jnc Q951 ;EXIT IF NO TERMINATOR ; E4XX: mov dptr,#EXC ;CONTROL STACK ERROR ajmp EK ;STACK ERROR ; N4: mov TXAH,TEMP3 ;GET TEXT POINTER mov TXAL,TEMP4 ljmp ILOOP ;EXIT ; ;*************************************************************** ; ; The statement action routine - RESTORE ; ;*************************************************************** ; SRESTR: acall X_TR ;swap POINTERS SRESTR_2: acall DP_B ;GET THE STARTING ADDRESS acall T_DP ;PUT STARTING ADDRESS IN TEXT POINTER acall B_TXA ;BUMP TXA ; ; Fall thru ; X_TR: ;swap txa and rtxa ; xch a,TXAH xch a,RTXAH xch a,TXAH xch a,TXAL xch a,RTXAL xch a,TXAL ret ;EXIT ; ;$EJECT ;*************************************************************** ; ; The statement action routine - READ ; ;*************************************************************** ; SREAD: acall X_TR ;swap POINTERS ; SRD0: acall C_TST ;CHECK FOR COMMA jc SRD4 ;SEE WHAT IT IS ; SRD: acall EXPRB ;EVALUATE THE EXPRESSION acall GC ;GET THE CHARACTER AFTER EXPRESSION cjne a,#',',SRD1 ;SEE IF MORE DATA ajmp SRD2 ;BYBASS CLEAN UP IF a COMMA ; SRD1: acall CLN_UP ;FINISH OFF THE LINE, IF AT END ; SRD2: acall X_TR ;RESTORE POINTERS acall VAR_ER ;GET VARIABLE ADDRESS acall XPOP ;FLIP THE REGISTERS FOR POPAS acall C_TST ;SEE IF a COMMA jnc SREAD ;READ AGAIN IF a COMMA Q957: ret ;EXIT IF NOT ; SRD4: cjne a,#T_DATA,SRD5 ;SEE IF DATA acall GCI1 ;BUMP POINTER ajmp SRD ; SRD5: cjne a,#EOF,SRD6 ;SEE IF YOU BLEW IT Q734: acall X_TR ;GET THE TEXT POINTER BACK mov dptr,#E14X ;READ ERROR ; EK: ljmp ERROR ; SRD6: acall FINDCR ;WASTE THIS LINE acall CLN_UP ;CLEAN IT UP jc Q734 ;ERROR IF AT END ajmp SRD0 ; NUMC: acall GC ;GET a CHARACTER cjne a,#'#',NUMC1 ;SEE IF a # setb COB ;VALID LINE PRINT ajmp IGC ;BUMP THE TEXT POINTER ; NUMC1: cjne a,#'@',Q957 ;EXIT IF NO GOOD setb LPB ajmp IGC ; ;$EJECT ;*************************************************************** ; ; The statement action routine - PRINT ; ;*************************************************************** ; SPH0: setb ZSURP ;NO ZEROS ; SPH1: setb HMODE ;HEX MODE ; SPRINT: acall NUMC ;TEST FOR a LINE PRINT acall Q86 ;PROCEED SPRINT4:anl 35,#0xf5 ;CLEAR COB AND LPB anl 38,#0x3f ;NO HEX MODE ; ret ; Q86: acall DELTST ;CHECK FOR a DELIMITER jc SP1 ; SP0: ljmp CRLF ;EXIT WITH a CR IF SO ; SP2: acall C_TST ;CHECK FOR a COMMA jc SP0 ;EXIT IF NO COMMA ; SP1: acall CPS ;SEE IF a STRING TO PRINT jnc SP2 ;IF a STRING, CHECK FOR a COMMA ; SP4: cjne a,#T_TAB,SP6 acall I_PI ;ALWAYS CLEARS CARRY subb a,PHEAD ;TAKE DELTA BETWEEN TAB AND PHEAD jc SP2 ;EXIT IF PHEAD > TAB ajmp SP7 ;OUTPUT SPACES ; SP6: cjne a,#T_SPC,SM acall I_PI ;SET UP PAREN VALUE ; SP7: jz SP2 lcall STEROT ;OUTPUT a SPACE dec a ;DECREMENT COUNTER ajmp SP7 ;LOOP ; ;$EJECT SM: cjne a,#T_CHR,SP8 acall IGC cjne a,#'$',Q87 acall CNX ;PUT THE CHARACTER ON THE STACK acall IFIXL ;PUT THE CHARACTER IN r1 ajmp Q88 Q87: acall ONE ;EVALUATE THE EXPRESSION, PUT IN r3:r1 acall ERPAR Q88: mov r5,R1B0 ;BYTE TO OUTPUT ajmp SQ ; SP8: cjne a,#T_CR,SX acall GCI1 ;EAT THE TOKEN mov r5,#SCR ; SQ: lcall TEROT ajmp SP2 ;OUTPUT a CR AND DO IT AGAIN ; SX: cjne a,#T_USE,SP9 ;USING TOKEN acall IGC ;GE THE CHARACTER AFTER THE USING TOKEN cjne a,#'F',U4 ;SEE IF FLOATING mov FORMAT,#0xf0 ;SET FLOATING acall IGC ;BUMP THE POINTER AND GET THE CHARACTER acall GCI1 ;BUMP IT AGAIN anl a,#0x0F ;STRIP OFF ASCII BIAS jz U3 ;EXIT IF ZERO cjne a,#3,Q89 ;SEE IF AT LEAST a THREE Q89: jnc U3 ;FORCE a THREE IF NOT a THREE mov a,#3 ; U3: orl FORMAT,a ;PUT DIGIT IN FORMAT ajmp U8 ;CLEAN UP END ; U4: cjne a,#'0',U5 mov FORMAT,#0 ;FREE FORMAT acall GCI1 ;BUMP THE POINTER ajmp U8 ; U5: cjne a,#'#',U8 ;SEE IF INTGER FORMAT acall U6 mov FORMAT,r7 ;SAVE THE FORMAT cjne a,#'.',U8A ;SEE IF TERMINATOR WAS RADIX acall IGC ;BUMP PAST . acall U6 ;LOOP AGAIN mov a,r7 ;GET COUNT add a,FORMAT ;SEE IF TOO BIG add a,#0xF7 jnc U5A ; ;$EJECT SE0: ljmp INTERX ;ERROR, BAD SYNTAX ; U5A: mov a,r7 ;GET THE COUNT BACK swap a ;ADJUST orl FORMAT,a ;GET THE COUNT ; U8A: mov a,FORMAT ; U8B: swap a ;GET THE FORMAT RIGHT mov FORMAT,a ; U8: acall ERPAR ajmp SP2 ;DONE ; U6: mov r7,#0 ;SET COUNTER ; U7: cjne a,#'#',SP9A ;EXIT IF NOT a # inc r7 ;BUMP COUNTER acall IGC ;GET THE NEXT CHARACTER ajmp U7 ;LOOP ; SP9: acall DELTST_2 ;CHECK FOR DELIMITER jnc SP9A ;EXIT IF a DELIMITER ; cjne a,#T_ELSE,SS ; SP9A: ret ;EXIT IF ELSE TOKEN ; ;************************************************************** ; ; P_E - Evaluate an expression in parens ( ) ; ;************************************************************** ; P_E: mov r7,#T_LPAR acall WE ; ERPAR: mov r7,#')' ;EAT a RIGHT PAREN ; EATC: acall GCI ;GET THE CHARACTER cjne a,R7B0,SE0 ;ERROR IF NOT THE SAME ret ; ;$EJECT ;*************************************************************** ; S_ON: ; ON Statement ; ;*************************************************************** ; acall ONE ;GET THE EXPRESSION acall GCI ;GET THE NEXT CHARACTER cjne a,#T_GOTO,XXC0 acall XXC1 ;EAT THE COMMAS ljmp SF3 ;DO GOTO ; XXC0: cjne a,#T_GOSB,SE0 acall XXC1 ajmp SGS0 ;DO GOSUB ; XXC1: cjne r1,#0,XXC2 acall INTERR ;GET THE LINE NUMBER acall FINDCR ajmp RL1 ;FINISH UP THIS LINE ; XXC2: mov r7,#',' acall FINDC cjne a,#',',SE0 ;ERROR IF NOT a COMMA dec r1 acall GCI1 ;BUMP PAST COMMA ajmp XXC1 ; ;$EJECT ; SS: acall S_C ;SEE IF a STRING jc SA ;NO STRING IF CARRY IS SET lcall UPRNT ;PUT POINTER IN dptr ajmp SP2 ;SEE IF MORE ; SA: acall EXPRB ;MUST BE AN EXPRESSION mov a,#72 cjne a,PHEAD,Q90 ;CHECK PHEAD POSITION Q90: jnc Q91 acall SP0 ;FORCE a CRLF Q91: jnb HMODE,S13 ;HEX MODE? acall FCMP ;SEE IF TOS IS < 0FFFH jc S13 ;EXIT IF GREATER lcall AABS ;GET THE SIGN jnz OOPS ;WASTE IF NEGATIVE acall IFIXL lcall HEXOUT ;PRINT HEXMODE ajmp SP2 OOPS: lcall ANEG ;MAKE IT NEGATIVE ; S13: lcall FLOATING_POINT_OUTPUT ;DO FP OUTPUT mov a,#1 ;OUTPUT a SPACE ajmp SP7 ; ;$EJECT ;*************************************************************** ; ; ANU - Get variable name from text - set carry if not found ; if succeeds returns variable in r7:r6 ; r6 = 0 if no digit in name ; ;*************************************************************** ; ANU: acall IGC ;INCREMENT AND GET CHARACTER lcall DIGIT_CHECK ;CHECK FOR DIGIT jc Q92 ;EXIT IF VALID DIGIT cjne a,#'_',AL ;SEE IF a _ ret ; AL: cjne a,#'A',Q93 ;IS IT AN ASCII a? Q93: jc Q94 ;EXIT IF CARRY IS SET cjne a,#'Z'+1,Q92 ;IS IT LESS THAN AN ASCII Z Q92: cpl c ;FLIP CARRY Q94: ret ; Q941: jnb F0,VAR2 ; SD0: mov dptr,#E6X ajmp EK ; SDIMX: setb F0 ;SAYS DOING a DIMENSION ajmp VAR1 ; VAR: clr F0 ;SAYS DOING a VARIABLE ; VAR1: acall GC ;GET THE CHARACTER acall AL ;CHECK FOR ALPHA jnc Q95 ;ERROR IF IN DIM jb F0,SD0 ret Q95: mov r7,a ;SAVE ALPHA CHARACTER clr a ;ZERO IN CASE OF FAILURE mov r5,a ;SAVE IT ; VY: mov r6,a acall ANU ;CHECK FOR ALPHA OR NUMBER jc VX ;EXIT IF NO ALPHA OR NUM ; xch a,r7 add a,r5 ;NUMBER OF CHARACTERS IN ALPHABET xch a,r7 ;PUT IT BACK mov r5,#26 ;FOR THE SECOND TIME AROUND ajmp VY ; VX: clr LINEB ;TELL EDITOR a VARIABLE IS DECLARED cjne a,#T_LPAR,V4 ;SEE IF a LEFT PAREN ; orl R6B0,#0x80 ;SET BIT 7 TO SIGINIFY MATRIX lcall F_VAR ;FIND THE VARIABLE push R2B0 ;SAVE THE LOCATION push R0B0 jnc Q941 ;DEFAULT IF NOT IN TABLE jb F0,SDI ;NO DEFAULT FOR DIMENSION mov r1,#10 mov r3,#0 acall D_CHK ; VAR2: acall PAREN_INT ;EVALUATE INTEGER IN PARENS cjne r3,#0,SD0 ;ERROR IF r3<>0 pop DPL ;GET VAR FOR LOOKUP pop DPH movx a,@dptr ;GET DIMENSION dec a ;BUMP OFFSET subb a,r1 ;a MUST BE > r1 jc SD0 lcall DECDP2 ;BUMP POINTER TWICE lcall VARB ;CALCULATE THE BASE ; X3120: xch a,r1 ;swap r2:r0, r3:r1 xch a,r0 xch a,r1 xch a,r3 xch a,r2 xch a,r3 ret ; V4: jb F0,SD0 ;ERROR IF NO LPAR FOR DIM lcall F_VAR ;GET SCALAR VARIABLE clr c ret ; ;$EJECT ; SDI: acall PAREN_INT ;EVALUATE PAREN EXPRESSION cjne r3,#0,SD0 ;ERROR IF NOT ZERO pop R0B0 ;SET UP r2:r0 pop R2B0 acall D_CHK ;DO DIM acall C_TST ;CHECK FOR COMMA jnc SDIMX ;LOOP IF COMMA ret ;RETURN IF NO COMMA ; D_CHK: inc r1 ;BUMP FOR TABLE LOOKUP mov a,r1 jz SD0 ;ERROR IF 0FFFFH mov r4,a ;SAVE FOR LATER mov dptr,#MT_ALL ;GET MATRIX ALLOCATION lcall VARB ;DO THE CALCULATION mov r7,DPH ;SAVE MATRIX ALLOCATION mov r6,DPL mov dptr,#ST_ALL ;SEE IF TOO MUCH MEMORY TAKEN lcall FUL1 ;ST_ALL SHOULD BE > r3:r1 mov dptr,#MT_ALL ;SAVE THE NEW MATRIX POINTER lcall S31DP mov DPL,r0 ;GET VARIABLE ADDRESS mov DPH,r2 mov a,r4 ;DIMENSION SIZE movx @dptr,a ;SAVE IT lcall DECDP2 ;SAVE TARGET ADDRESS ; R76S: mov a,r7 movx @dptr,a inc dptr mov a,r6 ;ELEMENT SIZE movx @dptr,a ret ;r2:r0 STILL HAS SYMBOL TABLE ADDRESS ; ;$EJECT ;*************************************************************** ; ; The statement action routine - INPUT ; ;*************************************************************** ; SINPUT: acall CPS ;PRINT STRING IF THERE ; acall C_TST ;CHECK FOR a COMMA jnc IN2A ;NO CRLF acall SP0 ;DO a CRLF ; IN2: mov r5,#'?' ;OUTPUT a ? lcall TEROT ; IN2A: setb INP_B ;DOING INPUT lcall INLINE ;INPUT THE LINE clr INP_B mov TEMP5,#IBUF>>8 mov TEMP4,#IBUF&0xff ; IN3: acall S_C ;SEE IF a STRING jc IN3A ;IF CARRY IS SET, NO STRING acall X3120 ;FLIP THE ADDRESSES mov r3,TEMP5 mov r1,TEMP4 lcall SSOOP acall C_TST ;SEE IF MORE TO DO jnc IN2 ret ; IN3A: lcall DTEMP ;GET THE USER LOCATION lcall GET_NUM ;GET THE USER SUPPLIED NUMBER jnz IN5 ;ERROR IF NOT ZERO lcall TEMPD ;SAVE THE DATA POINTER acall VAR_ER ;GET THE VARIABLE acall XPOP ;SAVE THE VARIABLE lcall DTEMP ;GET dptr BACK FROM VAR_ER acall C_TST ;SEE IF MORE TO DO jc IN6 ;EXIT IF NO COMMA movx a,@dptr ;GET INPUT TERMINATOR cjne a,#',',IN5 ;IF NOT a COMMA DO a CR AND TRY AGAIN inc dptr ;BUMP PAST COMMA AND READ NEXT VALUE lcall TEMPD ajmp IN3 ; ;$EJECT ; IN5: mov dptr,#IAN ;PRINT INPUT a NUMBER lcall CRP ;DO a CR, THEN, PRINT FROM ROM ljmp XCC1 ;TRY IT AGAIN ; IN6: movx a,@dptr cjne a,#SCR,EIGP ret ; EIGP: mov dptr,#EIG lcall CRP ;PRINT THE MESSAGE AND EXIT ajmp SP0 ;EXIT WITH a CRLF ; ;*************************************************************** ; SOT: ; On timer interrupt ; ;*************************************************************** ; acall TWO ;GET THE NUMBERS mov SP_H,r3 mov SP_L,r1 mov dptr,#TIV ;SAVE THE NUMBER setb OTS ajmp R76S ;EXIT ; ; ;*************************************************************** ; SCALL: ; Call a user rountine ; ;*************************************************************** ; acall INTERR ;CONVERT INTEGER cjne r2,#0,S_C_1 ;SEE IF TRAP mov a,r0 jb ACC.7,S_C_1 add a,r0 mov dptr,#0x4100 mov DPL,a ; S_C_1: lcall AC1 ;JUMP TO USER PROGRAM anl PSW,#0xe7 ;BACK TO BANK 0 ret ;EXIT ; ;$EJECT ;************************************************************** ; THREE: ; Save value for timer function ; ;************************************************************** ; acall ONE ;GET THE FIRST INTEGER lcall CBIAS ;BIAS FOR TIMER LOAD mov T_HH,r3 mov T_LL,r1 mov r7,#',' ;WASTE a COMMA acall EATC ;FALL THRU TO TWO ; ;************************************************************** ; TWO: ; Get two values seperated by a comma off the stack ; ;************************************************************** ; acall EXPRB mov r7,#',' ;WASTE THE COMMA acall WE ljmp TWOL ;EXIT ; ;************************************************************* ; ONE: ; Evaluate an expression and get an integer ; ;************************************************************* ; acall EXPRB ;EVALUATE EXPERSSION ; IFIXL: acall IFIX ;INTEGERS IN r3:r1 mov a,r1 ret ; ; ;************************************************************* ; I_PI: ; Increment text pointer then get an integer ; ;************************************************************* ; acall GCI1 ;BUMP TEXT, THEN GET INTEGER ; PAREN_INT:; Get an integer in parens ( ) ; acall P_E ajmp IFIXL ; ;$EJECT ; DP_B: mov DPH,BOFAH mov DPL,BOFAL ret ; DP_T: mov DPH,TXAH mov DPL,TXAL ret ; Q234: ajmp NOPASS CPS: acall GC ;GET THE CHARACTER cjne a,#'"',Q234 ;EXIT IF NO STRING acall DP_T ;GET TEXT POINTER inc dptr ;BUMP PAST " mov r4,#'"' lcall PN0 ;DO THE PRINT inc dptr ;GO PAST QUOTE clr c ;PASSED TEST ; T_DP: mov TXAH,DPH ;TEXT POINTER GETS dptr mov TXAL,DPL ret ; ;************************************************************* ; S_C: ; Check for a string ; ;************************************************************* ; acall GC ;GET THE CHARACTER cjne a,#'$',NOPASS ;SET CARRY IF NOT a STRING ljmp IST_CAL ;CLEAR CARRY, CALCULATE OFFSET ; ; ; ;************************************************************** ; C_TST: acall GC ;GET a CHARACTER cjne a,#',',NOPASS ;SEE IF a COMMA ; ;$EJECT ;*************************************************************** ; ;GC AND GCI - GET a CHARACTER FROM TEXT (NO BLANKS) ; PUT CHARACTER IN THE ACC ; ;*************************************************************** ; IGC: acall GCI1 ;BUMP POINTER, THEN GET CHARACTER ; GC: setb RS0 ;USE BANK 1 mov P2,r2 ;SET UP PORT 2 movx a,@r0 ;GET EXTERNAL BYTE clr RS0 ;BACK TO BANK 0 ret ;EXIT ; GCI: acall GC ; ; This routine bumps txa by one and always clears the carry ; GCI1: setb RS0 ;BANK 1 inc r0 ;BUMP TXA cjne r0,#0,Q96 inc r2 Q96: clr RS0 ret ;EXIT ; ;$EJECT ;************************************************************** ; ; Check delimiters ; ;************************************************************** ; DELTST: acall GC ;GET a CHARACTER DELTST_2: cjne a,#SCR,DT1 ;SEE IF a CR clr a ret ; DT1: cjne a,#':',NOPASS ;SET CARRY IF NO MATCH ; L_RET: ret ; ; ;*************************************************************** ; ; FINDC - Find the character in r7, update TXA ; ;*************************************************************** ; FINDCR: mov r7,#SCR ;KILL a STATEMENT LINE ; FINDC: acall DELTST jnc L_RET ; cjne a,R7B0,FNDCL2 ;MATCH? ret ; FNDCL2: acall GCI1 ajmp FINDC ;LOOP ; Q987: acall GCI1 ; WCR: acall DELTST ;WASTE UNTIL a "REAL" CR jnz Q987 ret ; ;$EJECT ;*************************************************************** ; ; VAR_ER - Check for a variable, exit if error ; ;*************************************************************** ; VAR_ER: acall VAR ajmp INTERR_2 ; ; ;*************************************************************** ; ; S_D0 - The Statement Action Routine DO ; ;*************************************************************** ; S_DO: acall CSC ;FINISH UP THE LINE mov r4,#DTYPE ;TYPE FOR STACK acall SGS1 ;SAVE ON STACK ljmp ILOOP ;EXIT ; ;$EJECT ;*************************************************************** ; ; CLN_UP - Clean up the end of a statement, see if at end of ; file, eat character and line count after CR ; ;*************************************************************** ; C_2: cjne a,#':',C_1 ;SEE IF a TERMINATOR ajmp GCI1 ;BUMP POINTER AND EXIT, IF SO ; C_1: cjne a,#T_ELSE,EP5X acall WCR ;WASTE UNTIL a CR ; CLN_UP: acall GC ;GET THE CHARACTER cjne a,#SCR,C_2 ;SEE IF a CR acall IGC ;GET THE NEXT CHARACTER cjne a,#EOF,B_TXA ;SEE IF TERMINATOR ; NOPASS: setb c ret ; B_TXA: xch a,TXAL ;BUMP TXA BY THREE add a,#3 xch a,TXAL jbc CY,Q97 ret Q97: inc TXAH ret ; ;$EJECT ;*************************************************************** ; ; Get an INTEGER from the text ; sets CARRY if not found ; returns the INTGER value in dptr and r2:r0 ; returns the terminator in ACC ; ;*************************************************************** ; INTERR: acall INTGER ;GET THE INTEGER INTERR_2: jc EP5X ;ERROR IF NOT FOUND ret ;EXIT IF FOUND EP5X: clr c ;NO RECOVERY ljmp E1XX_2 ; INTGER: acall DP_T lcall CONVERT_ASCII_STRING_TO_BINARY ;CONVERT THE INTEGER acall T_DP mov DPH,r2 ;PUT THE RETURNED VALUE IN THE dptr mov DPL,r0 ; ITRET: ret ;EXIT ; ; WE: acall EATC ;WASTE THE CHARACTER ; ; Fall thru to evaluate the expression ; ;$EJECT ;*************************************************************** ; ; EXPRB - Evaluate an expression ; ;*************************************************************** ; EXPRB: ;mov r2,#OPBOL&0xff ;BASE PRECEDENCE mov r2, #0 ; EP1: push R2B0 ;SAVE OPERATOR PRECEDENCE clr ARGF ;RESET STACK DESIGNATOR ; EP2: mov a,SP ;GET THE STACK POINTER add a,#12 ;NEED AT LEAST 12 BYTES jnc Q296 ljmp ERROR_3 Q296: mov a,ASTKA ;GET THE ARG STACK subb a,#(TM_TOP+12)&0xff;NEED 12 BYTES ALSO jnc Q297 ajmp E4YY Q297: jb ARGF,EP4 ;MUST BE AN OPERATOR, IF SET acall VAR ;IS THE VALUE a VARIABLE? jnc EP3 ;PUT VARIABLE ON STACK ; acall CONST ;IS THE VALUE a NUMERIC CONSTANT? jnc EP4 ;IF SO, CONTINUE, IF NOT, SEE WHAT acall GC ;GET THE CHARACTER cjne a,#T_LPAR,EP4 ;SEE IF a LEFT PAREN ;mov a,#(OPBOL+1)&0xff mov a,#1 ajmp XLPAR ;PROCESS THE LEFT PAREN ; EP3: acall PUSHAS ;SAVE VAR ON STACK ; EP4: acall GC ;GET THE OPERATOR ; cjne a,#T_LPAR,Q98 ;IS IT AN OPERATOR Q98: jnc XOP ;PROCESS OPERATOR cjne a,#T_UOP,Q99 ;IS IT a UNARY OPERATOR Q99: jnc XBILT ;PROCESS UNARY (BUILT IN) OPERATOR pop R2B0 ;GET BACK PREVIOUS OPERATOR PRECEDENCE jb ARGF,Q323 ;OK IF ARG FLAG IS SET ; EP5: clr c ;NO RECOVERY ljmp E1XX_2 ; ; Process the operator ; XOP: anl a,#0x1F ;STRIP OFF THE TOKE BITS jb ARGF,XOP1 ;IF ARG FLAG IS SET, PROCESS cjne a,#T_SUB-T_LPAR,XOP3 mov a,#T_NEG-T_LPAR ; ;$EJECT XOP1: ;add a,#(OPBOL+1)&0xff ;BIAS THE TABLE add a, #1 mov r2,a mov dptr,#OPBOL movc a,@a+dptr ;GET THE CURRENT PRECEDENCE mov r4,a pop ACC ;GET THE PREVIOUS PRECEDENCE mov r5,a ;SAVE THE PREVIOUS PRECEDENCE movc a,@a+dptr ;GET IT cjne a,R4B0,Q100 ;SEE WHICH HAS HIGHER PRECEDENCE cjne a,#12,Q323 ;SEE IF ANEG setb c Q100: jnc Q323 ;PROCESS NON-INCREASING PRECEDENCE ; ; Save increasing precedence ; push R5B0 ;SAVE OLD PRECEDENCE ADDRESS push R2B0 ;SAVE NEW PRECEDENCE ADDRESS acall GCI1 ;EAT THE OPERATOR acall EP1 ;EVALUATE REMAINING EXPRESSION XOP2_2: pop ACC ; ; r2 has the action address, now setup and perform operation ; XOP2: mov dptr,#OPTAB-2 ;add a,#(~ OPBOL)&0xff lcall ISTA1 ;SET UP TO RETURN TO EP2 ajmp EP2 ;JUMP TO EVALUATE EXPRESSION Q323: ret ; ; Built-in operator processing ; XBILT: acall GCI1 ;EAT THE TOKEN ;add a,#(0x50+(UOPBOL&0xff))&0xff add a,#(0x50+(UOPBOL-OPBOL))&0xff jb ARGF,EP5 ;XBILT MUST COME AFTER AN OPERATOR cjne a,#(STP-OPBOL)&0xff,Q101 ;cjne a,#(STP&0xff,Q101 Q101: jnc XOP2 ; XLPAR: push ACC ;PUT ADDRESS ON THE STACK acall P_E ajmp XOP2_2 ;PERFORM OPERATION ; XOP3: cjne a,#T_ADD-T_LPAR,EP5 acall GCI1 ajmp EP2 ;WASTE + SIGN ; ;$EJECT XPOP: acall X3120 ;FLIP ARGS THEN pop ; ;*************************************************************** ; ; POPAS - Pop arg stack and copy variable to r3:r1 ; ;*************************************************************** ; POPAS: acall INC_ASTKA ljmp VARCOP ;COPY THE VARIABLE ; AXTAL: mov r2,#CXTAL>>8 mov r0,#CXTAL&0xff ; ; fall thru ; ;*************************************************************** ; PUSHAS: ; Push the Value addressed by r2:r0 onto the arg stack ; ;*************************************************************** ; acall DEC_ASTKA setb ARGF ;SAYS THAT SOMTHING IS ON THE STACK ljmp VARCOP ; ; ;*************************************************************** ; ST_A: ; Store at expression ; ;*************************************************************** ; acall ONE ;GET THE EXPRESSION ajmp POPAS ;SAVE IT ; ; ;*************************************************************** ; LD_A: ; Load at expression ; ;*************************************************************** ; acall ONE ;GET THE EXPRESSION acall X3120 ;FLIP ARGS ajmp PUSHAS ; ;$EJECT ;*************************************************************** ; CONST: ; Get a constant fron the text ; ;*************************************************************** ; acall GC ;FIRST SEE IF LITERAL cjne a,#T_ASC,C0C ;SEE IF ASCII TOKEN acall IGC ;GET THE CHARACTER AFTER TOKEN cjne a,#'$',CN0 ;SEE IF a STRING ; CNX: lcall CSY ;CALCULATE IT ljmp AXBYTE_2 ;SAVE IT ON THE STACK ; CN0: lcall TWO_R2 ;PUT IT ON THE STACK acall GCI1 ;BUMP THE POINTER ajmp ERPAR ;WASTE THE RIGHT PAREN ; ; C0C: acall DP_T ;GET THE TEXT POINTER lcall GET_NUM ;GET THE NUMBER cjne a,#0xff,C1C ;SEE IF NO NUMBER setb c C2C: ret ; C1C: jnz FPTST clr c setb ARGF ; C3C: ajmp T_DP ; FPTST: anl a,#0x0b ;CHECK FOR ERROR jz C2C ;EXIT IF ZERO ; ; Handle the error condition ; mov dptr,#E2X ;DIVIDE BY ZERO jnb ACC.0,Q102 ;UNDERFLOW mov dptr,#E7X Q102: jnb ACC.1,Q102 ;OVERFLOW mov dptr,#E11X ; FPTS: ljmp ERROR ; ;$EJECT ;*************************************************************** ; ; The Command action routine - LIST ; ;*************************************************************** ; CLIST: acall NUMC ;SEE IF TO LINE PORT lcall FSTK ;PUT 0FFFFH ON THE STACK acall INTGER ;SEE IF USER SUPPLIES LN clr a ;LN = 0 TO START mov r3,a mov r1,a jc CxL1 ;START FROM ZERO ; lcall TEMPD ;SAVE THE START ADDTESS acall GCI ;GET THE CHARACTER AFTER LIST cjne a,#T_SUB,Q103 ;CHECK FOR TERMINATION ADDRESS "-" acall INC_ASTKA ;WASTE 0FFFFH acall INTERR ;GET TERMINATION ADDRESS lcall TWO_EY ;PUT TERMINATION ON THE ARG STACK Q103: mov r3,TEMP5 ;GET THE START ADDTESS mov r1,TEMP4 ; CxL1: lcall GETLIN ;GET THE LINE NO IN r3:r1 jz CL3 ;ret IF AT END ; CL2: acall C3C ;SAVE THE ADDRESS inc dptr ;POINT TO LINE NUMBER lcall PMTOP_3 ;PUT LINE NUMBER ON THE STACK acall CMPLK ;COMPARE LN TO END ADDRESS jc CL3 ;EXIT IF GREATER lcall BCK ;CHECK FOR a CONTROL c acall DEC_ASTKA ;SAVE THE COMPARE ADDRESS acall DP_T ;RESTORE ADDRESS acall UPPL ;UN-PROCESS THE LINE acall C3C ;SAVE THE CR ADDRESS acall CL6 ;PRINT IT inc dptr ;BUMP POINTER TO NEXT LINE movx a,@dptr ;GET LIN LENGTH djnz ACC,CL2 ;LOOP acall INC_ASTKA ;WASTE THE COMPARE BYTE ; CL3: ljmp CMND1 ;BACK TO COMMAND PROCESSOR ; CL6: mov dptr,#IBUF ;PRINT IBUF lcall PRNTCR ;PRINT IT acall DP_T ; CL7: ljmp CRLF ; UPPL_3: lcall X31DP ;$EJECT ;*************************************************************** ; ;UPPL - UN PREPROCESS a LINE ADDRESSED BY dptr INTO IBUF ; RETURN SOURCE ADDRESS OF CR IN dptr ON RETURN ; ;*************************************************************** ; UPPL: mov r3,#IBUF>>8 ;POINT r3 AT HIGH IBUF mov r1,#IBUF&0xff ;POINT r1 AT IBUF inc dptr ;SKIP OVER LINE LENGTH acall C3C ;SAVE THE dptr (DP_T) lcall L20DPI ;PUT LINE NUMBER IN r2:r0 lcall CONVERT_BINARY_TO_ASCII_STRING ;CONVERT r2:r0 TO INTEGER acall DP_T inc dptr ;BUMP DPTR PAST THE LINE NUMBER ; UPP0: cjne r1,#(IBUF+6)&0xff,Q105 Q105: jc Q923 ;PUT SPACES IN TEXT inc dptr ;BUMP PAST LN HIGH movx a,@dptr ;GET USER TEXT mov r6,a ;SAVE a IN r6 FOR TOKE COMPARE jb ACC.7,UPP1 ;IF TOKEN, PROCESS cjne a,#0x20,Q106 ;TRAP THE USER TOKENS Q106 jnc Q107 cjne a,#SCR,UPP1 ;DO IT IF NOT a CR Q107: cjne a,#'"',UPP9 ;SEE IF STRING acall UPP7 ;SAVE IT Q7: acall UPP8 ;GET THE NEXT CHARACTER AND SAVE IT cjne a,#'"',Q7 ;LOOP ON QUOTES ajmp UPP0 ; UPP9: cjne a,#':',UPP1A ;PUT a SPACE IN DELIMITER acall UPP7A mov a,r6 acall UPP7 Q923: acall UPP7A ajmp UPP0 ; UPP1A: acall UPP8_2 ;SAVE THE CHARACTER, UPDATE POINTER ajmp UPP0 ;EXIT IF a CR, ELSE LOOP ; UPP1: acall C3C ;SAVE THE TEXT POINTER mov c,XBIT mov F0,c ;SAVE XBIT IN F0 Q924: mov dptr,#TOKTAB ;POINT AT TOKEN TABLE ; jnb F0,UPP2 ; lcall 0x2078 ;SET UP dptr FOR LOOKUP ; UPP2: clr a ;ZERO a FOR LOOKUP movc a,@a+dptr ;GET TOKEN inc dptr ;ADVANCE THE TOKEN POINTER cjne a,#0xff,UP_2 ;SEE IF DONE jbc F0,Q924 ;NOW DO NORMAL TABLE ljmp CMND1 ;EXIT IF NOT FOUND ; UP_2: cjne a,R6B0,UPP2 ;LOOP UNTIL THE SAME ; UP_3: cjne a,#T_UOP,Q108 Q108: jnc UPP3 acall UPP7A ;PRINT THE SPACE IF OK ; UPP3: clr a ;DO LOOKUP movc a,@a+dptr jb ACC.7,UPP4 ;EXIT IF DONE, ELSE SAVE jz UPP4 ;DONE IF ZERO acall UPP7 ;SAVE THE CHARACTER inc dptr ajmp UPP3 ;LOOP ; UPP4: acall DP_T ;GET IT BACK mov a,r6 ;SEE IF a REM TOKEN xrl a,#T_REM jnz Q109 Q8: acall UPP8 ajmp Q8 Q109: jnc UPP0 ;START OVER AGAIN IF NO TOKEN acall UPP7A ;PRINT THE SPACE IF OK ajmp UPP0 ;DONE ; UPP7A: mov a,#' ' ;OUTPUT a SPACE ; UPP7: ljmp PPL9_1 ;SAVE a ; UPP8: inc dptr movx a,@dptr UPP8_2: cjne a,#SCR,UPP7 ljmp PPL7_1 ; ;$EJECT ;************************************************************** ; ; This table contains all of the floating point constants ; ; The constants in ROM are stored "backwards" from the way ; basic normally treats floating point numbers. Instead of ; loading from the exponent and decrementing the pointer, ; ROM constants pointers load from the most significant ; digits and increment the pointers. This is done to 1) make ; arg stack loading faster and 2) compensate for the fact that ; no decrement data pointer instruction exsist. ; ; The numbers are stored as follows: ; ; BYTE X+5 = MOST SIGNIFICANT DIGITS IN BCD ; BYTE X+4 = NEXT MOST SIGNIFICANT DIGITS IN BCD ; BYTE X+3 = NEXT LEAST SIGNIFICANT DIGITS IN BCD ; BYTE X+2 = LEAST SIGNIFICANT DIGITS IN BCD ; BYTE X+1 = SIGN OF THE ABOVE MANTISSA 0 = +, 1 = - ; BYTE X = EXPONENT IN TWO"S COMPLEMENT BINARY ; ZERO EXPONENT = THE NUMBER ZERO ; ;************************************************************** ; ATTAB: db 128-2 ; ARCTAN LOOKUP db 0x00 db 0x57 db 0x22 db 0x66 db 0x28 ; db 128-1 db 0x01 db 0x37 db 0x57 db 0x16 db 0x16 ; db 128-1 db 0x00 db 0x14 db 0x96 db 0x90 db 0x42 ; db 128-1 db 0x01 db 0x40 db 0x96 db 0x28 db 0x75 ; db 128 db 0x00 db 0x64 db 0x62 db 0x65 db 0x10 ; db 128 db 0x01 db 0x99 db 0x88 db 0x20 db 0x14 ; db 128 db 0x00 db 0x51 db 0x35 db 0x99 db 0x19 ; db 128 db 0x01 db 0x45 db 0x31 db 0x33 db 0x33 ; db 129 db 0x00 db 0x00 db 0x00 db 0x00 db 0x10 ; db 0xff ;END OF TABLE ; NTWO: db 129 db 0 db 0 db 0 db 0 db 0x20 ; TTIME: db 128-4 ; CLOCK CALCULATION db 0x00 db 0x00 db 0x00 db 0x04 db 0x13 ; ;$EJECT ;*************************************************************** ; ; COSINE - Add pi/2 to stack, then fall thru to SIN ; ;*************************************************************** ; ACOS: acall POTWO ;PUT PI/2 ON THE STACK lcall AADD ;TOS = TOS+PI/2 ; ;*************************************************************** ; ; SINE - use taylor series to calculate sin function ; ;*************************************************************** ; ASIN: lcall PIPI ;PUT PI ON THE STACK acall RV ;REDUCE THE VALUE mov a,MT2 ;CALCULATE THE SIGN anl a,#0x01 ;SAVE LSB xrl MT1,a ;SAVE SIGN IN MT1 lcall CSTAKA ;NOW CONVERT TO ONE QUADRANT acall POTWO acall CMPLK ;DO COMPARE jc Q110 lcall PIPI lcall ASUB Q110: lcall AABS mov dptr,#SINTAB ;SET UP LOOKUP TABLE acall POLYC ;CALCULATE THE POLY acall STRIP ajmp SIN0 ; ; Put PI/2 on the stack ; POTWO: lcall PIPI ;PUT PI ON THE STACK, NOW DIVIDE ; DBTWO: mov dptr,#NTWO lcall PUSHC ;mov a,#2 ;BY TWO ;acall TWO_R2 ljmp ADIV ; ;$EJECT ;************************************************************* ; POLYC: ; Expand a power series to calculate a polynomial ; ;************************************************************* ; lcall CSTAKA2 ;COPY THE STACK acall AMUL ;SQUARE THE STACK lcall POP_T1 ;SAVE X*X lcall PUSHC ;PUT CONSTANT ON STACK ; POLY1: lcall PUSH_T1 ;PUT COMPUTED VALUE ON STACK acall AMUL ;MULTIPLY CONSTANT AND COMPUTED VALUE lcall PUSHC ;PUT NEXT CONSTANT ON STACK lcall AADD ;add IT TO THE OLD VALUE clr a ;CHECK TO SEE IF DONE movc a,@a+dptr cjne a,#0xff,POLY1 ;LOOP UNTIL DONE ; AMUL: lcall FLOATING_MUL ajmp FPTST ; ;************************************************************* ; RV: ; Reduce a value for Trig and a**X functions ; ; value = (value/x - INT(value/x)) * x ; ;************************************************************* ; lcall Cx_T2 ;COPY TOS TO T2 lcall ADIV ;TOS = TOS/TEMP2 lcall AABS ;MAKE THE TOS a POSITIVE NUMBER mov MT1,a ;SAVE THE SIGN lcall CSTAKA2 ;COPY THE STACK TWICE acall IFIX ;PUT THE NUMBER IN r3:r1 push R3B0 ;SAVE r3 mov MT2,r1 ;SAVE THE LS BYTE IN MT2 lcall AINT ;MAKE THE TOS AN INTEGER lcall ASUB ;TOS = TOS/T2 - INT(TOS/T2) lcall P_T2 ;TOS = T2 acall AMUL ;TOS = T2*(TOS/T2 - INT(TOS/T2) pop R3B0 ;RESTORE r3 ret ;EXIT ; ;$EJECT ;************************************************************** ; ; TAN ; ;************************************************************** ; ATAN: lcall CSTAKA ;DUPLACATE STACK acall ASIN ;TOS = SIN(X) lcall SWAP_ASTKA ;TOS = X acall ACOS ;TOS = COS(X) ljmp ADIV ;TOS = SIN(X)/COS(X) ; STRIP: acall SETREG ;SETUP r0 mov r3,#1 ;LOOP COUNT ljmp AI2_1 ;WASTE THE LSB ; ;************************************************************ ; ; ARC TAN ; ;************************************************************ ; AATAN: lcall AABS mov MT1,a ;SAVE THE SIGN acall SETREG ;GET THE EXPONENT add a,#0x7f ;BIAS THE EXPONENT mov UBIT,c ;SAVE CARRY STATUS jnc Q210 ;SEE IF > 1 lcall RECIP ;IF > 1, TAKE RECIP Q210: mov dptr,#ATTAB ;SET UP TO CALCULATE THE POLY acall POLYC ;CALCULATE THE POLY jnb UBIT,SIN0 ;JUMP IF NOT SET lcall ANEG ;MAKE X POLY NEGATIVE acall POTWO ;SUBTRACT PI/2 lcall AADD ; SIN0: mov a,MT1 ;GET THE SIGN jz SRT ljmp ANEG ; E4YY: mov dptr,#EXA ajmp FPTS ;ARG STACK ERROR ; ;$EJECT ;************************************************************* ; ; FCOMP - COMPARE 0FFFFH TO TOS ; ;************************************************************* ; FCMP: lcall CSTAKA ;COPY THE STACK lcall FSTK ;MAKE THE TOS = 0FFFFH lcall SWAP_ASTKA ;NOW COMPARE IS 0FFFFH - X ; CMPLK: ljmp FLOATING_COMP ;DO THE COMPARE ; ;************************************************************* ; DEC_ASTKA: ;Push ARG STACK and check for underflow ; ;************************************************************* ; mov a,#(-FPSIZ)&0xff add a,ASTKA cjne a,#(TM_TOP+6)&0xff,Q111 Q111 jc E4YY mov ASTKA,a mov r1,a mov r3,#ASTKAH ; SRT: ret ; ; AXTAL3: lcall PUSHC ;push CONSTANT, THEN MULTIPLY acall AMUL ; ; Fall thru to IFIX ; ;$EJECT ;*************************************************************** ; IFIX: ; Convert a floating point number to an integer, put in r3:r1 ; ;*************************************************************** ; clr a ;RESET THE START mov r3,a mov r1,a mov r0,ASTKA ;GET THE ARG STACK mov P2,#ASTKAH movx a,@r0 ;READ EXPONENT clr c subb a,#0x81 ;BASE EXPONENT mov r4,a ;SAVE IT dec r0 ;POINT AT SIGN movx a,@r0 ;GET THE SIGN jnz SQ_ERR ;ERROR IF NEGATIVE jc INC_ASTKA ;EXIT IF EXPONENT IS < 0x81 inc r4 ;ADJUST LOOP COUNTER mov a,r0 ;BUMP THE POINTER REGISTER subb a,#FPSIZ-1 mov r0,a ; I2: inc r0 ;POINT AT DIGIT movx a,@r0 ;GET DIGIT swap a ;FLIP lcall MULNUM10 ;ACCUMULATE jc SQ_ERR djnz r4,Q112 ajmp INC_ASTKA Q112: movx a,@r0 ;GET DIGIT lcall MULNUM10 jc SQ_ERR djnz r4,I2 ; ;$EJECT ;************************************************************ ; INC_ASTKA: ; Pop the ARG STACK and check for overflow ; ;************************************************************ ; mov a,#FPSIZ ;NUMBER TO pop ajmp SETREG_1 ; SETREG: clr a ;DON"T pop ANYTHING SETREG_1: mov r0,ASTKA mov r2,#ASTKAH mov P2,r2 add a,r0 jc E4ZZ mov ASTKA,a movx a,@r0 A_D: ret SQ_ERR: ljmp E3XX ;LINK TO BAD ARG E4ZZ: ljmp E4YY ; ; ;************************************************************ ; ; EBIAS - Bias a number for E to the X calculations ; ;************************************************************ ; EBIAS: acall PUSH_ONE lcall RV cjne r3,#0x00,SQ_ERR ;ERROR IF r3 <> 0 acall Cx_T2 ;TEMP 2 GETS FRACTIONS lcall INC_ASTKA acall POP_T1 acall PUSH_ONE ; AELP: mov a,MT2 jnz AEL1 ; mov a,MT1 jz A_D mov dptr,#FPT2-1 movx @dptr,a ;MAKE THE FRACTIONS NEGATIVE ; RECIP: acall PUSH_ONE acall SWAP_ASTKA ajmp ADIV ; AEL1: dec MT2 acall PUSH_T1 lcall AMUL ajmp AELP ; ;$EJECT ;************************************************************ ; ; SQUARE ROOT ; ;************************************************************ ; ASQR: acall AABS ;GET THE SIGN jnz SQ_ERR ;ERROR IF NEGATIVE acall Cx_T2 ;COPY VARIABLE TO T2 acall POP_T1 ;SAVE IT IN T1 mov r0,#FPT1&0xff movx a,@r0 ;GET EXPONENT jz Q956 ;EXIT IF ZERO add a,#128 ;BIAS THE EXPONENT jnc SQR1 ;SEE IF < 0x80 rr a anl a,#127 ajmp SQR2 ; SQR1: cpl a ;FLIP BITS inc a rr a anl a,#127 ;STRIP MSB cpl a inc a ; SQR2: add a,#128 ;BIAS EXPONENT movx @r0,a ;SAVE IT ; ; NEWGUESS = ( X/OLDGUESS + OLDGUESS) / 2 ; SQR4: acall P_T2 ;TOS = X acall PUSH_T1 ;PUT NUMBER ON STACK acall ADIV ;TOS = X/GUESS acall PUSH_T1 ;PUT ON AGAIN acall AADD ;TOS = X/GUESS + GUESS lcall DBTWO ;TOS = ( X/GUESS + GUESS ) / 2 acall TEMP_COMP ;SEE IF DONE jnb F0,SQR4 ; Q956: ajmp PUSH_T1 ;PUT THE ANSWER ON THE STACK ; ;$EJECT ;************************************************************* ; ; NATURAL LOG ; ;************************************************************* ; ALN: acall AABS ;MAKE SURE THAT NUM IS POSITIVE jnz SQ_ERR ;ERROR IF NOT mov MT2,a ;CLEAR FOR LOOP inc r0 ;POINT AT EXPONENT movx a,@r0 ;READ THE EXPONENT jz SQ_ERR ;ERROR IF EXPONENT IS ZERO cjne a,#0x81,Q113 ;SEE IF NUM >= 1 Q113: mov UBIT,c ;SAVE CARRY STATUS jc ALNL ;TAKE RECIP IF >= 1 acall RECIP ; ; Loop to reduce ; ALNL: acall CSTAKA ;COPY THE STACK FOR COMPARE acall PUSH_ONE ;COMPARE NUM TO ONE lcall CMPLK jnc ALNO ;EXIT IF DONE lcall SETREG ;GET THE EXPONENT add a,#0x85 ;SEE HOW BIG IT IS jnc ALN11 ;BUMP BY EXP(11) IF TOO SMALL acall PLNEXP ;PUT EXP(1) ON STACK mov a,#1 ;BUMP COUNT ; ALNE: add a,MT2 jc SQ_ERR2 mov MT2,a lcall AMUL ;BIAS THE NUMBER ajmp ALNL ; ALN11: mov dptr,#EXP11 ;PUT EXP(11) ON STACK acall PUSHC mov a,#11 ajmp ALNE ; SQ_ERR2:ljmp E3XX ;LINK TO BAD ARG ;$EJECT ALNO: acall Cx_T2 ;PUT NUM IN TEMP 2 acall PUSH_ONE ;TOS = 1 acall ASUB ;TOS = X - 1 acall P_T2 ;TOS = X acall PUSH_ONE ;TOS = 1 acall AADD ;TOS = X + 1 acall ADIV ;TOS = (X-1)/(X+1) mov dptr,#LNTAB ;LOG TABLE lcall POLYC inc dptr ;POINT AT LN(10) acall PUSHC lcall AMUL mov a,MT2 ;GET THE COUNT acall TWO_R2 ;PUT IT ON THE STACK acall ASUB ;INT - POLY lcall STRIP jnb UBIT,QQ98 ; LN_D: ret QQ98: ajmp AABS ; ;************************************************************* ; TEMP_COMP: ; Compare FPTEMP1 to TOS, FPTEMP1 gets TOS ; ;************************************************************* ; acall PUSH_T1 ;SAVE THE TEMP acall SWAP_ASTKA ;TRADE WITH THE NEXT NUMBER acall CSTAKA ;COPY THE STACK acall POP_T1 ;SAVE THE NEW NUMBER ljmp FLOATING_COMP ;DO THE COMPARE ; ;$EJECT AETOX: acall PLNEXP ;EXP(1) ON TOS acall SWAP_ASTKA ;X ON TOS ; AEXP: ;EXPONENTIATION ; acall EBIAS ;T1=BASE,T2=FRACTIONS,TOS=INT MULTIPLIED mov dptr,#FPT2 ;POINT AT FRACTIONS movx a,@dptr ;READ THE EXP OF THE FRACTIONS jz LN_D ;EXIT IF ZERO acall P_T2 ;TOS = FRACTIONS acall PUSH_T1 ;TOS = BASE lcall SETREG ;SEE IF BASE IS ZERO jz Q115 acall ALN ;TOS = LN(BASE) Q115: lcall AMUL ;TOS = FRACTIONS * LN(BASE) acall PLNEXP ;TOS = EXP(1) acall SWAP_ASTKA ;TOS = FRACTIONS * LN(BASE) acall EBIAS ;T2 = FRACTIONS, TOS = INT MULTIPLIED mov MT2,#0x00 ;NOW CALCULATE E**X acall PUSH_ONE acall CSTAKA acall POP_T1 ;T1 = 1 ; AEXL: acall P_T2 ;TOS = FRACTIONS lcall AMUL ;TOS = FRACTIONS * ACCUMLATION inc MT2 ;DO THE DEMONIATOR mov a,MT2 acall TWO_R2 acall ADIV acall CSTAKA ;SAVE THE ITERATION acall PUSH_T1 ;NOW ACCUMLATE acall AADD ;add ACCUMLATION acall TEMP_COMP jnb F0,AEXL ;LOOP UNTIL DONE ; lcall INC_ASTKA acall PUSH_T1 lcall AMUL ;LAST INT MULTIPLIED ; MU1: ljmp AMUL ;FIRST INT MULTIPLIED ; ;$EJECT ;*************************************************************** ; ; integer operator - INT ; ;*************************************************************** ; AINT: lcall SETREG ;SET UP THE REGISTERS, CLEAR CARRY subb a,#129 ;SUBTRACT EXPONENT BIAS jnc AI1 ;JUMP IF ACC > 0x81 ; ; Force the number to be a zero ; lcall INC_ASTKA ;BUMP THE STACK ; P_Z: mov dptr,#ZRO ;PUT ZERO ON THE STACK ajmp PUSHC ; AI1: subb a,#7 jnc AI3 cpl a inc a mov r3,a AI2_1: dec r0 ;POINT AT SIGN ; AI2: dec r0 ;NOW AT LSB"S movx a,@r0 ;READ BYTE anl a,#0xf0 ;STRIP NIBBLE movx @r0,a ;WRITE BYTE djnz r3,Q116 ret Q116: clr a movx @r0,a ;CLEAR THE LOCATION djnz r3,AI2 ; AI3: ret ;EXIT ; ;$EJECT ;*************************************************************** ; AABS: ; Absolute value - Make sign of number positive ; return sign in ACC ; ;*************************************************************** ; acall ANEG ;CHECK TO SEE IF + OR - jnz ALPAR ;EXIT IF NON ZERO, BECAUSE THE NUM IS movx @r0,a ;MAKE a POSITIVE SIGN ret ; ;*************************************************************** ; ASGN: ; Returns the sign of the number 1 = +, -1 = - ; ;*************************************************************** ; lcall INC_ASTKA ;pop STACK, GET EXPONENT jz P_Z ;EXIT IF ZERO dec r0 ;BUMP TO SIGN movx a,@r0 ;GET THE SIGN mov r7,a ;SAVE THE SIGN acall PUSH_ONE ;PUT a ONE ON THE STACK mov a,r7 ;GET THE SIGN jz ALPAR ;EXIT IF ZERO ; ; Fall thru to ANEG ; ;*************************************************************** ; ANEG: ; Flip the sign of the number on the tos ; ;*************************************************************** ; lcall SETREG dec r0 ;POINT AT THE SIGN OF THE NUMBER jz ALPAR ;EXIT IF ZERO movx a,@r0 xrl a,#0x01 ;FLIP THE SIGN movx @r0,a xrl a,#0x01 ;RESTORE THE SIGN ; ALPAR: ret ; ;$EJECT ;*************************************************************** ; ACBYTE: ; Read the ROM ; ;*************************************************************** ; lcall IFIX ;GET EXPRESSION lcall X31DP ;PUT r3:r1 INTO THE DP clr a movc a,@a+dptr ajmp TWO_R2 ; ;*************************************************************** ; ADBYTE: ; Read internal memory ; ;*************************************************************** ; lcall IFIX ;GET THE EXPRESSION lcall R3CK ;MAKE SURE r3 = 0 mov a,@r1 ajmp TWO_R2 ; ;*************************************************************** ; AXBYTE: ; Read external memory ; ;*************************************************************** ; lcall IFIX ;GET THE EXPRESSION AXBYTE_2: mov P2,r3 movx a,@r1 ajmp TWO_R2 ; ;$EJECT ;*************************************************************** ; ; The relational operators - EQUAL (=) ; GREATER THAN (>) ; LESS THAN (<) ; GREATER THAN OR EQUAL (>=) ; LESS THAN OR EQUAL (<=) ; NOT EQUAL (<>) ; ;*************************************************************** ; AGT: lcall CMPLK orl c,F0 ;SEE IF EITHER IS a ONE AGT_4: jc P_Z ; FSTK: mov dptr,#FS ajmp PUSHC ; FS: db 0x85 db 0x00 db 0x00 db 0x50 db 0x53 db 0x65 ; ALT: lcall CMPLK ALT_2: cpl c ajmp AGT_4 ; AEQ: lcall CMPLK AEQ_2: mov c,F0 ajmp ALT_2 ; ANE: lcall CMPLK cpl F0 ajmp AEQ_2 ; AGE: lcall CMPLK ajmp AGT_4 ; ALE: lcall CMPLK orl c,F0 ajmp ALT_2 ; ;$EJECT ;*************************************************************** ; ARND: ; Generate a random number ; ;*************************************************************** ; mov dptr,#RCELL ;GET THE BINARY SEED lcall L31DPI mov a,r1 clr c rrc a mov r0,a mov a,#6 rrc a add a,r1 xch a,r0 addc a,r3 mov r2,a dec DPL ;SAVE THE NEW SEED acall S20DP acall TWO_EY acall FSTK ; ADIV: lcall FLOATING_DIV ljmp FPTST ; ;$EJECT ;*************************************************************** ; SONERR: ; ON ERROR Statement ; ;*************************************************************** ; lcall INTERR ;GET THE LINE NUMBER setb ON_ERR mov dptr,#ERRNUM ;POINT AT THR ERROR LOCATION ajmp S20DP ; ; ;************************************************************** ; SONEXT: ; ON EXT1 Statement ; ;************************************************************** ; lcall INTERR setb INTBIT orl IE,#0x84 ;ENABLE INTERRUPTS mov dptr,#INTLOC ; S20DP: mov a,r2 ;SAVE r2:r0 @dptr movx @dptr,a inc dptr mov a,r0 movx @dptr,a ret ; ;$EJECT ;*************************************************************** ; ; CASTAK - Copy and push another top of arg stack ; ;*************************************************************** ; CSTAKA2:acall CSTAKA ;COPY STACK TWICE ; CSTAKA: lcall SETREG ;SET UP r2:r0 ajmp PUSH_T1_4 ; PLNEXP: mov dptr,#EXP1 ; ;*************************************************************** ; ; PUSHC - Push constant on to the arg stack ; ;*************************************************************** ; PUSHC: lcall DEC_ASTKA mov P2,r3 mov r3,#FPSIZ ;LOOP COUNTER ; PCL: clr a ;SET UP a movc a,@a+dptr ;LOAD IT movx @r1,a ;SAVE IT inc dptr ;BUMP POINTERS dec r1 djnz r3,PCL ;LOOP ; setb ARGF ret ;EXIT ; PUSH_ONE:; ; mov dptr,#FPONE ajmp PUSHC ; ;$EJECT ; POP_T1: ; mov r3,#FPT1>>8 mov r1,#FPT1&0xff ljmp POPAS ; PUSH_T1: ; mov r0,#FPT1&0xff Q9: mov r2,#FPT1>>8 PUSH_T1_4: ljmp PUSHAS ; P_T2: mov r0,#FPT2&0xff ajmp Q9 ;JUMP TO PUSHAS ; ;**************************************************************** ; SWAP_ASTKA: ; swap TOS<>TOS-1 ; ;**************************************************************** ; lcall SETREG ;SET UP r2:r0 AND P2 mov a,#FPSIZ ;PUT TOS+1 IN r1 mov r2,a add a,r0 mov r1,a ; S_L: movx a,@r0 mov r3,a movx a,@r1 movx @r0,a mov a,r3 movx @r1,a dec r1 dec r0 djnz r2,S_L ret ; ;$EJECT ; Cx_T2: lcall SETREG ;SET UP r2:r0 mov r3,#FPT2>>8 mov r1,#FPT2&0xff ;TEMP VALUE ; ; Fall thru ; ;*************************************************************** ; ; VARCOP - Copy a variable from r2:r0 to r3:r1 ; ;*************************************************************** ; VARCOP: mov r4,#FPSIZ ;LOAD THE LOOP COUNTER ; V_C: mov P2,r2 ;SET UP THE PORTS movx a,@r0 ;READ THE VALUE mov P2,r3 ;PORT TIME AGAIN movx @r1,a ;SAVE IT acall DEC3210 ;BUMP POINTERS djnz r4,V_C ;LOOP ret ;EXIT ; PIPI: mov dptr,#PIE ajmp PUSHC ; ;$EJECT ;*************************************************************** ; ; The logical operators anl, orl, xrl, NOT ; ;*************************************************************** ; AANL: acall TWOL ;GET THE EXPRESSIONS mov a,r3 ;DO THE AND anl a,r7 mov r2,a mov a,r1 anl a,r6 ajmp TWO_EX ; AORL: acall TWOL ;SAME THING FOR OR mov a,r3 orl a,r7 mov r2,a mov a,r1 orl a,r6 ajmp TWO_EX ; ANOT: acall FSTK ;PUT 0FFFFH ON THE STACK ; Axrl: acall TWOL mov a,r3 xrl a,r7 mov r2,a mov a,r1 xrl a,r6 ajmp TWO_EX ; TWOL: lcall IFIX mov r7,R3B0 mov r6,R1B0 ljmp IFIX ; ;$EJECT ;************************************************************* ; AGET: ; READ THE BREAK BYTE AND PUT IT ON THE ARG STACK ; ;************************************************************* ; mov dptr,#GTB ;GET THE BREAK BYTE movx a,@dptr jbc GTRD,TWO_R2 clr a ; TWO_R2: mov r2,#0x00 ;ACC GOES TO STACK ; ; TWO_EX: mov r0,a ;r2:ACC GOES TO STACK ; ; TWO_EY: setb ARGF ;r2:r0 GETS PUT ON THE STACK ljmp PUSHR2R0 ;DO IT ; ;$EJECT ;************************************************************* ; ; Put directs onto the stack ; ;************************************************************** ; A_IE: mov a,IE ;IE ajmp TWO_R2 ; A_IP: mov a,IP ;IP ajmp TWO_R2 ; ATIM0: mov r2,TH0 ;TIMER 0 mov r0,TL0 ajmp TWO_EY ; ATIM1: mov r2,TH1 ;TIMER 1 mov r0,TL1 ajmp TWO_EY ; ATIM2: mov r2, TH2 mov r0, TL2 ajmp TWO_EY ;TIMER 2 ; AT2CON: mov a, T2CON ajmp TWO_R2 ; ATCON: mov a,TCON ;TCON ajmp TWO_R2 ; ATMOD: mov a,TMOD ;TMOD ajmp TWO_R2 ; ARCAP2: mov r2, RCAP2H mov r0, RCAP2L ajmp TWO_EY ; EE_RD: lcall IFIX push r4_0 push r5_0 push r6_0 push r7_0 mov r6, r3 mov r7, r1 mov r0, #r6_3 mov r2, #'R' mov r3, #1 acall b_do_ut pop r7_0 pop r6_0 pop r5_0 pop r4_0 mov r2, #0 mov r0, r6_3 ajmp TWO_EY AAB: lcall IFIX mov a, r1 anl a, #3 mov r0, a acall b_do_adc ; no utility vector in basic mov r2, r1 ajmp TWO_EY b_do_adc: mov r2, #'A' b_do_ut: mov dph, UV_H mov dpl, UV_L clr a jmp @a+dptr AP3B: lcall IFIX mov a, r1 jb acc.2, P3_4 jb acc.1, P3_2 jb acc.0, P3_1 mov c, P3.0 ajmp TTR2 P3_1: mov c, P3.1 ajmp TTR2 P3_2: jb acc.0, P3_3 mov c, P3.2 ajmp TTR2 P3_3: mov c, P3.3 ajmp TTR2 P3_4: jb acc.1, P3_6 jb acc.0, P3_5 mov c, P3.4 ajmp TTR2 P3_5: mov c, P3.5 ajmp TTR2 P3_6: jb acc.0, P3_7 mov c, P3.6 ajmp TTR2 P3_7: mov c, P3.7 ajmp TTR2 TTR2: clr a rlc a ajmp TWO_R2 AP1B: lcall IFIX mov a, r1 jb acc.2, P1_4 jb acc.1, P1_2 jb acc.0, P1_1 mov c, P1.0 ajmp TTR2 P1_1: mov c, P1.1 ajmp TTR2 P1_2: jb acc.0, P1_3 mov c, P1.2 ajmp TTR2 P1_3: mov c, P1.3 ajmp TTR2 P1_4: jb acc.1, P1_6 jb acc.0, P1_5 mov c, P1.4 ajmp TTR2 P1_5: mov c, P1.5 ajmp TTR2 P1_6: jb acc.0, P1_7 mov c, P1.6 ajmp TTR2 P1_7: mov c, P1.7 ajmp TTR2 ; AP1: mov a,P1 ;GET P1 ajmp TWO_R2 ;PUT IT ON THE STACK AP3: mov a,P3 ;GET P3 ajmp TWO_R2 ;PUT IT ON THE STACK ; APCON: mov a, PCON ajmp TWO_R2 ;PUT PCON ON THE STACK ; ;$EJECT ;*************************************************************** ; ;THIS IS THE LINE EDITOR ; ;TAKE THE PROCESSED LINE IN IBUF AND INSERT IT INTO THE ;BASIC TEXT FILE. ; ;*************************************************************** ; Q876: ljmp NOGO ;CAN"T EDIT a ROM ; LINE: mov a,BOFAH cjne a,#PSTART>>8,Q876 lcall XXG4 ;GET END ADDRESS FOR EDITING mov r4,DPL mov r5,DPH mov r3,TEMP5 ;GET HIGH ORDER IBLN mov r1,TEMP4 ;LOW ORDER IBLN ; lcall GETLIN ;FIND THE LINE jnz INSR ;INSERT IF NOT ZERO, ELSE APPEND ; ;APPEND THE LINE AT THE END ; mov a,TEMP3 ;PUT IBCNT IN THE ACC cjne a,#4,Q117 ;SEE IF NO ENTRY ret ;ret IF NO ENTRY ; Q117: acall FULL ;SEE IF ENOUGH SPACE LEFT mov r2,R5B0 ;PUT END ADDRESS a INTO TRANSFER mov r0,R4B0 ;REGISTERS acall Imov ;DO THE BLOCK movE ; UE: mov a,#EOF ;SAVE EOF CHARACTER ajmp TBR ; ;INSERT a LINE INTO THE FILE ; INSR: mov r7,a ;SAVE IT IN r7 acall TEMPD ;SAVE INSERATION ADDRESS mov a,TEMP3 ;PUT THE COUNT LENGTH IN THE ACC jc LTX ;JUMP IF NEW LINE # NOT = OLD LINE # cjne a,#0x04,Q118 ;SEE IF NULL clr a ; Q118: subb a,r7 ;SUBTRACT LINE COUNT FROM ACC jz LIN1 ;LINE LENGTHS EQUAL jc GTX ;SMALLER LINE ; ;$EJECT ; ;EXPAND FOR a NEW LINE OR a LARGER LINE ; LTX: mov r7,a ;SAVE a IN r7 mov a,TEMP3 ;GET THE COUNT IN THE ACC cjne a,#0x04,Q119 ;DO NO INSERTATION IF NULL LINE ret ;EXIT IF IT IS ; Q119: mov a,r7 ;GET THE COUNT BACK - DELTA IN a acall FULL ;SEE IF ENOUGH MEMORY NEW EOFA IN r3:r1 acall DTEMP ;GET INSERATION ADDRESS acall Nmov ;r7:r6 GETS (EOFA)-dptr lcall X3120 mov r1,R4B0 ;EOFA LOW mov r3,R5B0 ;EOFA HIGH inc r6 ;INCREMENT BYTE COUNT cjne r6,#00,Q120 ;NEED TO BUMP HIGH BYTE? inc r7 ; Q120: acall Rmov ;GO DO THE INSERTION ajmp LIN1 ;INSERT THE CURRENT LINE ; GTX: cpl a ;FLIP ACC inc a ;TWOS COMPLEMENT lcall ADdptr ;DO THE ADDITION acall Nmov ;r7:r6 GETS (EOFA)-dptr mov r1,DPL ;SET UP THE REGISTERS mov r3,DPH mov r2,TEMP5 ;PUT INSERTATION ADDRESS IN THE RIGHT REG mov r0,TEMP4 jz Q121 ;IF ACC WAS ZERO FROM Nmov, JUMP acall Lmov ;IF NO ZERO DO a Lmov ; Q121: acall UE ;SAVE NEW END ADDRESS ; LIN1: mov r2,TEMP5 ;GET THE INSERTATION ADDRESS mov r0,TEMP4 mov a,TEMP3 ;PUT THE COUNT LENGTH IN ACC cjne a,#0x04,Imov ;SEE IF NULL ret ;EXIT IF NULL ;$EJECT ;*************************************************************** ; ;INSERT a LINE AT ADDRESS r2:r0 ; ;*************************************************************** ; Imov: clr a ;TO SET UP mov r1,#IBCNT&0xff ;INITIALIZE THE REGISTERS mov r3,#IBCNT>>8 mov r6,TEMP3 ;PUT THE BYTE COUNT IN r6 FOR Lmov mov r7,a ;PUT a 0 IN r7 FOR Lmov ; ;*************************************************************** ; ;COPY a BLOCK FROM THE BEGINNING ; ;r2:r0 IS THE DESTINATION ADDRESS ;r3:r1 IS THE SOURCE ADDRESS ;r7:r6 IS THE COUNT REGISTER ; ;*************************************************************** ; Lmov: acall TBYTE ;TRANSFER THE BYTE acall INC3210 ;BUMP THE POINTER acall DEC76 ;BUMP r7:r6 jnz Lmov ;LOOP ret ;GO BACK TO CALLING ROUTINE ; INC3210:inc r0 cjne r0,#0x00,Q122 inc r2 ; Q122: inc r1 cjne r1,#0x00,Q123 inc r3 Q123: ret ; ;$EJECT ;*************************************************************** ; ;COPY a BLOCK STARTING AT THE END ; ;r2:r0 IS THE DESTINATION ADDRESS ;r3:r1 IS THE SOURCE ADDRESS ;r6:r7 IS THE COUNT REGISTER ; ;*************************************************************** ; Rmov: acall TBYTE ;TRANSFER THE BYTE acall DEC3210 ;dec THE LOCATIONS acall DEC76 ;BUMP THE COUNTER jnz Rmov ;LOOP ; DEC_R: nop ;CREATE EQUAL TIMING ret ;EXIT ; DEC3210:dec r0 ;BUMP THE POINTER cjne r0,#0xff,Q124 ;SEE IF OVERFLOWED DEC3210_4: dec r2 ;BUMP THE HIGH BYTE Q124: dec r1 ;BUMP THE POINTER cjne r1,#0xff,DEC_R ;SEE IF OVERFLOWED dec r3 ;CHANGE THE HIGH BYTE ret ;EXIT ; ;*************************************************************** ; ;TBYTE - TRANSFER a BYTE ; ;*************************************************************** ; TBYTE: mov P2,r3 ;OUTPUT SOURCE REGISTER TO PORT movx a,@r1 ;PUT BYTE IN ACC ; TBR: mov P2,r2 ;OUTPUT DESTINATION TO PORT movx @r0,a ;SAVE THE BYTE ret ;EXIT ; ;$EJECT ;*************************************************************** ; ;Nmov - r7:r6 = END ADDRESS - dptr ; ;ACC GETS CLOBBERED ; ;*************************************************************** ; Nmov: mov a,r4 ;THE LOW BYTE OF EOFA clr c ;CLEAR THE CARRY FOR subb subb a,DPL ;SUBTRACT DATA POINTER LOW mov r6,a ;PUT RESULT IN r6 mov a,r5 ;HIGH BYTE OF EOFA subb a,DPH ;SUBTRACT DATA POINTER HIGH mov r7,a ;PUT RESULT IN r7 orl a,r6 ;SEE IF ZERO Q873: ret ;EXIT ; ;*************************************************************** ; ;CHECK FOR a FILE OVERFLOW ;LEAVES THE NEW END ADDRESS IN r3:r1 ;a HAS THE INCREASE IN SIZE ; ;*************************************************************** ; FULL: add a,r4 ;add a TO END ADDRESS mov r1,a ;SAVE IT clr a addc a,r5 ;add THE CARRY mov r3,a mov dptr,#VARTOP ;POINT AT VARTOP ; FUL1: lcall DCMPX ;COMPARE THE TWO jc Q873 ;OUT OF ROOM ; TB: mov dptr,#E5X ;OUT OF MEMORY ljmp FPTS ; ;$EJECT ;*************************************************************** ; ; PP - Preprocesses the line in IBUF back into IBUF ; sets F0 if no line number ; leaves the correct length of processed line in IBCNT ; puts the line number in IBLN ; wastes the text address TXAL and TXAH ; ;*************************************************************** ; PP: acall T_BUF ;TXA GETS IBUF lcall INTGER ;SEE IF a NUMBER PRESENT acall TEMPD ;SAVE THE INTEGER IN TEMP5:TEMP4 mov F0,c ;SAVE INTEGER IF PRESENT mov dptr,#IBLN ;SAVE THE LINE NUMBER, EVEN IF NONE acall S20DP mov r0,TXAL ;TEXT POINTER mov r1,#IBUF&0xff ;STORE POINTER ; ; Now process the line back into IBUF ; PPL: clr ARGF ;FIRST PASS DESIGNATOR mov dptr,#TOKTAB ;POINT DPTR AT LOOK UP TABLE ; PPL1: mov R5B0,r0 ;SAVE THE READ POINTER clr a ;ZERO a FOR LOOKUP movc a,@a+dptr ;GET THE TOKEN mov r7,a ;SAVE TOKEN IN CASE OF MATCH ; PPL2: movx a,@r0 ;GET THE USER CHARACTER mov r3,a ;SAVE FOR REM cjne a,#'a',Q125 Q125: jc PPX ;CONVERT LOWER TO UPPER CASE cjne a,#('z'+1),Q126 Q126: jnc PPX clr ACC.5 ; PPX: mov r2,a movx @r0,a ;SAVE UPPER CASE inc dptr ;BUMP THE LOOKUP POINTER clr a movc a,@a+dptr cjne a,R2B0,PPL3 ;LEAVE IF NOT THE SAME inc r0 ;BUMP THE USER POINTER ajmp PPL2 ;CONTINUE TO LOOP ; PPL3: jb ACC.7,PPL6 ;JUMP IF FOUND MATCH jz PPL6 ;USER MATCH ; ; ; Scan to the next TOKTAB entry ; PPL4: inc dptr ;ADVANCE THE POINTER clr a ;ZERO a FOR LOOKUP movc a,@a+dptr ;LOAD a WITH TABLE jb ACC.7,Q127 ;KEEP SCANNING IF NOT a RESERVED WORD jnz PPL4 inc dptr ; ; See if at the end of TOKTAB ; Q127: mov r0,R5B0 ;RESTORE THE POINTER cjne a,#0xff,PPL1 ;SEE IF END OF TABLE ; ; Character not in TOKTAB, so see what it is ; cjne r2,#' ',PPLX ;SEE IF a SPACE inc r0 ;BUMP USER POINTER ajmp PPL ;TRY AGAIN ; PPLX:; jnb XBIT,PPLY ;EXTERNAL TRAP ; jb ARGF,PPLY ; setb ARGF ;SAYS THAT THE USER HAS TABLE ; lcall 0x2078 ;SET UP POINTER ; ljmp PPL1 ; PPLY: acall PPL7 ;SAVE CHARACTER, EXIT IF a CR cjne a,#'"',PPL ;SEE IF QUOTED STRING, START AGAIN IF NOT ; ; Just copy a quoted string ; Q10: acall PPL7 ;SAVE THE CHARACTER, TEST FOR CR cjne a,#'"',Q10 ;IS THERE AN ENDQUOTE, IF NOT LOOP ajmp PPL ;DO IT AGAIN IF ENDQUOTE ; PPL6: mov a,r7 ;GET THE TOKEN acall PPL9_1 ;SAVE THE TOKEN cjne a,#T_REM,PPL ;SEE IF a REM TOKEN mov a,r3 acall PPL7_1 ;WASTE THE REM STATEMENT Q12: acall PPL7 ;LOOP UNTIL a CR ajmp Q12 ; PPL7: movx a,@r0 ;GET THE CHARACTER PPL7_1: cjne a,#SCR,PPL9 ;FINISH IF a CR pop R0B0 ;WASTE THE CALLING STACK pop R0B0 movx @r1,a ;SAVE CR IN MEMORY inc r1 ;SAVE a TERMINATOR mov a,#EOF movx @r1,a mov a,r1 ;SUBTRACT FOR LENGTH subb a,#4 mov TEMP3,a ;SAVE LENGTH mov r1,#IBCNT&0xff ;POINT AT BUFFER COUNT mov p2,#IBCNT>>8 ; PPL9: inc r0 PPL9_1: movx @r1,a ;SAVE THE CHARACTER inc r1 ;BUMP THE POINTERS ret ;EXIT TO CALLING ROUTINE ; ; ;*************************************************************** ; ;DEC76 - DECREMENT THE REGISTER PAIR r7:r6 ; ;ACC = ZERO IF r7:r6 = ZERO ; ELSE ACC DOES NOT ; ;*************************************************************** ; DEC76: dec r6 ;BUMP r6 cjne r6,#0xff,Q128 ;SEE IF RAPPED AROUND dec r7 Q128: mov a,r7 ;SEE IF ZERO orl a,r6 ret ;EXIT ; ;*************************************************************** ; ; MTOP - Get or Put the top of assigned memory ; ;*************************************************************** ; PMTOP: mov dptr,#MEMTOP PMTOP_3: lcall L20DPI ajmp TWO_EY ;PUT r2:r0 ON THE STACK ; ;$EJECT ;************************************************************* ; ; AXTAL - Crystal value calculations ; ;************************************************************* ; AXTAL0: mov dptr,#XTALV ;CRYSTAL VALUE acall PUSHC ; AXTAL1: acall CSTAKA2 ;COPY CRYSTAL VALUE TWICE acall CSTAKA mov dptr,#PTIME ;PROM TIMER acall AXTAL2 mov dptr,#PROGS acall S31L mov dptr,#IPTIME ;IPROM TIMER acall AXTAL2 mov dptr,#IPROGS acall S31L mov dptr,#TTIME ;CLOCK CALCULATION lcall AXTAL3 mov a,r1 cpl a inc a mov SAVE_T,a mov r3,#CXTAL>>8 mov r1,#CXTAL&0xff ljmp POPAS ; AXTAL2: lcall AXTAL3 ; CBIAS: ;Bias the crystal calculations ; mov a,r1 ;GET THE LOW COUNT cpl a ;FLIP IT FOR TIMER LOAD add a,#15 ;BIAS FOR lcall AND LOAD TIMES mov r1,a ;RESTORE IT mov a,r3 ;GET THE HIGH COUNT cpl a ;FLIP IT addc a,#0x00 ;add THE CARRY mov r3,a ;RESTORE IT ret ; ;$EJECT ;$INCLUDE(:F2:BAS52.PWM) ;BEGINNING ;************************************************************** ; STONE: ; Toggle the I/O port ; ;************************************************************** ; lcall THREE ;GET THE NUMBERS acall CBIAS ;BIAS r3:r1 FOR COUNT LOOP ; STONE1: clr T_BIT ;TOGGLE THE BIT clr TR1 ;STOP THE TIMER mov TH1,r3 ;LOAD THE TIMER mov TL1,r1 clr TF1 ;CLEAR THE OVERFLOW FLAG setb TR1 ;TURN IT ON acall DEC76 jnb TF1,. ;WAIT acall ALPAR setb T_BIT ;BACK TO a ONE lcall TIMER_LOAD_2 ;LOAD THE HIGH VALUE jnb TF1,. ;WAIT jnz STONE1 ;LOOP ret ; ;END ;$INCLUDE(:F2:BAS52.PWM) ;$EJECT ;LNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLN ; LNTAB: ; Natural log lookup table ; ;LNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLN ; db 0x80 db 0x00 db 0x71 db 0x37 db 0x13 db 0x19 ; db 0x7f db 0x00 db 0x76 db 0x64 db 0x37 db 0x94 ; db 0x80 db 0x00 db 0x07 db 0x22 db 0x75 db 0x17 ; db 0x80 db 0x00 db 0x52 db 0x35 db 0x93 db 0x28 ; db 0x80 db 0x00 db 0x71 db 0x91 db 0x85 db 0x86 ; db 0xff ; db 0x81 db 0x00 db 0x51 db 0x58 db 0x02 db 0x23 ; ;$EJECT ;SINSINSINSINSINSINSINSINSINSINSINSINSINSINSINSINSIN ; SINTAB: ; Sin lookup table ; ;SINSINSINSINSINSINSINSINSINSINSINSINSINSINSINSINSIN ; db 128-9 db 0x00 db 0x44 db 0x90 db 0x05 db 0x16 ; db 128-7 db 0x01 db 0x08 db 0x21 db 0x05 db 0x25 ; db 128-5 db 0x00 db 0x19 db 0x73 db 0x55 db 0x27 ; ;$EJECT ; db 128-3 db 0x01 db 0x70 db 0x12 db 0x84 db 0x19 ; db 128-2 db 0x00 db 0x33 db 0x33 db 0x33 db 0x83 ; db 128 db 0x01 db 0x67 db 0x66 db 0x66 db 0x16 ; FPONE: db 128+1 db 0x00 db 0x00 db 0x00 db 0x00 db 0x10 ; db 0xff ;END OF TABLE ; ;$EJECT ; SBAUD: lcall AXTAL ;PUT CRYSTAL ON THE STACK lcall EXPRB ;PUT THE NUMBER AFTER BAUD ON STACK mov a,#12 acall TWO_R2 ;TOS = 12 lcall AMUL ;TOS = 12*BAUD acall ADIV ;TOS = XTAL/(12*BAUD) lcall IFIX acall CBIAS mov dptr,#SPV ; S31L: ljmp S31DP ; AFREE: acall PMTOP ;PUT MTOP ON STACK lcall XXG4 ;GET END ADDRESS mov r0,DPL mov r2,DPH acall TWO_EY ; ASUB: lcall FLOATING_SUB ;DO FP SUB ljmp FPTST ; ALEN: ;lcall CCAL ;CALCULATE THE LEN OF THE SELECTED PROGRAM ;mov r2,R7B0 ;SAVE THE HIGH BYTE ;mov a,r6 ;SAVE THE LOW BYTE mov a, #0 mov r2, a ajmp TWO_EX ;PUT IT ON THE STACK ; ATIME: mov c,EA ;SAVE INTERRUTS clr EA push MILLIV ;SAVE MILLI VALUE mov r2,TVH ;GET THE TIMER mov a,TVL mov EA,c ;SAVE INTERRUPTS acall TWO_EX ;PUT TIMER ON THE STACK pop ACC ;GET MILLI acall TWO_R2 ;PUT MILLI ON STACK mov a,#200 acall TWO_R2 ;DIVIDE MILLI BY 200 acall ADIV ; AADD: lcall FLOATING_ADD ;DO FP ADDITION ljmp FPTST ;CHECK FOR ERRORS ; ;$EJECT ;************************************************************** ; ; Here are some error messages that were moved ; ;************************************************************** ; ; E1X: db "BAD SYNTAX" E2X: db 128+10 db "DIVIDE BY ZERO" ; E6X: db "ARRAY SIZE" ; ;$EJECT ;************************************************************** ; T_BUF: ; TXA gets IBUF ; ;************************************************************** ; mov TXAH,#IBUF>>8 mov TXAL,#IBUF&0xff ret ; ; ;*************************************************************** ; CXFER: ; Transfer a program from rom to ram ; ;*************************************************************** ; ; lcall CCAL ;GET EVERYTHING SET UP ; mov r2,#PSTART>>8 ; mov r0,#PSTART&0xff ; acall Lmov ;DO THE TRANSFER mov r7_3, #1 lcall x_load_eeprom lcall RCLEAR ;CLEAR THE MEMORY ; ; Fall thru to CRAM ; ;*************************************************************** ; CRAM: ; The command action routine - RAM - Run out of ram ; ;*************************************************************** ; clr CONB ;CAN"T CONTINUE IF MODE CHANGE mov BOFAH,#PSTART>>8 mov BOFAL,#PSTART&0xff ; ; Fall thru to Command Processor ; ;$EJECT ;*************************************************************** ; CMND1: ; The entry point for the command processor ; ;*************************************************************** ; lcall SPRINT4 ;WASTE AT AND HEX clr XBIT ;TO RESET IF NEEDED ; clr a ; mov dptr,#0x2002 ;CHECK FOR EXTERNAL TRAP PACKAGE ; movc a,@a+dptr ; cjne a,#0x5A,Q129 ; lcall 0x2048 ;IF PRESENT JUMP TO LOCATION 200BH Q129: mov dptr,#RDYS ;PRINT THE READY MESSAGE lcall CRP ;DO a CR, THEN, PRINT FROM THE ROM ; CMNDR: setb DIRF ;SET THE DIRECT INPUT BIT mov SP,SPSAV ;LOAD THE STACK lcall CL7 ;DO a CRLF ; CMNX: clr GTRD ;CLEAR BREAK ;mov dptr,#0x5E ;DO RUN TRAP ;movx a,@dptr ;xrl a,#52 ;jnz Q130 ;ljmp CRUN Q130: mov r5,#'>' ;OUTPUT a PROMPT lcall TEROT lcall INLINE ;INPUT a LINE INTO IBUF acall PP ;PRE-PROCESS THE LINE jb F0,CMND3 ;NO LINE NUMBER acall LINE ;PROCESS THE LINE lcall LCLR jb LINEB,CMNX ;DON"T CLEAR MEMORY IF NO NEED setb LINEB lcall RCLEAR ;CLEAR THE MEMORY ajmp CMNX ;LOOP BACK ; CMND3: acall T_BUF ;SET UP THE TEXT POINTER lcall DELTST ;GET THE CHARACTER jz CMNDR ;IF CR, EXIT mov dptr,#CMNDD ;POINT AT THE COMMAND LOOKUP cjne a,#T_CMND,Q131 ;PROCESS STATEMENT IF NOT a COMMAND Q131: jc CMND5 lcall GCI1 ;BUMP TXA anl a,#0x0F ;STRIP MSB"S FOR LOOKUP lcall ISTA1 ;PROCESS COMMAND ajmp CMNDR ; CMND5: ljmp ILOOP ;CHECK FOR a POSSIBLE BREAK ; ; ; ;CONSTANTS ; XTALV: db 128+8 ; DEFAULT CRYSTAL VALUE db 0x00 db 0x00 db 0x92 db 0x05 db 0x11 ; EXP11: db 0x85 db 0x00 db 0x42 db 0x41 db 0x87 db 0x59 ; EXP1: db 128+1 ; EXP(1) db 0x00 db 0x18 db 0x28 db 0x18 db 0x27 ; IPTIME: db 128-4 ;FPROG TIMING db 0x00 db 0x00 db 0x00 db 0x75 db 0x83 ; PIE: db 128+1 ;PI db 0x00 db 0x26 db 0x59 db 0x41 db 0x31 ; 3.1415926 ; ;$EJECT ;*************************************************************** ; ; The error messages, some have been moved ; ;*************************************************************** ; E7X: db 128+30 db "ARITH. UNDERFLOW" ; E5X: db "MEMORY ALLOCATION" ; E3X: db 128+40 db "BAD ARGUMENT" ; EXI: db "I-STACK" ; ;$EJECT ;*************************************************************** ; ; The command action routine - CONTINUE ; ;*************************************************************** ; CCONT: mov dptr,#E15X jnb CONB,ERROR ;ERROR IF CONTINUE IS NOT SET ; XCC1: ;used for input statement entry ; mov TXAH,INTXAH ;RESTORE TXA mov TXAL,INTXAL ljmp CILOOP ;EXECUTE ; DTEMP: mov DPH,TEMP5 ;RESTORE dptr mov DPL,TEMP4 ret ; TEMPD: mov TEMP5,DPH mov TEMP4,DPL ret ; ;$EJECT ;************************************************************** ; I_DL: ; IDLE ; ;************************************************************** ; jb DIRF,E1XX ;SYNTAX ERROR IN DIRECT INPUT ;clr DACK ;ACK IDLE ; U_ID1: orl PCON, #1 jb INTPEN,I_RET ;EXIT IF EXTERNAL INTERRUPT jbc U_IDL,I_RET ;EXIT IF USER WANTS TO jnb OTS,U_ID1 ;LOOP IF TIMER NOT ENABLED lcall T_CMP ;CHECK THE TIMER jc U_ID1 ;LOOP IF TIME NOT BIG ENOUGH ; I_RET: ;setb DACK ;RESTORE EXECUTION ret ;EXIT IF IT IS ; ; ; ER0: inc dptr ;BUMP TO TEXT jb DIRF,ERROR0 ;CAN"T GET OUT OF DIRECT MODE jnb ON_ERR,ERROR0 ;IF ON ERROR ISN"T SET, GO BACK mov dptr,#ERRLOC ;SAVE THE ERROR CODE lcall RC2 ;SAVE ERROR AND SET UP THE STACKS inc dptr ;POINT AT ERRNUM ljmp ERL4 ;LOAD ERR NUM AND EXIT ; ;$EJECT ; ; Syntax error ; E1XX: mov c,DIRF ;SEE IF IN DIRECT MODE E1XX_2: mov dptr,#E1X ;ERROR MESSAGE ajmp ERROR_1 ;TRAP ON SET DIRF ; ERROR_3: mov dptr,#EXI ;STACK ERROR ; ; Falls through ; ;*************************************************************** ; ;ERROR PROCESSOR - PRINT OUT THE ERROR TYPE, CHECK TO SEE IF IN ; RUN OR COMMAND MODE, FIND AND PRINT OUT THE ; LINE NUMBER IF IN RUN MODE ; ;*************************************************************** ; ERROR: clr c ;RESET STACK ERROR_1: mov SP,SPSAV ;RESET THE STACK lcall SPRINT4 ;CLEAR LINE AND AT MODE clr a ;SET UP TO GET ERROR CODE movc a,@a+dptr jbc ACC.7,ER0 ;PROCESS ERROR ; ERROR0: acall TEMPD ;SAVE THE DATA POINTER jc Q132 ;NO RESET IF CARRY IS SET lcall RC1 ;RESET THE STACKS Q132: lcall CRLF2 ;DO TWO CARRIAGE ret - LINE FEED mov dptr,#ERS ;OUTPUT ERROR MESSAGE lcall ROM_P acall DTEMP ;GET THE ERROR MESSAGE BACK ; ERRS: lcall ROM_P ;PRINT ERROR TYPE jnb DIRF,ER1 ;DO NOT PRINT IN LINE IF DIRF=1 ; SERR1: clr STOPBIT ;PRINT STOP THEN EXIT, FOR LIST ajmp CMND1 ; ER1: mov dptr,#INS ;OUTPUT IN LINE lcall ROM_P ; ;NOW, FIND THE LINE NUMBER ; ; ;$EJECT ; ; lcall DP_B ;GET THE FIRST ADDRESS OF THE PROGRAM clr a ;FOR INITIALIZATION ; ER2: acall TEMPD ;SAVE THE dptr lcall ADdptr ;add ACC TO DPTR acall ER4 ;r3:r1 = TXA-dptr jc ER3 ;EXIT IF dptr>TXA jz ER3 ;EXIT IF dptr=TXA movx a,@dptr ;GET LENGTH cjne a,#EOF,ER2 ;SEE IF AT THE END ; ER3: acall DTEMP ;PUT THE LINE IN THE dptr acall ER4 ;r3:r1 = TXA - BEGINNING OF LINE mov a,r1 ;GET LENGTH add a,#10 ;add 10 TO LENGTH, dptr STILL HAS ADR mov MT1,a ;SAVE THE COUNT inc dptr ;POINT AT LINE NUMBER HIGH BYTE acall PMTOP_3 ;LOAD r2:r0, PUT IT ON THE STACK lcall FLOATING_POINT_OUTPUT ;OUTPUT IT jb STOPBIT,SERR1 ;EXIT IF STOP BIT SET lcall CRLF2 ;DO SOME CRLF"S acall DTEMP lcall UPPL ;UNPROCESS THE LINE lcall CL6 ;PRINT IT Q13: mov r5,#'-' ;OUTPUT DASHES, THEN AN X lcall T_L ;PRINT AN X IF ERROR CHARACTER FOUND djnz MT1,Q13 ;LOOP UNTIL DONE mov r5,#'X' lcall T_L ajmp SERR1 ; ER4: mov r3,TXAH ;GET TEXT POINTER AND PERFORM SUBTRACTION mov r1,TXAL ljmp DUBSUB ; ;$EJECT ;************************************************************** ; ; Interrupt driven timer ; ;************************************************************** ; I_DR: mov TH0,SAVE_T ;LOAD THE TIMER xch a,MILLIV ;SAVE a, GET MILLI COUNTER inc a ;BUMP COUNTER cjne a,#200,TR ;CHECK OUT TIMER VALUE clr a ;FORCE ACC TO BE ZERO inc TVL ;INCREMENT LOW TIMER cjne a,TVL,TR ;CHECK LOW VALUE inc TVH ;BUMP TIMER HIGH ; TR: xch a,MILLIV pop PSW reti ; ;$EJECT ;$INCLUDE(:F2:BAS52.CLK) ;BEGINNING ;************************************************************** ; ; The statement action routine - CLOCK ; ;************************************************************** ; SCLOCK: acall OTST ;GET CHARACTER AFTER CLOCK TOKEN clr ET0 clr C_BIT jnc SC_R ;EXIT IF a ZERO anl TMOD,#0xf0 ;SET UP THE MODE setb C_BIT ;USER INTERRUPTS orl IE,#0x82 ;ENABLE ET0 AND EA setb TR0 ;TURN ON THE TIMER ; SC_R: ret ; ;END ;$INCLUDE(:F2:BAS52.CLK) ; ; quit back to monitor ; SBYE: jnb ti, . mov ie, #0 mov PSW, #0 mov t2con, #0 ljmp 0 ;*************************************************************** ; ;SUI: ; Statement USER IN action routine ; ; ; ;*************************************************************** ; ; ; acall OTST ; mov CIUB,c ;SET OR CLEAR CIUB ; ret ; ; ; ;*************************************************************** ; ; ;SUO: ; Statement USER OUT action routine ; ; ; ;*************************************************************** ; ; ; acall OTST ; mov COUB,c ; ret ; OTST: ; Check for a one ; lcall GCI ;GET THE CHARACTER, CLEARS CARRY subb a,#'1' ;SEE IF a ONE cpl c ;SETS CARRY IF ONE, CLEARS IT IF ZERO Q872: ret ; ;$EJECT ;************************************************************** ; ; IBLK - EXECUTE USER SUPPLIED TOKEN ; ;************************************************************** ; IBLK: jb PSW.4,Q872 ;EXIT IF REGISTER BANK <> 0 jb PSW.3,Q872 jbc ACC.7,Q133 ;SEE IF BIT SEVEN IS SET mov dptr,#USENT ;USER ENTRY LOCATION ljmp ISTA1 ; Q133: ;jb ACC.0,0x199F ;FLOATING POINT INPUT jb ACC.0,xx1 jz T_L ;DO OUTPUT ON 0x80 mov dptr,#FP_BASE-2 push ACC movc a, @a+dptr mov b, a pop ACC inc dptr movc a, @a+dptr mov dph, b mov dpl, a clr a jmp @a+dptr xx1: ljmp FLOATING_POINT_INPUT ; ; ;************************************************************** ; ; GET_NUM - GET a NUMBER, EITHER HEX OR FLOAT ; ;************************************************************** ; xx2: ljmp FLOATING_POINT_INPUT GET_NUM: lcall HEXSCAN ;SCAN FOR HEX jnc xx2 ;DO FP INPUT ; lcall CONVERT_ASCII_STRING_TO_BINARY ;ASCII STRING TO r2:r0 jnz H_RET push DPH ;SAVE THE DATA_POINTER push DPL lcall PUSHR2R0 ;PUT r2:r0 ON THE STACK pop DPL ;RESTORE THE DATA_POINTER pop DPH clr a ;NO ERRORS ret ;EXIT ; ;$EJECT ;************************************************************** ; ; WB - THE EGO MESSAGE ; ;************************************************************** ; WB: db 'W'+0x80,'R'+0x80 db 'I'+0x80,'T'+0x80,'T','E'+0x80,'N'+0x80 db ' ','B'+0x80,'Y'+0x80,' ' db 'J'+0x80,'O'+0x80,'H'+0x80,'N'+0x80,' '+0x80 db 'K','A'+0x80,'T'+0x80,'A'+0x80,'U'+0x80 db 'S','K'+0x80,'Y'+0x80 db ', I','N'+0x80,'T'+0x80,'E'+0x80,'L'+0x80 db ' '+0x80,'c'+0x80,'O'+0x80,'R'+0x80,'P'+0x80 db '. 1','9'+0x80,"85" H_RET: ret ; ;$EJECT ; ORG 1990H ; T_L: ljmp TEROT ; ; ORG 1F78H ; ;CKS_I: jb CKS_B,CS_I ; ljmp 0x401B ; ;CS_I: ljmp 0x2088 ; E14X: db "NO DATA" ; E11X: db 128+20 db "ARITH. OVERFLOW" ; E16X: db "PROGRAMMING" ; E15X: db "CAN" db 0x27 db "T CONTINUE" ; E10X: db "INVALID LINE NUMBER" ; NOROM: db "PROM MODE" ; S_N: db "*MCS-51(tm) BASIC V1.1*" ; ; ORG 1FF8H ; ERS: db "ERROR: " ; ;$EJECT ;*************************************************************** ; ; XSEG ;External Ram ; ;*************************************************************** ; ram_base = 0x8000 ; DS 4 IBCNT = ram_base+4 ;LENGTH OF a LINE IBLN = IBCNT+1 ;THE LINE NUMBER IBUF = IBLN+2 ; DS LINLEN ;THE INPUT BUFFER CONVT = IBUF+LINLEN ; DS 15 ;CONVERSION LOCATION FOR FPIN ; ; ORG 100H ; GTB = ram_base+0x100 ; DS 1 ;GET LOCATION ERRLOC = GTB+1 ; DS 1 ;ERROR TYPE ERRNUM = ERRLOC+1 ; DS 2 ;WHERE TO GO ON AN ERROR VARTOP = ERRNUM+2 ; DS 2 ;TOP OF VARIABLE STORAGE ST_ALL = VARTOP+2 ; DS 2 ;STORAGE ALLOCATION MT_ALL = ST_ALL+2 ; DS 2 ;MATRIX ALLOCATION MEMTOP = MT_ALL+2 ; DS 2 ;TOP OF MEMORY RCELL = MEMTOP+2 ; DS 2 ;RANDOM NUMBER CELL ; DS FPSIZ-1 CXTAL = RCELL+2+FPSIZ-1 ; DS 1 ;CRYSTAL ; DS FPSIZ-1 FPT1 = CXTAL+1+FPSIZ-1 ; DS 1 ;FLOATINP POINT TEMP 1 ; DS FPSIZ-1 FPT2 = FPT1+1+FPSIZ-1 ; DS 1 ;FLOATING POINT TEMP 2 INTLOC = FPT2+1 ; DS 2 ;LOCATION TO GO TO ON INTERRUPT STR_AL = INTLOC+2 ; DS 2 ;STRING ALLOCATION SPV = STR_AL+2 ; DS 2 ;SERIAL PORT BAUD RATE TIV = SPV+2 ; DS 2 ;TIMER INTERRUPT NUM AND LOC PROGS = TIV+2 ; DS 2 ;PROGRAM a PROM TIME OUT IPROGS = PROGS+2 ; DS 2 ;INTELLIGENT PROM PROGRAMMER TIMEOUT TM_TOP = IPROGS+2 ; DS 1 ; END ;************************************************************ ; ; This is a complete BCD floating point package for the 8051 micro- ; controller. It provides 8 digits of accuracy with exponents that ; range from +127 to -127. The mantissa is in packed BCD, while the ; exponent is expressed in pseudo-twos complement. a ZERO exponent ; is used to express the number ZERO. An exponent value of 0x80 or ; greater than means the exponent is positive, i.e. 0x80 = E 0, ; 0x81 = E+1, 0x82 = E+2 and so on. If the exponent is 0x7f or less, ; the exponent is negative, 0x7f = E-1, 7EH = E-2, and so on. ; ALL NUMBERS ARE ASSUMED TO BE NORMALIZED and all results are ; normalized after calculation. a normalized mantissa is >=.10 and ; <=.99999999. ; ; The numbers in memory assumed to be stored as follows: ; ; EXPONENT OF ARGUMENT 2 = VALUE OF ARG_STACK+FP_NUMBER_SIZE ; SIGN OF ARGUMENT 2 = VALUE OF ARG_STACK+FP_NUMBER_SIZE-1 ; DIGIT 78 OF ARGUMENT 2 = VALUE OF ARG_STACK+FP_NUMBER_SIZE-2 ; DIGIT 56 OF ARGUMENT 2 = VALUE OF ARG_STACK+FP_NUMBER_SIZE-3 ; DIGIT 34 OF ARGUMENT 2 = VALUE OF ARG_STACK+FP_NUMBER_SIZE-4 ; DIGIT 12 OF ARGUMENT 2 = VALUE OF ARG_STACK+FP_NUMBER_SIZE-5 ; ; EXPONENT OF ARGUMENT 1 = VALUE OF ARG_STACK ; SIGN OF ARGUMENT 1 = VALUE OF ARG_STACK-1 ; DIGIT 78 OF ARGUMENT 1 = VALUE OF ARG_STACK-2 ; DIGIT 56 OF ARGUMENT 1 = VALUE OF ARG_STACK-3 ; DIGIT 34 OF ARGUMENT 1 = VALUE OF ARG_STACK-4 ; DIGIT 12 OF ARGUMENT 1 = VALUE OF ARG_STACK-5 ; ; The operations are performed thusly: ; ; ARG_STACK+FP_NUMBER_SIZE = ARG_STACK+FP_NUMBER_SIZE # ARG_STACK ; ; Which is ARGUMENT 2 = ARGUMENT 2 # ARGUMENT 1 ; ; Where # can be add, SUBTRACT, MULTIPLY OR DIVIDE. ; ; Note that the stack gets popped after an operation. ; ; The FP_COMP instruction POPS the ARG_STACK TWICE and returns status. ; ;********************************************************************** ; ;$EJECT ;********************************************************************** ; ; STATUS ON RETURN - After performing an operation (+, -, *, /) ; the accumulator contains the following status ; ; ACCUMULATOR - BIT 0 - FLOATING POINT UNDERFLOW OCCURED ; ; - BIT 1 - FLOATING POINT OVERFLOW OCCURED ; ; - BIT 2 - RESULT WAS ZER0 ; ; - BIT 3 - DIVIDE BY ZERO ATTEMPTED ; ; - BIT 4 - NOT USED, 0 RETURNED ; ; - BIT 5 - NOT USED, 0 RETURNED ; ; - BIT 6 - NOT USED, 0 RETURNED ; ; - BIT 7 - NOT USED, 0 RETURNED ; ; NOTE: When underflow occures, a ZERO result is returned. ; When overflow or divide by zero occures, a result of ; .99999999 E+127 is returned and it is up to the user ; to handle these conditions as needed in the program. ; ; NOTE: The Compare instruction returns F0 = 0 if ARG 1 = ARG 2 ; and returns a CARRY FLAG = 1 if ARG 1 is > ARG 2 ; ;*********************************************************************** ; ;$EJECT ;*********************************************************************** ; ; The following values MUST be provided by the user ; ;*********************************************************************** ; ARG_STACK = 9 ;ARGUMENT STACK POINTER ARG_STACK_PAGE = 0x81 FORMAT = 23 ;LOCATION OF OUTPUT FORMAT BYTE OUTPUT = TEROT ;lcall LOCATION TO OUTPUT a CHARACTER ;CONVT = 0x58 ;LOCATION TO CONVERT NUMBERS INTGRC = 35.1 ;BIT SET IF INTGER ERROR ;ZSURP = 54 ;ZERO SUPRESSION FOR HEX PRINT ; ;*********************************************************************** ; ; The following equates are used internally ; ;*********************************************************************** ; FP_NUMBER_SIZE = 6 XDIGIT = FP_NUMBER_SIZE-2 R0B0 = 0 R1B0 = 1 UNDERFLOW = 0 OVERFLOW = 1 ZERO = 2 ZERO_DIVIDE = 3 ; ;*********************************************************************** ;$EJECT ;************************************************************** ; ; The following internal locations are used by the math pack ; ordering is important and the FP_DIGITS must be bit ; addressable ; ;*************************************************************** ; FP_STATUS = 0x28 ;NOT USED FP_TEMP = FP_STATUS+1 ;NOT USED FP_CARRY = FP_STATUS+2 ;USED FOR BITS ADD_IN = 36.3 ;DCMPXZ IN BASIC BACKAGE XSIGN = FP_CARRY.0 FOUND_RADIX = FP_CARRY.1 FIRST_RADIX = FP_CARRY.2 DONE_LOAD = FP_CARRY.3 FP_DIG12 = FP_CARRY+1 FP_DIG34 = FP_CARRY+2 FP_DIG56 = FP_CARRY+3 FP_DIG78 = FP_CARRY+4 FP_SIGN = FP_CARRY+5 MSIGN = FP_SIGN.0 FP_EXP = FP_CARRY+6 FP_NIB1 = FP_DIG12 FP_NIB2 = FP_NIB1+1 FP_NIB3 = FP_NIB1+2 FP_NIB4 = FP_NIB1+3 FP_NIB5 = FP_NIB1+4 FP_NIB6 = FP_NIB1+5 FP_NIB7 = FP_NIB1+6 FP_NIB8 = FP_NIB1+7 FP_ACCX = FP_NIB1+8 FP_ACCC = FP_NIB1+9 FP_ACC1 = FP_NIB1+10 FP_ACC2 = FP_NIB1+11 FP_ACC3 = FP_NIB1+12 FP_ACC4 = FP_NIB1+13 FP_ACC5 = FP_NIB1+14 FP_ACC6 = FP_NIB1+15 FP_ACC7 = FP_NIB1+16 FP_ACC8 = FP_NIB1+17 FP_ACCS = FP_NIB1+18 ; ;$EJECT ; ORG 1993H FP_BASE: ; ;************************************************************** ; ; The floating point entry points and jump table ; ;************************************************************** ; dx FLOATING_ADD dx FLOATING_SUB dx FLOATING_COMP dx FLOATING_MUL dx FLOATING_DIV dx HEXSCAN dx FLOATING_POINT_INPUT dx FLOATING_POINT_OUTPUT dx CONVERT_BINARY_TO_ASCII_STRING dx CONVERT_ASCII_STRING_TO_BINARY dx MULNUM10 dx HEXOUT dx PUSHR2R0 ; ;$EJECT ; FLOATING_SUB: ; mov P2,#ARG_STACK_PAGE mov r0,ARG_STACK dec r0 ;POINT TO SIGN movx a,@r0 ;READ SIGN cpl ACC.0 movx @r0,a ; ;AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA ; FLOATING_ADD: ; ;AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA ; ; acall MDES1 ;r7=TOS EXP, r6=TOS-1 EXP, r4=TOS SIGN ;r3=TOS-1 SIGN, OPERATION IS r1 # r0 ; mov a,r7 ;GET TOS EXPONENT jz POP_AND_EXIT ;IF TOS=0 THEN pop AND EXIT cjne r6,#0,LOAD1 ;CLEAR CARRY EXIT IF ZERO ; ;************************************************************** ; SWAP_AND_EXIT: ; Swap external args and return ; ;************************************************************** ; acall LOAD_POINTERS mov r7,#FP_NUMBER_SIZE ; SE1: movx a,@r0 ;swap THE ARGUMENTS movx @r1,a dec r0 dec r1 djnz r7,SE1 ; POP_AND_EXIT: ; mov a,ARG_STACK ;pop THE STACK add a,#FP_NUMBER_SIZE mov ARG_STACK,a clr a ret ; ; LOAD1: subb a,r6 ;a = ARG 1 EXP - ARG 2 EXP mov FP_EXP,r7 ;SAVE EXPONENT AND SIGN mov FP_SIGN,r4 jnc LOAD2 ;ARG1 EXPONENT IS LARGER OR SAME mov FP_EXP,r6 mov FP_SIGN,r3 cpl a inc a ;COMPENSATE FOR EXP DELTA xch a,r0 ;FORCE r0 TO POINT AT THE LARGEST xch a,r1 ;EXPONENT xch a,r0 ; LOAD2: mov r7,a ;SAVE THE EXPONENT DELTA IN r7 clr ADD_IN cjne r5,#0,Q134 setb ADD_IN ; ;$EJECT Q134 ; Load the r1 mantissa ; acall LOADR1_MANTISSA ;LOAD THE SMALLEST NUMBER ; ; Now align the number to the delta exponent ; r4 points to the string of the last digits lost ; cjne r7,#XDIGIT+XDIGIT+3,Q135 Q135: jc Q136 mov r7,#XDIGIT+XDIGIT+2 ; Q136: mov FP_CARRY,#00 ;CLEAR THE CARRY acall RIGHT ;SHIFT THE NUMBER ; ; Set up for addition and subtraction ; mov r7,#XDIGIT ;LOOP COUNT mov r1,#FP_DIG78 mov a,#0x9e clr c subb a,r4 da a xch a,r4 jnz Q137 mov r4,a Q137: cjne a,#0x50,Q138 ;TEST FOR SUBTRACTION Q138: jnb ADD_IN,SUBLP ;DO SUBTRACTION IF NO ADD_IN cpl c ;FLIP CARRY FOR ADDITION acall ADDLP ;DO ADDITION ; jnc ADD_R inc FP_CARRY mov r7,#1 acall RIGHT acall INC_FP_EXP ;SHIFT AND BUMP EXPONENT ; ADD_R: ajmp STORE_ALIGN_TEST_AND_EXIT ; ADDLP: movx a,@r0 addc a,@r1 da a mov @r1,a dec r0 dec r1 djnz r7,ADDLP ;LOOP UNTIL DONE ret ; ;$EJECT ; SUBLP: movx a,@r0 ;NOW DO SUBTRACTION mov r6,a clr a addc a,#0x99 subb a,@r1 add a,r6 da a mov @r1,a dec r0 dec r1 djnz r7,SUBLP jc FSUB6 ; ;$EJECT ; ; Need to complement the result and sign because the floating ; point accumulator mantissa was larger than the external ; memory and their signs were equal. ; cpl FP_SIGN.0 mov r1,#FP_DIG78 mov r7,#XDIGIT ;LOOP COUNT ; FSUB5: mov a,#0x9a subb a,@r1 add a,#0 da a mov @r1,a dec r1 cpl c djnz r7,FSUB5 ;LOOP ; ; Now see how many zeros their are ; FSUB6: mov r0,#FP_DIG12 mov r7,#0 ; FSUB7: mov a,@r0 jnz FSUB8 inc r7 inc r7 inc r0 cjne r0,#FP_SIGN,FSUB7 ajmp ZERO_AND_EXIT ; FSUB8: cjne a,#0x10,Q139 Q139: jnc FSUB9 inc r7 ; ; Now r7 has the number of leading zeros in the FP ACC ; FSUB9: mov a,FP_EXP ;GET THE OLD EXPONENT clr c subb a,r7 ;SUBTRACT FROM THE NUMBER OF ZEROS jz FSUB10 jc FSUB10 ; mov FP_EXP,a ;SAVE THE NEW EXPONENT ; acall LEFT1 ;SHIFT THE FP ACC mov FP_CARRY,#0 ajmp STORE_ALIGN_TEST_AND_EXIT ; FSUB10: ajmp UNDERFLOW_AND_EXIT ; ;$EJECT ;*************************************************************** ; FLOATING_COMP: ; Compare two floating point numbers ; used for relational operations and is faster ; than subtraction. ON RETURN, The carry is set ; if ARG1 is > ARG2, else carry is not set ; if ARG1 = ARG2, F0 gets set ; ;*************************************************************** ; acall MDES1 ;SET UP THE REGISTERS mov a,ARG_STACK add a,#FP_NUMBER_SIZE+FP_NUMBER_SIZE mov ARG_STACK,a ;pop THE STACK TWICE, CLEAR THE CARRY mov a,r6 ;CHECK OUT EXPONENTS clr F0 subb a,r7 jz EXPONENTS_EQUAL jc ARG1_EXP_IS_LARGER ; ; Now the ARG2 EXPONENT is > ARG1 EXPONENT ; SIGNS_DIFFERENT: ; mov a,r3 ;SEE IF SIGN OF ARG2 IS POSITIVE ajmp Q140 ; ARG1_EXP_IS_LARGER: ; mov a,r4 ;GET THE SIGN OF ARG1 EXPONENT Q140: jz Q141 cpl c Q141: ret ; EXPONENTS_EQUAL: ; ; First, test the sign, then the mantissa ; cjne r5,#0,SIGNS_DIFFERENT ; BOTH_PLUS: ; mov r7,#XDIGIT ;POINT AT MS DIGIT dec r0 dec r0 dec r0 dec r1 dec r1 dec r1 ; ; Now do the compare ; CLOOP: movx a,@r0 mov r6,a movx a,@r1 subb a,r6 jnz ARG1_EXP_IS_LARGER inc r0 inc r1 djnz r7,CLOOP ; ; If here, the numbers are the same, the carry is cleared ; setb F0 ret ;EXIT WITH EQUAL ; ;$EJECT ;MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM ; FLOATING_MUL: ; Floating point multiply ; ;MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM ; acall MUL_DIV_EXP_AND_SIGN ; ; check for zero exponents ; cjne r6,#00,FMUL1 ;ARG 2 EXP ZERO? Q871: ajmp ZERO_AND_EXIT ; ; calculate the exponent ; FMUL1: mov FP_SIGN,r5 ;SAVE THE SIGN, IN CASE OF FAILURE ; mov a,r7 jz Q871 add a,r6 ;add THE EXPONENTS jb ACC.7,FMUL_OVER jbc CY,FMUL2 ;SEE IF CARRY IS SET ; ajmp UNDERFLOW_AND_EXIT ; FMUL_OVER: ; jnc FMUL2 ;OK IF SET ; FOV: ajmp OVERFLOW_AND_EXIT ; FMUL2: subb a,#129 ;SUBTRACT THE EXPONENT BIAS mov r6,a ;SAVE IT FOR LATER ; ; Unpack and load r0 ; acall UNPACK_R0 ; ; Now set up for loop multiply ; mov r3,#XDIGIT mov r4,R1B0 ; ;$EJECT ; ; Now, do the multiply and accumulate the product ; FMUL3: mov R1B0,r4 movx a,@r1 mov r2,a acall MUL_NIBBLE ; mov a,r2 swap a acall MUL_NIBBLE dec r4 djnz r3,FMUL3 ; ; Now, pack and restore the sign ; mov FP_EXP,r6 mov FP_SIGN,r5 ajmp PACK ;FINISH IT OFF ; ;$EJECT ;DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD ; FLOATING_DIV: ; ;DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD ; acall MDES1 ; ; Check the exponents ; mov FP_SIGN,r5 ;SAVE THE SIGN cjne r7,#0,DIV0 ;CLEARS THE CARRY acall OVERFLOW_AND_EXIT clr a ;setb ACC.ZERO_DIVIDE setb ACC.3 ret ; DIV0: mov a,r6 ;GET EXPONENT jz Q871 ;EXIT IF ZERO subb a,r7 ;DELTA EXPONENT jb ACC.7,D_UNDER jnc DIV3 ajmp UNDERFLOW_AND_EXIT ; D_UNDER:jnc FOV ; DIV3: add a,#129 ;CORRECTLY BIAS THE EXPONENT mov FP_EXP,a ;SAVE THE EXPONENT acall LOADR1_MANTISSA ;LOAD THE DIVIDED ; mov r2,#FP_ACCC ;SAVE LOCATION mov r3,R0B0 ;SAVE POINTER IN r3 mov FP_CARRY,#0 ;ZERO CARRY BYTE ; DIV4: mov r5,#0xff ;LOOP COUNT setb c ; DIV5: mov R0B0,r3 ;RESTORE THE EXTERNAL POINTER mov r1,#FP_DIG78 ;SET UP INTERNAL POINTER mov r7,#XDIGIT ;LOOP COUNT jnc DIV7 ;EXIT IF NO CARRY ; DIV6: movx a,@r0 ;DO ACCUMLATION mov r6,a clr a addc a,#0x99 subb a,r6 add a,@r1 da a mov @r1,a dec r0 dec r1 djnz r7,DIV6 ;LOOP ; inc r5 ;SUBTRACT COUNTER jc DIV5 ;KEEP LOOPING IF CARRY mov a,@r1 ;GET CARRY subb a,#1 ;CARRY IS CLEARED mov @r1,a ;SAVE CARRY DIGIT cpl c ajmp DIV5 ;LOOP ; ; Restore the result if carry was found ; DIV7: acall ADDLP ;add NUMBER BACK mov @r1,#0 ;CLEAR CARRY mov R0B0,r2 ;GET SAVE COUNTER mov @r0,5 ;SAVE COUNT BYTE ; inc r2 ;ADJUST SAVE COUNTER mov r7,#1 ;BUMP DIVIDEND acall LEFT cjne r2,#FP_ACC8+2,DIV4 ; djnz FP_EXP,DIV8 ajmp UNDERFLOW_AND_EXIT ; DIV8: mov FP_CARRY,#0 ; ;$EJECT ;*************************************************************** ; PACK: ; Pack the mantissa ; ;*************************************************************** ; ; First, set up the pointers ; mov r0,#FP_ACCC mov a,@r0 ;GET FP_ACCC mov r6,a ;SAVE FOR ZERO COUNT jz PACK0 ;JUMP OVER IF ZERO acall INC_FP_EXP ;BUMP THE EXPONENT dec r0 ; PACK0: inc r0 ;POINT AT FP_ACC1 ; PACK1: mov a,#8 ;ADJUST NIBBLE POINTER mov r1,a add a,r0 mov r0,a cjne @r0,#5,Q143 ;SEE IF ADJUSTING NEEDED Q143: jc Q721 ; PACK2: setb c clr a dec r0 addc a,@r0 da a xchd a,@r0 ;SAVE THE VALUE jnb ACC.4,PACK3 djnz r1,PACK2 ; dec r0 mov @r0,#1 acall INC_FP_EXP ajmp PACK4 ; PACK3: dec r1 Q721: mov a,r1 clr c xch a,r0 subb a,r0 mov r0,a ; PACK4: mov r1,#FP_DIG12 ; ; Now, pack ; PLOOP: mov a,@r0 swap a ;FLIP THE DIGITS inc r0 xchd a,@r0 orl 6,a ;ACCUMULATE THE OR"ED DIGITS mov @r1,a inc r0 inc r1 cjne r1,#FP_SIGN,PLOOP mov a,r6 jnz STORE_ALIGN_TEST_AND_EXIT mov FP_EXP,#0 ;ZERO EXPONENT ; ;************************************************************** ; STORE_ALIGN_TEST_AND_EXIT: ;Save the number align carry and exit ; ;************************************************************** ; acall LOAD_POINTERS mov ARG_STACK,r1 ;SET UP THE NEW STACK mov r0,#FP_EXP ; ; Now load the numbers ; STORE2: mov a,@r0 movx @r1,a ;SAVE THE NUMBER dec r0 dec r1 cjne r0,#FP_CARRY,STORE2 ; clr a ;NO ERRORS ; PRET: ret ;EXIT ; ;$EJECT INC_FP_EXP: ; inc FP_EXP mov a,FP_EXP jnz PRET ;EXIT IF NOT ZERO pop ACC ;WASTE THE CALLING STACK pop ACC ajmp OVERFLOW_AND_EXIT ; ;*********************************************************************** ; UNPACK_R0: ; Unpack BCD digits and load into nibble locations ; ;*********************************************************************** ; push R1B0 mov r1,#FP_NIB8 ; ULOOP: movx a,@r0 anl a,#0x0F mov @r1,a ;SAVE THE NIBBLE movx a,@r0 swap a anl a,#0x0F dec r1 mov @r1,a ;SAVE THE NIBBLE AGAIN dec r0 dec r1 cjne r1,#FP_NIB1-1,ULOOP ; pop R1B0 ; LOAD7: ret ; ;$EJECT ;************************************************************** ; OVERFLOW_AND_EXIT: ;LOAD 99999999 E+127, SET OV BIT, AND EXIT ; ;************************************************************** ; mov r0,#FP_DIG78 mov a,#0x99 ; OVE1: mov @r0,a dec r0 cjne r0,#FP_CARRY,OVE1 ; mov FP_EXP,#0xff acall STORE_ALIGN_TEST_AND_EXIT ; ; setb ACC.OVERFLOW setb ACC.1 ret ; ;$EJECT ;************************************************************** ; UNDERFLOW_AND_EXIT: ;LOAD 0, SET UF BIT, AND EXIT ; ;************************************************************** ; acall ZERO_AND_EXIT clr a ; setb ACC.UNDERFLOW setb ACC.0 ret ; ;************************************************************** ; ZERO_AND_EXIT: ;LOAD 0, SET ZERO BIT, AND EXIT ; ;************************************************************** ; acall FP_CLEAR acall STORE_ALIGN_TEST_AND_EXIT ;setb ACC.ZERO setb ACC.2 ret ;EXIT ; ;************************************************************** ; FP_CLEAR: ; ; Clear internal storage ; ;************************************************************** ; clr a mov r0,#FP_ACC8+1 ; FPC1: mov @r0,a dec r0 cjne r0,#FP_TEMP,FPC1 ret ; ;$EJECT ;************************************************************** ; RIGHT: ; Shift ACCUMULATOR RIGHT the number of nibbles in r7 ; Save the shifted values in r4 if SAVE_ROUND is set ; ;************************************************************** ; mov r4,#0 ;IN CASE OF NO SHIFT ; RIGHT1: clr c RIGHT1_1: mov a,r7 ;GET THE DIGITS TO SHIFT jz Q869 ;EXIT IF ZERO subb a,#2 ;TWO TO DO? jnc RIGHT5 ;SHIFT TWO NIBBLES ; ; Swap one nibble then exit ; RIGHT3: push R0B0 ;SAVE POINTER REGISTER push R1B0 ; mov r1,#FP_DIG78 ;LOAD THE POINTERS mov r0,#FP_DIG56 mov a,r4 ;GET THE OVERFLOW REGISTER xchd a,@r1 ;GET DIGIT 8 swap a ;FLIP FOR LOAD mov r4,a ; RIGHTL: mov a,@r1 ;GET THE LOW ORDER BYTE xchd a,@r0 ;swap NIBBLES swap a ;FLIP FOR STORE mov @r1,a ;SAVE THE DIGITS dec r0 ;BUMP THE POINTERS dec r1 cjne r1,#FP_DIG12-1,RIGHTL ;LOOP ; mov a,@r1 ;ACC = CH8 swap a ;ACC = 0x8c anl a,#0x0F ;ACC = 0CH mov @r1,a ;CARRY DONE pop R1B0 ;EXIT pop R0B0 ;RESTORE REGISTER Q869: ret ; RIGHT5: mov r7,a ;SAVE THE NEW SHIFT NUMBER clr a xch a,FP_CARRY ;swap THE NIBBLES xch a,FP_DIG12 xch a,FP_DIG34 xch a,FP_DIG56 xch a,FP_DIG78 mov r4,a ;SAVE THE LAST DIGIT SHIFTED ajmp RIGHT1_1 ; ;$EJECT ;*************************************************************** ; LEFT: ; Shift ACCUMULATOR LEFT the number of nibbles in r7 ; ;*************************************************************** ; mov r4,#0x00 ;CLEAR FOR SOME ENTRYS ; LEFT1: clr c LEFT1_1: mov a,r7 ;GET SHIFT VALUE jz Q869 ;EXIT IF ZERO subb a,#2 ;SEE HOW MANY BYTES TO SHIFT jnc LEFT5 ; LEFT3: push R0B0 ;SAVE POINTER push R1B0 mov r0,#FP_CARRY mov r1,#FP_DIG12 ; mov a,@r0 ;ACC=CHCL swap a ;ACC = CLCH mov @r0,a ;ACC = CLCH, @r0 = CLCH ; LEFTL: mov a,@r1 ;DIG 12 swap a ;DIG 21 xchd a,@r0 mov @r1,a ;SAVE IT inc r0 ;BUMP POINTERS inc r1 cjne r0,#FP_DIG78,LEFTL ; mov a,r4 swap a xchd a,@r0 anl a,#0xf0 mov r4,a ; pop R1B0 pop R0B0 ;RESTORE ret ;DONE ; LEFT5: mov r7,a ;RESTORE COUNT clr a xch a,r4 ;GET THE RESTORATION BYTE xch a,FP_DIG78 ;DO THE swap xch a,FP_DIG56 xch a,FP_DIG34 xch a,FP_DIG12 xch a,FP_CARRY ajmp LEFT1_1 ; ;$EJECT MUL_NIBBLE: ; ; Multiply the nibble in r7 by the FP_NIB locations ; accumulate the product in FP_ACC ; ; Set up the pointers for multiplication ; anl a,#0x0F ;STRIP OFF MS NIBBLE mov r7,a mov r0,#FP_ACC8 mov r1,#FP_NIB8 clr a mov FP_ACCX,a ; MNLOOP: dec r0 ;BUMP POINTER TO PROPAGATE CARRY add a,@r0 ;ATTEMPT TO FORCE CARRY da a ;BCD ADJUST jnb ACC.4,MNL0 ;DON"T ADJUST IF NO NEED dec r0 ;PROPAGATE CARRY TO THE NEXT DIGIT inc @r0 ;DO THE ADJUSTING inc r0 ;RESTORE r0 ; MNL0: xchd a,@r0 ;RESTORE INITIAL NUMBER mov B,r7 ;GET THE NUBBLE TO MULTIPLY mov a,@r1 ;GET THE OTHER NIBBLE mul ab ;DO THE MULTIPLY mov B,#10 ;NOW BCD ADJUST div ab xch a,B ;GET THE REMAINDER add a,@r0 ;PROPAGATE THE PARTIAL PRODUCTS da a ;BCD ADJUST jnb ACC.4,MNL1 ;PROPAGATE PARTIAL PRODUCT CARRY inc B ; MNL1: inc r0 xchd a,@r0 ;SAVE THE NEW PRODUCT dec r0 mov a,B ;GET BACK THE QUOTIENT dec r1 cjne r1,#FP_NIB1-1,MNLOOP ; add a,FP_ACCX ;GET THE OVERFLOW da a ;ADJUST mov @r0,a ;SAVE IT ret ;EXIT ; ;$EJECT ;*************************************************************** ; LOAD_POINTERS: ; Load the ARG_STACK into r0 and bump r1 ; ;*************************************************************** ; mov P2,#ARG_STACK_PAGE mov r0,ARG_STACK mov a,#FP_NUMBER_SIZE add a,r0 mov r1,a ret ; ;*************************************************************** ; MUL_DIV_EXP_AND_SIGN: ; ; Load the sign into r7, r6. r5 gets the sign for ; multiply and divide. ; ;*************************************************************** ; acall FP_CLEAR ;CLEAR INTERNAL MEMORY ; MDES1: acall LOAD_POINTERS ;LOAD REGISTERS movx a,@r0 ;ARG 1 EXP mov r7,a ;SAVED IN r7 movx a,@r1 ;ARG 2 EXP mov r6,a ;SAVED IN r6 dec r0 ;BUMP POINTERS TO SIGN dec r1 movx a,@r0 ;GET THE SIGN mov r4,a ;SIGN OF ARG1 movx a,@r1 ;GET SIGN OF NEXT ARG mov r3,a ;SIGN OF ARG2 xrl a,r4 ;ACC GETS THE NEW SIGN mov r5,a ;r5 GETS THE NEW SIGN ; ; Bump the pointers to point at the LS digit ; dec r0 dec r1 ; ret ; ;$EJECT ;*************************************************************** ; LOADR1_MANTISSA: ; ; Load the mantissa of r0 into FP_Digits ; ;*************************************************************** ; push R0B0 ;SAVE REGISTER 1 mov r0,#FP_DIG78 ;SET UP THE POINTER ; LOADR1: movx a,@r1 mov @r0,a dec r1 dec r0 cjne r0,#FP_CARRY,LOADR1 ; pop R0B0 ret ; ;$EJECT ;*************************************************************** ; HEXSCAN: ; Scan a string to determine if it is a hex number ; set carry if hex, else carry = 0 ; ;*************************************************************** ; acall GET_dptr_CHARACTER push DPH push DPL ;SAVE THE POINTER ; HEXSC1: movx a,@dptr ;GET THE CHARACTER acall DIGIT_CHECK ;SEE IF a DIGIT jc HS1 ;CONTINUE IF a DIGIT acall HEX_CHECK ;SEE IF HEX jc HS1 ; clr ACC.5 ;NO LOWER CASE cjne a,#'H',HEXDON setb c ajmp HEXDO1 ;NUMBER IS VALID HEX, MAYBE ; HEXDON: clr c ; HEXDO1: pop DPL ;RESTORE POINTER pop DPH ret ; HS1: inc dptr ;BUMP TO NEXT CHARACTER ajmp HEXSC1 ;LOOP ; HEX_CHECK: ;CHECK FOR a VALID ASCII HEX, SET CARRY IF FOUND ; clr ACC.5 ;WASTE LOWER CASE cjne a,#'F'+1,Q144 ;SEE IF F OR LESS Q144: jc HC1 ret ; HC1: cjne a,#'A',Q145 ;SEE IF a OR GREATER Q145: cpl c ret ; ;$EJECT ; PUSHR2R0: ; mov r3,#CONVT>>8 ;CONVERSION LOCATION mov r1,#CONVT&0xff acall CONVERT_BINARY_TO_ASCII_STRING mov a,#0xD ;a CR TO TERMINATE movx @r1,a ;SAVE THE CR mov dptr,#CONVT ; ; Falls thru to FLOATING INPUT ; ;$EJECT ;*************************************************************** ; FLOATING_POINT_INPUT: ; Input a floating point number pointed to by ; the dptr ; ;*************************************************************** ; acall FP_CLEAR ;CLEAR EVERYTHING acall GET_dptr_CHARACTER acall PLUS_MINUS_TEST mov MSIGN,c ;SAVE THE MANTISSA SIGN ; ; Now, set up for input loop ; mov r0,#FP_ACCC mov r6,#0x7f ;BASE EXPONENT setb F0 ;SET INITIAL FLAG ; INLOOP: acall GET_DIGIT_CHECK jnc GTEST ;IF NOT a CHARACTER, WHAT IS IT? anl a,#0x0f ;STRIP ASCII acall STDIG ;STORE THE DIGITS ; INLPIK: inc dptr ;BUMP POINTER FOR LOOP ajmp INLOOP ;LOOP FOR INPUT ; GTEST: cjne a,#'.',GT1 ;SEE IF a RADIX jb FOUND_RADIX,INERR setb FOUND_RADIX cjne r0,#FP_ACCC,INLPIK setb FIRST_RADIX ;SET IF FIRST RADIX ajmp INLPIK ;GET ADDITIONAL DIGITS ; GT1: jb F0,INERR ;ERROR IF NOT CLEARED cjne a,#'e',Q146 ;CHECK FOR LOWER CASE ajmp Q147 Q146: cjne a,#'E',FINISH_UP Q147: acall INC_AND_GET_dptr_CHARACTER acall PLUS_MINUS_TEST mov XSIGN,c ;SAVE SIGN STATUS acall GET_DIGIT_CHECK jnc INERR ; anl a,#0x0f ;STRIP ASCII BIAS OFF THE CHARACTER mov r5,a ;SAVE THE CHARACTER IN r5 ; GT2: inc dptr acall GET_DIGIT_CHECK jnc FINISH1 anl a,#0x0f ;STRIP OFF BIAS xch a,r5 ;GET THE LAST DIGIT mov B,#10 ;MULTIPLY BY TEN mul ab add a,r5 ;add TO ORIGINAL VALUE mov r5,a ;SAVE IN r5 jnc GT2 ;LOOP IF NO CARRY mov r5,#0xff ;FORCE AN ERROR ; FINISH1:mov a,r5 ;GET THE SIGN jnb XSIGN,POSNUM ;SEE IF EXPONENT IS POS OR NEG clr c subb a,r6 cpl a inc a jc FINISH2 mov a,#0x01 ret ; POSNUM: add a,r6 ;add TO EXPONENT jnc FINISH2 ; POSNM1: mov a,#0x02 ret ; FINISH2:xch a,r6 ;SAVE THE EXPONENT ; FINISH_UP: ; mov FP_EXP,r6 ;SAVE EXPONENT cjne r0,#FP_ACCC,Q148 acall FP_CLEAR ;CLEAR THE MEMORY IF 0 Q148: mov a,ARG_STACK ;GET THE ARG STACK clr c subb a,#FP_NUMBER_SIZE+FP_NUMBER_SIZE mov ARG_STACK,a ;ADJUST FOR STORE ajmp PACK ; STDIG: clr F0 ;CLEAR INITIAL DESIGNATOR jnz STDIG1 ;CONTINUE IF NOT ZERO cjne r0,#FP_ACCC,STDIG1 jnb FIRST_RADIX,RET_X ; DECX: djnz r6,RET_X ; INERR: mov a,#0xff ; RET_X: ret ; STDIG1: jb DONE_LOAD,FRTEST clr FIRST_RADIX ; FRTEST: jb FIRST_RADIX,DECX ; FDTEST: jb FOUND_RADIX,FDT1 inc r6 ; FDT1: jb DONE_LOAD,RET_X cjne r0,#FP_ACC8+1,FDT2 setb DONE_LOAD ; FDT2: mov @r0,a ;SAVE THE STRIPPED ACCUMULATOR inc r0 ;BUMP THE POINTER ret ;EXIT ; ;$EJECT ;*************************************************************** ; ; I/O utilities ; ;*************************************************************** ; INC_AND_GET_dptr_CHARACTER: ; inc dptr ; GET_dptr_CHARACTER: ; movx a,@dptr ;GET THE CHARACTER cjne a,#' ',PMT1 ;SEE IF a SPACE ; ; Kill spaces ; ajmp INC_AND_GET_dptr_CHARACTER ; PLUS_MINUS_TEST: ; cjne a,#0xE3,Q149 ;SEE IF a PLUS, PLUS TOKEN FROM BASIC ajmp PMT3 Q149: cjne a,#'+',Q150 ajmp PMT3 Q150: cjne a,#0xE5,Q151 ;SEE IF MINUS, MINUS TOKEN FROM BASIC ajmp PMT2 Q151: cjne a,#'-',PMT1 ; PMT2: setb c ; PMT3: inc dptr ; PMT1: ret ; ;$EJECT ;*************************************************************** ; FLOATING_POINT_OUTPUT: ; Output the number, format is in location 23 ; ; IF FORMAT = 00 - FREE FLOATING ; = FX - EXPONENTIAL (X IS THE NUMBER OF SIG DIGITS) ; = NX - N = NUM BEFORE RADIX, X = NUM AFTER RADIX ; N + X = 8 MAX ; ;*************************************************************** ; acall MDES1 ;GET THE NUMBER TO OUTPUT, r0 IS POINTER acall POP_AND_EXIT ;OUTPUT POPS THE STACK mov a,r7 mov r6,a ;PUT THE EXPONENT IN r6 acall UNPACK_R0 ;UNPACK THE NUMBER mov r0,#FP_NIB1 ;POINT AT THE NUMBER mov a,FORMAT ;GET THE FORMAT mov r3,a ;SAVE IN CASE OF EXP FORMAT jz FREE ;FREE FLOATING? cjne a,#0xf0,Q152 ;SEE IF EXPONENTIAL Q152: jnc Q235 ; ; If here, must be integer USING format ; mov a,r6 ;GET THE EXPONENT jnz Q153 mov r6,#0x80 Q153: mov a,r3 ;GET THE FORMAT swap a ;SPLIT INTEGER AND FRACTION anl a,#0x0f mov r2,a ;SAVE INTEGER acall NUM_LT ;GET THE NUMBER OF INTEGERS xch a,r2 ;FLIP FOR subb clr c subb a,r2 mov r7,a jnc Q154 mov r5,#'?' ;OUTPUT a QUESTION MARK acall SOUT1 ;NUMBER IS TOO LARGE FOR FORMAT ajmp FREE Q154: cjne r2,#00,USING0 ;SEE IF ZERO dec r7 acall SS7 acall ZOUT ;OUTPUT a ZERO ajmp USING1 ; USING0: acall SS7 ;OUTPUT SPACES, IF NEED TO mov a,r2 ;OUTPUT DIGITS mov r7,a acall OUTR0 ; USING1: mov a,r3 anl a,#0x0f ;GET THE NUMBER RIGHT OF DP mov r2,a ;SAVE IT jz PMT1 ;EXIT IF ZERO acall ROUT ;OUTPUT DP acall NUM_RT cjne a,2,USINGX ;COMPARE a TO r2 ; USINGY: mov a,r2 ajmp Z7R7 Q235: ajmp EXPOUT ; USINGX: jnc USINGY ; USING2: xch a,r2 clr c subb a,r2 xch a,r2 acall Z7R7 ;OUTPUT ZEROS IF NEED TO mov a,r2 mov r7,a ajmp OUTR0 ; ; First, force exponential output, if need to ; FREE: mov a,r6 ;GET THE EXPONENT jnz FREE1 ;IF ZERO, PRINT IT acall SOUT ajmp ZOUT ; FREE1: mov r3,#0xf0 ;IN CASE EXP NEEDED mov a,#0x80-XDIGIT-XDIGIT-1 add a,r6 jc EXPOUT subb a,#0xF7 jc EXPOUT ; ; Now, just print the number ; acall SINOUT ;PRINT THE SIGN OF THE NUMBER acall NUM_LT ;GET THE NUMBER LEFT OF DP cjne a,#8,FREE4 ajmp OUTR0 ; FREE4: acall OUTR0 acall ZTEST ;TEST FOR TRAILING ZEROS jz U_RET ;DONE IF ALL TRAILING ZEROS acall ROUT ;OUTPUT RADIX ; FREE2: mov r7,#1 ;OUTPUT ONE DIGIT acall OUTR0 jnz U_RET acall ZTEST jz U_RET ajmp FREE2 ;LOOP ; EXPOUT: acall SINOUT ;PRINT THE SIGN mov r7,#1 ;OUTPUT ONE CHARACTER acall OUTR0 acall ROUT ;OUTPUT RADIX mov a,r3 ;GET FORMAT anl a,#0x0f ;STRIP INDICATOR jz EXPOTX ; mov r7,a ;OUTPUT THE NUMBER OF DIGITS dec r7 ;ADJUST BECAUSE ONE CHAR ALREADY OUT acall OUTR0 ajmp EXPOT4 ; EXPOTX: acall FREE2 ;OUTPUT UNTIL TRAILING ZEROS ; EXPOT4: acall SOUT ;OUTPUT a SPACE mov r5,#'E' acall SOUT1 ;OUTPUT AN E mov a,r6 ;GET THE EXPONENT jz XOUT0 ;EXIT IF ZERO dec a ;ADJUST FOR THE DIGIT ALREADY OUTPUT cjne a,#0x80,XOUT2 ;SEE WHAT IT IS ; XOUT0: acall SOUT clr a ajmp XOUT4 ; XOUT2: jc XOUT3 ;NEGATIVE EXPONENT mov r5,#'+' ;OUTPUT a PLUS SIGN acall SOUT1 ajmp XOUT4 ; XOUT3: acall MOUT cpl a ;FLIP BITS inc a ;BUMP ; XOUT4: clr ACC.7 mov r0,a mov r2,#0 mov r1,#CONVT&0xff ;CONVERSION LOCATION mov r3,#CONVT>>8 acall CONVERT_BINARY_TO_ASCII_STRING mov r0,#CONVT&0xff ;NOW, OUTPUT EXPONENT ; EXPOT5: movx a,@r0 ;GET THE CHARACTER mov r5,a ;OUTPUT IT acall SOUT1 inc r0 ;BUMP THE POINTER mov a,r0 ;GET THE POINTER cjne a,R1B0,EXPOT5 ;LOOP ; U_RET: ret ;EXIT ; OUTR0: ; Output the characters pointed to by r0, also bias ascii ; mov a,r7 ;GET THE COUNTER jz OUTR ;EXIT IF DONE mov a,@r0 ;GET THE NUMBER orl a,#0x30 ;ASCII BIAS inc r0 ;BUMP POINTER AND COUNTER dec r7 mov r5,a ;PUT CHARACTER IN OUTPUT REGISTER acall SOUT1 ;OUTPUT THE CHARACTER clr a ;JUST FOR TEST cjne r0,#FP_NIB8+1,OUTR0 mov a,#0x55 ;KNOW WHERE EXIT OCCURED ; OUTR: ret ; ZTEST: mov r1,R0B0 ;GET POINTER REGISTER ; ZT0: mov a,@r1 ;GET THE VALUE jnz ZT1 inc r1 ;BUMP POINTER cjne r1,#FP_NIB8+1,ZT0 ; ZT1: ret ; NUM_LT: mov a,r6 ;GET EXPONENT clr c ;GET READY FOR subb subb a,#0x80 ;SUB EXPONENT BIAS jnc NL1 ;OK IF NO CARRY clr a ;NO DIGITS LEFT ; NL1: mov r7,a ;SAVE THE COUNT ret ; NUM_RT: clr c ;subb AGAIN mov a,#0x80 ;EXPONENT BIAS subb a,r6 ;GET THE BIASED EXPONENT jnc NR1 clr a ; NR1: ret ;EXIT ; SPACE7: mov a,r7 ;GET THE NUMBER OF SPACES jz NR1 ;EXIT IF ZERO acall SOUT ;OUTPUT a SPACE dec r7 ;BUMP COUNTER ajmp SPACE7 ;LOOP ; Z7R7: mov r7,a ; ZERO7: mov a,r7 ;GET COUNTER jz NR1 ;EXIT IF ZERO acall ZOUT ;OUTPUT a ZERO dec r7 ;BUMP COUNTER ajmp ZERO7 ;LOOP ; SS7: acall SPACE7 ; SINOUT: mov a,r4 ;GET THE SIGN jz SOUT ;OUTPUT a SPACE IF ZERO ; MOUT: mov r5,#'-' ajmp SOUT1 ;OUTPUT a MINUS IF NOT ; ROUT: mov r5,#'.' ;OUTPUT a RADIX ajmp SOUT1 ; ZOUT: mov r5,#'0' ;OUTPUT a ZERO ajmp SOUT1 ; SOUT: mov r5,#' ' ;OUTPUT a SPACE ; SOUT1: ljmp OUTPUT ; ;$EJECT ;*************************************************************** ; CONVERT_ASCII_STRING_TO_BINARY: ; ;dptr POINTS TO ASCII STRING ;PUT THE BINARY NUMBER IN r2:r0, ERROR IF >64K ; ;*************************************************************** ; CASB: acall HEXSCAN ;SEE IF HEX NUMBER mov ADD_IN,c ;IF ADD_IN IS SET, THE NUMBER IS HEX acall GET_DIGIT_CHECK cpl c ;FLIP FOR EXIT jc RCASB mov r3,#0x00 ;ZERO r3:r1 FOR LOOP mov r1,#0x00 ajmp CASB5 ; CASB2: inc dptr mov R0B0,r1 ;SAVE THE PRESENT CONVERTED VALUE mov R0B0+2,r3 ;IN r2:r0 acall GET_DIGIT_CHECK jc CASB5 jnb ADD_IN,RCASB ;CONVERSION COMPLETE acall HEX_CHECK ;SEE IF HEX NUMBER jc CASB4 ;PROCEED IF GOOD inc dptr ;BUMP PAST H ajmp RCASB ; CASB4: add a,#9 ;ADJUST HEX ASCII BIAS ; CASB5: mov B,#10 jnb ADD_IN,CASB6 mov B,#16 ;HEX MODE ; CASB6: acall MULNUM ;ACCUMULATE THE DIGITS jnc CASB2 ;LOOP IF NO CARRY ; RCASB: clr a ;RESET ACC ; mov ACC.OVERFLOW,c ;IF OVERFLOW, SAY SO mov ACC.1,c ;IF OVERFLOW, SAY SO ret ;EXIT ; ;$EJECT ; MULNUM10:mov B,#10 ; ;*************************************************************** ; MULNUM: ; Take the next digit in the acc (masked to 0x0f) ; accumulate in r3:r1 ; ;*************************************************************** ; push ACC ;SAVE ACC push B ;SAVE MULTIPLIER mov a,r1 ;PUT LOW ORDER BITS IN ACC mul ab ;DO THE MULTIPLY mov r1,a ;PUT THE RESULT BACK mov a,r3 ;GET THE HIGH ORDER BYTE mov r3,B ;SAVE THE OVERFLOW pop B ;GET THE MULTIPLIER mul ab ;DO IT mov c,OV ;SAVE OVERFLOW IN F0 mov F0,c add a,r3 ;add OVERFLOW TO HIGH RESULT mov r3,a ;PUT IT BACK pop ACC ;GET THE ORIGINAL ACC BACK orl c,F0 ;OR CARRY AND OVERFLOW jc MULX ;NO GOOD IF THE CARRY IS SET ; MUL11: anl a,#0x0f ;MASK OFF HIGH ORDER BITS add a,r1 ;NOW add THE ACC mov r1,a ;PUT IT BACK clr a ;PROPAGATE THE CARRY addc a,r3 mov r3,a ;PUT IT BACK ; MULX: ret ;EXIT WITH OR WITHOUT CARRY ; ;*************************************************************** ; CONVERT_BINARY_TO_ASCII_STRING: ; ;r3:r1 contains the address of the string ;r2:r0 contains the value to convert ;dptr, r7, r6, and ACC gets clobbered ; ;*************************************************************** ; clr a ;NO LEADING ZEROS mov dptr,#10000 ;SUBTRACT 10000 acall RSUB ;DO THE SUBTRACTION mov dptr,#1000 ;NOW 1000 acall RSUB mov dptr,#100 ;NOW 100 acall RSUB mov dptr,#10 ;NOW 10 acall RSUB mov dptr,#1 ;NOW 1 acall RSUB jz RSUB2 ;JUMP OVER ret ; RSUB_R: ret ; RSUB: mov r6,#0xff ;SET UP THE COUNTER ; RSUB1: inc r6 ;BUMP THE COUNTER xch a,r2 ;DO a FAST COMPARE cjne a,DPH,Q155 Q155: xch a,r2 jc FAST_DONE xch a,r0 ;GET LOW BYTE subb a,DPL ;SUBTRACT, CARRY IS CLEARED xch a,r0 ;PUT IT BACK xch a,r2 ;GET THE HIGH BYTE subb a,DPH ;add THE HIGH BYTE xch a,r2 ;PUT IT BACK jnc RSUB1 ;LOOP UNTIL CARRY ; xch a,r0 add a,DPL ;RESTORE r2:r0 xch a,r0 xch a,r2 addc a,DPH xch a,r2 ; FAST_DONE: ; orl a,r6 ;OR THE COUNT VALUE jz RSUB_R ;RETURN IF ZERO ; RSUB2: mov a,#'0' ;GET THE ASCII BIAS add a,r6 ;add THE COUNT ; RSUB4: mov P2,r3 ;SET UP P2 movx @r1,a ;PLACE THE VALUE IN MEMORY inc r1 cjne r1,#0x00,RSUB3 ;SEE IF RAPPED AROUND inc r3 ;BUMP HIGH BYTE ; RSUB3: ret ;EXIT ; ;$EJECT ;*************************************************************** ; HEXOUT: ; Output the hex number in r3:r1, supress leading zeros, if set ; ;*************************************************************** ; acall SOUT ;OUTPUT a SPACE mov c,ZSURP ;GET ZERO SUPPRESSION BIT mov ADD_IN,c mov a,r3 ;GET HIGH NIBBLE AND PRINT IT acall HOUTHI mov a,r3 acall HOUTLO ; HEX2X: clr ADD_IN ;DON"T SUPPRESS ZEROS mov a,r1 ;GET LOW NIBBLE AND PRINT IT acall HOUTHI mov a,r1 acall HOUTLO mov r5,#'H' ;OUTPUT H TO INDICATE HEX MODE ; SOUT_1: ajmp SOUT1 ; HOUT1: clr ADD_IN ;PRINTED SOMETHING, SO CLEAR ADD_IN add a,#0x90 ;CONVERT TO ASCII da a addc a,#0x40 da a ;GOT IT HERE mov r5,a ;OUTPUT THE BYTE ajmp SOUT_1 ; HOUTHI: swap a ;swap TO OUTPUT HIGH NIBBLE ; HOUTLO: anl a,#0x0f ;STRIP jnz HOUT1 ;PRINT IF NOT ZERO jnb ADD_IN,HOUT1 ;OUTPUT a ZERO IF NOT SUPRESSED ret ; ;$EJECT ; ORG 1FEBH ;FOR LINK COMPATABILITY ; ; GET_DIGIT_CHECK: ; Get a character, then check for digit ; acall GET_dptr_CHARACTER ; DIGIT_CHECK: ;CHECK FOR a VALID ASCII DIGIT, SET CARRY IF FOUND ; cjne a,#'9'+1,Q156 ;SEE IF ASCII 9 OR LESS Q156: jc DC1 ret ; DC1: cjne a,#'0',Q157 ;SEE IF ASCII 0 OR GREATER Q157: cpl c ret ; ;; ;; And now on to the forth interpreter ;; ;TITLE 8051 eForth ;PAGE 62,132 ;62 lines per page, 132 characters per line ;=============================================================== ; ; 8051 eForth 1.1 by C. H. Ting, 1990 ; ; This eForth system was developed using chipForth from Forth, Inc. ; and tested on a Micromint BCC52 single board computer. ; The eForth Model was developed by Bill Muench and C. H. Ting. ; ; The goal of this implementation is to show that the eForth Model ; can be ported to a ROM based 8 bit microprocessor, Intel 8051. ; Deviations from the original eForth Model are: ; ; All kernel words are assembled as DB statements. ; Memory map is tailored to a ROM based system. ; $COLON and $USER are modified to compile LJMP doLIST. ; call, compiles a LCALL with a flipped destination address. ; USER, VARIABLE and : are modified to use above 'call,'. ; FORTH vocabulary pointer is a pair user variables. ; BYE is deleted. (I put it back - PWC) ; ; To assemble this source file and generate a ROM image, ; type the following commands using MASM and LINK: ; >MASM 8051; ; >LINK 8051; ; The resulting 8051.EXE contains the binary image suitable ; for PROM programming. The actual image is offset by 200H ; bytes from the beginning of the .EXE file. This image ; must be placed in a PROM from 0 to 1FFFH, and it uses a RAM ; chip from 8000H to 9FFFH. If your system does not have ; this memory configuration, modify the memory pointers in ; the source file accordingly. Places to be modified are ; marked by '******'. ; 8051 is a slow processor. Do not expect great performance ; of this implementation, considering that most words are in high ; level. Your are encouraged to recode some of the high level words ; to optimize its performance. ; ; Direct your questions and contributions to: ; ; Dr. C. H. Ting ; 156 14th Avenue ; San Mateo, CA 94402 ; (415) 571-7639 ; ;=============================================================== ;; Version control VER = 1 ;major release version EXT = 1 ;minor extension ;; Constants COMPO = 0x40 ;lexicon compile only bit IMEDD = 0x80 ;lexicon immediate bit MASKK = 0x7F1F ;lexicon bit mask CELLL = 2 ;size of a cell BASEE = 10 ;default radix VOCSS = 8 ;depth of vocabulary stack BKSPP = 8 ;backspace LF = 10 ;line feed CRR = 13 ;carriage return ERR = 27 ;error escape TIC = 39 ;tick CALLL = 0x1200 ;NOP CALL opcodes****** ;LISTT = 0x6001 ;CALL address****** ;; Memory allocation 0//code>--//------rp//em EM = 0xfe00 ;top of RAM memory****** SerM = EM ; serial buffer BM = 0 ;bottom of ROM memory****** COLDD = BM+0x40 ;cold start vector****** US = 0x100 ;user area size in cells RTS = 0x100 ;return stack/TIB size DTS = 0x100 ;data stack size UPP = EM-US ;start of user area (UP0) TIBB = UPP-RTS ;terminal input buffer (TIB) RPP = UPP-2 ;start of return stack (RP0) SPP = RPP-RTS ;start of data stack (SP0) ;NAMEE = BM+0x1FFE ;initial name dictionary****** ;CODEE = BM+0x100 ;initial code dictionary****** ;; Initialize assembly variables ;_LINK = 0 ;force a null link ;_NAME = NAMEE ;initialize name pointer ;_CODE = CODEE ;initialize code pointer _USER = 4*CELLL ;first user variable offset ; ; registers ; RPL = 0 SPL = 1 TPL = 2 TPH = 3 NPL = 4 ;IPL = 6 ;IPH = 7 RPH = 8 SPH = 9 TM1 = 10 TM2 = 11 TM3 = 12 TM4 = 13 UPL = 14 UPH = 15 ;; Define assembly macros ; Adjust an address to the next cell boundary. ;$ALIGN MACRO ; EVEN ;;for 16bit systems ; ENDM ; Compile a code definition header. ; ; dw code address ; dw link ; db len | code_type ; db ;$CODE MACRO LEX,NAME,LABEL ; $ALIGN ;;force to cell boundary ;LABEL: ;;assembly label ; _CODE = $ ;;save code pointer ; _LEN = (LEX AND 01FH)/CELLL ;;string cell count, round down ; _NAME = _NAME-((_LEN+3)*CELLL) ;;new header on cell boundary ;ORG _NAME ;;set name pointer ; DW _CODE,_LINK ;;token pointer and link ; _LINK = $ ;;link points to a name string ; db LEX,NAME ;;name string ;ORG _CODE ;;restore code pointer ; ENDM ; ;; Compile a colon definition header. ;$COLON MACRO LEX,NAME,LABEL ; $CODE LEX,NAME,LABEL ; DW CALLL ;;align to cell boundary****** ; DW LISTT ;;include CALL doLIST****** ; ENDM ; ;; Compile a user variable header. ;$USER MACRO LEX,NAME,LABEL ; $CODE LEX,NAME,LABEL ; DW CALLL ;;align to cell boundary****** ; DW LISTT ;;include CALL doLIST****** ; DW DOUSE,_USER ;;followed by doUSER and offset ; _USER = _USER+CELLL ;;update user area offset ; ENDM ; Compile an inline string. ;D$ MACRO FUNCT,STRNG ; DW FUNCT ;;function ; _LEN = $ ;;save address of count byte ; db 0,STRNG ;;count byte and string ; _CODE = $ ;;save code pointer ;ORG _LEN ;;point to count byte ; db _CODE-_LEN-1 ;;set count ;ORG _CODE ;;restore code pointer ; $ALIGN ; ENDM ;; Main entry points and COLD start data ;MAIN SEGMENT ;ASSUME CS:MAIN,DS:MAIN,ES:MAIN,SS:MAIN ;ORG BM ;Power up location****** ; .=0 ; ljmp coldstart ; db 0x32,0,0,0,0,0,0,0 ;Return from interrupt ; db 0x32,0,0,0,0,0,0,0 ;Return from interrupt ; db 0x32,0,0,0,0,0,0,0 ;Return from interrupt ; db 0x32,0,0,0,0,0,0,0 ;Return from interrupt ; db 0x32,0,0,0,0,0,0,0 ;Return from interrupt ; db 0x32,0,0,0,0,0,0,0 ;Return from interrupt ; db 0x32,0,0,0,0,0,0,0 ;Return from interrupt ; db 0x32,0,0,0,0 ;ORG COLDD ;User variable initial values ; COLD start moves the following to USER variables. ; MUST BE IN SAME ORDER AS USER VARIABLES. ;$ALIGN ;align to cell boundary .even UZERO: dw 0, 0, 0, 0 ;reserved dw SPP ;SP0 dw RPP ;RP0 dw QRX ;'?KEY dw TXSTO ;'EMIT dw ACCEP ;'EXPECT dw KTAP ;'TAP dw TXSTO ;'ECHO dw DOTOK ;'PROMPT dw BASEE ;BASE dw 0 ;tmp dw 0 ;SPAN dw 0 ;>IN dw 0 ;#TIB dw TIBB ;TIB dw 0 ;CSP dw INTER ;'EVAL dw NUMBQ ;'NUMBER dw 0 ;HLD dw 0 ;HANDLER dw 0 ;CONTEXT pointer dw 0,0,0,0,0,0,0,0 ;vocabulary stack dw 0 ;CURRENT pointer dw 0 ;vocabulary link pointer dw EM-0x2000 ;CP****** dw SPP-DTS ;NP dw LASTN ;LAST dw LASTN ;FORTH dw 0 ;vocabulary link ULAST: ;ORG CODEE ;start code dictionary SER_IN = 0x10 ; register bank 2 r0 - incoming data pointer SER_OUT = 0x11 ; register bank 2 r1 - outgoing pointer SER_COUNT = 0x12 ; register bank 2 r2 - char count XOFFED = 0x13 ; register bank 2 r3 - we have sent an XOFF NEED_XOFF = 0x14 ; register bank 2 r4 - need to send an XOFF flag IN_TYPE = 0x16 ; register bank 2 r6 - 0 for normal ; 1 for reading from EEPROM ; 2 for EEPROM eof XMT_BUSY = 0x17 ; register bank 2 r7 - the transmitter is busy EF_SER: ; forth serial interrupt routine jnb ri, SER1 push ACC mov a, IN_TYPE jz EF_SE6 pop ACC clr ri reti EF_SE6: push PSW push dph push dpl setb RS1 ; switch register sets to #2 mov dpl, r0 mov dph, #SerM>>8 movx a, @dptr ; is the buffer full? jnz SER2 mov a, sbuf ; put the character jz SER2 ; nulls are out movx @dptr, a inc r0 inc r2 ; inc the counter cjne r3, #0, SER2 ; have we sent an xoff? mov a, r2 xrl a, #0xff anl a, #0xe0 ; do we need to? jnz SER2 jnb ti, SER3 ; can we send an XOFF? mov r4, #1 ; no - mark it for later ajmp SER2 SER3: inc r3 ; mark it done mov sbuf, #0x11 ; send the xoff mov r7, #1 ; mark transmitter busy SER2: clr ri pop dpl pop dph pop PSW pop ACC SER5: reti SER1: jnb ti, SER5 ; xmit interrupt? push PSW setb RS1 clr ti cjne r4, #1, SER6 ; need to send xoff? dec r4 mov sbuf, #0x11 ; send it pop PSW reti SER6: mov r7, #0 pop PSW reti ORIG: ;Cold boot routine forth_coldstart: EFORTH_START: jnb ti, . ; wait for output to drain clr ti clr ri mov vserl, #EF_SER&0xff ; hook into the main ISRs mov vserh, #EF_SER>>8 mov SP,#tcounth+8 mov PSW,#0x10 mov r0, #0 mov r1, #0 mov r2, #0 mov r3, #0 mov r4, #0 mov r7, #0 mov PSW,#0x0 mov IN_TYPE, #0 mov dptr, #SerM clr a mov r0, #0xff lp1: movx @dptr, a inc dptr djnz r0, lp1 movx @dptr, a mov r0,#RPP&0xff mov RPH,#RPP>>8 mov UPL,#UPP&0xff mov UPH,#UPP>>8 mov r1,#SPP&0xff mov SPH,#SPP>>8 ;mov TH1,#0xFD ; 19200 Baud ;mov PCON,#0x80 ;mov SCON,#0x50 ;setb TCON.6 ;mov TMOD,#0x20 mov p2,SPH mov SP,#tcounth+8 mov a, r7_3 cjne a, #'F', lp2 lcall forth_eeprom_setup mov a, scon ; turn off input interrupts anl a, #0xee mov scon, a lp2: mov IE,#0xb0 ljmp COLD ;******to be hand coded! ;db 0,0,0 ;filler ;; RETURN RETURN: ;The Forth Inner Interpreter mov DPL,r6 mov DPH,r7 RETURN4: clr a movc a,@a+dptr mov r4,a mov a,#1 movc a,@a+dptr mov DPH,a mov DPL,r4 mov a,r6 add a,#2 mov r6,a jnc Xx1 inc r7 Xx1: ;lcall BADX clr a jmp @a+dptr ;; The kernel ; doLIT ( -- w ) ; Push an inline literal. ; $CODE COMPO+5,'doLIT',DOLIT DOLIT: mov DPL,r6 mov DPH,r7 mov a,r3 movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 clr a movc a,@a+dptr mov r2,a inc dptr clr a movc a,@a+dptr mov r3,a inc dptr mov r6,DPL mov r7,DPH ajmp RETURN4 ; doLIST ( a -- ) ; Process colon list. ; $CODE COMPO+6,'doLIST',DOLST DOLST: LISTT: mov p2,RPH ; Get list address mov a,r7 movx @r0,a dec r0 mov a,r6 movx @r0,a dec r0 mov p2,SPH ; Restore stack pointer pop 7 pop 6 ajmp RETURN ; next ( -- ) ; Run time code for the single index loop. ; : next ( -- ) \ hilevel model ; r> r> dup if 1 - >r @ >r exit then drop cell+ >r ; ; $CODE COMPO+4,'next',DONXT DONXT: mov p2,RPH inc r0 movx a,@r0 clr c subb a,#1 movx @r0,a inc r0 movx a,@r0 subb a,#0 movx @r0,a mov p2,SPH mov DPL,r6 mov DPH,r7 jnc Xx2 inc dptr inc dptr mov r6,DPL mov r7,DPH ajmp RETURN Xx2: dec r0 dec r0 clr a movc a,@a+dptr mov r6,a mov a,#1 movc a,@a+dptr mov r7,a ajmp RETURN ; ?branch ( f -- ) ; Branch if flag is zero. ; $CODE COMPO+7,'?branch',QBRAN QBRAN: ;lcall BADa mov DPL,r6 mov DPH,r7 mov a,r2 orl a,r3 jz Xx3 inc dptr inc dptr mov r6,DPL mov r7,DPH inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ;lcall BADb ljmp RETURN Xx3: clr a movc a,@a+dptr mov r6,a mov a,#1 movc a,@a+dptr mov r7,a inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ;lcall BADc ljmp RETURN ; branch ( -- ) ; Branch to an inline address. ; $CODE COMPO+6,'branch',BRAN BRAN: mov DPL,r6 mov DPH,r7 clr a movc a,@a+dptr mov r6,a mov a,#1 movc a,@a+dptr mov r7,a ljmp RETURN ; EXECUTE ( ca -- ) ; Execute the word at ca. ; $CODE 7,'EXECUTE',EXECU EXECU: mov DPL,r2 mov DPH,r3 inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ;lcall BAD4 clr a jmp @a+dptr ; EXIT ( -- ) ; Terminate a colon definition. ; $CODE 4,'EXIT',EXIT EXIT: mov p2,RPH inc r0 movx a,@r0 mov r6,a inc r0 movx a,@r0 mov r7,a mov p2,SPH ;ljmp BAD_A ljmp RETURN ; ! ( w a -- ) ; Pop the data stack to memory. ; $CODE 1,'!',STORE STORE: mov DPL,r2 mov DPH,r3 inc r1 movx a,@r1 movx @dptr,a inc dptr inc r1 movx a,@r1 movx @dptr,a inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ljmp RETURN ; @ ( a -- w ) ; Push memory location to the data stack. ; $CODE 1,'@',AT AT: mov DPL,r2 mov DPH,r3 movx a,@dptr mov r2,a inc dptr movx a,@dptr mov r3,a ljmp RETURN ; C! ( c b -- ) ; Pop the data stack to byte memory. ; $CODE 2,'C!',CSTOR CSTOR: mov DPL,r2 mov DPH,r3 inc r1 movx a,@r1 movx @dptr,a inc r1 inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ljmp RETURN ; C@ ( b -- c ) ; Push byte memory location to the data stack. ; $CODE 2,'C@',CAT CAT: mov DPL,r2 mov DPH,r3 movx a,@dptr mov r2,a mov r3,#0 ljmp RETURN ; >R ( w -- ) ; Push the data stack to the return stack. ; $CODE COMPO+2,'>R',TOR TOR: mov p2,RPH mov a,r3 movx @r0,a dec r0 mov a,r2 movx @r0,a dec r0 mov p2,SPH inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ljmp RETURN ; R@ ( -- w ) ; Copy top of return stack to the data stack. ; $CODE 2,'R@',RAT RAT: mov a,r3 movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 mov DPL,r0 mov DPH,RPH inc dptr movx a,@dptr mov r2,a inc dptr movx a,@dptr mov r3,a ljmp RETURN ; R> ( -- w ) ; Pop the return stack to the data stack. ; $CODE 2,'R>',RFROM RFROM: mov a,r3 movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 mov p2,RPH inc r0 movx a,@r0 mov r2,a inc r0 movx a,@r0 mov r3,a mov p2,SPH ljmp RETURN ; RP@ ( -- a ) ; Push the current RP to the data stack. ; $CODE 3,'RP@',RPAT RPAT: mov a,r3 movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 mov r2,r0 mov r3,RPH ljmp RETURN ; RP! ( a -- ) ; Set the return stack pointer. ; $CODE COMPO+3,'RP!',RPSTO RPSTO: mov r0,r2 mov RPH,r3 inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ljmp RETURN ; SP@ ( -- a ) ; Push the current data stack pointer. ; $CODE 3,'SP@',SPAT SPAT: mov a,r3 movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 mov r2,r1 mov r3,SPH ljmp RETURN ; SP! ( a -- ) ; Set the data stack pointer. ; $CODE 3,'SP!',SPSTO SPSTO: mov r1,r2 mov SPH,r3 mov p2, r3 inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ljmp RETURN ; DUP ( w -- w w ) ; Duplicate the top stack item. ; $CODE 3,'DUP',DUPP DUPP: mov a,r3 movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 ;lcall BAD5 ljmp RETURN ; DROP ( w -- ) ; Discard top stack item. ; $CODE 4,'DROP',DROP DROP: inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ljmp RETURN XXXSWAP: ; byte swap mov a,r2 mov r2,r3 mov r3,a ljmp RETURN ; SWAP ( w1 w2 -- w2 w1 ) ; Exchange top two stack items. ; $CODE 4,'SWAP',SWAP SWAP: mov DPL,r1 mov DPH,SPH inc DPL movx a,@dptr xch a,r2 movx @dptr,a inc DPL movx a,@dptr xch a,r3 movx @dptr,a ljmp RETURN ; OVER ( w1 w2 -- w1 w2 w1 ) ; Copy second stack item to top. ; $CODE 4,'OVER',OVER OVER: mov DPL,r1 mov DPH,SPH mov a,r3 movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 inc dptr movx a,@dptr mov r2,a inc dptr movx a,@dptr mov r3,a ljmp RETURN ; 0< ( n -- t ) ; Return true if n is negative. ; $CODE 2,'0<',ZLESS ZLESS: mov a,r3 jnb ACC.7,Xx4 mov a,#0xFF ajmp Xx5 Xx4: clr a Xx5: mov r2,a mov r3,a ljmp RETURN ; AND ( w w -- w ) ; Bitwise AND. ; $CODE 3,'AND',ANDD ANDD: inc r1 movx a,@r1 anl 2,a inc r1 movx a,@r1 anl 3,a ljmp RETURN ; OR ( w w -- w ) ; Bitwise inclusive OR. ; $CODE 2,'OR',ORR ORR: inc r1 movx a,@r1 orl 2,a inc r1 movx a,@r1 orl 3,a ljmp RETURN ; XOR ( w w -- w ) ; Bitwise exclusive OR. ; $CODE 3,'XOR',XORR XORR: inc r1 movx a,@r1 xrl 2,a inc r1 movx a,@r1 xrl 3,a ljmp RETURN ; UM+ ( w w -- w cy ) ; Add two numbers, return the sum and carry flag. ; $CODE 3,'UM+',UPLUS UPLUS: inc r1 movx a,@r1 add a,r2 movx @r1,a inc r1 movx a,@r1 addc a,r3 movx @r1,a dec r1 dec r1 clr a mov r3,a addc a,r3 mov r2,a ljmp RETURN ; ; BYE ( -- ) return to monitor ; BYE: mov ie, #0 mov PSW, #0 ljmp 0 ; ; IWAIT1MS (w -- ) wait N mS ; IWAIT1MS: mov tcountl, r2 mov tcounth, r3 mov a, r2 cjne a, tcountl, IWAIT1MS mov a, r3 cjne a, tcounth, IWAIT1MS acall FDO_POP IW1: mov a, tcounth jnz IW1 IW2: mov a, tcountl jnz IW2 ljmp RETURN WAIT1SEC: mov tcounth, #1000>>8 XIW3: mov tcountl, #1000&0xff mov a, #1000&0xff cjne a, tcountl, XIW3 mov a, #1000>>8 cjne a, tcounth, WAIT1SEC XIW1: mov a, tcounth jnz XIW1 XIW2: mov a, tcountl jnz XIW2 ret ; ; IWAIT1S (w -- ) wait N mS ; IWAIT1S: inc r3 IWW1: acall WAIT1SEC djnz r2, IWW1 djnz r3, IWW1 acall FDO_POP ljmp RETURN FDO_POP: inc r1 movx a,@r1 mov r2, a inc r1 movx a,@r1 mov r3, a ret FDO_PUSH: mov a,r3 movx @r1,a dec r1 mov a, r2 movx @r1,a dec r1 ret ITIME: acall FDO_PUSH push ie mov ie, #0 mov r2, timel mov r3, timem pop ie ljmp RETURN XITIME: acall FDO_PUSH mov r3, #0 push ie mov ie, #0 mov b, timel mov r4, timem mov r2, timeh pop ie acall FDO_PUSH mov r2, b mov r3, r4 ljmp RETURN ;; Device dependent I/O ; !IO ( -- ) ; Initialize the serial I/O devices. ; $CODE 3,'!IO',STOIO STOIO: ljmp RETURN ; ?RX ( -- c T | F ) ; Return input character and true, or a false if no input. ; $CODE 3,'?RX',QRX QRX: mov a,r3 movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 mov a, IN_TYPE cjne a, #0, QRX_ee mov a, SER_COUNT jz Xx6 mov a,#0 movx @r1,a dec r1 mov p2, #SerM>>8 setb RS1 movx a, @r1 mov b, a clr a movx @r1, a inc r1 dec r2 cjne r3, #1, QRX1 mov a, r2 anl a, #0x80 jnz QRX1 cjne r7, #0, . inc r7 mov sbuf, #0x13 dec r3 QRX1: clr RS1 mov p2, SPH mov a, b movx @r1,a dec r1 mov r2,#0xFF mov r3,#0xFF ljmp RETURN Xx6: mov r2,#0 mov r3,#0 ljmp RETURN ; ; eeprom version of the same ; QRX_ee: cjne a, #1, Xx6 mov a,#0 movx @r1,a dec r1 lcall forth_ee_in mov p2, SPH movx @r1,a dec r1 mov r2,#0xFF mov r3,#0xFF ljmp RETURN ; TX! ( c -- ) ; Send character c to the output device. ; $CODE 3,'TX!',TXSTO TXST1: pop ie clr RS1 TXSTO: mov a, r2 setb RS1 push ie mov ie, #0 cjne r7, #0, TXST1 mov r7, #1 mov sbuf,a pop ie clr RS1 done_wr: inc r1 movx a,@r1 mov r2,a inc r1 movx a,@r1 mov r3,a ljmp RETURN ; ; EE! ; EEWR: inc r1 movx a,@r1 inc r1 push r0_0 push r1_0 push r4_0 push r5_0 push r6_0 push r7_0 mov r6, r3 mov r7, r2 mov r0, #0xf0 mov @r0, a mov r2, #'W' mov r3, #1 lcall do_nvram pop r7_0 pop r6_0 pop r5_0 pop r4_0 pop r1_0 pop r0_0 ajmp done_wr EERD: push r0_0 push r1_0 push r4_0 push r5_0 push r6_0 push r7_0 mov r6, r3 mov r7, r2 mov r0, #0xf0 mov r2, #'R' mov r3, #1 lcall do_nvram mov r1, #0xf0 mov a, @r1 mov r2,a mov r3,#0 pop r7_0 pop r6_0 pop r5_0 pop r4_0 pop r1_0 pop r0_0 ljmp RETURN ; P0! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 3,'P0!',P0WR P0WR: mov p0, r2 ajmp done_wr P0RD: mov a, P0 ajmp done_rd ; P1! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 3,'P1!',P1WR P1WR: mov p1, r2 ajmp done_wr P1RD: mov a, P1 ajmp done_rd ; P2! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 3,'P2!',P2WR P2WR: mov p2, r2 ajmp done_wr P2RD: mov a, P2 ajmp done_rd ; P3! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 3,'P3!',P3WR P3WR: mov p3, r2 ajmp done_wr P3RD: mov a, P3 ajmp done_rd ; PSW! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 4,'PSW!',PSWWR PSWWR: mov PSW, r2 ajmp done_wr PSWRD: mov a, PSW ajmp done_rd ; IP! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 3,'IP!',IPWR IPWR: mov IP, r2 ajmp done_wr IPRD: mov a, IP ajmp done_rd ; T2CON! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 6,'T2CON!',T2CONWR T2CONWR: mov T2CON, r2 ajmp done_wr T2CONRD: mov a, T2CON ajmp done_rd ; RCAP2L! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 7,'RCAP2L!',RCAP2LWR RCAP2LWR: mov RCAP2L, r2 ajmp done_wr RCAP2LRD: mov a, RCAP2L ajmp done_rd ; RCAP2H! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 7,'RCAP2H!',RCAP2HWR RCAP2HWR: mov RCAP2H, r2 ajmp done_wr RCAP2HRD: mov a, RCAP2H ajmp done_rd ; TL2! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 4,'TL2!',TL2WR TL2WR: mov TL2, r2 ajmp done_wr TL2RD: mov a, TL2 ajmp done_rd ; TH2! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 4,'TH2!',TH2WR TH2WR: mov TH2, r2 ajmp done_wr TH2RD: mov a, TH2 ajmp done_rd ; IE! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 3,'IE!',IEWR IEWR: mov IE, r2 ajmp done_wr IERD: mov a, IE ajmp done_rd ; SCON! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 5,'SCON!',SCONWR SCONWR: mov SCON, r2 ajmp done_wr SCONRD: mov a, SCON ajmp done_rd ; SBUF! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 5,'SBUF!',SBUFWR SBUFWR: mov SBUF, r2 ajmp done_wr SBUFRD: mov a, SBUF ajmp done_rd ; TCON! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 5,'TCON!',TCONWR TCONWR: mov TCON, r2 ajmp done_wr TCONRD: mov a, TCON ajmp done_rd ; TMOD! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 5,'TMOD!',TMODWR TMODWR: mov TMOD, r2 ajmp done_wr TMODRD: mov a, TMOD ajmp done_rd ; TL0! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 4,'TL0!',TL0WR TL0WR: mov TL0, r2 ajmp done_wr TL0RD: mov a, TL0 ajmp done_rd ; TH0! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 4,'TH0!',TH0WR TH0WR: mov TH0, r2 ajmp done_wr TH0RD: mov a, TH0 ajmp done_rd ; TL1! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 4,'TL1!',TL1WR TL1WR: mov TL1, r2 ajmp done_wr TL1RD: mov a, TL1 ajmp done_rd ; TH1! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 4,'TH1!',TH1WR TH1WR: mov TH1, r2 ajmp done_wr TH1RD: mov a, TH1 ajmp done_rd done_rdc: clr a rlc a done_rd: mov r4, a mov a,r3 movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 mov r2,r4 mov r3,#0 ljmp RETURN ; ; analog channels ; AR0D: mov a, #0 ajmp ARC AR1D: mov a, #1 ajmp ARC AR2D: mov a, #2 ajmp ARC AR3D: mov a, #3 ARC: push r0_0 mov r0, a mov a,r3 ; push tos movx @r1,a dec r1 mov a,r2 movx @r1,a dec r1 push r1_0 lcall get_adc mov r2, r0 mov r3, r1 pop r1_0 pop r0_0 ljmp RETURN ; PCON! ( c -- ) ; Pop the data stack to byte memory. ; $CODE 5,'PCON!',PCONWR PCONWR: mov PCON, r2 ajmp done_wr PCONRD: mov a, PCON ajmp done_rd ; P0_0 ( c -- ) ; 5,'P0_0',P0_0 P0_0WR: mov a, r2 rrc a mov p0.0, c ajmp done_wr P0_0RD: mov c, p0.0 ajmp done_rdc ; P0_1 ( c -- ) ; 5,'P0_1',P0_1 P0_1WR: mov a, r2 rrc a mov p0.1, c ajmp done_wr P0_1RD: mov c, p0.1 ajmp done_rdc ; P0_2 ( c -- ) ; 5,'P0_2',P0_2 P0_2WR: mov a, r2 rrc a mov p0.2, c ajmp done_wr P0_2RD: mov c, p0.2 ajmp done_rdc ; P0_3 ( c -- ) ; 5,'P0_3',P0_3 P0_3WR: mov a, r2 rrc a mov p0.3, c ajmp done_wr P0_3RD: mov c, p0.3 ajmp done_rdc ; P0_4 ( c -- ) ; 5,'P0_4',P0_4 P0_4WR: mov a, r2 rrc a mov p0.4, c ajmp done_wr P0_4RD: mov c, p0.4 ajmp done_rdc ; P0_5 ( c -- ) ; 5,'P0_5',P0_5 P0_5WR: mov a, r2 rrc a mov p0.5, c ajmp done_wr P0_5RD: mov c, p0.5 ajmp done_rdc ; P0_6 ( c -- ) ; 5,'P0_6',P0_6 P0_6WR: mov a, r2 rrc a mov p0.6, c ajmp done_wr P0_6RD: mov c, p0.6 ajmp done_rdc ; P0_7 ( c -- ) ; 5,'P0_7',P0_7 P0_7WR: mov a, r2 rrc a mov p0.7, c ajmp done_wr P0_7RD: mov c, p0.7 ajmp done_rdc ; P1_0 ( c -- ) ; 5,'P1_0',P1_0 P1_0WR: mov a, r2 rrc a mov p1.0, c ajmp done_wr P1_0RD: mov c, p1.0 ajmp done_rdc ; P1_1 ( c -- ) ; 5,'P1_1',P1_1 P1_1WR: mov a, r2 rrc a mov p1.1, c ajmp done_wr P1_1RD: mov c, p1.1 ajmp done_rdc ; P1_2 ( c -- ) ; 5,'P1_2',P1_2 P1_2WR: mov a, r2 rrc a mov p1.2, c ajmp done_wr P1_2RD: mov c, p1.2 ajmp done_rdc ; P1_3 ( c -- ) ; 5,'P1_3',P1_3 P1_3WR: mov a, r2 rrc a mov p1.3, c ajmp done_wr P1_3RD: mov c, p1.3 ajmp done_rdc ; P1_4 ( c -- ) ; 5,'P1_4',P1_4 P1_4WR: mov a, r2 rrc a mov p1.4, c ajmp done_wr P1_4RD: mov c, p1.4 ajmp done_rdc ; P1_5 ( c -- ) ; 5,'P1_5',P1_5 P1_5WR: mov a, r2 rrc a mov p1.5, c ajmp done_wr P1_5RD: mov c, p1.5 ajmp done_rdc ; P1_6 ( c -- ) ; 5,'P1_6',P1_6 P1_6WR: mov a, r2 rrc a mov p1.6, c ajmp done_wr P1_6RD: mov c, p1.6 ajmp done_rdc ; P1_7 ( c -- ) ; 5,'P1_7',P1_7 P1_7WR: mov a, r2 rrc a mov p1.7, c ajmp done_wr P1_7RD: mov c, p1.7 ajmp done_rdc ; P2_0 ( c -- ) ; 5,'P2_0',P2_0 P2_0WR: mov a, r2 rrc a mov p2.0, c ajmp done_wr P2_0RD: mov c, p2.0 ajmp done_rdc ; P2_1 ( c -- ) ; 5,'P2_1',P2_1 P2_1WR: mov a, r2 rrc a mov p2.1, c ajmp done_wr P2_1RD: mov c, p2.1 ajmp done_rdc ; P2_2 ( c -- ) ; 5,'P2_2',P2_2 P2_2WR: mov a, r2 rrc a mov p2.2, c ajmp done_wr P2_2RD: mov c, p2.2 ajmp done_rdc ; P2_3 ( c -- ) ; 5,'P2_3',P2_3 P2_3WR: mov a, r2 rrc a mov p2.3, c ajmp done_wr P2_3RD: mov c, p2.3 ajmp done_rdc ; P2_4 ( c -- ) ; 5,'P2_4',P2_4 P2_4WR: mov a, r2 rrc a mov p2.4, c ajmp done_wr P2_4RD: mov c, p2.4 ajmp done_rdc ; P2_5 ( c -- ) ; 5,'P2_5',P2_5 P2_5WR: mov a, r2 rrc a mov p2.5, c ajmp done_wr P2_5RD: mov c, p2.5 ajmp done_rdc ; P2_6 ( c -- ) ; 5,'P2_6',P2_6 P2_6WR: mov a, r2 rrc a mov p2.6, c ajmp done_wr P2_6RD: mov c, p2.6 ajmp done_rdc ; P2_7 ( c -- ) ; 5,'P2_7',P2_7 P2_7WR: mov a, r2 rrc a mov p2.7, c ajmp done_wr P2_7RD: mov c, p2.7 ajmp done_rdc ; P3_0 ( c -- ) ; 5,'P3_0',P3_0 P3_0WR: mov a, r2 rrc a mov p3.0, c ajmp done_wr P3_0RD: mov c, p3.0 ajmp done_rdc ; P3_1 ( c -- ) ; 5,'P3_1',P3_1 P3_1WR: mov a, r2 rrc a mov p3.1, c ajmp done_wr ARMWR: mov a, r2 rrc a cpl c mov p3.2, c ajmp done_wr P3_1RD: mov c, p3.1 ajmp done_rdc ; P3_2 ( c -- ) ; 5,'P3_2',P3_2 P3_2WR: mov a, r2 rrc a mov p3.2, c ajmp done_wr P3_2RD: mov c, p3.2 ajmp done_rdc ; P3_3 ( c -- ) ; 5,'P3_3',P3_3 P3_3WR: mov a, r2 rrc a mov p3.3, c ajmp done_wr P3_3RD: mov c, p3.3 ajmp done_rdc ; P3_4 ( c -- ) ; 5,'P3_4',P3_4 P3_4WR: mov a, r2 rrc a mov p3.4, c ajmp done_wr P3_4RD: mov c, p3.4 ajmp done_rdc ; P3_5 ( c -- ) ; 5,'P3_5',P3_5 P3_5WR: mov a, r2 rrc a mov p3.5, c ajmp done_wr P3_5RD: mov c, p3.5 ajmp done_rdc ; P3_6 ( c -- ) ; 5,'P3_6',P3_6 P3_6WR: mov a, r2 rrc a mov p3.6, c ajmp done_wr P3_6RD: mov c, p3.6 ajmp done_rdc ; P3_7 ( c -- ) ; 5,'P3_7',P3_7 P3_7WR: mov a, r2 rrc a mov p3.7, c ajmp done_wr P3_7RD: mov c, p3.7 ajmp done_rdc ; AC ( c -- ) ; 5,'AC!',ACWR ACWR: mov a, r2 rrc a mov AC, c ajmp done_wr ACRD: mov c, AC ajmp done_rdc ; F0 ( c -- ) ; 5,'F0!',F0WR F0WR: mov a, r2 rrc a mov F0, c ajmp done_wr F0RD: mov c, F0 ajmp done_rdc ; RS0 ( c -- ) ; 5,'RS0!',RS0WR RS0WR: mov a, r2 rrc a mov RS0, c ajmp done_wr RS0RD: mov c, RS0 ajmp done_rdc ; RS1 ( c -- ) ; 5,'RS1!',RS1WR RS1WR: mov a, r2 rrc a mov RS1, c ajmp done_wr RS1RD: mov c, RS1 ajmp done_rdc ; OV ( c -- ) ; 5,'OV!',OVWR OVWR: mov a, r2 rrc a mov OV, c ajmp done_wr OVRD: mov c, OV ajmp done_rdc ; P ( c -- ) ; 5,'P!',PWR PWR: mov a, r2 rrc a mov P, c ajmp done_wr PRD: mov c, P ajmp done_rdc ; EA ( c -- ) ; 5,'EA!',EAWR EAWR: mov a, r2 rrc a mov EA, c ajmp done_wr EARD: mov c, EA ajmp done_rdc ; ET2 ( c -- ) ; 5,'ET2!',ET2WR ET2WR: mov a, r2 rrc a mov ET2, c ajmp done_wr ET2RD: mov c, ET2 ajmp done_rdc ; ES ( c -- ) ; 5,'ES!',ESWR ESWR: mov a, r2 rrc a mov ES, c ajmp done_wr ESRD: mov c, ES ajmp done_rdc ; ET1 ( c -- ) ; 5,'ET1!',ET1WR ET1WR: mov a, r2 rrc a mov ET1, c ajmp done_wr ET1RD: mov c, ET1 ajmp done_rdc ; EX1 ( c -- ) ; 5,'EX1!',EX1WR EX1WR: mov a, r2 rrc a mov EX1, c ajmp done_wr EX1RD: mov c, EX1 ajmp done_rdc ; ET0 ( c -- ) ; 5,'ET0!',ET0WR ET0WR: mov a, r2 rrc a mov ET0, c ajmp done_wr ET0RD: mov c, ET0 ajmp done_rdc ; EX0 ( c -- ) ; 5,'EX0!',EX0WR EX0WR: mov a, r2 rrc a mov EX0, c ajmp done_wr EX0RD: mov c, EX0 ajmp done_rdc ; PT2 ( c -- ) ; 5,'PT2!',PT2WR PT2WR: mov a, r2 rrc a mov PT2, c ajmp done_wr PT2RD: mov c, PT2 ajmp done_rdc ; PS ( c -- ) ; 5,'PS!',PSWR PSWR: mov a, r2 rrc a mov PS, c ajmp done_wr PSRD: mov c, PS ajmp done_rdc ; PT1 ( c -- ) ; 5,'PT1!',PT1WR PT1WR: mov a, r2 rrc a mov PT1, c ajmp done_wr PT1RD: mov c, PT1 ajmp done_rdc ; PX1 ( c -- ) ; 5,'PX1!',PX1WR PX1WR: mov a, r2 rrc a mov PX1, c ajmp done_wr PX1RD: mov c, PX1 ajmp done_rdc ; PT0 ( c -- ) ; 5,'PT0!',PT0WR PT0WR: mov a, r2 rrc a mov PT0, c ajmp done_wr PT0RD: mov c, PT0 ajmp done_rdc ; PX0 ( c -- ) ; 5,'PX0!',PX0WR PX0WR: mov a, r2 rrc a mov PX0, c ajmp done_wr PX0RD: mov c, PX0 ajmp done_rdc ; TF1 ( c -- ) ; 5,'TF1!',TF1WR TF1WR: mov a, r2 rrc a mov TF1, c ajmp done_wr TF1RD: mov c, TF1 ajmp done_rdc ; TR1 ( c -- ) ; 5,'TR1!',TR1WR TR1WR: mov a, r2 rrc a mov TR1, c ajmp done_wr TR1RD: mov c, TR1 ajmp done_rdc ; TF0 ( c -- ) ; 5,'TF0!',TF0WR TF0WR: mov a, r2 rrc a mov TF0, c ajmp done_wr TF0RD: mov c, TF0 ajmp done_rdc ; TR0 ( c -- ) ; 5,'TR0!',TR0WR TR0WR: mov a, r2 rrc a mov TR0, c ajmp done_wr TR0RD: mov c, TR0 ajmp done_rdc ; IE1 ( c -- ) ; 5,'IE1!',IE1WR IE1WR: mov a, r2 rrc a mov IE1, c ajmp done_wr IE1RD: mov c, IE1 ajmp done_rdc ; IT1 ( c -- ) ; 5,'IT1!',IT1WR IT1WR: mov a, r2 rrc a mov IT1, c ajmp done_wr IT1RD: mov c, IT1 ajmp done_rdc ; IE0 ( c -- ) ; 5,'IE0!',IE0WR IE0WR: mov a, r2 rrc a mov IE0, c ajmp done_wr IE0RD: mov c, IE0 ajmp done_rdc ; IT0 ( c -- ) ; 5,'IT0!',IT0WR IT0WR: mov a, r2 rrc a mov IT0, c ajmp done_wr IT0RD: mov c, IT0 ajmp done_rdc ; TF2 ( c -- ) ; 5,'TF2!',TF2WR TF2WR: mov a, r2 rrc a mov TF2, c ajmp done_wr TF2RD: mov c, TF2 ajmp done_rdc ; EXF2 ( c -- ) ; 5,'EXF2!',EXF2WR EXF2WR: mov a, r2 rrc a mov EXF2, c ajmp done_wr EXF2RD: mov c, EXF2 ajmp done_rdc ; RCLK ( c -- ) ; 5,'RCLK!',RCLKWR RCLKWR: mov a, r2 rrc a mov RCLK, c ajmp done_wr RCLKRD: mov c, RCLK ajmp done_rdc ; TCLK ( c -- ) ; 5,'TCLK!',TCLKWR TCLKWR: mov a, r2 rrc a mov TCLK, c ajmp done_wr TCLKRD: mov c, TCLK ajmp done_rdc ; EXEN2 ( c -- ) ; 5,'EXEN2!',EXEN2WR EXEN2WR: mov a, r2 rrc a mov EXEN2, c ajmp done_wr EXEN2RD: mov c, EXEN2 ajmp done_rdc ; TR2 ( c -- ) ; 5,'TR2!',TR2WR TR2WR: mov a, r2 rrc a mov TR2, c ajmp done_wr TR2RD: mov c, TR2 ajmp done_rdc ; C_T2 ( c -- ) ; 5,'C_T2!',C_T2WR C_T2WR: mov a, r2 rrc a mov C_T2, c ajmp done_wr C_T2RD: mov c, C_T2 ajmp done_rdc ; CP_RL2 ( c -- ) ; 5,'CP_RL2!',CP_RL2WR CP_RL2WR: mov a, r2 rrc a mov CP_RL2, c ajmp done_wr CP_RL2RD: mov c, CP_RL2 ajmp done_rdc ; SM0 ( c -- ) ; 5,'SM0!',SM0WR SM0WR: mov a, r2 rrc a mov SM0, c ajmp done_wr SM0RD: mov c, SM0 ajmp done_rdc ; SM1 ( c -- ) ; 5,'SM1!',SM1WR SM1WR: mov a, r2 rrc a mov SM1, c ajmp done_wr SM1RD: mov c, SM1 ajmp done_rdc ; SM2 ( c -- ) ; 5,'SM2!',SM2WR SM2WR: mov a, r2 rrc a mov SM2, c ajmp done_wr SM2RD: mov c, SM2 ajmp done_rdc ; REN ( c -- ) ; 5,'REN!',RENWR RENWR: mov a, r2 rrc a mov REN, c ajmp done_wr RENRD: mov c, REN ajmp done_rdc ; TB8 ( c -- ) ; 5,'TB8!',TB8WR TB8WR: mov a, r2 rrc a mov TB8, c ajmp done_wr TB8RD: mov c, TB8 ajmp done_rdc ; RB8 ( c -- ) ; 5,'RB8!',RB8WR RB8WR: mov a, r2 rrc a mov RB8, c ajmp done_wr RB8RD: mov c, RB8 ajmp done_rdc ; TI ( c -- ) ; 5,'TI!',TIWR TIWR: mov a, r2 rrc a mov TI, c ajmp done_wr TIRD: mov c, TI ajmp done_rdc ; RI ( c -- ) ; 5,'RI!',RIWR RIWR: mov a, r2 rrc a mov RI, c ajmp done_wr RIRD: mov c, RI ajmp done_rdc ;; System and user variables ; doVAR ( -- a ) ; Run time routine for VARIABLE and CREATE. ; $COLON COMPO+5,'doVAR',DOVAR DOVAR: xcall LISTT dw RFROM,EXIT ; UP ( -- a ) ; Pointer to the user area. ; $COLON 2,'UP',UP UP: ; xcall LISTT ; dw DOVAR ; dw UPP acall FDO_PUSH mov r2, #UPX&0xff mov r3, #UPX>>8 ljmp RETURN UPX: dw UPP ; doUSER ( -- a ) ; Run time routine for user variables. ; $COLON COMPO+6,'doUSER',DOUSE DOUSE: xcall LISTT dw RFROM,AT,UP,AT,PLUS,EXIT ; SP0 ( -- a ) ; Pointer to bottom of the data stack. ; $USER 3,'SP0',SZERO SZERO: ; xcall LISTT ; dw DOUSE,_USER ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER)&0xff mov r3, #(UPP+_USER)>>8 ljmp RETURN _USER1 = _USER+CELLL ;;update user area offset ; RP0 ( -- a ) ; Pointer to bottom of the return stack. ; $USER 3,'RP0',RZERO RZERO: ; xcall LISTT ; dw DOUSE,_USER1 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER1)&0xff mov r3, #(UPP+_USER1)>>8 ljmp RETURN _USER2 = _USER1+CELLL ;;update user area offset ; '?KEY ( -- a ) ; Execution vector of ?KEY. ; $USER 5,"'?KEY",TQKEY TQKEY: ; xcall LISTT ; dw DOUSE,_USER2 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER2)&0xff mov r3, #(UPP+_USER2)>>8 ljmp RETURN _USER3 = _USER2+CELLL ;;update user area offset ; 'EMIT ( -- a ) ; Execution vector of EMIT. ; $USER 5,"'EMIT",TEMIT TEMIT: ; xcall LISTT ; dw DOUSE,_USER3 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER3)&0xff mov r3, #(UPP+_USER3)>>8 ljmp RETURN _USER4 = _USER3+CELLL ;;update user area offset ; 'EXPECT ( -- a ) ; Execution vector of EXPECT. ; $USER 7,"'EXPECT",TEXPE TEXPE: ; xcall LISTT ; dw DOUSE,_USER4 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER4)&0xff mov r3, #(UPP+_USER4)>>8 ljmp RETURN _USER5 = _USER4+CELLL ;;update user area offset ; 'TAP ( -- a ) ; Execution vector of TAP. ; $USER 4,"'TAP",TTAP TTAP: ; xcall LISTT ; dw DOUSE,_USER5 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER5)&0xff mov r3, #(UPP+_USER5)>>8 ljmp RETURN _USER6 = _USER5+CELLL ;;update user area offset ; 'ECHO ( -- a ) ; Execution vector of ECHO. ; $USER 5,"'ECHO",TECHO TECHO: ; xcall LISTT ; dw DOUSE,_USER6 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER6)&0xff mov r3, #(UPP+_USER6)>>8 ljmp RETURN _USER7 = _USER6+CELLL ;;update user area offset ; 'PROMPT ( -- a ) ; Execution vector of PROMPT. ; $USER 7,"'PROMPT",TPROM TPROM: ; xcall LISTT ; dw DOUSE,_USER7 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER7)&0xff mov r3, #(UPP+_USER7)>>8 ljmp RETURN _USER8 = _USER7+CELLL ;;update user area offset ; BASE ( -- a ) ; Storage of the radix base for numeric I/O. ; $USER 4,'BASE',BASE BASE: ; xcall LISTT ; dw DOUSE,_USER8 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER8)&0xff mov r3, #(UPP+_USER8)>>8 ljmp RETURN _USER9 = _USER8+CELLL ;;update user area offset ; tmp ( -- a ) ; A temporary storage location used in parse and find. ; $USER COMPO+3,'tmp',TEMP TEMP: ; xcall LISTT ; dw DOUSE,_USER9 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER9)&0xff mov r3, #(UPP+_USER9)>>8 ljmp RETURN _USER10 = _USER9+CELLL ;;update user area offset ; SPAN ( -- a ) ; Hold character count received by EXPECT. ; $USER 4,'SPAN',SPAN SPAN: ; xcall LISTT ; dw DOUSE,_USER10 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER10)&0xff mov r3, #(UPP+_USER10)>>8 ljmp RETURN _USER11 = _USER10+CELLL ;;update user area offset ; >IN ( -- a ) ; Hold the character pointer while parsing input stream. ; $USER 3,'>IN',INN INN: ; xcall LISTT ; dw DOUSE,_USER11 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER11)&0xff mov r3, #(UPP+_USER11)>>8 ljmp RETURN _USER12 = _USER11+CELLL ;;update user area offset ; #TIB ( -- a ) ; Hold the current count and address of the terminal input buffer. ; $USER 4,'#TIB',NTIB NTIB: ; xcall LISTT ; dw DOUSE,_USER12 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER12)&0xff mov r3, #(UPP+_USER12)>>8 ljmp RETURN _USER13 = _USER12+2*CELLL ;;update user area offset ; _USER = _USER+CELLL ; CSP ( -- a ) ; Hold the stack pointer for error checking. ; $USER 3,'CSP',CSP CSP: ; xcall LISTT ; dw DOUSE,_USER13 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER13)&0xff mov r3, #(UPP+_USER13)>>8 ljmp RETURN _USER14 = _USER13+CELLL ;;update user area offset ; 'EVAL ( -- a ) ; Execution vector of EVAL. ; $USER 5,"'EVAL",TEVAL TEVAL: ; xcall LISTT ; dw DOUSE,_USER14 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER14)&0xff mov r3, #(UPP+_USER14)>>8 ljmp RETURN _USER15 = _USER14+CELLL ;;update user area offset ; 'NUMBER ( -- a ) ; Execution vector of NUMBER?. ; $USER 7,"'NUMBER",TNUMB TNUMB: ; xcall LISTT ; dw DOUSE,_USER15 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER15)&0xff mov r3, #(UPP+_USER15)>>8 ljmp RETURN _USER16 = _USER15+CELLL ;;update user area offset ; HLD ( -- a ) ; Hold a pointer in building a numeric output string. ; $USER 3,'HLD',HLD HLD: ; xcall LISTT ; dw DOUSE,_USER16 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER16)&0xff mov r3, #(UPP+_USER16)>>8 ljmp RETURN _USER17 = _USER16+CELLL ;;update user area offset ; HANDLER ( -- a ) ; Hold the return stack pointer for error handling. ; $USER 7,'HANDLER',HANDL HANDL: ; xcall LISTT ; dw DOUSE,_USER17 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER17)&0xff mov r3, #(UPP+_USER17)>>8 ljmp RETURN _USER18 = _USER17+CELLL ;;update user area offset ; CONTEXT ( -- a ) ; A area to specify vocabulary search order. ; $USER 7,'CONTEXT',CNTXT CNTXT: ; xcall LISTT ; dw DOUSE,_USER18 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER18)&0xff mov r3, #(UPP+_USER18)>>8 ljmp RETURN _USER19 = _USER18+CELLL+VOCSS*CELLL ;;update user area offset ; _USER = _USER+VOCSS*CELLL ;vocabulary stack ; CURRENT ( -- a ) ; Point to the vocabulary to be extended. ; $USER 7,'CURRENT',CRRNT CRRNT: ; xcall LISTT ; dw DOUSE,_USER19 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER19)&0xff mov r3, #(UPP+_USER19)>>8 ljmp RETURN _USER20 = _USER19+2*CELLL ;;update user area offset ;_USER = _USER+CELLL ;vocabulary link pointer ; CP ( -- a ) ; Point to the top of the code dictionary. ; $USER 2,'CP',CP CP: ; xcall LISTT ; dw DOUSE,_USER20 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER20)&0xff mov r3, #(UPP+_USER20)>>8 ljmp RETURN _USER21 = _USER20+CELLL ;;update user area offset ; NP ( -- a ) ; Point to the bottom of the name dictionary. ; $USER 2,'NP',NP NP: ; xcall LISTT ; dw DOUSE,_USER21 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER21)&0xff mov r3, #(UPP+_USER21)>>8 ljmp RETURN _USER22 = _USER21+CELLL ;;update user area offset ; LAST ( -- a ) ; Point to the last name in the name dictionary. ; $USER 4,'LAST',LAST LAST: ; xcall LISTT ; dw DOUSE,_USER22 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER22)&0xff mov r3, #(UPP+_USER22)>>8 ljmp RETURN _USER23 = _USER22+CELLL ;;update user area offset ; forth ( -- a ) ; Point to the last name in the name dictionary. ; $USER 5,'forth',VFRTH VFRTH: ; xcall LISTT ; dw DOUSE,_USER23 ;;followed by doUSER and offset acall FDO_PUSH mov r2, #(UPP+_USER23)&0xff mov r3, #(UPP+_USER23)>>8 ljmp RETURN _USER24 = _USER23+CELLL ;;update user area offset ;; Common functions ; FORTH ( -- ) ; Make FORTH the context vocabulary. ; $COLON 5,'FORTH',FORTH FORTH: xcall LISTT dw VFRTH,CNTXT,STORE,EXIT ; ?DUP ( w -- w w | 0 ) ; Dup tos if its is not zero. ; $COLON 4,'?DUP',QDUP QDUP: ; xcall LISTT ; dw DUPP ; dw QBRAN,QDUP1 ; dw DUPP ;QDUP1: dw EXIT mov a, r2 jnz QDUP1a mov a, r3 jz QDUP2a QDUP1a: mov a,r3 movx @r1,a dec r1 mov a, r2 movx @r1,a dec r1 QDUP2a: ljmp RETURN ; ROT ( w1 w2 w3 -- w2 w3 w1 ) ; Rot 3rd item to top. ; $COLON 3,'ROT',ROT ROT: xcall LISTT dw TOR,SWAP,RFROM,SWAP,EXIT ; 2DROP ( w w -- ) ; Discard two items on stack. ; $COLON 5,'2DROP',DDROP DDROP: ; xcall LISTT ; dw DROP,DROP,EXIT inc r1 inc r1 ajmp DROP ; 2DUP ( w1 w2 -- w1 w2 w1 w2 ) ; Duplicate top two items. ; $COLON 4,'2DUP',DDUP DDUP: xcall LISTT dw OVER,OVER,EXIT ; + ( w w -- sum ) ; Add top two items. ; $COLON 1,'+',PLUS PLUS: ; xcall LISTT ; dw UPLUS,DROP,EXIT inc r1 movx a,@r1 add a,r2 mov r2,a inc r1 movx a,@r1 addc a,r3 mov r3,a ljmp RETURN ; D+ ( d d -- d ) ; Double addition, as an example using UM+. ; ; $COLON 2,'D+',DPLUS ; DW TOR,SWAP,TOR,UPLUS ; DW RFROM,RFROM,PLUS,PLUS,EXIT ; NOT ( w -- w ) ; One's complement of tos. ; $COLON 3,'NOT',INVER INVER: ; xcall LISTT ; dw DOLIT,0xffff,XORR,EXIT xrl 2,#0xff xrl 3,#0xff ljmp RETURN ; NEGATE ( n -- -n ) ; Two's complement of tos. ; $COLON 6,'NEGATE',NEGAT NEGAT: ; xcall LISTT ; dw INVER,DOLIT,1,PLUS,EXIT do_fneg:clr a clr c subb a, r2 mov r2, a clr a subb a, r3 mov r3, a ljmp RETURN ; DNEGATE ( d -- -d ) ; Two's complement of top double. ; $COLON 7,'DNEGATE',DNEGA DNEGA: xcall LISTT dw INVER,TOR,INVER dw DOLIT,1,UPLUS dw RFROM,PLUS,EXIT ; - ( n1 n2 -- n1-n2 ) ; Subtraction. ; $COLON 1,'-',SUBB SUBB: ; xcall LISTT ; dw NEGAT,PLUS,EXIT inc r1 movx a,@r1 clr c subb a,r2 mov r2,a inc r1 movx a,@r1 subb a,r3 mov r3,a ljmp RETURN ; ABS ( n -- n ) ; Return the absolute value of n. ; $COLON 3,'ABS',ABSS ABSS: ; xcall LISTT ; dw DUPP,ZLESS ; dw QBRAN,ABS1 ; dw NEGAT ;ABS1: dw EXIT mov a, r3 jb acc.7, do_fneg ljmp RETURN ; = ( w w -- t ) ; Return true if top two are equal. ; $COLON 1,'=',EQUAL EQUAL: ; xcall LISTT ; dw XORR ; dw QBRAN,EQU1 ; dw DOLIT,0,EXIT ;false flag ;EQU1: dw DOLIT,0xffff,EXIT ;true flag inc r1 movx a,@r1 xrl a,r2 jnz EQ1 inc r1 movx a,@r1 xrl a,r3 jnz EQ2 mov r3, #0xff mov r2, #0xff ljmp RETURN EQ1: inc r1 EQ2: mov r2, #0 mov r3, #0 ljmp RETURN ; U< ( u u -- t ) ; Unsigned compare of top two items. ; $COLON 2,'U<',ULESS ULESS: xcall LISTT dw DDUP,XORR,ZLESS dw QBRAN,ULES1 dw SWAP,DROP,ZLESS,EXIT ULES1: dw SUBB,ZLESS,EXIT ; < ( n1 n2 -- t ) ; Signed compare of top two items. ; $COLON 1,'<',LESS LESS: xcall LISTT .even dw DDUP,XORR,ZLESS dw QBRAN,LESS1 dw DROP,ZLESS,EXIT LESS1: dw SUBB,ZLESS,EXIT ; MAX ( n n -- n ) ; Return the greater of two top stack items. ; $COLON 3,'MAX',MAX MAX: xcall LISTT .even dw DDUP,LESS dw QBRAN,MAX1 dw SWAP MAX1: dw DROP,EXIT ; MIN ( n n -- n ) ; Return the smaller of top two stack items. ; $COLON 3,'MIN',MIN MIN: xcall LISTT .even dw DDUP,SWAP,LESS dw QBRAN,MIN1 dw SWAP MIN1: dw DROP,EXIT ; WITHIN ( u ul uh -- t ) ; Return true if u is within the range of ul and uh. ; $COLON 6,'WITHIN',WITHI WITHI: xcall LISTT .even dw OVER,SUBB,TOR ;ul <= u < uh dw SUBB,RFROM,ULESS,EXIT ;; Divide ; UM/MOD ( udl udh u -- ur uq ) ; Unsigned divide of a double by a single. Return mod and quotient. ; $COLON 6,'UM/MOD',UMMOD UMMOD: xcall LISTT .even dw DDUP,ULESS dw QBRAN,UMM4 dw NEGAT,DOLIT,15,TOR UMM1: dw TOR,DUPP,UPLUS dw TOR,TOR,DUPP,UPLUS dw RFROM,PLUS,DUPP dw RFROM,RAT,SWAP,TOR dw UPLUS,RFROM,ORR dw QBRAN,UMM2 dw TOR,DROP,DOLIT,1,PLUS,RFROM dw BRAN,UMM3 UMM2: dw DROP UMM3: dw RFROM dw DONXT,UMM1 dw DROP,SWAP,EXIT UMM4: dw DROP,DDROP dw DOLIT,0xffff,DUPP,EXIT ;overflow, return max ; M/MOD ( d n -- r q ) ; Signed floored divide of double by single. Return mod and quotient. ; $COLON 5,'M/MOD',MSMOD MSMOD: xcall LISTT .even dw DUPP,ZLESS,DUPP,TOR dw QBRAN,MMOD1 dw NEGAT,TOR,DNEGA,RFROM MMOD1: dw TOR,DUPP,ZLESS dw QBRAN,MMOD2 dw RAT,PLUS MMOD2: dw RFROM,UMMOD,RFROM dw QBRAN,MMOD3 dw SWAP,NEGAT,SWAP MMOD3: dw EXIT ; /MOD ( n n -- r q ) ; Signed divide. Return mod and quotient. ; $COLON 4,'/MOD',SLMOD SLMOD: xcall LISTT .even dw OVER,ZLESS,SWAP,MSMOD,EXIT ; MOD ( n n -- r ) ; Signed divide. Return mod only. ; $COLON 3,'MOD',MODD MOD: xcall LISTT .even dw SLMOD,DROP,EXIT ; / ( n n -- q ) ; Signed divide. Return quotient only. ; $COLON 1,'/',SLASH SLASH: xcall LISTT .even dw SLMOD,SWAP,DROP,EXIT ;; Multiply ; UM* ( u u -- ud ) ; Unsigned multiply. Return double product. ; $COLON 3,'UM*',UMSTA UMSTA: xcall LISTT .even dw DOLIT,0,SWAP,DOLIT,15,TOR UMST1: dw DUPP,UPLUS,TOR,TOR dw DUPP,UPLUS,RFROM,PLUS,RFROM dw QBRAN,UMST2 dw TOR,OVER,UPLUS,RFROM,PLUS UMST2: dw DONXT,UMST1 dw ROT,DROP,EXIT ; * ( n n -- n ) ; Signed multiply. Return single product. ; $COLON 1,'*',STAR STAR: xcall LISTT .even dw UMSTA,DROP,EXIT ; M* ( n n -- d ) ; Signed multiply. Return double product. ; $COLON 2,'M*',MSTAR MSTAR: xcall LISTT .even dw DDUP,XORR,ZLESS,TOR dw ABSS,SWAP,ABSS,UMSTA dw RFROM dw QBRAN,MSTA1 dw DNEGA MSTA1: dw EXIT ; */MOD ( n1 n2 n3 -- r q ) ; Multiply n1 and n2, then divide by n3. Return mod and quotient. ; $COLON 5,'*/MOD',SSMOD SSMOD: xcall LISTT .even dw TOR,MSTAR,RFROM,MSMOD,EXIT ; */ ( n1 n2 n3 -- q ) ; Multiply n1 by n2, then divide by n3. Return quotient only. ; $COLON 2,'*/',STASL STASL: xcall LISTT .even dw SSMOD,SWAP,DROP,EXIT ;; Miscellaneous ; CELL+ ( a -- a ) ; Add cell size in byte to address. ; $COLON 5,'CELL+',CELLP CELLP: ; xcall LISTT ; .even ; dw DOLIT,CELLL,PLUS,EXIT mov a, r2 add a, #2 mov r2, a mov a, r3 addc a, #0 mov r3, a ljmp RETURN ; CELL- ( a -- a ) ; Subtract cell size in byte from address. ; $COLON 5,'CELL-',CELLM CELLM: ; xcall LISTT ; .even ; dw DOLIT,(0-CELLL)&0xffff,PLUS,EXIT clr c mov a, r2 subb a, #2 mov r2, a mov a, r3 subb a, #0 mov r3, a ljmp RETURN ; CELLS ( n -- n ) ; Multiply tos by cell size in bytes. ; $COLON 5,'CELLS',CELLS CELLS: ; xcall LISTT ; .even ; dw DOLIT,CELLL,STAR,EXIT clr c mov a, r2 rlc a mov r2, a mov a, r3 rlc a mov r3, a ljmp RETURN ; ALIGNED ( b -- a ) ; Align address to the cell boundary. ; $COLON 7,'ALIGNED',ALGND ALGND: ; xcall LISTT ; .even ; dw DUPP,DOLIT,0,DOLIT,CELLL ; dw UMMOD,DROP,DUPP ; dw QBRAN,ALGN1 ; dw DOLIT,CELLL,SWAP,SUBB ;ALGN1: dw PLUS,EXIT mov a, r2 jnb ACC.0, ALGN1 inc r2 ALGN1: ljmp RETURN ; BL ( -- 32 ) ; Return 32, the blank character. ; $COLON 2,'BL',BLANK BLANK: ; xcall LISTT ; .even ; dw DOLIT,' ',EXIT lcall FDO_PUSH mov r2, #' ' mov r3, #0 ljmp RETURN ; >CHAR ( c -- c ) ; Filter non-printing characters. ; $COLON 5,'>CHAR',TCHAR TCHAR: ; xcall LISTT ; .even ; dw DOLIT,0x7F,ANDD,DUPP ;mask msb ; dw DOLIT,127,BLANK,WITHI ;check for printable ; dw QBRAN,TCHA1 ; dw DROP,DOLIT,'_' ;replace non-printables ;TCHA1: dw EXIT anl 2, #0x7f mov r3, #0 cjne r2, #' ', TCHA1a TCHA1a: jnc TCHA2 mov r2, #'_' TCHA2: ljmp RETURN ; DEPTH ( -- n ) ; Return the depth of the data stack. ; $COLON 5,'DEPTH',DEPTH DEPTH: xcall LISTT .even dw SPAT,SZERO,AT,SWAP,SUBB dw DOLIT,CELLL,SLASH,EXIT ; PICK ( ... +n -- ... w ) ; Copy the nth stack item to tos. ; $COLON 4,'PICK',PICK PICK: xcall LISTT .even dw DOLIT,1,PLUS,CELLS dw DOLIT,1,PLUS dw SPAT,PLUS,AT,EXIT ;; Memory access ; +! ( n a -- ) ; Add n to the contents at address a. ; $COLON 2,'+!',PSTOR PSTOR: xcall LISTT .even dw SWAP,OVER,AT,PLUS dw SWAP,STORE,EXIT ; 2! ( d a -- ) ; Store the double integer to address a. ; $COLON 2,'2!',DSTOR DSTOR: xcall LISTT .even dw SWAP,OVER,STORE dw CELLP,STORE,EXIT ; 2@ ( a -- d ) ; Fetch double integer from address a. ; $COLON 2,'2@',DAT DAT: xcall LISTT .even dw DUPP,CELLP,AT dw SWAP,AT,EXIT ; COUNT ( b -- b +n ) ; Return count byte of a string and add 1 to byte address. ; $COLON 5,'COUNT',COUNTX COUNTX: ; xcall LISTT ; .even ; dw DUPP,DOLIT,1,PLUS ; dw SWAP,CAT,EXIT mov dpl, r2 mov dph, r3 inc r2 cjne r2, #0, CTX1 inc r3 CTX1: lcall FDO_PUSH mov r3, #0 movx a, @dptr mov r2, a ljmp RETURN ; HERE ( -- a ) ; Return the top of the code dictionary. ; $COLON 4,'HERE',HERE HERE: xcall LISTT .even dw CP,AT,EXIT ; PAD ( -- a ) ; Return the address of a temporary buffer. ; $COLON 3,'PAD',PAD PAD: xcall LISTT .even dw HERE,DOLIT,80,PLUS,EXIT ; TIB ( -- a ) ; Return the address of the terminal input buffer. ; $COLON 3,'TIB',TIB TIB: xcall LISTT .even dw NTIB,CELLP,AT,EXIT ; @EXECUTE ( a -- ) ; Execute vector stored in address a. ; $COLON 8,'@EXECUTE',ATEXE ATEXE: xcall LISTT dw AT,QDUP ;?address or zero dw QBRAN,EXE1 dw EXECU ;execute if non-zero EXE1: dw EXIT ;do nothing if zero ; CMOVE ( b1 b2 u -- ) ; Copy u bytes from b1 to b2. ; $COLON 5,'CMOVE',CMOVE CMOVE: xcall LISTT .even dw TOR dw BRAN,CMOV2 CMOV1: dw TOR,DUPP,CAT dw RAT,CSTOR dw DOLIT,1,PLUS dw RFROM,DOLIT,1,PLUS CMOV2: dw DONXT,CMOV1 dw DDROP,EXIT ; FILL ( b u c -- ) ; Fill u bytes of character c to area beginning at b. ; $COLON 4,'FILL',FILL FILL: xcall LISTT .even ; dw SWAP,TOR,SWAP ; dw BRAN,FILL2 ;FILL1: dw DDUP,CSTOR,DOLIT,1,PLUS ;FILL2: dw DONXT,FILL1 ; dw DDROP,EXIT mov r4, r2 lcall FDO_POP inc r1 movx a,@r1 mov dpl, a inc r1 movx a,@r1 mov dph, a mov a, r2 jnz FILL1b mov a, r3 jz FILL2a mov a, r4 FILL1b: inc r3 FILL1a: movx @dptr, a inc dptr djnz r2, FILL1a inc dptr djnz r3, FILL1a FILL2a: ljmp DROP ; -TRAILING ( b u -- b u ) ; Adjust the count to eliminate trailing white space. ; $COLON 9,'-TRAILING',DTRAI DTRAI: xcall LISTT .even dw TOR dw BRAN,DTRA2 DTRA1: dw BLANK,OVER,RAT,PLUS,CAT,LESS dw QBRAN,DTRA2 dw RFROM,DOLIT,1,PLUS,EXIT ;adjusted count DTRA2: dw DONXT,DTRA1 dw DOLIT,0,EXIT ;count=0 ; PACK$ ( b u a -- a ) ; Build a counted string with u characters from b. Null fill. ; $COLON 5,'PACK$',PACKS PACKS: xcall LISTT .even dw ALGND,DUPP,TOR ;strings only on cell boundary dw OVER,DUPP,DOLIT,0 dw DOLIT,CELLL,UMMOD,DROP ;count mod cell dw SUBB,OVER,PLUS dw DOLIT,0,SWAP,STORE ;null fill cell dw DDUP,CSTOR,DOLIT,1,PLUS ;save count dw SWAP,CMOVE,RFROM,EXIT ;move string ;; Numeric output, single precision ; DIGIT ( u -- c ) ; Convert digit u to a character. ; $COLON 5,'DIGIT',DIGIT DIGIT: xcall LISTT .even dw DOLIT,9,OVER,LESS dw DOLIT,7,ANDD,PLUS dw DOLIT,'0',PLUS,EXIT ; EXTRACT ( n base -- n c ) ; Extract the least significant digit from n. ; $COLON 7,'EXTRACT',EXTRC EXTRC: xcall LISTT .even dw DOLIT,0,SWAP,UMMOD dw SWAP,DIGIT,EXIT ; <# ( -- ) ; Initiate the numeric output process. ; $COLON 2,'<#',BDIGS BDIGS: xcall LISTT .even dw PAD,HLD,STORE,EXIT ; HOLD ( c -- ) ; Insert a character into the numeric output string. ; $COLON 4,'HOLD',HOLD HOLD: xcall LISTT .even dw HLD,AT,DOLIT,1,SUBB dw DUPP,HLD,STORE,CSTOR,EXIT ; # ( u -- u ) ; Extract one digit from u and append the digit to output string. ; $COLON 1,'#',DIG DIG: xcall LISTT .even dw BASE,AT,EXTRC,HOLD,EXIT ; #S ( u -- 0 ) ; Convert u until all digits are added to the output string. ; $COLON 2,'#S',DIGS DIGS: xcall LISTT .even DIGS1: dw DIG,DUPP dw QBRAN,DIGS2 dw BRAN,DIGS1 DIGS2: dw EXIT ; SIGN ( n -- ) ; Add a minus sign to the numeric output string. ; $COLON 4,'SIGN',SIGN SIGN: xcall LISTT .even dw ZLESS dw QBRAN,SIGN1 dw DOLIT,'-',HOLD SIGN1: dw EXIT ; #> ( w -- b u ) ; Prepare the output string to be TYPE'd. ; $COLON 2,'#>',EDIGS EDIGS: xcall LISTT .even dw DROP,HLD,AT dw PAD,OVER,SUBB,EXIT ; str ( n -- b u ) ; Convert a signed integer to a numeric string. ; $COLON 3,'str',STR STR: xcall LISTT .even dw DUPP,TOR,ABSS dw BDIGS,DIGS,RFROM dw SIGN,EDIGS,EXIT ; HEX ( -- ) ; Use radix 16 as base for numeric conversions. ; $COLON 3,'HEX',HEX HEX: xcall LISTT .even dw DOLIT,16,BASE,STORE,EXIT ; DECIMAL ( -- ) ; Use radix 10 as base for numeric conversions. ; $COLON 7,'DECIMAL',DECIM DECIM: xcall LISTT .even dw DOLIT,10,BASE,STORE,EXIT ;; Numeric input, single precision ; DIGIT? ( c base -- u t ) ; Convert a character to its numeric value. A flag indicates success. ; $COLON 6,'DIGIT?',DIGTQ DIGTQ: xcall LISTT .even dw TOR,DOLIT,'0',SUBB dw DOLIT,9,OVER,LESS dw QBRAN,DGTQ1 dw DOLIT,7,SUBB dw DUPP,DOLIT,10,LESS,ORR DGTQ1: dw DUPP,RFROM,ULESS,EXIT ; NUMBER? ( a -- n T | a F ) ; Convert a number string to integer. Push a flag on tos. ; $COLON 7,'NUMBER?',NUMBQ NUMBQ: xcall LISTT .even dw BASE,AT,TOR,DOLIT,0,OVER,COUNTX dw OVER,CAT,DOLIT,'$',EQUAL dw QBRAN,NUMQ1 dw HEX,SWAP,DOLIT,1,PLUS dw SWAP,DOLIT,1,SUBB NUMQ1: dw OVER,CAT,DOLIT,'-',EQUAL,TOR dw SWAP,RAT,SUBB,SWAP,RAT,PLUS,QDUP dw QBRAN,NUMQ6 dw DOLIT,1,SUBB,TOR NUMQ2: dw DUPP,TOR,CAT,BASE,AT,DIGTQ dw QBRAN,NUMQ4 dw SWAP,BASE,AT,STAR,PLUS,RFROM dw DOLIT,1,PLUS dw DONXT,NUMQ2 dw RAT,SWAP,DROP dw QBRAN,NUMQ3 dw NEGAT NUMQ3: dw SWAP dw BRAN,NUMQ5 NUMQ4: dw RFROM,RFROM,DDROP,DDROP,DOLIT,0 NUMQ5: dw DUPP NUMQ6: dw RFROM,DDROP dw RFROM,BASE,STORE,EXIT ;; Basic I/O ; ?KEY ( -- c T | F ) ; Return input character and true, or a false if no input. ; $COLON 4,'?KEY',QKEY QKEY: xcall LISTT .even dw TQKEY,ATEXE dw EXIT ; KEY ( -- c ) ; Wait for and return an input character. ; $COLON 3,'KEY',KEY KEY: xcall LISTT .even KEY1: dw QKEY dw QBRAN,KEY1 dw EXIT ; EMIT ( c -- ) ; Send a character to the output device. ; $COLON 4,'EMIT',EMIT EMIT: xcall LISTT .even dw TEMIT,ATEXE,EXIT ; NUF? ( -- t ) ; Return false if no input, else pause and if CR return true. ; $COLON 4,'NUF?',NUFQ NUFQ: xcall LISTT .even dw QKEY,DUPP dw QBRAN,NUFQ1 dw DDROP,KEY,DOLIT,CRR,EQUAL NUFQ1: dw EXIT ; PACE ( -- ) ; Send a pace character for the file downloading process. ; $COLON 4,'PACE',PACE PACE: xcall LISTT .even dw DOLIT,11,EMIT,EXIT ; SPACE ( -- ) ; Send the blank character to the output device. ; $COLON 5,'SPACE',SPACE SPACE: xcall LISTT .even dw BLANK,EMIT,EXIT ; SPACES ( +n -- ) ; Send n spaces to the output device. ; $COLON 6,'SPACES',SPACS SPACS: xcall LISTT .even dw DOLIT,0,MAX,TOR dw BRAN,CHAR2 CHAR1: dw SPACE CHAR2: dw DONXT,CHAR1 dw EXIT ; TYPE ( b u -- ) ; Output u characters from b. ; $COLON 4,'TYPE',TYPEE TYPEE: xcall LISTT .even dw TOR dw BRAN,TYPE2 TYPE1: dw DUPP,CAT,EMIT dw DOLIT,1,PLUS TYPE2: dw DONXT,TYPE1 dw DROP,EXIT ; CR ( -- ) ; Output a carriage return and a line feed. ; $COLON 2,'CR',CR XXCR: xcall LISTT .even dw DOLIT,CRR,EMIT dw DOLIT,LF,EMIT,EXIT ; do$ ( -- a ) ; Return the address of a compiled string. ; $COLON COMPO+3,'do$',DOSTR DOSTR: xcall LISTT .even dw RFROM,RAT,RFROM,COUNTX,PLUS dw ALGND,TOR,SWAP,TOR,EXIT ; $"| ( -- a ) ; Run time routine compiled by $". Return address of a compiled string. ; $COLON COMPO+3,'$"|',STRQP STRQP: xcall LISTT .even dw DOSTR,EXIT ;force a call to do$ ; ."| ( -- ) ; Run time routine of ." . Output a compiled string. ; $COLON COMPO+3,'."|',DOTQP DOTQP: xcall LISTT dw DOSTR dw COUNTX dw TYPEE dw EXIT ; .R ( n +n -- ) ; Display an integer in a field of n columns, right justified. ; $COLON 2,'.R',DOTR DOTR: xcall LISTT .even dw TOR,STR,RFROM,OVER,SUBB dw SPACS,TYPEE,EXIT ; U.R ( u +n -- ) ; Display an unsigned integer in n column, right justified. ; $COLON 3,'U.R',UDOTR UDOTR: xcall LISTT .even dw TOR,BDIGS,DIGS,EDIGS dw RFROM,OVER,SUBB dw SPACS,TYPEE,EXIT ; U. ( u -- ) ; Display an unsigned integer in free format. ; $COLON 2,'U.',UDOT UDOT: xcall LISTT .even dw BDIGS,DIGS,EDIGS dw SPACE,TYPEE,EXIT ; . ( w -- ) ; Display an integer in free format, preceeded by a space. ; $COLON 1,'.',DOT DOT: xcall LISTT .even dw BASE,AT,DOLIT,10,XORR ;?decimal dw QBRAN,DOT1 dw UDOT,EXIT ;no, display unsigned DOT1: dw STR,SPACE,TYPEE,EXIT ;yes, display signed ; ? ( a -- ) ; Display the contents in a memory cell. ; $COLON 1,'?',QUEST QUEST: xcall LISTT .even dw AT,DOT,EXIT ;; Parsing ; parse ( b u c -- b u delta ; ) ; Scan string delimited by c. Return found string and its offset. ; $COLON 5,'parse',PARS PARS: xcall LISTT .even dw TEMP,STORE,OVER,TOR,DUPP dw QBRAN,PARS8 dw DOLIT,1,SUBB,TEMP,AT,BLANK,EQUAL dw QBRAN,PARS3 dw TOR PARS1: dw BLANK,OVER,CAT ;skip leading blanks ONLY dw SUBB,ZLESS,INVER dw QBRAN,PARS2 dw DOLIT,1,PLUS dw DONXT,PARS1 dw RFROM,DROP,DOLIT,0,DUPP,EXIT PARS2: dw RFROM PARS3: dw OVER,SWAP dw TOR PARS4: dw TEMP,AT,OVER,CAT,SUBB ;scan for delimiter dw TEMP,AT,BLANK,EQUAL dw QBRAN,PARS5 dw ZLESS PARS5: dw QBRAN,PARS6 dw DOLIT,1,PLUS dw DONXT,PARS4 dw DUPP,TOR dw BRAN,PARS7 PARS6: dw RFROM,DROP,DUPP dw DOLIT,1,PLUS,TOR PARS7: dw OVER,SUBB dw RFROM,RFROM,SUBB,EXIT PARS8: dw OVER,RFROM,SUBB,EXIT ; PARSE ( c -- b u ; ) ; Scan input stream and return counted string delimited by c. ; $COLON 5,'PARSE',PARSE PARSE: xcall LISTT .even dw TOR,TIB,INN,AT,PLUS ;current input buffer pointer dw NTIB,AT,INN,AT,SUBB ;remaining count dw RFROM,PARS,INN,PSTOR,EXIT ; .( ( -- ) ; Output following string up to next ) . ; $COLON IMEDD+2,'.(',DOTPR DOTPR: xcall LISTT .even dw DOLIT,')',PARSE,TYPEE,EXIT ; ( ( -- ) ; Ignore following string up to next ) . A comment. ; $COLON IMEDD+1,'(',PAREN PAREN: xcall LISTT .even dw DOLIT,')',PARSE,DDROP,EXIT ; \ ( -- ) ; Ignore following text till the end of line. ; $COLON IMEDD+1,'\',BKSLA BKSLA: xcall LISTT .even dw NTIB,AT,INN,STORE,EXIT ; CHAR ( -- c ) ; Parse next word and return its first character. ; $COLON 4,'CHAR',CHAR CHAR: xcall LISTT .even dw BLANK,PARSE,DROP,CAT,EXIT ; TOKEN ( -- a ; ) ; Parse a word from input stream and copy it to name dictionary. ; $COLON 5,'TOKEN',TOKEN TOKEN: xcall LISTT .even dw BLANK,PARSE,DOLIT,31,MIN dw NP,AT,OVER,SUBB,CELLM dw PACKS,EXIT ; WORD ( c -- a ; ) ; Parse a word from input stream and copy it to code dictionary. ; $COLON 4,'WORD',WORDD WORDD: xcall LISTT .even dw PARSE,HERE,PACKS,EXIT ;; Dictionary search ; NAME> ( na -- ca ) ; Return a code address given a name address. ; $COLON 5,'NAME>',NAMET NAMET: ; xcall LISTT ; .even ; dw CELLM,CELLM,AT,EXIT clr c mov a, r2 subb a, #4 mov dpl, a mov a, r3 subb a, #0 mov dph, a movx a, @dptr mov r2, a inc dptr movx a, @dptr mov r3, a ljmp RETURN ; SAME? ( a a u -- a a f \ -0+ ) ; Compare u cells in two strings. Return 0 if identical. ; $COLON 5,'SAME?',SAMEQ SAMEQ: xcall LISTT .even dw TOR dw BRAN,SAME2 SAME1: dw OVER,RAT,CELLS,PLUS,AT dw OVER,RAT,CELLS,PLUS,AT dw SUBB,QDUP dw QBRAN,SAME2 dw RFROM,DROP,EXIT ;strings not equal SAME2: dw DONXT,SAME1 dw DOLIT,0,EXIT ;strings equal ; find ( a va -- ca na | a F ) ; Search a vocabulary for a string. Return ca and na if succeeded. ; entries look like ; dw QCSP, XXLL209 ;XXLL210: ; db 4, "?CSP\z" ; ; $COLON 4,'find',FIND FIND: push 7 push 6 push 5 push 0 inc r1 ; pop string into TM2:TM1 movx a,@r1 ; r3:r2 = vocab mov r6, a inc r1 movx a,@r1 mov r7,a FINDA1: cjne r2, #0, FINDA8 ; end of vocab list? cjne r3, #0, FINDA8 mov p2, SPH mov a, r7 movx @r1, a dec r1 mov a, r6 movx @r1, a dec r1 mov r2, #0 mov r3, #0 pop 0 pop 5 pop 6 pop 7 ljmp RETURN FINDA8: mov dpl, r2 ; point to vocab entry mov dph, r3 mov p2, r7 ; reset string mov r0, r6 movx a, @r0 ; a = length of string mov r4, a movx a, @dptr anl a, #0x1f xrl a, r4 jnz FINDA2 ; branch if different lengths FINDA4: inc dptr ; increment pointers inc r0 jnc FINDA3 mov a, r7 inc a mov p2, a FINDA3: movx a, @r0 ; get each char mov r5, a movx a, @dptr xrl a, r5 jnz FINDA2 ; branch if different djnz r4, FINDA4 clr c mov p2, SPH mov a, r2 subb a, #4 ; if we got here we found it mov dpl, a mov a, r3 subb a, #0 mov dph, a movx a, @dptr mov r6, a inc dptr movx a, @dptr movx @r1, a dec r1 mov a, r6 movx @r1, a dec r1 pop 0 pop 5 pop 6 pop 7 ljmp RETURN FINDA2: clr c mov a, r2 subb a, #2 ; if we got here we found it mov dpl, a mov a, r3 subb a, #0 mov dph, a movx a, @dptr mov r2, a inc dptr movx a, @dptr mov r3, a ljmp FINDA1 ; xcall LISTT ; .even ; string vocab ; ;dw SWAP,DUPP,CAT ; vocab string *string(len) ; ;dw DOLIT,CELLL,SLASH,TEMP,STORE ; vocab string temp=*string/2 ; ; dw DUPP,AT,TOR,CELLP,SWAP ; string vocab ret=*string ;FIND1: dw AT,DUPP ; string *vocab *vocab ; dw QBRAN,FIND6 ; if NULL goto FIND6 ; dw DUPP,AT,DOLIT,MASKK,ANDD,RAT,XORR ; string *vocab **vocal&MASKK^*string/2 ; dw QBRAN,FIND2 ; if (0) goto find2 ; dw CELLP,DOLIT,0xffff ;true flag ; dw BRAN,FIND3 ;FIND2: dw CELLP,TEMP,AT,SAMEQ ;FIND3: dw BRAN,FIND4 ;FIND6: dw RFROM,DROP ; dw SWAP,CELLM,SWAP,EXIT ;FIND4: dw QBRAN,FIND5 ; dw CELLM,CELLM ; dw BRAN,FIND1 ;FIND5: dw RFROM,DROP,SWAP,DROP ; dw CELLM ; dw DUPP,NAMET,SWAP,EXIT ; NAME? ( a -- ca na | a F ) ; Search all context vocabularies for a string. ; $COLON 5,'NAME?',NAMEQ NAMEQ: xcall LISTT .even dw CNTXT,DUPP,DAT,XORR ;?context=also dw QBRAN,NAMQ1 dw CELLM ;no, start with context NAMQ1: dw TOR NAMQ2: dw RFROM,CELLP,DUPP,TOR ;next in search order dw AT,QDUP dw QBRAN,NAMQ3 dw FIND,QDUP ;search vocabulary dw QBRAN,NAMQ2 dw RFROM,DROP,EXIT ;found name NAMQ3: dw RFROM,DROP ;name not found dw DOLIT,0,EXIT ;false flag ;; Terminal response ; ^H ( bot eot cur -- bot eot cur ) ; Backup the cursor by one character. ; $COLON 2,'^H',BKSP BKSP: xcall LISTT .even dw TOR,OVER,RFROM,SWAP,OVER,XORR dw QBRAN,BACK1 dw DOLIT,BKSPP,TECHO,ATEXE,DOLIT,1,SUBB dw BLANK,TECHO,ATEXE dw DOLIT,BKSPP,TECHO,ATEXE BACK1: dw EXIT ; TAP ( bot eot cur c -- bot eot cur ) ; Accept and echo the key stroke and bump the cursor. ; $COLON 3,'TAP',TAP TAP: xcall LISTT .even dw DUPP,TECHO,ATEXE dw OVER,CSTOR,DOLIT,1,PLUS,EXIT ; kTAP ( bot eot cur c -- bot eot cur ) ; Process a key stroke, CR or backspace. ; $COLON 4,'kTAP',KTAP KTAP: xcall LISTT .even dw DUPP,DOLIT,CRR,XORR dw QBRAN,KTAP2 dw DOLIT,BKSPP,XORR dw QBRAN,KTAP1 dw BLANK,TAP,EXIT KTAP1: dw BKSP,EXIT KTAP2: dw DROP,SWAP,DROP,DUPP,EXIT ; accept ( b u -- b u ) ; Accept characters to input buffer. Return with actual count. ; $COLON 6,'accept',ACCEP ACCEP: xcall LISTT .even dw OVER,PLUS,OVER ACCP1: dw DDUP,XORR dw QBRAN,ACCP4 dw KEY,DUPP ; DW BLANK,SUBB,DOLIT,95,ULESS dw BLANK,DOLIT,127,WITHI dw QBRAN,ACCP2 dw TAP dw BRAN,ACCP3 ACCP2: dw TTAP,ATEXE ACCP3: dw BRAN,ACCP1 ACCP4: dw DROP,OVER,SUBB,EXIT ; EXPECT ( b u -- ) ; Accept input stream and store count in SPAN. ; $COLON 6,'EXPECT',EXPEC EXPEC: xcall LISTT .even dw TEXPE,ATEXE,SPAN,STORE,DROP,EXIT ; QUERY ( -- ) ; Accept input stream to terminal input buffer. ; $COLON 5,'QUERY',QUERY QUERY: xcall LISTT .even dw TIB,DOLIT,80,TEXPE,ATEXE,NTIB,STORE dw DROP,DOLIT,0,INN,STORE,EXIT ;; Error handling ; CATCH ( ca -- 0 | err# ) ; Execute word at ca and set up an error frame for it. ; $COLON 5,'CATCH',CATCH CATCH: xcall LISTT .even dw SPAT,TOR,HANDL,AT,TOR ;save error frame dw RPAT,HANDL,STORE,EXECU ;execute dw RFROM,HANDL,STORE ;restore error frame dw RFROM,DROP,DOLIT,0,EXIT ;no error ; THROW ( err# -- err# ) ; Reset system to current local error frame an update error flag. ; $COLON 5,'THROW',THROW THROW: xcall LISTT .even dw HANDL,AT,RPSTO ;restore return stack dw RFROM,HANDL,STORE ;restore handler frame dw RFROM,SWAP,TOR,SPSTO ;restore data stack dw DROP,RFROM,EXIT ; NULL$ ( -- a ) ; Return address of a null string with zero count. ; $COLON 5,'NULL$',NULLS NULLS: xcall LISTT .even dw DOVAR ;emulate CREATE dw 0 db 99,111,121,111,116,101 .even ; ABORT ( -- ) ; Reset data stack and jump to QUIT. ; $COLON 5,'ABORT',ABORT ABORT: xcall LISTT .even dw NULLS,THROW ; abort" ( f -- ) ; Run time routine of ABORT" . Abort with a message. ; $COLON COMPO+6,'abort"',ABORQ ABORQ: xcall LISTT .even dw QBRAN,ABOR1 ;text flag dw DOSTR,THROW ;pass error string ABOR1: dw DOSTR,DROP,EXIT ;drop error ;; The text interpreter ; $INTERPRET ( a -- ) ; Interpret a word. If failed, try to convert it to an integer. ; $COLON 10,'$INTERPRET',INTER INTER: xcall LISTT .even dw NAMEQ,QDUP ;?defined dw QBRAN,INTE1 dw AT,DOLIT,COMPO,ANDD ;?compile only lexicon bits ; D$ ABORQ,' compile only' dw ABORQ db 13, " compile only\z" .even dw EXECU,EXIT ;execute defined word INTE1: dw TNUMB,ATEXE ;convert a number dw QBRAN,INTE2 dw EXIT INTE2: dw THROW ;error ; [ ( -- ) ; Start the text interpreter. ; $COLON IMEDD+1,'[',LBRAC LBRAC: xcall LISTT .even dw DOLIT,INTER,TEVAL,STORE,EXIT ; .OK ( -- ) ; Display 'ok' only while interpreting. ; $COLON 3,'.OK',DOTOK DOTOK: xcall LISTT .even dw DOLIT,INTER,TEVAL,AT,EQUAL dw QBRAN,DOTO1 ; D$ DOTQP,' ok' dw DOTQP db 3, " ok\z" .even DOTO1: dw XXCR,EXIT ; ?STACK ( -- ) ; Abort if the data stack underflows. ; $COLON 6,'?STACK',QSTAC QSTAC: xcall LISTT .even dw DEPTH,ZLESS ;check only for underflow ; D$ ABORQ,' underflow' dw ABORQ db 10, " underflow\z" .even dw EXIT ; EVAL ( -- ) ; Interpret the input stream. ; $COLON 4,'EVAL',EVAL EVAL: xcall LISTT .even EVAL1: dw TOKEN,DUPP,CAT ;?input stream empty dw QBRAN,EVAL2 dw TEVAL,ATEXE,QSTAC ;evaluate input, check stack dw BRAN,EVAL1 EVAL2: dw DROP,TPROM,ATEXE,EXIT ;prompt ;; Shell ; PRESET ( -- ) ; Reset data stack pointer and the terminal input buffer. ; $COLON 6,'PRESET',PRESE PRESE: xcall LISTT .even dw SZERO,AT,SPSTO dw DOLIT,TIBB,NTIB,CELLP,STORE,EXIT ; xio ( a a a -- ) ; Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT. ; $COLON COMPO+3,'xio',XIO XIO: xcall LISTT .even dw DOLIT,ACCEP,TEXPE,DSTOR dw TECHO,DSTOR,EXIT ; FILE ( -- ) ; Select I/O vectors for file download. ; $COLON 4,'FILE',FILE FILE: xcall LISTT .even dw DOLIT,PACE,DOLIT,DROP dw DOLIT,KTAP,XIO,EXIT ; HAND ( -- ) ; Select I/O vectors for terminal interface. ; $COLON 4,'HAND',HAND HAND: xcall LISTT .even dw DOLIT,DOTOK,DOLIT,EMIT dw DOLIT,KTAP,XIO,EXIT ; I/O ( -- a ) ; Array to store default I/O vectors. ; $COLON 3,'I/O',ISLO ISLO: xcall LISTT .even dw DOVAR ;emulate CREATE dw QRX,TXSTO ;default I/O vectors ; CONSOLE ( -- ) ; Initiate terminal interface. ; $COLON 7,'CONSOLE',CONSO CONSO: xcall LISTT .even dw ISLO,DAT,TQKEY,DSTOR ;restore default I/O device dw HAND,EXIT ;keyboard input ; QUIT ( -- ) ; Reset return stack pointer and start text interpreter. ; $COLON 4,'QUIT',QUIT QUIT: xcall LISTT .even dw RZERO,AT,RPSTO ;reset return stack pointer QUIT1: dw LBRAC ;start interpretation QUIT2: dw QUERY ;get input dw DOLIT,EVAL,CATCH,QDUP ;evaluate input dw QBRAN,QUIT2 ;continue till error dw TPROM,AT,SWAP ;save input device dw CONSO,NULLS,OVER,XORR ;?display error message dw QBRAN,QUIT3 dw SPACE,COUNTX,TYPEE ;error message ; D$ DOTQP,' ? ' ;error prompt dw DOTQP db 3, " ? \z" .even QUIT3: dw DOLIT,DOTOK,XORR ;?file input dw QBRAN,QUIT4 dw DOLIT,ERR,EMIT ;file error, tell host QUIT4: dw PRESE ;some cleanup dw BRAN,QUIT1 ;; The compiler ; ' ( -- ca ) ; Search context vocabularies for the next word in input stream. ; $COLON 1,"'",TICK TICK: xcall LISTT .even dw TOKEN,NAMEQ ;?defined dw QBRAN,TICK1 dw EXIT ;yes, push code address TICK1: dw THROW ;no, error ; ALLOT ( n -- ) ; Allocate n bytes to the code dictionary. ; $COLON 5,'ALLOT',ALLOT ALLOT: xcall LISTT .even dw CP,PSTOR,EXIT ;adjust code pointer ; , ( w -- ) ; Compile an integer into the code dictionary. ; $COLON 1,',',COMMA COMMA: xcall LISTT .even dw HERE,DUPP,CELLP ;cell boundary dw CP,STORE,STORE,EXIT ;adjust code pointer, compile ; [COMPILE] ( -- ; ) ; Compile the next immediate word into code dictionary. ; $COLON IMEDD+9,'[COMPILE]',BCOMP BCOMP: xcall LISTT .even dw TICK,COMMA,EXIT ; COMPILE ( -- ) ; Compile the next address in colon list to code dictionary. ; $COLON COMPO+7,'COMPILE',COMPI COMPI: xcall LISTT .even dw RFROM,DUPP,AT,COMMA ;compile address dw CELLP,TOR,EXIT ;adjust return address ; LITERAL ( w -- ) ; Compile tos to code dictionary as an integer literal. ; $COLON IMEDD+7,'LITERAL',LITER LITER: xcall LISTT .even dw COMPI,DOLIT,COMMA,EXIT ; $," ( -- ) ; Compile a literal string up to next " . ; $COLON 3,'$,"',STRCQ STRCQ: xcall LISTT .even dw DOLIT,'"',WORDD ;move string to code dictionary dw COUNTX,PLUS,ALGND ;calculate aligned end of string dw CP,STORE,EXIT ;adjust the code pointer ; RECURSE ( -- ) ; Make the current word available for compilation. ; $COLON IMEDD+7,'RECURSE',RECUR RECUR: xcall LISTT .even dw LAST,AT,NAMET,COMMA,EXIT ;; Structures ; FOR ( -- a ) ; Start a FOR-NEXT loop structure in a colon definition. ; $COLON IMEDD+3,'FOR',FOR FOR: xcall LISTT .even dw COMPI,TOR,HERE,EXIT ; BEGIN ( -- a ) ; Start an infinite or indefinite loop structure. ; $COLON IMEDD+5,'BEGIN',BEGIN BEGIN: xcall LISTT .even dw HERE,EXIT ; NEXT ( a -- ) ; Terminate a FOR-NEXT loop structure. ; $COLON IMEDD+4,'NEXT',NEXT NEXT: xcall LISTT .even dw COMPI,DONXT,COMMA,EXIT ; UNTIL ( a -- ) ; Terminate a BEGIN-UNTIL indefinite loop structure. ; $COLON IMEDD+5,'UNTIL',UNTIL UNTIL: xcall LISTT .even dw COMPI,QBRAN,COMMA,EXIT ; AGAIN ( a -- ) ; Terminate a BEGIN-AGAIN infinite loop structure. ; $COLON IMEDD+5,'AGAIN',AGAIN AGAIN: xcall LISTT .even dw COMPI,BRAN,COMMA,EXIT ; IF ( -- A ) ; Begin a conditional branch structure. ; $COLON IMEDD+2,'IF',IFF IFF: xcall LISTT .even dw COMPI,QBRAN,HERE dw DOLIT,0,COMMA,EXIT ; AHEAD ( -- A ) ; Compile a forward branch instruction. ; $COLON IMEDD+5,'AHEAD',AHEAD AHEAD: xcall LISTT .even dw COMPI,BRAN,HERE,DOLIT,0,COMMA,EXIT ; REPEAT ( A a -- ) ; Terminate a BEGIN-WHILE-REPEAT indefinite loop. ; $COLON IMEDD+6,'REPEAT',REPEA REPEA: xcall LISTT .even dw AGAIN,HERE,SWAP,STORE,EXIT ; THEN ( A -- ) ; Terminate a conditional branch structure. ; $COLON IMEDD+4,'THEN',THENN THENN: xcall LISTT .even dw HERE,SWAP,STORE,EXIT ; AFT ( a -- a A ) ; Jump to THEN in a FOR-AFT-THEN-NEXT loop the first time through. ; $COLON IMEDD+3,'AFT',AFT AFT: xcall LISTT .even dw DROP,AHEAD,BEGIN,SWAP,EXIT ; ELSE ( A -- A ) ; Start the false clause in an IF-ELSE-THEN structure. ; $COLON IMEDD+4,'ELSE',ELSEE ELSEE: xcall LISTT .even dw AHEAD,SWAP,THENN,EXIT ; WHILE ( a -- A a ) ; Conditional branch out of a BEGIN-WHILE-REPEAT loop. ; $COLON IMEDD+5,'WHILE',WHILE WHILE: xcall LISTT .even dw IFF,SWAP,EXIT ; ABORT" ( -- ; ) ; Conditional abort with an error message. ; $COLON IMEDD+6,'ABORT"',ABRTQ ABRTQ: xcall LISTT .even dw COMPI,ABORQ,STRCQ,EXIT ; $" ( -- ; ) ; Compile an inline string literal. ; $COLON IMEDD+2,'$"',STRQ STRQ: xcall LISTT .even dw COMPI,STRQP,STRCQ,EXIT ; ." ( -- ; ) ; Compile an inline string literal to be typed out at run time. ; $COLON IMEDD+2,'."',DOTQ DOTQ: xcall LISTT .even dw COMPI,DOTQP,STRCQ,EXIT ;; Name compiler ; ?UNIQUE ( a -- a ) ; Display a warning message if the word already exists. ; $COLON 7,'?UNIQUE',UNIQU UNIQU: xcall LISTT .even dw DUPP,NAMEQ ;?name exists dw QBRAN,UNIQ1 ;redefinitions are OK ; D$ DOTQP,' reDef ' ;but warn the user dw DOTQP db 7, " reDef \z" .even dw OVER,COUNTX,TYPEE ;just in case its not planned UNIQ1: dw DROP,EXIT ; $,n ( na -- ) ; Build a new dictionary name using the string at na. ; $COLON 3,'$,n',SNAME SNAME: xcall LISTT .even dw DUPP,CAT ;?null input dw QBRAN,PNAM1 dw UNIQU ;?redefinition dw DUPP,LAST,STORE ;save na for vocabulary link dw HERE,ALGND,SWAP ;align code address dw CELLM ;link address dw CRRNT,AT,AT,OVER,STORE dw CELLM,DUPP,NP,STORE ;adjust name pointer dw STORE,EXIT ;save code pointer PNAM1:; D$ STRQP,' name' ;null input dw STRQP db 5, " name\z" .even dw THROW ;; FORTH compiler ; $COMPILE ( a -- ) ; Compile next word to code dictionary as a token or literal. ; $COLON 8,'$COMPILE',SCOMP SCOMP: xcall LISTT .even dw NAMEQ,QDUP ;?defined dw QBRAN,SCOM2 dw AT,DOLIT,IMEDD,ANDD ;?immediate dw QBRAN,SCOM1 dw EXECU,EXIT ;its immediate, execute SCOM1: dw COMMA,EXIT ;its not immediate, compile SCOM2: dw TNUMB,ATEXE ;try to convert to number dw QBRAN,SCOM3 dw LITER,EXIT ;compile number as integer SCOM3: dw THROW ;error ; OVERT ( -- ) ; Link a new word into the current vocabulary. ; $COLON 5,'OVERT',OVERT OVERT: xcall LISTT .even dw LAST,AT,CRRNT,AT,STORE,EXIT ; ; ( -- ) ; Terminate a colon definition. ; $COLON IMEDD+COMPO+1,';',SEMIS SEMIS: xcall LISTT .even dw COMPI,EXIT,LBRAC,OVERT,EXIT ; ] ( -- ) ; Start compiling the words in the input stream. ; $COLON 1,']',RBRAC RBRAC: xcall LISTT .even dw DOLIT,SCOMP,TEVAL,STORE,EXIT ; call, ( ca -- ) ; Assemble a call instruction to ca. ; $COLON 5,'call,',CALLC CALLC: xcall LISTT .even dw DOLIT,CALLL,COMMA ;Direct Threaded Code dw XXXSWAP, COMMA,EXIT ;DTC 8086 relative call ; : ( -- ; ) ; Start a new colon definition using next word as its name. ; $COLON 1,':',COLON COLON: xcall LISTT .even dw TOKEN,SNAME,DOLIT,LISTT dw CALLC,RBRAC,EXIT ; IMMEDIATE ( -- ) ; Make the last compiled word an immediate word. ; $COLON 9,'IMMEDIATE',IMMED IMMED: xcall LISTT .even dw DOLIT,IMEDD,LAST,AT,AT,ORR dw LAST,AT,STORE,EXIT ;; Defining words ; USER ( u -- ; ) ; Compile a new user variable. ; $COLON 4,'USER',USER USER: xcall LISTT .even dw TOKEN,SNAME,OVERT dw DOLIT,LISTT,CALLC dw COMPI,DOUSE,COMMA,EXIT ; CREATE ( -- ; ) ; Compile a new array entry without allocating code space. ; $COLON 6,'CREATE',CREAT CREAT: xcall LISTT .even dw TOKEN,SNAME,OVERT dw DOLIT,LISTT,CALLC dw COMPI,DOVAR,EXIT ; VARIABLE ( -- ; ) ; Compile a new variable initialized to 0. ; $COLON 8,'VARIABLE',VARIA VARIA: xcall LISTT .even dw CREAT,DOLIT,0,COMMA,EXIT ;; Tools ; _TYPE ( b u -- ) ; Display a string. Filter non-printing characters. ; $COLON 5,'_TYPE',UTYPE UTYPE: xcall LISTT .even dw TOR ;start count down loop dw BRAN,UTYP2 ;skip first pass UTYP1: dw DUPP,CAT,TCHAR,EMIT ;display only printable dw DOLIT,1,PLUS ;increment address UTYP2: dw DONXT,UTYP1 ;loop till done dw DROP,EXIT ; dm+ ( a u -- a ) ; Dump u bytes from , leaving a+u on the stack. ; $COLON 3,'dm+',DMP DMP: xcall LISTT .even dw OVER,DOLIT,4,UDOTR ;display address dw SPACE,TOR ;start count down loop dw BRAN,PDUM2 ;skip first pass PDUM1: dw DUPP,CAT,DOLIT,3,UDOTR ;display numeric data dw DOLIT,1,PLUS ;increment address PDUM2: dw DONXT,PDUM1 ;loop till done dw EXIT ; DUMP ( a u -- ) ; Dump u bytes from a, in a formatted manner. ; $COLON 4,'DUMP',DUMP DUMP: xcall LISTT .even dw BASE,AT,TOR,HEX ;save radix, set hex dw DOLIT,16,SLASH ;change count to lines dw TOR ;start count down loop DUMP1: dw XXCR,DOLIT,16,DDUP,DMP ;display numeric dw ROT,ROT dw SPACE,SPACE,UTYPE ;display printable characters dw NUFQ,INVER ;user control dw QBRAN,DUMP2 dw DONXT,DUMP1 ;loop till done dw BRAN,DUMP3 DUMP2: dw RFROM,DROP ;cleanup loop stack, early exit DUMP3: dw DROP,RFROM,BASE,STORE ;restore radix dw EXIT ; .S ( ... -- ... ) ; Display the contents of the data stack. ; $COLON 2,'.S',DOTS DOTS: xcall LISTT .even dw XXCR,DEPTH ;stack depth dw TOR ;start count down loop dw BRAN,DOTS2 ;skip first pass DOTS1: dw RAT,PICK,DOT ;index stack, display contents DOTS2: dw DONXT,DOTS1 ;loop till done ; D$ DOTQP,' NAME ( ca -- na | F ) ; Convert code address to a name address. ; $COLON 5,'>NAME',TNAME TNAME: xcall LISTT .even dw CRRNT ;vocabulary link TNAM1: dw CELLP,AT,QDUP ;check all vocabularies dw QBRAN,TNAM4 dw DDUP TNAM2: dw AT,DUPP ;?last word in a vocabulary dw QBRAN,TNAM3 dw DDUP,NAMET,XORR ;compare dw QBRAN,TNAM3 dw CELLM ;continue with next word dw BRAN,TNAM2 TNAM3: dw SWAP,DROP,QDUP dw QBRAN,TNAM1 dw SWAP,DROP,SWAP,DROP,EXIT TNAM4: dw DROP,DOLIT,0,EXIT ;false flag ; .ID ( na -- ) ; Display the name at address. ; $COLON 3,'.ID',DOTID DOTID: xcall LISTT .even dw QDUP ;if zero no name dw QBRAN,DOTI1 dw COUNTX,DOLIT,0x1F,ANDD ;mask lexicon bits dw UTYPE,EXIT ;display name string DOTI1:; D$ DOTQP,' {noName}' dw DOTQP db 9, " {noName}\z" .even dw EXIT ; SEE ( -- ; ) ; A simple decompiler. ; $COLON 3,'SEE',SEE SEE: xcall LISTT .even dw TICK ;starting address dw XXCR,CELLP SEE1: dw CELLP,DUPP,AT,DUPP ;?does it contain a zero dw QBRAN,SEE2 dw TNAME ;?is it a name SEE2: dw QDUP ;name address or zero dw QBRAN,SEE3 dw SPACE,DOTID ;display name dw BRAN,SEE4 SEE3: dw DUPP,AT,UDOT ;display number SEE4: dw NUFQ ;user control dw QBRAN,SEE1 dw DROP,EXIT ; WORDS ( -- ) ; Display the names in the context vocabulary. ; $COLON 5,'WORDS',WORDS WORDS: xcall LISTT .even dw XXCR,CNTXT,AT ;only in context WORS1: dw AT,QDUP ;?at end of list dw QBRAN,WORS2 dw DUPP,SPACE,DOTID ;display a name dw CELLM,NUFQ ;user control dw QBRAN,WORS1 dw DROP WORS2: dw EXIT ;; Hardware reset ; VER ( -- n ) ; Return the version number of this implementation. ; $COLON 3,'VER',VERSN VERSN: xcall LISTT dw DOLIT,VER*256+EXT,EXIT ; hi ( -- ) ; Display the sign-on message of eForth. ; $COLON 2,'hi',HI HI: xcall LISTT dw STOIO,XXCR ;initialize I/O ; D$ DOTQP,'eForth v' ;model dw DOTQP db 8, "eForth v\z" .even dw BASE,AT,HEX ;save radix dw VERSN,BDIGS,DIG,DIG dw DOLIT,'.',HOLD dw DIGS,EDIGS,TYPEE ;format version number dw BASE,STORE,XXCR,XXCR,EXIT ;restore radix ; 'BOOT ( -- a ) ; The application startup vector. ; $COLON 5,"'BOOT",TBOOT TBOOT: xcall LISTT dw DOVAR dw HI ;application to boot ; COLD ( -- ) ; The hilevel cold start sequence. ; $COLON 4,'COLD',COLD COLD: xcall LISTT COLD1: dw DOLIT,UZERO,DOLIT,UPP dw DOLIT,ULAST-UZERO,CMOVE ;initialize user area dw PRESE ;initialize stack and TIB dw TBOOT,ATEXE ;application boot dw FORTH,CNTXT,AT,DUPP ;initialize search order dw CRRNT,DSTOR,OVERT dw QUIT ;start interpretation dw BRAN,COLD1 ;just in case ;=============================================================== ;LASTN EQU _NAME+4 ;last name address ;NTOP EQU _NAME-0 ;next available memory in name dictionary ;CTOP EQU $+0 ;next available memory in code dictionary ;MAIN ENDS ;END ORIG ;=============================================================== dw BYE, 0 XXLA06: db 3, "BYE\z" .even dw XITIME, XXLA06 XXLA07: db 6, "XITIME\z" .even dw ITIME, XXLA07 XXLA08: db 5, "ITIME\z" .even dw IWAIT1S, XXLA08 XXLA09: db 7, "IWAIT1S\z" .even dw IWAIT1MS, XXLA09 XXLA10: db 8, "IWAIT1MS\z" .even dw ACWR, XXLA10 XXLA11: db 3, "AC!\z" .even dw ACRD, XXLA11 XXLA12: db 3, "?AC\z" .even dw F0WR, XXLA12 XXLA13: db 3, "F0!\z" .even dw F0RD, XXLA13 XXLA14: db 3, "?F0\z" .even dw RS0WR, XXLA14 XXLA15: db 4, "RS0!\z" .even dw RS0RD, XXLA15 XXLA16: db 4, "?RS0\z" .even dw RS1WR, XXLA16 XXLA17: db 4, "RS1!\z" .even dw RS1RD, XXLA17 XXLA18: db 4, "?RS1\z" .even dw OVWR, XXLA18 XXLA19: db 3, "OV!\z" .even dw OVRD, XXLA19 XXLA20: db 3, "?OV\z" .even dw PWR, XXLA20 XXLA21: db 2, "P!\z" .even dw PRD, XXLA21 XXLA22: db 2, "?P\z" .even dw EAWR, XXLA22 XXLA23: db 3, "EA!\z" .even dw EARD, XXLA23 XXLA24: db 3, "?EA\z" .even dw ET2WR, XXLA24 XXLA25: db 4, "ET2!\z" .even dw ET2RD, XXLA25 XXLA26: db 4, "?ET2\z" .even dw ESWR, XXLA26 XXLA27: db 3, "ES!\z" .even dw ESRD, XXLA27 XXLA28: db 3, "?ES\z" .even dw ET1WR, XXLA28 XXLA29: db 4, "ET1!\z" .even dw ET1RD, XXLA29 XXLA30: db 4, "?ET1\z" .even dw EX1WR, XXLA30 XXLA31: db 4, "EX1!\z" .even dw EX1RD, XXLA31 XXLA32: db 4, "?EX1\z" .even dw ET0WR, XXLA32 XXLA33: db 4, "ET0!\z" .even dw ET0RD, XXLA33 XXLA34: db 4, "?ET0\z" .even dw EX0WR, XXLA34 XXLA35: db 4, "EX0!\z" .even dw EX0RD, XXLA35 XXLA36: db 4, "?EX0\z" .even dw PT2WR, XXLA36 XXLA37: db 4, "PT2!\z" .even dw PT2RD, XXLA37 XXLA38: db 4, "?PT2\z" .even dw PSWR, XXLA38 XXLA39: db 3, "PS!\z" .even dw PSRD, XXLA39 XXLA40: db 3, "?PS\z" .even dw PT1WR, XXLA40 XXLA41: db 4, "PT1!\z" .even dw PT1RD, XXLA41 XXLA42: db 4, "?PT1\z" .even dw PX1WR, XXLA42 XXLA43: db 4, "PX1!\z" .even dw PX1RD, XXLA43 XXLA44: db 4, "?PX1\z" .even dw PT0WR, XXLA44 XXLA45: db 4, "PT0!\z" .even dw PT0RD, XXLA45 XXLA46: db 4, "?PT0\z" .even dw PX0WR, XXLA46 XXLA47: db 4, "PX0!\z" .even dw PX0RD, XXLA47 XXLA48: db 4, "?PX0\z" .even dw TF1WR, XXLA48 XXLA49: db 4, "TF1!\z" .even dw TF1RD, XXLA49 XXLA50: db 4, "?TF1\z" .even dw TR1WR, XXLA50 XXLA51: db 4, "TR1!\z" .even dw TR1RD, XXLA51 XXLA52: db 4, "?TR1\z" .even dw TF0WR, XXLA52 XXLA53: db 4, "TF0!\z" .even dw TF0RD, XXLA53 XXLA54: db 4, "?TF0\z" .even dw TR0WR, XXLA54 XXLA55: db 4, "TR0!\z" .even dw TR0RD, XXLA55 XXLA56: db 4, "?TR0\z" .even dw IE1WR, XXLA56 XXLA57: db 4, "IE1!\z" .even dw IE1RD, XXLA57 XXLA58: db 4, "?IE1\z" .even dw IT1WR, XXLA58 XXLA59: db 4, "IT1!\z" .even dw IT1RD, XXLA59 XXLA60: db 4, "?IT1\z" .even dw IE0WR, XXLA60 XXLA61: db 4, "IE0!\z" .even dw IE0RD, XXLA61 XXLA62: db 4, "?IE0\z" .even dw IT0WR, XXLA62 XXLA63: db 4, "IT0!\z" .even dw IT0RD, XXLA63 XXLA64: db 4, "?IT0\z" .even dw TF2WR, XXLA64 XXLA65: db 4, "TF2!\z" .even dw TF2RD, XXLA65 XXLA66: db 4, "?TF2\z" .even dw EXF2WR, XXLA66 XXLA67: db 5, "EXF2!\z" .even dw EXF2RD, XXLA67 XXLA68: db 5, "?EXF2\z" .even dw RCLKWR, XXLA68 XXLA69: db 5, "RCLK!\z" .even dw RCLKRD, XXLA69 XXLA70: db 5, "?RCLK\z" .even dw TCLKWR, XXLA70 XXLA71: db 5, "TCLK!\z" .even dw TCLKRD, XXLA71 XXLA72: db 5, "?TCLK\z" .even dw EXEN2WR, XXLA72 XXLA73: db 6, "EXEN2!\z" .even dw EXEN2RD, XXLA73 XXLA74: db 6, "?EXEN2\z" .even dw TR2WR, XXLA74 XXLA75: db 4, "TR2!\z" .even dw TR2RD, XXLA75 XXLA76: db 4, "?TR2\z" .even dw C_T2WR, XXLA76 XXLA77: db 5, "C_T2!\z" .even dw C_T2RD, XXLA77 XXLA78: db 5, "?C_T2\z" .even dw CP_RL2WR, XXLA78 XXLA79: db 7, "CP_RL2!\z" .even dw CP_RL2RD, XXLA79 XXLA80: db 7, "?CP_RL2\z" .even dw SM0WR, XXLA80 XXLA81: db 4, "SM0!\z" .even dw SM0RD, XXLA81 XXLA82: db 4, "?SM0\z" .even dw SM1WR, XXLA82 XXLA83: db 4, "SM1!\z" .even dw SM1RD, XXLA83 XXLA84: db 4, "?SM1\z" .even dw SM2WR, XXLA84 XXLA85: db 4, "SM2!\z" .even dw SM2RD, XXLA85 XXLA86: db 4, "?SM2\z" .even dw RENWR, XXLA86 XXLA87: db 4, "REN!\z" .even dw RENRD, XXLA87 XXLA88: db 4, "?REN\z" .even dw TB8WR, XXLA88 XXLA89: db 4, "TB8!\z" .even dw TB8RD, XXLA89 XXLA90: db 4, "?TB8\z" .even dw RB8WR, XXLA90 XXLA91: db 4, "RB8!\z" .even dw RB8RD, XXLA91 XXLA92: db 4, "?RB8\z" .even dw TIWR, XXLA92 XXLA93: db 3, "TI!\z" .even dw TIRD, XXLA93 XXLA94: db 3, "?TI\z" .even dw RIWR, XXLA94 XXLA95: db 3, "RI!\z" .even dw RIRD, XXLA95 XXLA96: db 3, "?RI\z" .even dw PCONRD, XXLA96 XXLZ99: db 5, "?PCON\z" .even dw PCONWR, XXLZ99 XXLZ98: db 5, "PCON!\z" .even dw P0_0WR, XXLZ98 XXLZ1 db 5, "P0_0!\z" .even dw P0_1WR, XXLZ1 XXLZ2 db 5, "P0_1!\z" .even dw P0_2WR, XXLZ2 XXLZ3 db 5, "P0_2!\z" .even dw P0_3WR, XXLZ3 XXLZ4 db 5, "P0_3!\z" .even dw P0_4WR, XXLZ4 XXLZ5 db 5, "P0_4!\z" .even dw P0_5WR, XXLZ5 XXLZ6 db 5, "P0_5!\z" .even dw P0_6WR, XXLZ6 XXLZ7 db 5, "P0_6!\z" .even dw P0_7WR, XXLZ7 XXLZ8 db 5, "P0_7!\z" .even dw P1_0WR, XXLZ8 XXLZ9 db 5, "P1_0!\z" .even dw P1_1WR, XXLZ9 XXLZ10 db 5, "P1_1!\z" .even dw P1_2WR, XXLZ10 XXLZ11 db 5, "P1_2!\z" .even dw P1_3WR, XXLZ11 XXLZ12 db 5, "P1_3!\z" .even dw P1_4WR, XXLZ12 XXLZ13 db 5, "P1_4!\z" .even dw P1_5WR, XXLZ13 XXLZ14 db 5, "P1_5!\z" .even dw P1_6WR, XXLZ14 XXLZ15 db 5, "P1_6!\z" .even dw P1_7WR, XXLZ15 XXLZ16 db 5, "P1_7!\z" .even dw P2_0WR, XXLZ16 XXLZ17 db 5, "P2_0!\z" .even dw P2_1WR, XXLZ17 XXLZ18 db 5, "P2_1!\z" .even dw P2_2WR, XXLZ18 XXLZ19 db 5, "P2_2!\z" .even dw P2_3WR, XXLZ19 XXLZ20 db 5, "P2_3!\z" .even dw P2_4WR, XXLZ20 XXLZ21 db 5, "P2_4!\z" .even dw P2_5WR, XXLZ21 XXLZ22 db 5, "P2_5!\z" .even dw P2_6WR, XXLZ22 XXLZ23 db 5, "P2_6!\z" .even dw P2_7WR, XXLZ23 XXLZ24 db 5, "P2_7!\z" .even dw P3_0WR, XXLZ24 XXLZ25 db 5, "P3_0!\z" .even dw P3_1WR, XXLZ25 XXLZ26 db 5, "P3_1!\z" .even dw ARMWR, XXLZ26 XXLZ27a db 3, "ARM\z" .even dw P3_3WR, XXLZ27a XXLZ27 db 5, "P3_2!\z" .even dw P3_3WR, XXLZ27 XXLZ28 db 5, "P3_3!\z" .even dw P3_4WR, XXLZ28 XXLZ29 db 5, "P3_4!\z" .even dw P3_5WR, XXLZ29 XXLZ30 db 5, "P3_5!\z" .even dw P3_6WR, XXLZ30 XXLZ31 db 5, "P3_6!\z" .even dw P3_7WR, XXLZ31 XXLZ32 db 5, "P3_7!\z" .even dw P0_0RD, XXLZ32 XXLZ33: db 5, "?P0_0\z" .even dw P0_1RD, XXLZ33 XXLZ34: db 5, "?P0_1\z" .even dw P0_2RD, XXLZ34 XXLZ35: db 5, "?P0_2\z" .even dw P0_3RD, XXLZ35 XXLZ36: db 5, "?P0_3\z" .even dw P0_4RD, XXLZ36 XXLZ37: db 5, "?P0_4\z" .even dw P0_5RD, XXLZ37 XXLZ38: db 5, "?P0_5\z" .even dw P0_6RD, XXLZ38 XXLZ39: db 5, "?P0_6\z" .even dw P0_7RD, XXLZ39 XXLZ40: db 5, "?P0_7\z" .even dw P1_0RD, XXLZ40 XXLZ41: db 5, "?P1_0\z" .even dw P1_1RD, XXLZ41 XXLZ42: db 5, "?P1_1\z" .even dw P1_2RD, XXLZ42 XXLZ43: db 5, "?P1_2\z" .even dw P1_3RD, XXLZ43 XXLZ44: db 5, "?P1_3\z" .even dw P1_4RD, XXLZ44 XXLZ45: db 5, "?P1_4\z" .even dw P1_5RD, XXLZ45 XXLZ46: db 5, "?P1_5\z" .even dw P1_6RD, XXLZ46 XXLZ47: db 5, "?P1_6\z" .even dw P1_7RD, XXLZ47 XXLZ48: db 5, "?P1_7\z" .even dw P2_0RD, XXLZ48 XXLZ49: db 5, "?P2_0\z" .even dw P2_1RD, XXLZ49 XXLZ50: db 5, "?P2_1\z" .even dw P2_2RD, XXLZ50 XXLZ51: db 5, "?P2_2\z" .even dw P2_3RD, XXLZ51 XXLZ52: db 5, "?P2_3\z" .even dw P2_4RD, XXLZ52 XXLZ53: db 5, "?P2_4\z" .even dw P2_5RD, XXLZ53 XXLZ54: db 5, "?P2_5\z" .even dw P2_6RD, XXLZ54 XXLZ55: db 5, "?P2_6\z" .even dw P2_7RD, XXLZ55 XXLZ56: db 5, "?P2_7\z" .even dw P3_0RD, XXLZ56 XXLZ57: db 5, "?P3_0\z" .even dw P3_1RD, XXLZ57 XXLZ58: db 5, "?P3_1\z" .even dw AR0D, XXLZ58 XXLZ59a: db 3, "?A0\z" .even dw AR1D, XXLZ59a XXLZ59b: db 3, "?A1\z" .even dw AR2D, XXLZ59b XXLZ59c: db 3, "?A2\z" .even dw AR3D, XXLZ59c XXLZ59d: db 3, "?A3\z" .even dw P3_2RD, XXLZ59d XXLZ59: db 5, "?P3_2\z" .even dw P3_3RD, XXLZ59 XXLZ60: db 5, "?P3_3\z" .even dw P3_4RD, XXLZ60 XXLZ61: db 5, "?P3_4\z" .even dw P3_5RD, XXLZ61 XXLZ62: db 5, "?P3_5\z" .even dw P3_6RD, XXLZ62 XXLZ63: db 5, "?P3_6\z" .even dw P3_7RD, XXLZ63 XXLZ64: db 5, "?P3_7\z" .even dw EERD, XXLZ64 XXLY1a: db 3, "?EE\z" .even dw P0RD, XXLY1a XXLY1: db 3, "?P0\z" .even dw P1RD, XXLY1 XXLY2: db 3, "?P1\z" .even dw P2RD, XXLY2 XXLY3: db 3, "?P2\z" .even dw P3RD, XXLY3 XXLY4: db 3, "?P3\z" .even dw PSWRD, XXLY4 XXLY5: db 4, "?PSW\z" .even dw IPRD, XXLY5 XXLY6: db 3, "?IP\z" .even dw T2CONRD, XXLY6 XXLY7: db 6, "?T2CON\z" .even dw RCAP2LRD, XXLY7 XXLY8: db 7, "?RCAP2L\z" .even dw RCAP2HRD, XXLY8 XXLY9: db 7, "?RCAP2H\z" .even dw TL2RD, XXLY9 XXLY10: db 4, "?TL2\z" .even dw TH2RD, XXLY10 XXLY11: db 4, "?TH2\z" .even dw IERD, XXLY11 XXLY12: db 3, "?IE\z" .even dw SCONRD, XXLY12 XXLY13: db 5, "?SCON\z" .even dw SBUFRD, XXLY13 XXLY14: db 5, "?SBUF\z" .even dw TCONRD, XXLY14 XXLY15: db 5, "?TCON\z" .even dw TMODRD, XXLY15 XXLY16: db 5, "?TMOD\z" .even dw TL0RD, XXLY16 XXLY17: db 4, "?TL0\z" .even dw TH0RD, XXLY17 XXLY18: db 4, "?TH0\z" .even dw TL1RD, XXLY18 XXLY19: db 4, "?TL1\z" .even dw TH1RD, XXLY19 XXLY20: db 4, "?TH1\z" .even dw P0WR, XXLY20 XXLY21: db 3, "P0!\z" .even dw EEWR, XXLY21 XXLY21a: db 3, "EE!\z" .even dw P1WR, XXLY21a XXLY22: db 3, "P1!\z" .even dw P2WR, XXLY22 XXLY23: db 3, "P2!\z" .even dw P3WR, XXLY23 XXLY24: db 3, "P3!\z" .even dw PSWWR, XXLY24 XXLY25: db 4, "PSW!\z" .even dw IPWR, XXLY25 XXLY26: db 3, "IP!\z" .even dw T2CONWR, XXLY26 XXLY27: db 6, "T2CON!\z" .even dw RCAP2LWR, XXLY27 XXLY28: db 7, "RCAP2L!\z" .even dw RCAP2HWR, XXLY28 XXLY29: db 7, "RCAP2H!\z" .even dw TL2WR, XXLY29 XXLY30: db 4, "TL2!\z" .even dw TH2WR, XXLY30 XXLY31: db 4, "TH2!\z" .even dw IEWR, XXLY31 XXLY32: db 3, "IE!\z" .even dw SCONWR, XXLY32 XXLY33: db 5, "SCON!\z" .even dw SBUFWR, XXLY33 XXLY34: db 5, "SBUF!\z" .even dw TCONWR, XXLY34 XXLY35: db 5, "TCON!\z" .even dw TMODWR, XXLY35 XXLY36: db 5, "TMOD!\z" .even dw TL0WR, XXLY36 XXLY37: db 4, "TL0!\z" .even dw TH0WR, XXLY37 XXLY38: db 4, "TH0!\z" .even dw TL1WR, XXLY38 XXLY39: db 4, "TL1!\z" .even dw TH1WR, XXLY39 XXLY40: db 4, "TH1!\z" .even dw DOLIT, XXLY40 XXLL1: db COMPO+5, "doLIT\z" .even dw DOLST, XXLL1 XXLL2: db COMPO+6, "doLIST\z" .even dw DONXT, XXLL2 XXLL3: db COMPO+4, "next\z" .even dw QBRAN, XXLL3 XXLL4: db COMPO+7, "?branch\z" .even dw BRAN, XXLL4 XXLL5: db COMPO+6, "branch\z" .even dw EXECU, XXLL5 XXLL6: db 7, "EXECUTE\z" .even dw EXIT, XXLL6 XXLL7: db 4, "EXIT\z" .even dw STORE, XXLL7 XXLL8: db 1, "!\z" .even dw AT, XXLL8 XXLL9: db 1, "@\z" .even dw CSTOR, XXLL9 XXLL10: db 2, "C!\z" .even dw CAT, XXLL10 XXLL11: db 2, "C@\z" .even dw TOR, XXLL11 XXLL12: db 2, ">R\z" .even dw RAT, XXLL12 XXLL13: db 2, "R@\z" .even dw RFROM, XXLL13 XXLL14: db 2, "R>\z" .even dw RPAT, XXLL14 XXLL15: db 3, "RP@\z" .even dw RPSTO, XXLL15 XXLL16: db COMPO+3, "RP!\z" .even dw SPAT, XXLL16 XXLL17: db 3, "SP@\z" .even dw SPSTO, XXLL17 XXLL18: db 3, "SP!\z" .even dw DUPP, XXLL18 XXLL19: db 3, "DUP\z" .even dw DROP, XXLL19 XXLL20: db 4, "DROP\z" .even dw SWAP, XXLL20 XXLL21: db 4, "SWAP\z" .even dw OVER, XXLL21 XXLL22: db 4, "OVER\z" .even dw ZLESS, XXLL22 XXLL23: db 2, "0<\z" .even dw ANDD, XXLL23 XXLL24: db 3, "AND\z" .even dw ORR, XXLL24 XXLL25: db 2, "OR\z" .even dw XORR, XXLL25 XXLL26: db 3, "XOR\z" .even dw UPLUS, XXLL26 XXLL27: db 3, "UM+\z" .even dw STOIO, XXLL27 XXLL28: db 3, "!IO\z" .even dw QRX, XXLL28 XXLL29: db 3, "?RX\z" .even dw TXSTO, XXLL29 XXLL30: db 3, "TX!\z" .even dw DOVAR, XXLL30 XXLL31: db COMPO+5, "doVAR\z" .even dw UP, XXLL31 XXLL32: db 2, "UP\z" .even dw DOUSE, XXLL32 XXLL33: db COMPO+6, "doUSER\z" .even dw SZERO, XXLL33 XXLL34: db 3, "SP0\z" .even dw RZERO, XXLL34 XXLL35: db 3, "RP0\z" .even dw TQKEY, XXLL35 XXLL36: db 5, "'?KEY\z" .even dw TEMIT, XXLL36 XXLL37: db 5, "'EMIT\z" .even dw TEXPE, XXLL37 XXLL38: db 7, "'EXPECT\z" .even dw TTAP, XXLL38 XXLL39: db 4, "'TAP\z" .even dw TECHO, XXLL39 XXLL40: db 5, "'ECHO\z" .even dw TPROM, XXLL40 XXLL41: db 7, "'PROMPT\z" .even dw BASE, XXLL41 XXLL42: db 4, "BASE\z" .even dw TEMP, XXLL42 XXLL43: db COMPO+3, "tmp\z" .even dw SPAN, XXLL43 XXLL44: db 4, "SPAN\z" .even dw INN, XXLL44 XXLL45: db 3, ">IN\z" .even dw NTIB, XXLL45 XXLL46: db 4, "#TIB\z" .even dw CSP, XXLL46 XXLL47: db 3, "CSP\z" .even dw TEVAL, XXLL47 XXLL48: db 5, "'EVAL\z" .even dw TNUMB, XXLL48 XXLL49: db 7, "'NUMBER\z" .even dw HLD, XXLL49 XXLL50: db 3, "HLD\z" .even dw HANDL, XXLL50 XXLL51: db 7, "HANDLER\z" .even dw CNTXT, XXLL51 XXLL52: db 7, "CONTEXT\z" .even dw CRRNT, XXLL52 XXLL53: db 7, "CURRENT\z" .even dw CP, XXLL53 XXLL54: db 2, "CP\z" .even dw NP, XXLL54 XXLL55: db 2, "NP\z" .even dw LAST, XXLL55 XXLL56: db 4, "LAST\z" .even dw VFRTH, XXLL56 XXLL57: db 5, "forth\z" .even dw FORTH, XXLL57 XXLL58: db 5, "FORTH\z" .even dw QDUP, XXLL58 XXLL59: db 4, "?DUP\z" .even dw ROT, XXLL59 XXLL60: db 3, "ROT\z" .even dw DDROP, XXLL60 XXLL61: db 5, "2DROP\z" .even dw DDUP, XXLL61 XXLL62: db 4, "2DUP\z" .even dw PLUS, XXLL62 XXLL63: db 1, "+\z" .even dw INVER, XXLL63 XXLL64: db 3, "NOT\z" .even dw NEGAT, XXLL64 XXLL65: db 6, "NEGATE\z" .even dw DNEGA, XXLL65 XXLL66: db 7, "DNEGATE\z" .even dw SUBB, XXLL66 XXLL67: db 1, "-\z" .even dw ABSS, XXLL67 XXLL68: db 3, "ABS\z" .even dw EQUAL, XXLL68 XXLL69: db 1, "=\z" .even dw ULESS, XXLL69 XXLL70: db 2, "U<\z" .even dw LESS, XXLL70 XXLL71: db 1, "<\z" .even dw MAX, XXLL71 XXLL72: db 3, "MAX\z" .even dw MIN, XXLL72 XXLL73: db 3, "MIN\z" .even dw WITHI, XXLL73 XXLL74: db 6, "WITHIN\z" .even dw UMMOD, XXLL74 XXLL75: db 6, "UM/MOD\z" .even dw MSMOD, XXLL75 XXLL76: db 5, "M/MOD\z" .even dw SLMOD, XXLL76 XXLL77: db 4, "/MOD\z" .even dw MOD, XXLL77 XXLL78: db 3, "MOD\z" .even dw SLASH, XXLL78 XXLL79: db 1, "/\z" .even dw UMSTA, XXLL79 XXLL80: db 3, "UM*\z" .even dw STAR, XXLL80 XXLL81: db 1, "*\z" .even dw MSTAR, XXLL81 XXLL82: db 2, "M*\z" .even dw SSMOD, XXLL82 XXLL83: db 5, "*/MOD\z" .even dw STASL, XXLL83 XXLL84: db 2, "*/\z" .even dw CELLP, XXLL84 XXLL85: db 5, "CELL+\z" .even dw CELLM, XXLL85 XXLL86: db 5, "CELL-\z" .even dw CELLS, XXLL86 XXLL87: db 5, "CELLS\z" .even dw ALGND, XXLL87 XXLL88: db 7, "ALIGNED\z" .even dw BLANK, XXLL88 XXLL89: db 2, "BL\z" .even dw TCHAR, XXLL89 XXLL90: db 5, ">CHAR\z" .even dw DEPTH, XXLL90 XXLL91: db 5, "DEPTH\z" .even dw PICK, XXLL91 XXLL92: db 4, "PICK\z" .even dw PSTOR, XXLL92 XXLL93: db 2, "+!\z" .even dw DSTOR, XXLL93 XXLL94: db 2, "2!\z" .even dw DAT, XXLL94 XXLL95: db 2, "2@\z" .even dw COUNTX, XXLL95 XXLL96: db 5, "COUNT\z" .even dw HERE, XXLL96 XXLL97: db 4, "HERE\z" .even dw PAD, XXLL97 XXLL98: db 3, "PAD\z" .even dw TIB, XXLL98 XXLL99: db 3, "TIB\z" .even dw ATEXE, XXLL99 XXLL100: db 8, "@EXECUTE\z" .even dw CMOVE, XXLL100 XXLL101: db 5, "CMOVE\z" .even dw FILL, XXLL101 XXLL102: db 4, "FILL\z" .even dw DTRAI, XXLL102 XXLL103: db 9, "-TRAILING\z" .even dw PACKS, XXLL103 XXLL104: db 5, "PACK$\z" .even dw DIGIT, XXLL104 XXLL105: db 5, "DIGIT\z" .even dw EXTRC, XXLL105 XXLL106: db 7, "EXTRACT\z" .even dw BDIGS, XXLL106 XXLL107: db 2, "<#\z" .even dw HOLD, XXLL107 XXLL108: db 4, "HOLD\z" .even dw DIG, XXLL108 XXLL109: db 1, "#\z" .even dw DIGS, XXLL109 XXLL110: db 2, "#S\z" .even dw SIGN, XXLL110 XXLL111: db 4, "SIGN\z" .even dw EDIGS, XXLL111 XXLL112: db 2, "#>\z" .even dw STR, XXLL112 XXLL113: db 3, "str\z" .even dw HEX, XXLL113 XXLL114: db 3, "HEX\z" .even dw DECIM, XXLL114 XXLL115: db 7, "DECIMAL\z" .even dw DIGTQ, XXLL115 XXLL116: db 6, "DIGIT?\z" .even dw NUMBQ, XXLL116 XXLL117: db 6, "NUMBER?\z" .even dw QKEY, XXLL117 XXLL118: db 4, "?KEY\z" .even dw KEY, XXLL118 XXLL119: db 3, "KEY\z" .even dw EMIT, XXLL119 XXLL120: db 4, "EMIT\z" .even dw NUFQ, XXLL120 XXLL121: db 4, "NUF?\z" .even dw PACE, XXLL121 XXLL122: db 4, "PACE\z" .even dw SPACE, XXLL122 XXLL123: db 5, "SPACE\z" .even dw SPACS, XXLL123 XXLL124: db 6, "SPACES\z" .even dw TYPEE, XXLL124 XXLL125: db 4, "TYPE\z" .even dw XXCR, XXLL125 XXLL126: db 2, "CR\z" .even dw DOSTR, XXLL126 XXLL127: db COMPO+3, "do$\z" .even dw STRQP, XXLL127 XXLL128: db COMPO+3, "$\"|\z" .even dw DOTQP, XXLL128 XXLL129: db COMPO+3, ".\"|\z" .even dw DOTR, XXLL129 XXLL130: db 2, ".R\z" .even dw UDOTR, XXLL130 XXLL131: db 3, "U.R\z" .even dw UDOT, XXLL131 XXLL132: db 2, "U.\z" .even dw DOT, XXLL132 XXLL133: db 1, ".\z" .even dw QUEST, XXLL133 XXLL134: db 1, "?\z" .even dw PARS, XXLL134 XXLL135: db 5, "parse\z" .even dw PARSE, XXLL135 XXLL136: db 5, "PARSE\z" .even dw DOTPR, XXLL136 XXLL137: db IMEDD+2, ".(\z" .even dw PAREN, XXLL137 XXLL138: db IMEDD+1, "(\z" .even dw BKSLA, XXLL138 XXLL139: db IMEDD+1, "\\\z" .even dw CHAR, XXLL139 XXLL140: db 4, "CHAR\z" .even dw TOKEN, XXLL140 XXLL141: db 5, "TOKEN\z" .even dw WORDD, XXLL141 XXLL142: db 4, "WORD\z" .even dw NAMET, XXLL142 XXLL143: db 5, "NAME>\z" .even dw SAMEQ, XXLL143 XXLL144: db 5, "SAME?\z" .even dw FIND, XXLL144 XXLL145: db 4, "find\z" .even dw NAMEQ, XXLL145 XXLL146: db 5, "NAME?\z" .even dw BKSP, XXLL146 XXLL147: db 2, "^H\z" .even dw TAP, XXLL147 XXLL148: db 3, "TAP\z" .even dw KTAP, XXLL148 XXLL149: db 4, "kTAP\z" .even dw ACCEP, XXLL149 XXLL150: db 6, "accept\z" .even dw EXPEC, XXLL150 XXLL151: db 6, "EXPECT\z" .even dw QUERY, XXLL151 XXLL152: db 5, "QUERY\z" .even dw CATCH, XXLL152 XXLL153: db 5, "CATCH\z" .even dw THROW, XXLL153 XXLL154: db 5, "THROW\z" .even dw NULLS, XXLL154 XXLL155: db 5, "NULL$\z" .even dw ABORT, XXLL155 XXLL156: db 5, "ABORT\z" .even dw ABORQ, XXLL156 XXLL157: db COMPO+6, "abort\z" .even dw INTER, XXLL157 XXLL158: db 10, "$INTERPRET\z" .even dw LBRAC, XXLL158 XXLL159: db IMEDD+1, "[\z" .even dw DOTOK, XXLL159 XXLL160: db 3, ".OK\z" .even dw QSTAC, XXLL160 XXLL161: db 6, "?STACK\z" .even dw EVAL, XXLL161 XXLL162: db 4, "EVAL\z" .even dw PRESE, XXLL162 XXLL163: db 6, "PRESET\z" .even dw XIO, XXLL163 XXLL164: db COMPO+3, "xio\z" .even dw FILE, XXLL164 XXLL165: db 4, "FILE\z" .even dw HAND, XXLL165 XXLL166: db 4, "HAND\z" .even dw ISLO, XXLL166 XXLL167: db 3, "I/O\z" .even dw CONSO, XXLL167 XXLL168: db 7, "CONSOLE\z" .even dw QUIT, XXLL168 XXLL169: db 4, "QUIT\z" .even dw TICK, XXLL169 XXLL170: db 1, "'\z" .even dw ALLOT, XXLL170 XXLL171: db 5, "ALLOT\z" .even dw COMMA, XXLL171 XXLL172: db 1, ",\z" .even dw BCOMP, XXLL172 XXLL173: db IMEDD+9, "[COMPILE]\z" .even dw COMPI, XXLL173 XXLL174: db COMPO+7, "COMPILE\z" .even dw LITER, XXLL174 XXLL175: db IMEDD+7, "LITERAL\z" .even dw STRCQ, XXLL175 XXLL176: db 3, "$,\"\z" .even dw RECUR, XXLL176 XXLL177: db IMEDD+7, "RECURSE\z" .even dw FOR, XXLL177 XXLL178: db IMEDD+3, "FOR\z" .even dw BEGIN, XXLL178 XXLL179: db IMEDD+5, "BEGIN\z" .even dw NEXT, XXLL179 XXLL180: db IMEDD+4, "NEXT\z" .even dw UNTIL, XXLL180 XXLL181: db IMEDD+5, "UNTIL\z" .even dw AGAIN, XXLL181 XXLL182: db IMEDD+5, "AGAIN\z" .even dw IFF, XXLL182 XXLL183: db IMEDD+2, "IF\z" .even dw AHEAD, XXLL183 XXLL184: db IMEDD+5, "AHEAD\z" .even dw REPEA, XXLL184 XXLL185: db IMEDD+6, "REPEA\z" .even dw THENN, XXLL185 XXLL186: db IMEDD+4, "THEN\z" .even dw AFT, XXLL186 XXLL187: db IMEDD+3, "AFT\z" .even dw ELSEE, XXLL187 XXLL188: db IMEDD+4, "ELSE\z" .even dw WHILE, XXLL188 XXLL189: db IMEDD+5, "WHILE\z" .even dw ABRTQ, XXLL189 XXLL190: db IMEDD+6, "ABORT\"\z" .even dw STRQ, XXLL190 XXLL191: db IMEDD+2, "$\"\z" .even dw DOTQ, XXLL191 XXLL192: db IMEDD+2, ".\"\z" .even dw UNIQU, XXLL192 XXLL193: db 7, "?UNIQUE\z" .even dw SNAME, XXLL193 XXLL194: db 3, "$,n\z" .even dw SCOMP, XXLL194 XXLL195: db 8, "$COMPILE\z" .even dw OVERT, XXLL195 XXLL196: db 5, "OVERT\z" .even dw SEMIS, XXLL196 XXLL197: db IMEDD+COMPO+1, ";\z" .even dw RBRAC, XXLL197 XXLL198: db 1, "]\z" .even dw CALLC, XXLL198 XXLL199: db 5, "call,\z" .even dw COLON, XXLL199 XXLL200: db 1, ":\z" .even dw IMMED, XXLL200 XXLL201: db 9, "IMMEDIATE\z" .even dw USER, XXLL201 XXLL202: db 4, "USER\z" .even dw CREAT, XXLL202 XXLL203: db 6, "CREATE\z" .even dw VARIA, XXLL203 XXLL204: db 8, "VARIABLE\z" .even dw UTYPE, XXLL204 XXLL205: db 5, "_TYPE\z" .even dw DMP, XXLL205 XXLL206: db 3, "dm+\z" .even dw DUMP, XXLL206 XXLL207: db 4, "DUMP\z" .even dw DOTS, XXLL207 XXLL208: db 2, ".S\z" .even dw STCSP, XXLL208 XXLL209: db 4, "!CSP\z" .even dw QCSP, XXLL209 XXLL210: db 4, "?CSP\z" .even dw TNAME, XXLL210 XXLL211: db 5, ">NAME\z" .even dw DOTID, XXLL211 XXLL212: db 3, ".ID\z" .even dw SEE, XXLL212 XXLL213: db 3, "SEE\z" .even dw WORDS, XXLL213 XXLL214: db 5, "WORDS\z" .even dw VERSN, XXLL214 XXLL215: db 3, "VER\z" .even dw HI, XXLL215 XXLL216: db 2, "hi\z" .even dw TBOOT, XXLL216 XXLL217: db 5, "'BOOT\z" .even dw COLD, XXLL217 XXLL218: db 4, "COLD\z" .even LASTN = XXLL218 ;last name address ; ; utility routine to talk to an ADC1034 ; - asumptions - CS/OE are wired together to P1.0 ; - Cclk/Sclk is wired to P1.1 ; - DO is wired to P1.2 ; - DI is wired to P1.3 ; ; P1.0 must be high when not in use, P1.1-P1.3 are available when P1.0 is high ; and it is only ever pulled low while in this routine so they are free at all ; other times to be used by other devices that can be put into quiescent modes ; while this one is active ; ; calling conventions: ; always clear carry on return ; a, r1, r2 are available ; r0 lsbs contains adc index ; result is returned in r1:r0 (2 msbs in R1, 8 LSBs in R0) ; ; This is highly unoptimised - and could run twice as fast if transactions were pipelined ; but then the programming interface would be much more difficult ; ; Current time spent in here is ~300uS/conversion so you can get ~3000 samples/sec ; probably more than enough for a rocketry related datalogger - or even maybe ; for engine monitoring ; ; entry_1034: cjne r2, #'A', no_1034 ajmp get_1034 no_1034: ljmp utilityv get_1034: mov a, r0 ; make it <1><0><0><0><0> rl a orl a, #1 ; set big-endian mode anl a, #0xf swap a push acc acall talk_1034 ; once to send the address pop acc acall talk_1034 ; and a second time to get good data ret talk_1034: setb p1.2 ; listen here clr p1.1 ; clock to 0 mov r2, #6 clr p1.0 ; oe/cs enabled - start transaction loop1: rlc a ; loop sending 6 bits of data (inc 2 bits of 0) mov p1.3, c ; send data bit setb p1.1 ; clock it clr p1.1 djnz r2, loop1 setb p1.3 ; turn it off mov r2, #8 ; read 8 MSBs into r1 clr a loop2: mov c, p1.2 ; sample it setb p1.1 ; clock it rlc a ; shift it clr p1.1 djnz r2, loop2 mov r1, a mov r2, #2 ; and the next 2 into r0 loop3: mov c, p1.2 setb p1.1 ; clock it rlc a clr p1.1 djnz r2, loop3 swap a rlc a rlc a anl a, #0xc0 mov r0, a setb p1.0 ; oe/cs disabled mov r2, #(41-8)/4+1 loop4: ; and allow the next conversion to complete setb p1.1 ; clock it clr p1.1 setb p1.1 ; clock it clr p1.1 setb p1.1 ; clock it clr p1.1 setb p1.1 ; clock it clr p1.1 djnz r2, loop4 setb p1.1 ; clock to 0 clr c ret ; ; utility vector hook for NVRAM ; entry_nvram: cjne r2, #'W', no_nonvwr mov r1, #100 ; timeout ajmp entry_write_nvram no_nonvwr: cjne r2, #'w', no_nonvwr2 mov r1, r4 ; timeout ajmp entry_write_nvram no_nonvwr2: cjne r2, #'R', no_nonvrd mov r1, #100 ; timeout ajmp entry_read_nvram no_nonvrd: cjne r2, #'r', no_nonvrd2 mov r1, r4 ; timeout ajmp entry_read_nvram no_nonvrd2: ajmp entry_1034 ; ; ; this wonderfull code is from Larry Lynch-Freshner larrylf@engr.sgi.com ; don't blame him if it works wrong but thank him if it ; works right! ; ; utility routine to access a 24lc164 NVRAM ; - asumptions ; - SCL (Serial Clock) is wired to p1.4 ; - SDA (Serial I/O) is wired to P1.3 ;; ; calling conventions: ; - r6:r7 contain the address to write/read NVRAM ; to (r6 is 6msb, r7 is 8lsb) ; - r3 contains the number of bytes to write ; (max 16 for write, 256 for read) ; - r0 contains the address to read/write from (internal mem) ; - uses r0-r3 and A entry_write_nvram: mov a, r6 ; setup control word rl a orl a, #0x80 ; set start bit xrl a, #0x20 ; compliment chip addr bit 1 (see spec) anl a, #0xfe ; clear low bit (write) nvwrwaitlp: push acc lcall send_start ; send start lcall send_nvram ; send control word pop acc ; restore acc jnc wrcont dec r1 cjne r1, #0, nvwrwaitlp setb c ret wrcont: mov a, r7 ; load address low lcall send_nvram ; send address nvwrite_loop: mov a, @r0 ; get byte lcall send_nvram ; send it inc r0 djnz r3, nvwrite_loop lcall send_stop clr c ret nvrdtimeout: pop acc ; get rid of it... ret ; CY is still set ;; ;; we can handle timeout easy here, as this won't be called in the ;; logging loop ;; entry_read_nvram: mov a, r6 ; setup control word rl a orl a, #0x80 ; set start bit xrl a, #0x20 ; compliment chip addr bit 1 (see spec) anl a, #0xfe ; clear low bit (write to set address) nvrdwaitlp: push acc ; save control word lcall send_start ; send start lcall send_nvram ; send control word jnc rdcont dec r1 cjne r1, #0, nvrdwaitlp pop acc setb c ret rdcont: mov a, r7 ; load address low acall send_nvram ; send address ;; address is now sent, put in read mode: pop acc ; get control word orl a, #1 ; set low bit (read) acall send_start ; send start (again) acall send_nvram ; send control word dec r3 mov a, r3 jz nvr_1 nvread_loop: acall recv_nvram_ack ; get byte mov @r0, a ; store it inc r0 djnz r3, nvread_loop nvr_1: acall recv_nvram ; get last byte, no ack mov @r0, a ; store it acall send_stop clr c mov tcountl, #0 ret send_start: clr p1.4 ; set port to known state nop nop setb p1.3 nop nop setb p1.4 ; clock high nop nop nop clr p1.3 ; start nop nop nop clr p1.4 ; drop clock nop ret send_stop: clr p1.4 ; set port to known state nop nop clr p1.3 nop nop setb p1.4 ; clock high nop nop nop setb p1.3 ; stop nop nop nop clr p1.4 ; drop clock ret ;; send 8 bits in A to nvram. Ack bit is returned in CY ;; uses r2 send_nvram: mov r2, #8 sloop: rlc a mov p1.3, c nop nop setb p1.4 nop nop nop nop nop nop clr p1.4 djnz r2, sloop nop setb p1.3 ; allow line to be driven nop nop nop setb p1.4 ; clock for ack bit nop nop nop nop mov c, p1.3 ; ack bit into carry nop clr p1.4 nop nop nop nop nop nop nop nop nop nop nop nop ret ;; receive 8 bits in A from nvram. ;; uses r2. Doesn't acknowedge recv_nvram: setb p1.3 mov r2, #8 rloop: setb p1.4 ; clock high nop nop mov c, p1.3 ; read bit rlc a ; store it clr p1.4 ; clock low nop nop nop nop nop nop nop nop djnz r2, rloop ret recv_nvram_ack: acall recv_nvram nop nop nop nop nop clr p1.3 ; ack bit nop nop setb p1.4 ; clock for ack bit nop nop nop nop nop clr p1.4 nop nop setb p1.3 nop nop ret ; ; Utility routines form inspecting EEPROM ; dump_eeprom: lcall get_addr jc de_fail_addr do_dump_eeprom: mov a, r7 lcall disp_byte mov a, r6 lcall disp_byte mov a, #':' lcall send mov a, #' ' lcall send mov r0, #old_addr mov a, r6 add a, #8 mov @r0, a inc r0 mov a, r7 addc a, #0 mov @r0, a inc r0 mov a, #5 mov @r0, a mov a, r6 mov r6, r7 mov r7, a mov r0, #0xf0 mov r3, #16 mov r2, #'R' acall do_nvram mov r0, #0xf0 mov r7, #8 dee_loop: mov a, @r0 inc r0 push r0_0 lcall disp_byte mov a, #' ' lcall send pop r0_0 djnz r7, dee_loop mov dptr, #DO_NL ljmp DisplayC do_nvram: mov r1, #utility_vector mov a, @r1 mov dpl, a inc r1 mov a, @r1 mov dph, a clr a jmp @a+dptr de_fail_addr: mov dptr, #ERR2 ljmp DisplayC ; ; Copy N bytes of data to the eeprom starting at 0000 ; from memory at 8000 - it is prefixed by ; ; 0000: 0xa5 ; 0001: 'C' meaning 'executable code' for power on boot ; 0002: lsb count ; 0003: msb count ; write_eeprom_f: mov a, #'F' ajmp nep write_eeprom: mov a, #'C' nep: push acc lcall get_addr jc de_fail_addr mov r0, #0xf0 mov a, #0xa5 mov @r0, a inc r0 pop acc mov @r0, a inc r0 mov a, r6 mov @r0, a inc r0 mov a, r7 mov @r0, a inc r0 mov dptr, #0x8000 mov r1, #12 mov r5, r7 mov r4, r6 mov r6, #0 mov r7, #0 wee_loop: acall mov_ee ; suck 16 bytes push r5_0 push r4_0 push dpl push dph mov r0, #0xf0 mov r3, #16 mov r2, #'W' acall do_nvram mov a, r7 ; increment the eeprom address add a, #16 mov r7, a mov a, r6 addc a, #0 mov r6, a pop dph pop dpl pop r4_0 pop r5_0 mov r1, #16 mov r0, #0xf0 cjne r5, #0, wee_loop cjne r4, #0, wee_loop mov dptr, #WEE_DONE ljmp DisplayC WEE_DONE: byte "Copy completed" mov_ee: movx a, @dptr inc dptr mov @r0, a inc r0 dec r4 cjne r4, #0xff, mee1 dec r5 mee1: cjne r4, #0, mee2 cjne r5, #0, mee2 ret mee2: djnz r1, mov_ee ret ; ; copy the eeprom back to main memory ; load_eeprom: mov r7_3, #0 x_load_eeprom: ; ; read the header ; mov r0, #0xf0 clr a mov @r0, a inc r0 mov @r0, a mov r6, #0 mov r7, #0 mov r0, #0xf0 mov r3, #16 mov r2, #'R' acall g_do_nvram ; ; check it's validity ; mov r0, #0xf0 mov a, @r0 cjne a, #0xa5, lee_bad inc r0 mov a, @r0 cjne a, #'C', lee_0 ajmp lee_99 lee_0: cjne a, #'B', lee_1 ajmp lee_98 lee_1: cjne a, #'F', lee_bad lee_99: mov a, r7_3 jnz lee_bad lee_98: ; ; get the count ; inc r0 mov a, @r0 mov r4, a inc r0 mov a, @r0 mov r5, a inc r0 ; ; set up the transfer ; mov r1, #12 ; ; check to see if it's a basic load mov a, r7_3 jnz lee_8 mov dptr, #0x8000 ajmp lee_9 lee_8: mov dptr, #PSTART lee_9: lee_loop: ; ; copy out to sram ; acall lee_out ; ; have we reached the end? ; cjne r5, #0, lee_4 cjne r4, #0, lee_4 clr a ret lee_4: ; ; increment eeprom address ; mov a, r7 add a, #16 mov r7, a cjne a, #0, lee_3 inc r6 lee_3: push r5_0 push r4_0 push dpl push dph ; ; read the next set of data ; mov r0, #0xf0 mov r3, #16 mov r2, #'R' acall g_do_nvram ; ; set up for the next copy ; pop dph pop dpl pop r4_0 pop r5_0 mov r1, #16 mov r0, #0xf0 ajmp lee_loop g_do_nvram: mov a, r7_3 jnz lee_11 ajmp do_nvram lee_11: ajmp b_do_nvram ; ; copy eeprom data to external sram ; lee_out: mov a, @r0 inc r0 movx @dptr, a inc dptr dec r4 cjne r4, #0xff, lee1 dec r5 lee1: cjne r4, #0, lee2 cjne r5, #0, lee2 ret lee2: djnz r1, lee_out ret lee_bad: mov a, r7_3 jz l224 ret l224: mov dptr, #LEE_BAD ljmp DisplayC LEE_BAD: byte "Invalid eeprom header" ; ; print a directory of the eeprom ; ee_dir: mov r6_3, #0 ; starting address mov r7_3, #0 eed_loop: mov r6, r6_3 mov r7, r7_3 mov r0, #0xf0 mov r3, #16 mov r2, #'R' acall do_nvram mov r0, #0xf0 mov a, @r0 cjne a, #0xa5, eed_done inc r0 mov a, @r0 clr c subb a, #'A' cjne a, #26, eed1 eed1: jnc eed_done mov a, r6_3 lcall disp_byte mov a, r7_3 lcall disp_byte mov a, #':' lcall send mov a, #' ' lcall send mov r0, #0xf1 mov a, @r0 lcall send mov a, #' ' lcall send mov r0, #0xf2 ; get the count and increment the address mov a, @r0 mov r0_3, a add a, r7_3 mov r7_3, a inc r0 mov a, @r0 mov r1_3, a addc a, r6_3 mov r6_3, a mov a, r7_3 ; and add in the header add a, #4 mov r7_3, a jnc eed2 inc r6_3 eed2: anl a, #0xf ; and round it up to a multiple of 16 jz eed3 mov a, r7_3 anl a, #0xf0 add a, #0x10 mov r7_3, a jnc eed3 inc r6_3 eed3: mov a, r1_3 lcall disp_byte mov a, r0_3 lcall disp_byte mov dptr, #DO_NL lcall DisplayC ajmp eed_loop eed_done: ret ; ; loads the header and leaves the byte in r7_3 ; check_eeprom: mov r6, #0 mov r7, #0 mov r0, #0xf0 mov r3, #2 mov r2, #'R' acall do_nvram mov r0, #0xf0 mov a, @r0 cjne a, #0xa5, cee_bad inc r0 mov a, @r0 cjne a, #'C', cee_0 ajmp cee_99 cee_0: cjne a, #'B', cee_1 ajmp cee_99 cee_1: cjne a, #'F', cee_bad cee_99: mov r7_3, a ret cee_bad:mov r7_3, #0 ret ; ; do auto-load - a contains byte 2 from the EEPROM ; eeprom_load: cjne a, #'C', not_code acall load_eeprom mov dptr, #0x8000 clr a jmp @a+dptr ;GO DO IT not_code: cjne a, #'B', not_basic ljmp START_BASIC not_basic: ljmp EFORTH_START ; ; basic store stuff ; b_eeprom_header: push r1_0 mov r1, #0xed mov a, #0xf4 mov @r1, a inc r1 clr a mov @r1, a inc r1 mov @r1, a inc r1 mov a, #0xa5 mov @r1, a inc r1 mov a, #'B' mov @r1, a inc r1 mov a, r6 mov @r1, a inc r1 mov a, r7 mov @r1, a pop r1_0 ret b_eeprom_byte: push r0_0 ; get some pointers push r1_0 push acc ; save the byte mov r1, #0xed ; get the pointer mov a, @r1 mov r0, a pop acc ; move the byte mov @r0, a inc r0 cjne r0, #0, bee_n ; if we got 16 ; write them acall b_ee_write pop r1_0 pop r0_0 ret bee_n: mov a, r0 mov @r1, a pop r1_0 pop r0_0 ret ; ; at the end flush out the last buffer b_eeprom_end: push r0_0 push r1_0 mov r1, #0xed mov a, @r1 cjne a, #0xf0, bee_2 ajmp bee_3 bee_2: acall b_ee_write bee_3: pop r1_0 pop r0_0 ret ; ; basic has a copy of the utility vector elsewhere ; b_do_nvram: mov dph, UV_H mov dpl, UV_L clr a jmp @a+dptr ; ; ; utility routine for Basic - writes out a block ; b_ee_write: push r2_0 ; get some space to work push r3_0 push r5_0 push r6_0 push r7_0 mov a, #0xf0 ; reset the pointer mov @r1, a inc r1 mov a, @r1 ; get the eeprom address mov r7, a inc r1 mov a, @r1 mov r6, a mov r0, #0xf0 ; write it mov r3, #16 mov r2, #'W' acall b_do_nvram mov r1, #0xee ; save the new address mov a, r7 add a, #16 mov @r1, a cjne a, #0, bee_1 inc r6 mov a, r6 inc r1 mov @r1, a bee_1: pop r7_0 ; recover the saved state pop r6_0 pop r5_0 pop r3_0 pop r2_0 ret ; ; set up the forth EEPROM stuff ; forth_eeprom_setup: push r0_0 push r1_0 push r2_0 push r3_0 push r4_0 push r5_0 push r6_0 push r7_0 mov r7, #0 ; get the header mov r6, #0 mov r0, #0xf0 ; write it mov r3, #16 mov r2, #'R' acall do_nvram mov r0, #0xf2 mov a, @r0 mov r4_3, a ; count inc r0 mov a, @r0 mov r5_3, a ; mov r0_3, #0xf4 mov r6_3, #0 ; address mov r7_3, #16 mov IN_TYPE, #1 pop r7_0 pop r6_0 pop r5_0 pop r4_0 pop r3_0 pop r2_0 pop r1_0 pop r0_0 ret ; ; returns next character in a ; forth_ee_in: push r0_0 mov r0, r0_3 mov a, @r0 push acc inc r0 mov r0_3, r0 cjne r0, #0, fee_1 push r1_0 push r2_0 push r3_0 push r4_0 push r5_0 push r6_0 push r7_0 mov r6, r6_3 mov r7, r7_3 mov r0, #0xf0 ; read it mov r3, #16 mov r2, #'R' acall do_nvram mov a, r7_3 add a, #16 mov r7_3, a cjne a, #0, fee_3 inc r6_3 fee_3: pop r7_0 pop r6_0 pop r5_0 pop r4_0 pop r3_0 pop r2_0 pop r1_0 mov r0_3, #0xf0 fee_1: dec r4_3 mov a, r4_3 cjne a, #0xff, fee_2 dec r5_3 fee_2: mov a, r4_3 cjne a, #0, fee_5 mov a, r5_3 cjne a, #0, fee_5 mov IN_TYPE, #2 fee_5: pop acc ; we put a null at the end incase they typed the wrong number cjne a, #0, fee_6 mov IN_TYPE, #2 mov a, #0x0d fee_6: pop r0_0 ret