;STATES2 05/21/81 ;XYBASIC Interpreter Source Module ;Copyright (C) 1978, 1979, 1980, 1981 by Mark Williams Company, Chicago ;statement routines for statements FOR through NULL ;FOR = TO [STEP ] for: call gtlhs ;get destination for ASIGN if strng cpi strst jz snerr ;SN error if FOR endif lxi h,inone ;integer 1 addr to HL if float cpi sngst jnz for1 ;integer FOR lxi h,fpone ;floating 1. addr to HL endif ;At FOR1 the FOR var addr is in LHSAD, the default incr pointer in HL. ;The CSTACK is examined for a previous FOR entry with the same variable, ;and the entry is flushed if found. for1: push h ;save default incr pointer lxi b,(csfor shl 8) or csfor lhld cstkp ;set BC, HL for CSDIG for1a: call csdi1 ;look for old FOR entry jc for2 ;not found push h ;save current entry addr mov a,m ani 1FH call sbahl ;address next CSTACK entry xthl ;save next addr, current addr to HL lxi d,-5 dad d ;address var addr bytes call mvdem ;fetch FOR entry var addr to DE lhld lhsad ;FOR var addr to HL call cmdhu ;check if same variable pop h ;next entry addr to HL jnz for1a ;no match, try next mov a,b ;match, entry type to A call csrst ;and purge the entry ;FOR2 builds a new CSTACK FOR entry. The entry consists of a type/length byte ;(1 byte), line # address, return textp and variable address (2 bytes each), ;and bound and increment values (2 or 4 bytes each). After CPUSH allocates ;space for the entry, the CSTACK pointer is reset to ignore the protoentry ;in case FOR aborts, e.g. with a SN error. Another CPUSH completes the entry. for2: mov a,b call cpush ;allocate new CSTACK FOR entry xchg if not compl call linbc cz dcstd ;unincrement CSTACK direct count if direct endif lhld lhsad xchg call mvmde ;variable addr to entry mvi a,2*fbyts+1 ;skip two values call sbahl ;address next CSTACK entry shld cstkp ;reset CSTACK in case SN error in FOR inx h ;address bottom of new FOR entry push h ;and save pointer for bound/incr insertion call let1 ;get initial value and assign to var mvi d,tot call gtdsn ;skip TO token call evalt ;get bound of desired type inx h ;point to bound value xthl ;FOR entry pointer to HL pop b ;bound pointer to BC call moveb ;copy bound to entry xthl ;save entry addr for increment push h ;and default incr mvi d,stept call gtd ;look for STEP pop h ;default increment pointer to HL jc for2a ;no STEP, take default value call evalt ;get increment value inx h ;and point to value for2a: xthl ;entry pointer to HL pop b ;incr pointer to BC if for0 push h ;save pointer to incr for FOR0 test endif call moveb ;copy increment to entry and return mvi a,csfor if not for0 jmp cpush ;build the new CSTACK entry else call cpush ;must now check for vacuous condition (e.g. FOR I=1 TO 0) in FOR0 version lhld lhsad if float lda lhsty cpi sngst if f9511 cz lod95 ;load floating value to 9511 stack else cz fload ;load floating value to FACC endif endif mov c,m inx h mov b,m ;fetch integer value to BC pop d ;incr pointer to DE lxi h,-fbyts dad d ;bound pointer to HL call bdtst ;test FOR condition rnc ;ok, just return lhld cstkp call next6 ;purge the CSTACK entry just built call eos mvi b,nextt call fndst ;find matching NEXT jnc next7 ;look for following comma, return or do another error f, F, R ;not found, fatal FR error endif ;GOSUB gosub: call goto ;find new textp and lnnum gosu1: mvi a,csgos ;ON entry point push b ;save return text pointer jmp cpsh1 ;build control stack entry and return ;GOTO ;GOTO is called by GOSUB to read a line #, look for it and ;check for end of statement garbage. Branches to US error if illegal ;or no such line #, otherwise: ;Retn: A clobbered ; BC return text pointer, i.e. delimiter address ; DE line # ; HL address of preceding desired line in text ; (textp) same as HL goto: call gtlno ;line # to DE jc snerr ;no line # goto1: call eos ;end of statement test -- IF entry point goto2: call fdlno ;find line # -- interrupt, ON entry point jmp bakup ;back up textp and return ;IF THEN { | } ifcom: call gtexp ;evaluate the IF expression mvi d,thent call gtdsn ;skip THEN token mov a,b ora c jz rem ;false -- scan to cr and return call gtlno ;look for line # jc xsta2 ;none -- execute THENpart jmp goto1 ;GOTO line # and return ;INPUT [] [;] ;INPUT @, [in SDISK versions] ;INPUT @ [in PACKI versions] ;INPUT must scan two lines, the command line INPUT and the line ;of data typed by the user. The two text pointers are kept in TEXTP ;and TXTP2, and exchanged by FLIP. The original TEXTP ;is also PUSHed, to be available when REDOing. If the data is of ;incorrect type or there are fewer data than variables, REDO. If there are ;fewer variables than data, EXCESS IGNORED. ;DINP0 is in module SDISK. ;PAINP is in module PACKARD. input: call idtst ;INPUT illegal direct mode if sdisk call gtsfn ;look for disk file specification jnc dinp0 ;disk INPUT endif ;end of SDISK conditional if packi mvi d,'@' call gtd ;look for @ jnc painp ;found @, must be Packard INPUT @ endif xra a sta omode ;turn on output mode mvi d,'"' call gtd ;look for quoted string cnc prquo ;print it if present mvi d,semic call gtd ;look for ; and ignore if present ;INPU1 sets up pointers, and is entry point for retries after REDO message. inpu1: push h ;save textp to redo shld txtp2 ;save textp to scan varlist mvi a,'?' call writc ;write a ? call wrtsp ;and a space lhld savtp shld textp ;reset text pointer in case ^C typed call gtlin ;get input line call flip ;to scan varlist ;INPU2 gets the next variable and checks its type (string or nonstring). inpu2: call gtlhs ;get destination call flip ;to scan data if strng cpi strst jnz inpu3 ;nonstring variable call evunq ;get string value, perhaps unquoted jc inpu7 ;no string, REDO jmp inpu4 ;assign string value to destination endif ;INPU3 gets a nonstring value. inpu3: call gtlit ;get value jc inpu7 ;REDO if none if strng cpi strst ;check if string value jz inpu7 ;REDO if so endif ;INPU4 assigns a value to the destination variable. inpu4: call asigv ;assign value to destination call gtcnd ;look for comma not followed by delimiter jc inpu6 ;no more data or bad item call flip ;to scan varlist call gtcom ;look for comma jnc inpu2 ;continue with next var in varlist call prntm ;else print EXCESS IGNORED db 'EXCESS IGNORED', cr, lf or 80H ;INPU5 is the exit from a successful INPUT. inpu5: pop h ;pop REDO pointer ret ;and done inpu6: call dtst0 ;check if delimiter jc inpu7 ;no, REDO call flip ;else scan varlist call gtcom ;see if more vars jc inpu5 ;no, done ;INPU7 prints REDO message and retries after bad data. inpu7: call prntm ;more vars than data, print REDO message db 'RED', 'O' or 80H pop h jmp inpu1 ;reset varlist pointer and try again ;[LET] = let0: call bakup ;back up textp to get current char again call dtest ;test if delimiter rnc ;null statement let: if camac call gtcam ;look for camac variable jnc letcv ;perform camac LET endif if wild mvi d,wbuft call gtd jnc wletb ;BUFFER legal lhs in WILD version endif call gtlhs ;get destination for ASSGN let1: call gtequ ;skip = token -- FOR entry point call evals ;evaluate the rhs jmp asign ;and assign rhs to lhs ;letcv is in module CAMAC ;LIST [] [, ] if compl list equ uferr ;UF error in COMPL version else list: call gtlno ;min line # to DE, 0 if none call findl ;look for it push h ;save min line length byte address call gtcom ;skip the comma, if any call gtlno ;max line # to DE, 0 if none cc cpld1 ;complement to give default max = 0FFFFH call eos ;check for garbage mov b,d mov c,e ;max to BC pop h ;min length byte address to HL list1: mov a,m ;fetch length byte ora a rz ;eof -- done inx h mov e,m inx h mov d,m ;line # of current line to DE call cmbdu ;compare unsigned to max rc ;max < (DE) -- return dcx h ;point to line # call ctest ;look for break char call prntl ;print the line call wcrlf ;and crlf jmp list1 ;and try next endif ;end of NOT COMPL conditional ;LOAD is in section STATES4. ;MOVE {TO | FROM} ;MOVE performs a block move of a ROMSQ version user program TO or FROM RAM. ;The specified location must not overlap either BASIC or user RAM. if romsq and (not wild) if compl move equ uferr else move: call gtcha push psw ;save TO | FROM token call gtexp ;get location if camac ;RAM test only in segmented CAMAC versions lxi d,ramorg else lxi d,romorg ;base of BASIC to DE if rom ;check if within BASIC in ROM versions lxi h,eoram+1 ;top of BASIC + 1 to HL call mvtst ;check if loc within BASIC lxi d,ramorg ;base of user RAM to DE endif ;end of ROM conditional endif ;end of NOT CAMAC conditional if cpm and sdisk lhld filet ;top of RAM is (FILET) in CP/M SDISK versions else if strng lhld strt ;top of RAM is (STRT) in STRNG versions else lhld memt ;top of RAM is (MEMT) otherwise endif endif inx h ;top of user RAM + 1 to HL mov a,h ora l cnz mvtst ;check for loc within user RAM pop psw ;restore token cpi tot jnz movef ;must be FROM push b ;save destination lxi d,srcad-2 call cplde ;2-SRCAD to DE lhld eofad dad d ;last - first + 1 = length xchg ;to DE pop h ;destination to HL push h push d ;save dest, length move1: call rtest ;check if RAM jnz roerr ;ROM, RO error inx h dcx d mov a,d ora e jnz move1 ;check next lxi b,srcad-1 ;source to BC pop d ;length to DE pop h ;destination to HL jmp moved ;block move and return movef: cpi fromt jnz snerr ;neither TO nor FROM, SN error ldax b ;fetch first prog char cpi cr jnz roerr ;not a prog, RO error push b push b push b lhld sourc xthl ;save SOURC value inx h ;point to first length byte shld sourc call last ;last loc to BC pop h shld sourc ;restore SOURC pop d call cplde ;-first to DE lhld symta xchg ;-first to HL, SYMTA to DE dad b ;last-first=length-1 to HL push h ;save length for block move lxi b,srcad push b ;save destination for block move dad b ;last needed + 1 to HL call cmdhu jc omerr ;too big, OM error pop h ;destination pop d ;length pop b inx b ;source call moved ;block move into working space dcx h ;point to new eof jmp new1 ;reset stacks and EOFAD ;MVTST is called from MOVE to assure location specified does not overlap ;with XYBASIC or with user RAM. Issues fatal RO error if min <= loc <= max. ;Call: BC specified location ; DE min ; HL max+1 mvtst: call cmbdu rc ;loc < min xchg ;max+1 to DE call cmbdu rnc ;loc >= max+1 jmp roerr ;else fatal RO error endif ;end of NOT COMPL conditional else move equ exerr ;EX error in non-ROMSQ versions endif ;end of ROMSQ conditional ;NEW if compl newcm equ uferr ;UF error in COMPL version else newcm: if romsq call issrc ;check if addressing working space endif call iitst ;NEW is illegal indirect if sdisk call closn ;close any OPEN files endif new: call clea1 ;clear symbol table -- LOAD, init entry point xra a sta trace ;traceoff sta trap ;trapon lxi h,srcad mov m,a ;source text empty new1: push h ;ADDLN, DMODX, MOVE FROM entry point call stzap ;reset BREAK and FN symbol table entries call rstor ;restore the READ pointer if not wild call disab ;disable interrupts endif pop h shld eofad ;set eof address -- LOAD entry point endif ;end of NOT COMPL conditional cspst: shld cstkp ;clear control stack -- call to reset it shld estkp ;reset expr stack pointer ret ;NEXT [ [, ]* ] ;First the most recent CSTACK FOR entry is found. next: lxi b,(csfor shl 8) or csfor call csdig ;look for CSTACK FOR entry jc nferr ;not found -- fatal NF error push h ;save FOR entry address lxi d,-5 dad d ;point to var address bytes mov b,m dcx h mov c,m ;fetch var addr to BC push h ;and save var addr pointer lhld textp shld savtp ;save TEXTP in case retry necessary push b call fdvar ;look for var name after NEXT inx h pop b jc next1 ;no name ;NEXT specified, so the FOR is compared to it. xchg ;NEXT var addr DE, type addr HL call cmbdu ;compare FOR and NEXT s jz next3 ;FOR and NEXT s match ;s do not match, so CSTACK FOR entry is poped. lhld savtp shld textp ;restore textp to get var name again pop h pop h ;FOR entry address to HL mov a,m ;type/length byte to A mov b,a ;saved in B ani 1FH ;mask to length call sbahl ;address next entry mov a,b ;type/length restored call csrst ;purge the FOR entry from CSTACK jmp next ;and try again ;When no is specified after NEXT, the last CSTACK FOR entry ; is assumed. The type byte must be found for correct tracing. next1: lhld symta next2: call stnxt ;address next symbol table entry xchg call cmbdu ;compare to desired value addr xchg jnc next2 ;var addr >= next entry, try another xchg ;type byte addr to HL ;At NEXT3 the desired is known. The stack contains the FOR entry ;addr and the FOR entry var addr, BC contains the var addr, and HL ;contains the type byte pointer for the specified . ;The trace info [] is printed if desired. next3: if float mov a,m ani 1FH ;mask to type sta lhsty ;save destination type endif if not compl lda trace ora m ;sign set iff tracing sta vtrac ;set VTRAC for ASSGN inx h ;point to name jp next4 ;no tracing desired call bprnt ;print trace line # call prtst ;print var name endif ;At NEXT4 the bound & incr pointers are found in preparation for incrementing, ;and the old value is replace by value+increment. next4: pop h ;FOR entry var addr pointer to HL lxi d,-fbyts dad d push h ;save incr pointer push h dad d xthl ;save bound pointer, incr pointer to HL push b ;and save var addr if float lda lhsty cpi intst jz nxt4i ;integer FOR ;Now floating value is replaced by old value plus increment. push b if f9511 call lod95 ;incr to 9511 stack pop h call lod95 ;var value to 9511 stack call fadd ;add increment to var value mvi a,pto95 call o9511 ;copy stacktop call fet95 ;fetch result from 9511 stack else xthl ;save incr address, var address to HL call fload pop h ;incr address to HL if fpbcd call fadd ;add var value to increment else call fincr ;instead of CALL FADD call etest ;perform significance test endif endif pop h ;restore var addr if compl if f9511 call sto95 ;result to var addr else call fstor ;result to var addr endif else ;NOT COMPL push h if f9511 call sto95 ;result to var addr else call fstor ;result to var addr endif pop h ;restore var addr for tracing mvi b,sngst ;type to B call trval ;print trace info if desired endif jmp next5 endif ;Integer value is replaced by old value plus increment. nxt4i: mov c,m inx h mov b,m ;incr to BC pop h mov e,m inx h mov d,m ;value to DE push h call iadd ;integer add incr+value cc iover ;overflow, nonfatal OV error pop h call asigi ;assign and print trace info if desired ;At NEXT5 the bound is compared to the value to test for loop termination. next5: pop h ;bound pointer to HL pop d ;incr pointer to DE call bdtst ;test for completion condition pop h ;FOR entry addr to HL jnc cspop ;don't exit loop -- get new text addr & return next6: if compl lxi d,-(2*fbyts+7) ;- entry length to DE else ;Before purging the FOR-entry the CSTACK direct count must be updated. dcx h mov a,m dcx h ora m ;check line # of FOR cz dcstd ;decrement CSTKD if direct lxi d,-(2*fbyts+5) endif dad d ;point to next entry mvi a,csfor call csrst ;reset stack pointer next7: call gtcnd ;look for comma jnc next ;do another NEXT if comma ret nferr: error f, N, F ;fatal NF error ;NULL if not wild null: call gtbex ;get byte-value expr mov a,c sta nulls ;value to NULLS ret endif ;end of NOT WILD conditional ;end of STATES2 page