;AUX 11/19/80 ;XYBASIC Interpreter Source Module ;Copyright (C) 1978, 1979, 1980 by Mark Williams Company, Chicago ;statement auxilliary routines ;general purpose routines used in statement execution ;LINBC gets current line # in BC. ;Call: (LNNUM) current line # address, 0 if direct ;Retn: A clobbered ; BC if (LNNUM) = 0 then 0 else ((LNNUM)) ; DE preserved ; HL if (LNNUM) = 0 then 0 else (LNNUM) + 1 ; Zero set iff (LNNUM) = 0 linbc: lhld lnnum linb1: mov a,h ora l jz linb2 ;line # is 0, i.e. direct mov c,m inx h mov b,m ;line # to BC ret linb2: mov b,a mov c,a ;0 to BC ret ;IDTST issues a fatal ID error if current statement is direct, i.e. (LNNUM)=0. ;IITST performs EOS test, then issues fatal II error if current is indirect. if compl idtst equ linbc ;just return current line in BC else idtst: call linbc ;zero set iff direct rnz iderr: error f, I, D ;fatal ID error iitst: call eos call linbc ;zero set iff direct rz ;ok if direct error f, I, I ;issue fatal II error endif ;end of NOT COMPL conditional ;RTEST returns Zero set iff location HL is RAM. rtest: mov a,m ;fetch byte cma mov m,a ;store complement cmp m ;compare to stored value cma mov m,a ;restore value ret if romsq and not compl ;ISSRC returns if SOURC address working space, issues fatal RO error otherwise. issrc: lxi d,srcad lhld sourc call cmdhu ;compare SOURC to SRCAD rz ;addressing working space, OK roerr: error f, R, O ;fatal RO error ;ISROM checks if current program is running in ROM, issues nonfatal RO error ;and scans to next command if so. isrom: lhld sourc call rtest ;test if ROM rz ;RAM, OK error c, R, O ;nonfatal RO error and scan on endif ;end of ROMSQ AND NOT COMPL conditional ;EOS checks for garbage on end of statement, and is called by routines which ;alter normal control flow (GOTO, GOSUB, RETURN, etc.). ;Falls through to syntax error if next nonspace char is not :, ' or . ;Retn: A next nonspace char ; BC,DE preserved ; HL address of next nonspace char (i.e. of :, ' or ) eos: call dtst0 rnc ;ok if next is delimiter snerr: error c, S, N ;issue SN error and scan to next exerr: error f, E, X ;fatal EX error if compl uferr: error c, U, F ;issue UF error and scan to next endif ;DTEST tests whether A contains a delimiter. ;Retn: Carry reset iff (A) = :, ' or ; Registers preserved dtst0: call gtcho dtest: cpi ':' rz dtst1: cpi cr rz if rtpak or not compl ;comments already purged if compiled cpi '''' rz endif stc ret ;GTLHS gets a destination variable reference. It calls GTVAR with ;INLHS true (to indicate tracing may be desired) and stores the ;destination returned in LHSAD for ASSGN to perform assignment. gtlhs: if not compl mvi a,255 sta inlhs ;set INLHS to true endif call gtvar ;perform variable reference jc snerr ;no variable name sta lhsty ;save type shld lhsad ;save destination if not compl mov b,a ;save type xra a sta inlhs ;reset INLHS to false mov a,b ;restore type endif ret ;ASIGN is CALLed by FOR, NEXT, LET, READ, INPUT to change a variable's value. ;The value addressed by HL is assigned to the destination LHSAD. ;Trace information is printed if (VTRAC) is negative. asigv: call esval ;value to ESTACK lhld estkp inx h ;point to value asign: lda lhsty ;desired type to A call cnvrt ;convert value to desired type if strng cpi strst cz scopv ;copy to string space if type string endif call bytsd ;# bytes in value to DE inx h ;point to value mov b,h mov c,l ;value source to BC lhld lhsad ;destination to HL if compl jmp moved ;value to destination and return if COMPL else push psw ;save type push b ;and save value location call moved ;value to destination pop h ;value location to HL pop b ;value type to B ;and fall through to TRVAL ;TRVAL prints variable value if tracing is desired. ;Call: VTRAC bit 7 set iff tracing desired ; B value type ; HL value location trval: lda vtrac ora a rp ;done if not tracing trva1: mvi a,'=' ;BTEST entry point call writc ;write the = dcx h ;point to type mov a,b ;fetch type if strng cpi strst jnz prval ;print nonstring value xchg lxi h,stemp inr m ;increment STEMP count before fetching string xchg endif jmp prval ;print the value and return endif ;end of NOT COMPL conditional ;ASIGI performs traced integer assignment for NEXT and SCALL value return. asigi: mov m,b dcx h mov m,c ;value to destination if not compl push b mvi b,intst call trval ;print trace info if desired pop b endif ret ;BYTSD returns with the number of bytes in an value in DE. bytsd: lxi d,vbyts-1 if float cpi sngst rz ;return 4 if floating if fpbcd mvi e,3 else dcx d endif endif if strng cpi strst rz ;return 3 if string endif if float or strng dcx d endif ret ;return 2 if integer ;FETCH fetches a value addressed by HL and returns its type in the status bits. ;Call: HL pointer to type ;Retn: A type token ; BC value if integer, Carry reset and Zero set ; C,DE length, location if string, Carry set and Zero set ; FACC value if floating, Carry reset and Zero reset ;FETBC does a FETCH of arg in BC. fetbc: mov h,b mov l,c fetch: mov a,m ;fetch the type token fetc1: if float cpi sngst jz fetcf ;fetch floating endif if strng cpi strst jz fetcs ;fetch string endif fetci: cpi intst jnz exerr if float shld argad ;save location for retry of ambiguous op endif mobcm: inx h ;Zero is set, Carry reset mov c,m inx h mov b,m ;fetch integer to BC ret if strng fetcs: inx h mov c,m ;length to C call modem ;location to DE lxi h,stemp dcr m ;decrement # string temps in use jm exerr ;EX error if negative xra a ;Zero is set stc ;and Carry set also ret endif if float if f9511 ;9511 version fetches to 9511 stack fetcf: push h push b inx h ;point to first value byte call lod95 ;load value to 9511 stack pop b ;restore BC pop h ;restore HL mvi a,sngst ;floating point token to A ora a ;clear Carry and Zero ret ;and return else ;NOT F9511 fetcf: push3 ;save registers inx h ;point to value call fload ;load value to FACC mvi a,sngst ;return type in A ora a ;Carry reset, Zero reset jmp pop3 ;restore registers and return endif endif ;MVDEM returns (M):(M-1) in DE, (HL)-2 in HL ;BC, PSW preserved mvdem: mov d,m dcx h mov e,m dcx h ret ;MVMDE moves (DE) to (M-1):(M-2), returns (HL)-2 in HL mvmde: dcx h mov m,d dcx h mov m,e ret ;MODEM moveds (M+2):(M+1) to DE, returns (HL)+2 in HL. modem: inx h mov e,m inx h mov d,m ret ;ISBYT checks whether (B) = 0. If so, it returns. ;If not, a nonfatal BY error is issued and B is set to 0. ;A clobbered, B forced to 0, other registers preserved. isbyt: mov a,b ora a ;clear carry, set zero iff (B) = 0 rz mvi b,0 ;force (B) to 0 error n, B, Y ;nonfatal BYte error ret ;and return ;CPLDE replaces (DE) with its two's complement. ;CPLD1 replaces (DE) with its one's complement. ;Retn: A clobbered ; BC,HL preserved ; DE two's complemented ; Carry set iff (DE) = 8000H, i.e. overflow cplde: dcx d cpld1: mov a,e ;entry point to one's complement DE -- cma ; NB carry set if called with 7FFFH mov e,a mov a,d cma mov d,a xri 80H ora e ;zero set iff (DE) = 8000H rnz cmc ;set carry if overflow ret ;ADAHL adds (A) + (HL), leaves result in HL and sets carry on overflow. adahl: add l mov l,a rnc ;done if no carry inr h ;else inc high order rz ;return with carry set iff overflow cmc ret ;SBAHL subtracts (HL) - (A), leaves result in HL and sets carry on underflow. sbahl: sub l ;(A) - (L) to A, carry set iff L > A cma ;L - A - 1 mov l,a inx h ;L - A rc dcr h ret ;CMBDU compares (BC) to (DE) as 16 bit unsigned integers. ;Retn: A clobbered ; BC,DE,HL unchanged ; Zero set iff (BC) = (DE) ; Carry set iff (BC) < (DE) cmbdu: mov a,b cmp d ;carry set iff (B) < (D) rnz ;finished unless (B) = (D) mov a,c ;(B) = (D), so compare (C) to (E) cmp e ret ;CMDHU same as CMBDU except DE::HL cmdhu: mov a,d cmp h rnz mov a,e cmp l ret ;CMBDS compares (BC) to (DE) as 16 bit signed (two's complement) integers. ;Retn: same as CMBDU above. cmbds: mov a,b xra d ;sign set iff signs agree jp cmbdu ;unsigned compare works when signs agree mov a,b ;signs disagree, sign of B gives result ral ;NB zero is reset from xra above ret ;FLIP is called by READ and INPUT to exchange text pointers in TEXTP and TXTP2. ;Clobbers DE, preserves PSW, leaves TEXTP in HL. flip: lhld txtp2 xchg ;TXTP2 to DE lhld textp shld txtp2 ;TEXTP to TXTP2 xchg shld textp ;TXTP2 to TEXTP ret ;DMODX is a common exit for various versions of LOAD and EXEC. ;First the control and expr stacks are reset. Then execution continues ;if the command was direct, and XYBASIC returns to DMODE if indirect ;(since the source program has been changed by the EXEC or LOAD). ;Call: HL eof address of new program if not compl dmodx: call new1 ;reset stacks call linbc ;Zero set iff direct rz ;continue normally if direct jmp dmod2 ;otherwise to DMODE endif ;BDTST is called from FOR and NEXT to test FOR-loop termination. ;Call: BC or FACC new FOR-variable value (integer or floating) ; DE increment pointer ; HL bound pointer ; LHSTY FOR-variable type ;Retn: Carry Set iff exit condition satisfied, i.e. value>bound and inr>=0 ; or valuebound, return complemented incr sign ret endif bdts1: ldax d mov e,m inx h mov d,m ;integer bound to DE rlc cnc bcde ;exchange value and bound if incr>=0 jmp cmbds ;and CMBDS returns desired Carry status ;FNDST is called from FOR and READ to scan through a program for ;the matching NEXT or next DATA statement. ;Call: (textp) text address at which scanning is to begin ; B token to be matched (NEXT or DATA) ; (1) Found (2) Notfound ;Retn: A token 0 ; B preserved preserved ; C,DE clobbered clobbered ; HL address of next unparsed text char eof address ; Carry reset set ; (textp) ditto eof address - 1 fnds0: call dtst0 ;check if at delimiter cmc rnc ;return carry reset if not ;else empty DATA, fall through to retry fndst: mvi c,1 ;initialize FOR count lxi d,4 ;to skip bytes after fnds1: call gtcha ;get next char cmp b jz fnds3 ;found one cpi ':' jz fnds1 ;multiple statements -- look at next if rtpak or not compl ;comments purged if compiled cpi '''' cz rem ;on-line comment -- scan to endif cpi cr jz fnds2 ;cr cpi fort cz inrc ;increment FOR-count if FOR call gtdel ;scan to delimiter jmp fnds1 ;keep trying inrc: inr c ret fnds2: mov a,m ;fetch next line length byte ora a ;check for end of file jz bkupc ;return carry set if failed dad d ;point to next text byte shld textp ;store new pointer jmp fnds1 ;and keep looking fnds3: cpi datat jz fnds0 ;done if DATA fnds4: call gtnam ;look for var name after NEXT dcr c ;decrement count jnc fnds5 cmc ;clear carry in case found rz ;done if NEXT and FOR count is 0 jmp fnds1 ;and keep looking fnds5: rz ;return if counted to 0 call gtcom ;look for comma after jc fnds1 ;none jmp fnds4 ;else look for more ;FNDLN finds the line # address of the line which DE points into. ;Used by READ for DATA syntax errors. ;Call: DE pointer into text ;Retn: BC,DE preserved ; HL line # address of desired text line fndln: if not romsq lxi h,srcad else lhld sourc endif fnln1: shld temp ;save length byte address mov a,m ;fetch length call adahl ;address next line call cmdhu ;compare to desired pointer jnc fnln1 ;keep looking lhld temp ;restore length byte addr inx h ;point to line # ret if realt ;CLOCK is the interrupt service routine to tick the real-time clock. ;The interrupt branches to 10H, POKEd during initialization to come here. ;The four bytes at TIMEX contain 20ths-20, seconds-60, minutes-60 and hours-24. clock: push psw push h lxi h,timex ;address 20ths counter inr m ;tick it jnz clocx ;done mvi m,255 and -20 ;reset to -20 inx h ;address seconds counter inr m ;tick it jnz clocx ;done mvi m,255 and -60 ;reset to -60 inx h ;address minutes counter inr m ;tick... jnz clocx ;done mvi m,255 and -60 ;reset inx h ;address hours counter inr m ;tick... jnz clocx ;done mvi m,255 and -24 ;welcome to tomorrow clocx: pop h mvi a,20H out 0D8H ;reinitialize the clock pop psw ei ;reenable interrupts ret endif if editc and (not compl) ;LNREF changes all occurrences of s in source text for RENUM. lnref: lxi h,srcad ;begin at the beginning ;process next line of source text lnre1: mov a,m ;fetch length byte ora a rz ;eof, done push h inx h inx h inx h inx h ;address first text byte ;process next byte of source text lnre2: mov a,m ;fetch a text byte inx h cpi cr ;check if end of line jz lnre5 ;yes cpi '''' jz lnre4 ;on-line comment, scan to cpi remt jz lnre4 ;REM, scan to if key80 cpi 20H jc lnre3 ;reserved word token, check it endif cpi 80H jc lnre2 ;not a token, try next ;found a , check if can and does follow lnre3: call kltst ;test if token can have following jc lnre2 ;no, try next sta txtp2 ;save token in TXTP2 in case ON list or LIST shld textp ;set TEXTP to scan possible lnr3j: call gtcho ;skip spaces, if any push h ;save HL pointing to first nonspace call gtlno ;look for xthl ;restore HL pop b ;first nondigit location to BC jc lnre2 ;not a , try next byte ;found a push h ;save first for insertion of new line # xchg call cplde ;- first xchg dad b ;last + 1 - first = length to HL push h ;save length call findl ;look for jc lnr3c ;not found, flag the line push h ;save location lhld rnold xchg call findl ;find location of first renumbered line pop d ;location of desired line to DE call cmdhu jc lnr3d ;before renumbered lines, unchanged push h ;save first loc lhld rninc mov b,h mov c,l ;increment to BC lhld rnnew ;first destination line # to HL jz lnr3b ;matched, take first line # ;compute new corresponding to old lnr3a: xthl ;first line loc to HL mov a,m call adahl ;address next line call cmdhu ;compare to desired line # xthl dad b ;compute new line # jnz lnr3a ;no match, try next ;convert new to string and compare to length of old lnr3b: pop d ;discard saved location mov b,h mov c,l ;new line # to BC xra a call cvtis ;and converted to string, no leading char call bcde ;location to BC, length to E pop h ;length of old line # to L sub l ;new length - old length pop h ;old line # loc to HL jm lnr3e ;old line # longer jnz lnr3f ;old line # shorter call movd0 ;move new line # to replace old jmp lnr3h ;and keep scanning ;old not found, flag bit 7 of line break byte lnr3c: pop h ;discard saved length pop h ;and discard saved first loc pop h ;length byte addr to HL push h ;and resaved inx h inx h inx h ;address break byte mvi m,80H ;set bit 7 to indicate line # not found jmp lnr3h ;and keep scanning ;old precedes renumbered lines, leave unchanged lnr3d: pop h ;discard saved length pop h ;and discard saved first loc jmp lnr3h ;and keep scanning ;old longer than new lnr3e: push psw ;save offset call movd0 ;copy new line # to old place shld textp ;and set new TEXTP xchg ;new destination to DE pop psw ;restore offset pop h ;line length pointer to HL push psw add m ;add offset mov m,a ;and store new line length pop psw push h ;resave line length pointer cma inr a ;complement offset xchg ;restore destination to HL push h ;save destination call adahl ;+offset = source push h xchg call cplde ;-source lhld eofad inx h dad d ;count bytes to move xchg ;to DE pop b pop h call moved ;block move the remaining text dcx h shld eofad ;store new eof jmp lnr3h ;and keep scanning ;old shorter than new lnr3f: push psw push b push d push h ;save all xchg ;first old line # byte addr to DE lhld eofad mov b,h mov c,l ;end of file to BC call adahl ;offset + eof = new eof shld eofad ;store new eof lnr3g: ldax b ;fetch a text byte mov m,a ;and store in new location dcx b dcx h mov a,e cmp c jnz lnr3g mov a,d cmp b jnz lnr3g ;copy more text bytes pop h pop d pop b ;restore new line # info call movd0 ;and copy line # into text shld textp pop psw ;offset pop h ;line length addr add m ;old length + offset mov m,a ;gives new length push h lnr3h: lda txtp2 ;recover token preceding lhld textp cpi gotot jz lnr3i ;GOTO cpi gsubt jz lnr3i ;GOSUB cpi listt jnz lnre2 ;not GOTO, GOSUB nor LIST, keep scanning lnr3i: call gtcom ;look for comma jc lnre2 ;none, keep scanning jmp lnr3j ;look for next element in list ;scan to next lnre4: mov a,m inx h cpi cr jnz lnre4 ;end of source text line, try the next lnre5: pop h ;length byte addr to HL mov a,m call adahl ;address next line jmp lnre1 ;and try next line ;KLTST tests if token in A may have following. ;Call: A Token ;Retn: C Clobbered ; A,B,DE,HL Preserved ; Carry Set iff not found kltst: push h mvi c,klnct ;table count to C lxi h,klnta ;table addr to HL klts1: cmp m ;compare token to table entry jz klts2 ;matched inx h dcr c jnz klts1 ;try next stc ;not found klts2: pop h ;restore HL ret ;and return endif ;end of EDITC conditional if not compl ;BKNAM constructs a 3-byte symbol table 'name' at BUFAD for a line break. ;Byte 1 is H6-H0, byte 2 is L6-L0, both with bit 7 reset. ;Byte 3 has 1,H7,L7 in bits 7-5 and bits 4-0 reset. ;Call: HL desired break entry 'name' (i.e. line # addr) bknam: xchg ;desired line # addr to DE lxi h,bufad mov a,d ani 7FH mov m,a ;byte 1 = D6-D0 to BUFAD inx h mov a,e ani 7FH mov m,a ;byte 2 = E6-E0 to BUFAD+1 inx h mov a,d ral ;D7 to Carry mov a,e rar ;D7, E7 to A7, A6 stc rar ;1, D7, E7 to A7-5 ani 0E0H ;mask off A4-0 mov m,a ;byte 3 to BUFAD+2 ret endif ;end of NOT COMPL conditional ;GTPAR gets a parameter from CALL command line. ;Parameters must be or *. ;Retn: A 0 if no more params, 1 if integer, 2 if string, 3 if floating ; B bytes per entry ; C # dims ; DE address of first dimension ; HL address of first data item gtpar: call gtcnd ;look for comma not followed by delimiter mvi a,0 rc ;no more parameters, return 0 mvi d,multt call gtd ;look for * jnc gtpa1 ;array passed call gtvar ;else var ref lxi b,0 ;# dims = 0 to C push b ;push 0 for DE jnc gtpa2 ;and continue below mcerr: error f, M, C ;fatal MC error gtpa1: call fdvar ;look for var name jc mcerr ldax d ;fetch type mov c,m ;# dims to C mvi b,0 ;to allow dad inx h ;point to first dim byte push h ;and save dad b dad b ;point to first data byte gtpa2: call bytsd ;bytes per entry to DE mov b,e ;and then to B pop d ;dim addr to DE mov a,b dcr a ;A gets 1 for int, 2 string, 3 floating ret ;DISAB disables all interrupts if not wild disab: xra a sta inttc ;reset interrupt table count sta intad ;clear interrupt table ret ; , [, ] [,$] ;IINFO gets interrupt information for ENABLE and WAIT. ;Four bytes corresponding to the first four bytes of an interrupt table ;entry are returned in BCDE (type, port, mask, value). iinfo: call gtbex mov b,c ;port # to B mvi c,0C0H ;type to C push b ;and saved call gtcbe mov d,c ;value to D mvi e,0 ;mask 0 for now call gtcom jc iinf3 ;default mask 0, null $ call gtcho cpi '$' jz iinf1 ;default mask 0, $ call gtbex mov e,c ;mask to E call gtcom jc iinf2 ;null $ iinf1: call gtcha cpi '$' jnz snerr mov a,d cma ora e mov d,a ;value = NOT value OR mask (if $) pop b mvi c,0E0H ;set type $ bit ret iinf2: mov a,d ora e mov d,a ;value = value OR mask (if null $) iinf3: pop b ret endif ;end of NOT WILD conditional ;end of AUX page