;STRINGS 11/1/79 ;XYBASIC Interpreter Source Module ;Copyright (C) 1978, 1979 by Mark Williams Company, Chicago ;string routines and functions if strng ;String space consists of RAM from (MEMT)+1 to (STRT). String variables are ;stored from (MEMT)+1 to (STRPT), and (STRPT)+1 to (STRP2) is used for ;temporary string storage. The string temporaries at STEMP contain the ;addresses of ESTACK string entries, as the strings may move during garbage ;collection. ;ATEMP assigns the ESTACK location in HL to a string temporary. ;The temporary is freed when the string value is FETCHed. ;Retn: A clobbered ; BCDEHL preserved atemp: push d xchg ;location to DE lxi h,stemp ;temp base addr to HL mov a,m ;fetch # temps in use inr a ;and bump cpi stmax ;compare to # available jnc sterr ;too many, fatal ST error mov m,a ;store new # in use add a ;# * 2 bytes per temp call adahl ;+ base = bottom of new temp mov m,d dcx h mov m,e ;location to temp xchg ;restore loc to HL pop d ;and restore DE ret sterr: error f, S, T ;fatal ST error ;SCOPY copies a new string to string temp space for GET$, CHR$, and STR$. ;Call: C string length ; DE string location ;Retn: B preserved ; C string length ; DE string location (in string space) ; HL top of string temp space used ;SCOP0 is called from concatenation (SADD) and assignment (SCOPV) to ;fetch the string value addressed by HL and then copy to string space. scop0: call fetcs ;fetch string arg scopy: mov a,c call stfre ;assure sufficient free space mov a,c ora a rz ;null string, just return push b ;save length call bcde ;length to E, location to BC inx h ;next available location to HL push h ;save location call movd0 ;copy string to string space dcx h shld strp2 ;new top of string temp space used pop d ;restore location pop b ;and length ret ;SCOPV copies the value addressed by HL to string space for string assignment. scopv: push h inx h mov a,m ;fetch length lhld strpt shld strp2 ;clear string temp spacce call stfre ;assure sufficient free space pop h ;restore value pointer push h call scop0 ;fetch the value and copy to string space shld strpt ;and reset string space var pointer pop h ;restore the value pointer push h inx h inx h mov m,e inx h mov m,d ;new location to value entry pop h ;restore HL mov a,m ;and restore type ret ;STFRE assures that (A) bytes of string space is availfable. ;Garbage collection is performed if required, and an OS error if insufficient. ;Call: A amount of string space needed ;Retn: BC,DE preserved ; HL top of used string space (STRP2) stfre: push b push d mov c,a mvi b,0 ;desired space to BC lhld strt xchg ;top of string space to DE lhld strp2 ;current used string space top to HL push h ;and saved dad b ;current top + desired amount to HL cnc cmdhu ;compare top to needed jnc pop3 ;top >= needed, restore and return pop h push b ;save desired call garbg ;garbage collect xchg pop b push h ;save used top dad b cnc cmdhu ;compare top to needed jnc pop3 ;ok after garbage collection error f, O, S ;fatal OS error ;GARBG is the string space garbage collector. All strings referenced by ;string variables or temporaries are compacted to the base of string space. ;Retn: DE top of used string space (STRPT) ; HL top of string space (STRT) garbg: lhld memt inx h ;point to first byte of string space shld gcmin ;min value to accept ;First the string with the minimum location >= GCMIN is found. ;GCLST contains the least so far, and GCLOC the location of the least. garb1: lxi h,-1 shld gclst ;string space loc of least string found lhld symta push h garb2: pop d ;set initial values for NXTST call nxtst ;find next symbol table string var jc garb4 ;no more string entries push d push h mov d,b mov e,c ;next string location to DE call gccmp ;compare to min and least pop h ;restore next entry pointer to HL jc garb2 ;< min or >= least, try next xchg shld gclst ;else current becomes new least xchg shld gcloc ;and gcloc stores its address jmp garb2 ;and try next ;All strings checked, must check if least was found. garb4: lhld gclst mov a,h ana l inr a jz garb5 ;no least found, string var compacting done ;Move the least string to the top of available string space. lhld gcloc dcx h dcx h dcx h ;point to length byte call tpmov ;move string temps pointing within string call stmov ;move the string jmp garb1 ;and continue compacting ;String vars compacted, now compact the string temps. garb5: lhld gcmin dcx h shld strpt ;store new string var pointer lhld strt shld gclst ;set GCLST for GCCMP lxi h,stemp mov a,m ;fetch # temps in use garb6: dcr a jm garb7 ;all temps moved, garbage collection done push psw ;save # temps still to move call modem ;fetch temp loc to DE push h push d ;save temp loc xchg call modem ;fetch loc of temporary to DE call gccmp ;compare to min and least pop h ;temp loc to HL cnc stmov ;move temp to base of avail space pop h pop psw jmp garb6 ;and look for more temps garb7: lhld gcmin dcx h shld strp2 ;store new top of string temp space xchg lhld strt ;and return string space top in HL ret gccmp: lhld gcmin call cmdhu rc ;location < min, try next lhld gclst call cmdhu cmc ;location >= least, try next ret ;STMOV moves a string during garbage collection. ;Call: HL pointer to string length byte ; (GCMIN) destination ;Retn: (GCMIN) next unused location in string space stmov: mov e,m ;length to E inx h push h ;save location address mov c,m inx h mov b,m ;location to BC lhld gcmin ;destination to HL push h ;and saved call movd0 ;move string in string space shld gcmin ;and store new min pop d pop h mov m,e inx h mov m,d ;and copy new loc to value ret ;TPMOV moves temporaries during garbage collection. tpmov: lxi d,stemp ldax d ;fetch # temps in use tpmo1: dcr a rm ;no more temps to check push h ;save string value location push h xchg call modem ;fetch ESTACK location of temp to DE xthl ;save STEMP pointer, string value ptr to HL push psw ;save # temps still to check push h ;and string value ptr xchg ;ESTACK temp loc to HL call modem ;fetch temp loc to DE xthl ;save string temp pointer, value ptr to HL push d ;and save temp loc mov c,m ;length to C call modem ;location to DE mvi b,0 call cplde ;- loc to DE pop h ;temp loc to HL dad d ;temp loc - source loc jnc tpmo2 ;temp loc < source xchg ;offset to DE dcx b ;length - 1 to BC call cmbdu jc tpmo2 ;length <= offset lhld gcmin dad d ;destination + offset = new loc xchg ;to DE pop h mov m,d dcx h mov m,e ;and to temp push h tpmo2: pop h pop psw ;# temps still unchecked pop d ;temp pointer pop h ;value pointer jmp tpmo1 ;and check the next temp ;NXTST is used during garbage collection to find locations of nonnull strings. ;Call: DE next symbol table entry addr (initially SYMTA) ; HL next length byte in current entry (initially SYMTA) ;Retn: Carry Set iff no more nonnull strings ; A length of next nonnull string ; BC location of string ; DE next entry addr ; HL next length byte nxtst: call cmdhu jnz nxts3 ;more in current entry nxts1: call stnxt ;address next symbol table entry rc ;no more ldax d ;fetch type byte ani 1FH ;mask to type cpi strst jnz nxts1 ;not a string xchg ;next entry addr to DE nxts2: inx h ;point to next name byte ora m jp nxts2 ;scan past name inx h ;point to # dims mov c,m ;# dims to C mvi b,0 inx h dad b dad b ;point to first length byte nxts3: mov a,m ;fetch length call mobcm ;fetch location to BC inx h ;point to next ora a rnz ;return unless null jmp nxtst ;else try next ;EVUNQ gets a string value for READ or INPUT. If the next item scanned ;EVALuates to a string value, its value is passed. Otherwise the item is ;considered to be an unquoted string starting at the first nonblank and ;delimited by the next comma or cr, and a pointer to it is returned. ;Retn: Carry Set iff next nonblank char is delimiter ; C, DE length, location of string evunq: call gtcha ;fetch first nonblank cpi '"' jz gtlis ;quoted string literal call bakup ;let HL and TEXTP point to first call dtst1 cmc rc ;first nonblank is delimiter, return Carry mov d,h mov e,l ;first nonblank loc to DE evun1: cpi ',' jz gtls1 ;done if next is comma call dtst1 jnc gtls1 ;or if next is cr or ' call read1 ;else read the current mov a,m ;and fetch next jmp evun1 ;and continue scanning ;CMSTR compares two strings. ;Call: B length of string 2 ; C length of string 1 ; DE location of string 1 ; HL location of string 2 ;Retn: Carry Set iff string 1 < string 2 ; Zero Set iff string 1 = string 2 cmstr: mov a,c ora a jz cmst1 ;end of string 1 mov a,b ora a jz cmst2 ;end of string 2 ldax d ;else fetch string 1 char cmp m ;compare to string 2 rnz ;unequal dcr b dcr c ;decrement lengths inx d inx h ;increment pointers jmp cmstr ;and continue checking cmst1: cmp b ret cmst2: ori 1 ;clear Carry and Zero ret ;SIARG is called by LEFT$, RIGHT$ and MID$ to manipulate arguments. ;Call: BC,DE arg1 (string), arg2 (integer) pointers ;Retn: A arg2, 0 if < 0 and 255 if > 255 (with nonfatal FC error) ; C, DE string length and location ;SIAR0 is called by INST3 and MID3 to fetch integer arg 0 <= arg <= 255. siar0: call cnvbi ;force to integer and fetch mov h,b mov l,c jmp siar1 ;force 0 <= arg <= 255 to A siarg: push d ;save integer arg2 call fetbc ;fetch string arg1 to C, DE jnc tmerr ;fatal TM error if nonstring pop h ;arg2 to HL siar1: mov a,h ;MID3 entry point ora a mov a,l ;lsbyte of arg2 to A rz ;done if 0 <= arg2 <= 255 call fcern ;else issue nonfatal FC error mov a,h ora a mvi a,0 rm ;and return 0 if < 0 dcr a ;else return 255 ret ;string functions follow ;Concatenation (+): x --> sadd: mov a,b ora a jz sadd3 ;string 2 null, return s1 mov a,c ora a jz sadd2 ;string 1 null, return s2 add b ;else find length of concatenation jnc sadd1 ;not too long error n, L, S ;issue nonfatal LS error mov a,c cma mov b,a ;useable length of s2 = 255 - length of s1 add c ;length of concatenation to A sadd1: push psw ;save length lxi h,stemp inr m inr m ;reassign string temporaries call stfre ;assure sufficient space available lhld estkp inx h ;address s1 ESTACK entry push h call scop0 ;fetch and copy to string space pop h push d ;save location of copied s1 lxi d,vbyts+2 dad d ;address s2 ESTACK entry call scop0 ;fetch and copy to string space pop d ;result location to DE pop psw mov c,a ;result length to C mvi a,strst ;result type to A ret sadd2: mov c,b ;length of s2 to C xchg ;and loc to DE sadd3: mvi a,strst ret ;INSTR: [ x] x --> instr: lxi h,1 ;default arg0 value to HL inst0: push h ;save first to test -- INST3 entry point dcx h push h ;save first-1 call ambop ;fetch matching args jnc tmerr ;nonstrings xthl ;save s1 location, first-1 to HL xchg dad d ;s2 loc + first - 1 = s2 remaining loc to HL mov a,c mov c,b sub e ;s2 length + first - 1 = s2 remaining length pop d jc inst2 ;s2 too short, return 0 jz inst2 ;s2 rem null, return 0 mov b,a ;s2 rem len to B ;At INST1 B=s2 rem len, C=s1 len, DE=s1 loc, HL=s2 rem loc, stack=result inst1: mov a,b cmp c jc inst2 ;remaining part of s2 too short, return 0 push b push d push h mov b,c ;set lengths equal for string compare call cmstr ;compare s1 to LEFT$(rem s2,LEN(s1)) pop h pop d pop b jz pop1 ;matched, pop result to BC and return dcr b ;else decr s2 rem len inx h ;and incr s2 rem loc xthl inx h ;and incr proto result xthl jmp inst1 ;and try again inst2: pop b lxi b,0 ret ;INST3 executes ternary INSTR. inst3: push d ;save arg2 push h ;and arg3 call siar0 ;force 0 <= arg3 <= 255 to A mov l,a mvi h,0 ;arg3 to HL ora a cz inxh ;fudge value 0 to 1 pop d pop b ;restore args call inst0 ;perform INSTR mvi a,intst ;and return type integer ret ;BIN$: --> binfn: lxi h,(16 shl 8) or 1 ;16 digits, 1 bit each jmp hexf0 ;HEX$: --> hexfn: lxi h,(4 shl 8) or 4 ;4 digits, 4 bits each ;HEXF0 is called by BIN$ and OCT$ to convert to string. ; BC integer value to convert ; H max digit count ; L nummber of bits per digit hexf0: lxi d,bufad+1 ;destination to DE push b ;save arg mov b,h ;remaining digit count to B mvi h,0 ;to suppress leading 0s hexf1: mov c,l ;shift count to C -- OCT$ entry point xthl ;save status & count, get value xra a ;build result digit in A hexf2: dad h ;shift arg left ral ;Carry to A0 dcr c jnz hexf2 ;shift more bits adi 90H ;90H, ..., 99H, 9AH, ..., 9FH daa ;90H, ..., 99H, 00H+C,...,05H+C aci 40H ;D0H, ..., D9H, 41H, ..., 46H daa ;30H, ..., 39H, 41H, ..., 46H stax d ;store ASCII digit inx d dcr b jz hexf4 ;done xthl ;save value, get status sui '0' ;Zero set iff digit is 0 ora h ;Zero set iff leading 0 mov h,a ;save leading 0 status jnz hexf1 ;not a leading 0, do not suppress dcx d ;suppress it jmp hexf1 hexf4: pop b ;discard saved status lxi h,bufad mvi m,' ' ;store first char = xchg ;first loc to DE, last+1 to HL mov a,l sub e ;compute length mov c,a ;length to C jmp scopy ;copy to string space and return ;OCT$: --> octfn: mov h,b mov l,c ;arg to HL dad h ;shift left one bit, Carry iff leading 1 mov b,h mov c,l ;shifted arg to BC lxi h,(5 shl 8) or 3 ;5 digits, 3 bits each jnc hexf0 ;high bit 0, so just do as in HEX$ lxi d,bufad+1 mvi a,'1' stax d ;store leading ASCII 1 inx d push b ;save arg mov b,h ;repeat count to B jmp hexf1 ;leave H nonzero to retain 0s ;STR$: { | } --> strs: if float ; --> call fout ;convert floating value to string else ; --> mov a,b ora a mvi a,0 jp strs1 ;convert to string with no leading char if + call iumin ;else negate the arg mvi a,'-' strs1: call cvtis ;convert integer to string endif jmp scopy ;copy to string space and return ;VAL: --> { | } val: call fetbc ;fetch the arg inr c ;bump length jnz val1 dcr c ;length was 255, unincrement val1: call scopy ;make new copy with extra char mvi m,cr ;last char is cr xchg ;location to HL shld txtp2 ;and to TXTP2 for FLIP call flip ;let TEXTP scan the string call gtlit ;look for a literal push psw push b push d ;and save result of GTLIT call gtcha ;get first char after literal call flip ;restore TEXTP mov h,a ;first char after lit to H pop d pop b pop psw ;recover result of GTLIT mov l,a mov a,h cpi cr ;check if next after lit was cr mov a,l jnz fcer0 ;FC error if not cpi intst ;check if type integer rz ;yes, return if float cpi sngst jnz fcer0 ;not floating nor integer, FC error lxi h,temp mov e,m ;restore saved value for A to E if floating ret endif ;ASC: --> asc: call len ;fetch string arg, 0 to B mov a,c ;length to A ora a ;check length jz fcer0 ;null, nonfatal FC error and return 0 ldax d ;else fetch character mov c,a ret ;LEN: --> len: call fetbc ;fetch string arg mvi b,0 ;return length in BC ret ;CHR$: --> chrs: call isbyt ;arg must be byte expr mov a,c ;value to A chrs1: lxi d,temp stax d ;save in TEMP mvi c,1 ;length is 1 jmp scopy ;and copy to string space ;LEFT$: x --> lefts: call siarg ;args to A, CDE left1: cmp c rnc ;arg >= length, return unchanged mov c,a ;else arg becomes new length ret ;RIGHT$: x --> right: call siarg righ1: cmp c rnc ;arg >= length, return unchanged dcr c inx d ;else chop off head char jmp righ1 ;and try again ;MID$: x [x ] --> mids: mvi a,255 ;default arg3 value to A mid0: push psw ;MID3 entry point call siarg pop h ;arg3 to H ora a jz mid2 ;arg2 is 0, just do LEFT$ inr c dcx d ;add bogus head char mid1: inx d dcr c ;lop off head rz ;return if null dcr a ;and decrease arg2 jnz mid1 mid2: mov a,h jmp left1 ;and do a LEFT$ with arg3 mid3: push b ;save arg1 mov b,d mov c,e ;arg2 to BC call cnvbi ;convert to integer and fetch push b ;and save arg2 mov b,h mov c,l call siar0 ;force 0 <= arg3 <= 255 to A pop d ;arg2 value to DE pop b ;and arg1 addr to BC call mid0 ;do the MID$ mvi a,strst ;and return type string ret if realt ;TIME$: --> ;TIME$ returns the current time as string "hh:mm:ss". timed: lxi d,timex+3 ;DE addresses hours count lxi h,bufad ;HL addresses string being built push h ;save for result di ;disable so clock does not tick during fetch ldax d ;fetch hours-24 adi 24 ;hours call time1 ;convert hours, fetch minutes call time1 ;convert minutes, fetch seconds ei ;all fetched, renable call time1 ;convert seconds pop d ;recover string address time0: mvi c,8 ;length = 8 for hh:mm:ss jmp scopy ;copy to string space and return ;TIME1 adds two ASCII decimal digits and a colon to result string. ;Call: A desired value (hours, minutes or seconds) ; DE count location ; HL string destination ;Retn: A next count (from (DE)-1) ; DE decremented ; HL next location = HL + 3 time1: mvi m,'0' ;store tens digit time2: cpi 10 jc time3 ;tens digit is now correct inr m ;else bump tens digit sui 10 ;and subtract from count jmp time2 ;and try again time3: adi '0' ;make remainder ASCII inx h mov m,a ;and add to string inx h mvi m,':' ;and add colon inx h ;point to next available dcx d ldax d ;fetch next count adi 60 ;add negative bias ret endif ;end of REALT conditional endif ;end of STRNG conditional ;end of STRINGS page