PAG ***************************** * * * Applesoft - Part B * * * * Copywrite Apple Computer, * * Inc. and Microsoft, Inc.; * * not for publication or * * distribution. * * * ***************************** * * * Formula evaluation, * * Pointer locating, * * & String Handling. * * * * $DD67 - $E79F * * * ***************************** FRMNUM JSR FRMEVL CHKNUM CLC HEX 24 ;Dummy for skip CHKSTR SEC CHKVAL BIT VALTYP BMI :OV BCS MISMTCH :RET RTS :OV BCS :RET MISMTCH LDX #TYPEMISS-ERRMSG JERROR JMP ERROR * Main formula evalutation routine. * On entry TXTPTR points at 1st chr of formula. FRMEVL DECR TXTPTR LDX #0 ;Initial preference DFB $24 ;Trick to skip FEVLOOP PHA ;Push last CPRTYP TXA PHA ; and preference LDA #1 JSR CHKMEM ;Check stack ptr >= $38 JSR GETVAL ;Get value or str desc LDA #0 ; at TXTPTR STA CPRTYP FRMEVL2 JSR CHRGOT :CL SEC SBC #$CF ;> token BCC :TYP? CMP #3 ;or =, < BGE :TYP? ;Branch if not CMP #1 ROL EOR #1 EOR CPRTYP ;Set bits of CPRTYP: CMP CPRTYP ; 00000>=< BCC SNTXERR STA CPRTYP JSR CHRGET ;Another operator? JMP :CL ;Check for <,=,> again :TYP? LDX CPRTYP BNE COMPARE ;Branch if had <,=,> BCS NOTMATH ;Branch if next token > "<" ADC #$CF-plus BCC NOTMATH ;Branch if next token < "+" ADC VALTYP ;+ and last result a string? BNE :OV ;Branch if not JMP CAT ;Concatenate if so. :OV ADC #$FF ;Now A-reg has offset STA INDEX ; from "+". ASL ADC INDEX ;Times 3 TAY PREFTEST PLA ;Get last preferance CMP MATHTBL,Y ;Compare current priority BGE DOMTH ;Do now if preferred JSR CHKNUM ;Was last result a #? NXOP PHA SAVOP JSR PSHMAD ;Save operation on stack PLA LDY LASTOP BPL PREFNC ;Branch if more formula TAX BEQ GOEX ;Exit if no math in frm BNE DOMATH ;Do last operation COMPARE LSR VALTYP ;Enable string compare TXA ;Set CPRTYP: 0000>=? BEQ :OV ;Allow string compare if so JSR CHKNUM :OV STY LASTOP * Pull floating # from stack, place in ARG and go to * math routine via RTS (address was placed on stack): * (Note that <=> routines all go to POSOP.) DOMATH PLA LSR ;Restore carry status STA CPRMASK ; 00000>=< PULL ARG PULL ARG+2 PULL ARG+4 EOR FACSGN STA SGNCPR EXIT LDA FAC ;Go to routine with status RTS ; set by FAC * Get value of variable, function or number following * TXTPTR, or point to string descriptor if a string, * and put in FAC. This also evaluates expressions in * parens by means of a recursive call to FRMEVL. * It is the "kernel" subroutine of FRMEVL: GETVAL LDA #0 STA VALTYP SKIP JSR CHRGET BCS VAR? NUMBER JMP FIN ;If numeric VAR? JSR ISLETC ;A variable? BCS VARL CMP #'.' BEQ NUMBER CMP #minus BEQ MIN CMP #plus BEQ SKIP CMP #'"' BNE NOT? STRTXT LDA TXTPTR ;Explicit string, build desc. LDY TXTPTR+1 ADC #0 BCC :OV INY :OV JSR STRLIT JMP POINT ;Get pointer to desc. in FAC NOT? CMP #not BNE FN? LDY #UNOT-MATHTBL BNE EQUL ;Always EQUOP LDA FAC ;This routine is called only BNE :OV ; by NOT through preceding LDY #1 ; branch to EQUL. HEX 2C ;Trick to skip next instruction :OV LDY #0 JMP SNGFLT FN? CMP #fn BNE SGN? JMP FUNCT SGN? CMP #sgn BLT PARCHK JMP UNARY PARCHK JSR CHKOPN ;Is there a '(' at TXTPTR? JSR FRMEVL ;If so, evaluate and CHKCLS LDA #')' ;Check for ')' HEX 2C ;Trick CHKOPN LDA #'(' HEX 2C ;Trick CHKCOM LDA #',' ;Comma at TXTPTR? SYNCHR LDY #0 CMP (TXTPTR),Y BNE SYNERR JMP CHRGET ;If ok, get next chr & return SYNERR LDX #SYNTXERR-ERRMSG JMP ERROR MIN LDY #MINUS-MATHTBL EQUL PLA PLA JMP SAVOP VARL JSR PTRGET STA VPNT STY VPNT+1 LDX VALTYP ;String? BEQ :V1 ;Branch if not LDX #0 STX EXTRAFAC RTS :V1 LDX INTFLG ;Integer var? BPL :V2 ;Branch if not LDY #0 LDA (VPNT),Y ;Get val high TAX INY LDA (VPNT),Y ; and low TAY TXA JMP GIVAYF ;Float it :V2 JMP MOVFM ;Move (A,Y) to FAC SCREEN JSR CHRGET JSR PLOTFNS TXA LDY FIRST DO APPLEC JSR SCRN80 ELSE JSR SCRN FIN TAY JSR SNGFLT JMP CHKCLS * Process unary operators (functions): UNARY CMP #scrn ;Not unary, do special BEQ SCREEN ASL PHA TAX JSR CHRGET CPX #leftstr*2-1 BLT NOTinstr ;Branch if not an instring op JSR CHKOPN ;Check for '(' JSR FRMEVL ;Process concat., etc. JSR CHKCOM JSR CHKSTR ;Make sure it is a string PLA TAX ;Retrieve routine pointer PUSH VPNT TXA PHA ;Push it back JSR GETBYT ;Get 1st param in X PLA TAY ;Point Y to routine TXA PHA ;Push 1st param JMP GOROUT ;Go to appropriate string routine NOTinstr JSR PARCHK ;Check syntax & evaluate argument PLA ;Retrieve token*2 TAY GOROUT LDA UNFNC-$A4,Y ;$A4=sgn*2 STA JMPADRS+1 LDA UNFNC-$A3,Y STA JMPADRS+2 JSR JMPADRS ;Does not return for ; LEFT$, RIGHT$, MID$. JMP CHKNUM OR LDA ARG ORA FAC BNE TRUE AND LDA ARG BEQ FALSE LDA FAC BNE TRUE FALSE LDY #0 HEX 2C ;Trick to skip next instruction TRUE LDY #1 JMP SNGFLT * Common routine for <, =, > comparisons: POSOP JSR CHKVAL BCS STRCMP ;Branch if strings LDA ARGSGN ;If ARGSGN + then ORA #$7F ; strip high bit of ARG+1 AND ARG+1 STA ARG+1 LDA #ARG LDY #0 JSR FCOMP ;Return A-reg = -1,0,1 TAX ; as ARG <,=,> FAC JMP NUMCMP STRCMP LDA #0 STA VALTYP DEC CPRTYP ;? JSR FREFAC STA FAC ;String length STX FAC+1 STY FAC+2 LDA ARG+3 LDY ARG+4 JSR FRETMP STX ARG+3 STY ARG+4 TAX ;Len (ARG) string SEC SBC FAC ;Set X to smaller len BEQ :SFS LDA #1 BCC :SFS LDX FAC LDA #$FF :SFS STA FACSGN ;Flag which shorter LDY #$FF INX CMPLOOP INY DEX BNE DOCMP LDX FACSGN ;If = so far, decide by len NUMCMP BMI CMPDONE CLC BCC CMPDONE DOCMP LDA (ARG+3),Y CMP (FAC+1),Y BEQ CMPLOOP LDX #$FF BCS CMPDONE LDX #1 CMPDONE INX ;Convert FF,0,1 to 1,2,4 TXA ROL AND CPRMASK ; 00000>=< BEQ :F ;If no match: false LDA #1 ;At least one match: true :F JMP FLOAT PDL JSR CONINT ;Get # in X (<4 not checked) JSR PREAD ;Read paddle JMP SNGFLT ;Float result NXDIM JSR CHKCOM DIM TAX JSR PTRGET2 ;Creates & zeros array JSR CHRGOT BNE NXDIM RTS PTRGET LDX #0 JSR CHRGOT ;Get variable name PTRGET2 STX DIMFLG ;X has VARNAM if from DIM PTRGET3 STA VARNAM ;Entry from FNC JSR CHRGOT JSR ISLETC ;Is it a letter? BCS NAMOK ;Branch if so BADNAM JMP SYNERR ;Error if not NAMOK LDX #0 STX VALTYP STX INTFLG JMP MORNAM ;To branch across $E000 vectors * BASIC entry points for DOS etc., use: JMP COLDST JMP RESTART DO NEWROMS DO APPLEC HEX 96 ;//c revised roms ELSE HEX C4 ;New //e roms FIN ELSE HEX 00 ;Old roms FIN MORNAM JSR CHRGET ;2nd chr of variable name BCC :OV ;Branch if numeric JSR ISLETC ;Is it alpha? BCC :STR ;Branch if not :OV TAX ;Save 2nd chr of name in X :BY JSR CHRGET ;Find end of var. name BCC :BY ;Loop if numeric JSR ISLETC BCS :BY ;or if alpha. :STR CMP #'$' ;Set up var type flags BNE :INTV LDA #$FF STA VALTYP ;Flag as string BNE :NIN ;Always :INTV CMP #'%' BNE :SECND LDA SUBFLG ;Integer var allowed? BMI BADNAM ;Error if not. LDA #$80 STA INTFLG ;Flag as integer ORA VARNAM STA VARNAM ;Set high bit of 1st name chr :NIN TXA ORA #$80 ;Set high bit of 2nd name chr TAX JSR CHRGET :SECND STX VARNAM+1 ;2nd var name chr SEC ORA SUBFLG ;Subscripts allowed SBC #'(' ; and an array? BNE :BS ;Branch if not :ARY JMP ARRAY :BS BIT SUBFLG BMI :VS ;Branch if from FOR, DEF or FN BVS :ARY ;Branch if called by GETARYPT :VS LDA #0 STA SUBFLG LDA VARTAB ;Init varl pntr LDX VARTAB+1 LDY #0 :NXVAR STX LOWTR+1 :N1 STA LOWTR CPX ARYTAB+1 ;End of simple vars? BNE :N2 ;No, go on CMP ARYTAB BEQ NOTFND ;Yes, make one? :N2 LDA VARNAM CMP (LOWTR),Y BNE :NXPTR ;Branch if not this one LDA VARNAM+1 INY CMP (LOWTR),Y BEQ SETVPNT ;Branch if found DEY :NXPTR CLC LDA LOWTR ADC #7 BCC :N1 INX BNE :NXVAR ;Always * Check if letter A-Z, set carry if so, clear if not: ISLETC CMP #'A' BLT :RET SBC #'[' SEC SBC #$100-'[' ;Get orig. A-reg :RET RTS NOTFND PLA ;Get calling adrs low PHA ;Reset stack ptr CMP #VARL+2 ;Called by VARL? BNE NEWVAR ;Branch if not TSX LDA STACK+2,X ;Get calling adrs high CMP #>VARL+2 ;From VARL? BNE NEWVAR ;Branch if not LDA #TWOBRK ;It is not an assignment LDY #>TWOBRK ; so fake variable adrs RTS ; so that value 0 is returned TWOBRK BRK BRK * Move arrays to make room for new variable: NEWVAR TRAY ARYTAB;LOWTR TRAY STREND;HIGHTR CLC ADC #7 ;Set for 7 byte move up BCC :OV INY :OV STA HIGHDS ;Set destination adrs STY HIGHDS+1 JSR BLTU ;Do the move LDA HIGHDS LDY HIGHDS+1 INY ;BLTU leaves this 1 too low STA ARYTAB STY ARYTAB+1 LDY #0 LDA VARNAM STA (LOWTR),Y ;Store name of new var INY LDA VARNAM+1 STA (LOWTR),Y LDA #0 ;Set value to 0 LUP 5 INY STA (LOWTR),Y --^ SETVPNT LDA LOWTR CLC ADC #2 LDY LOWTR+1 BCC :OV INY :OV STA VARPNT ;Point to 1st byte of value STY VARPNT+1 RTS GETARY LDA NUMDIM ;Get # of dimensions GETARY2 ASL ; times 2 ADC #5 ; plus 5 (name, offset and #dim) ADC LOWTR ;Add to variable pointer LDY LOWTR+1 BCC :OV INY :OV STA ARYPNT ;Now points to first descriptor STY ARYPNT+1 ; in array. RTS * Bug: Following # is missing the last (0) byte: NEGNUM HEX 90800000 ;=-32768 MAKINT JSR CHRGET JSR FRMNUM MKINT LDA FACSGN ;Error if - BMI MI1 AYINT LDA FAC CMP #$90 ;Abs<2^15 ? BCC MI2 ;Branch if so LDA #NEGNUM ;=-2^15 ? LDY #>NEGNUM JSR FCOMP MI1 BNE IQERR ;Error if not MI2 JMP QINT * Routine to locate array element or to create an array. ARRAY LDA SUBFLG ;Subscripts given? BNE FNDARY ;Branch if not LDA DIMFLG ORA INTFLG ;Set high bit if % PHA LDA VALTYP PHA LDY #0 NXTDIM TYA PHA PUSH VARNAM JSR MAKINT PULL VARNAM PLA TAY TSX LDA STACK+2,X ;Get VALTYP & INTFLG PHA ; and duplicate LDA STACK+1,X PHA LDA FAC+3 ;Get subscript STA STACK+2,X ; and put on stack where LDA FAC+4 ; VALTYP & INTVLG were STA STACK+1,X INY JSR CHRGOT CMP #',' BEQ NXTDIM ;Loop till all subs put on stack STY NUMDIM JSR CHKCLS PULL VALTYP ;Retrieve VALTYP & INTFLG AND #$7F ;Mask bit from INTFLG STA DIMFLG ; retrieving DIMFLG FNDARY LDX ARYTAB LDA ARYTAB+1 ARYLOOP STX LOWTR STA LOWTR+1 CMP STREND+1 BNE ARYNAM? CPX STREND BEQ NOTFOUND ARYNAM? LDY #0 LDA (LOWTR),Y ;Get name of array INY CMP VARNAM ;Desired one? BNE NXARY ;Branch if not LDA VARNAM+1 CMP (LOWTR),Y BEQ ARYFOUND NXARY INY LDA (LOWTR),Y CLC ADC LOWTR TAX INY LDA (LOWTR),Y ADC LOWTR+1 BCC ARYLOOP SUBERR LDX #BADSUBS-ERRMSG HEX 2C ;Trick IQERR LDX #ILLQUAN-ERRMSG JER JMP ERROR ARYFOUND LDX #REdimARR-ERRMSG LDA DIMFLG BNE JER LDA SUBFLG BEQ CHKDIM SEC ;Required by STORE RTS ;Exit if from GETARYPT CHKDIM JSR GETARY LDA NUMDIM ;Get specified # of dims LDY #4 CMP (LOWTR),Y ;Same as actual #? BNE SUBERR ;Error if not JMP FNDELEM ;Look for specified element NOTFOUND LDA SUBFLG ;From GETARYPT? BEQ MAKARY ;Make new array if not LDX #OofDATA-ERRMSG JMP ERROR ;Error if so MAKARY JSR GETARY JSR REASON LDA #0 TAY STA STRNG2+1 LDX #5 LDA VARNAM STA (LOWTR),Y BPL NINT DEX ;Integer array NINT INY LDA VARNAM+1 STA (LOWTR),Y BPL RAR ;Branch if real array DEX DEX RAR STX STRNG2 ;X=5,3,2 as: real,str,int LDA NUMDIM INY ;Bypass offset to next array INY ; (to be set later) INY STA (LOWTR),Y SAVDIM LDX #11 ;Default dimension + 1 LDA #0 BIT DIMFLG ;Dimensioned array? BVC DFLTDIM ;Branch if not PLA ;Get specified dim in A,X CLC ADC #1 TAX PLA ADC #0 DFLTDIM INY ;Build dim table STA (LOWTR),Y INY TXA STA (LOWTR),Y JSR MULT STX STRNG2 STA STRNG2+1 LDY INDEX ;Retrieve Y saved by MULT DEC NUMDIM ;Count down # dims BNE SAVDIM ;Loop till done ADC ARYPNT+1 ;Point to end of array BCS GME STA ARYPNT+1 TAY TXA ADC ARYPNT BCC :OV INY BEQ GME :OV JSR REASON ;Make sure there is room STA STREND ; and then zero out STY STREND+1 ; the array. LDA #0 INC STRNG2+1 LDY STRNG2 BEQ :NXP :ZL DEY STA (ARYPNT),Y BNE :ZL :NXP DEC ARYPNT+1 ;Point to next page DEC STRNG2+1 BNE :ZL ;Loop till done INC ARYPNT+1 SEC LDA STREND ;Compute offset to next array SBC LOWTR LDY #2 STA (LOWTR),Y ; & place following name LDA STREND+1 INY SBC LOWTR+1 STA (LOWTR),Y LDA DIMFLG ;From DIM? BNE RTN2 ;Branch if so INY FNDELEM LDA (LOWTR),Y ;Find specified element STA NUMDIM ; of array from index put LDA #0 ; on stack by NXTDIM. STA STRNG2 DIMLUP STA STRNG2+1 INY PLA TAX STA FAC+3 ;Retrieve index and PLA ; check against dim. STA FAC+4 CMP (LOWTR),Y BCC DIMOK BNE GSE INY TXA CMP (LOWTR),Y BCC DIMOK2 GSE JMP SUBERR GME JMP MEMERR DIMOK INY DIMOK2 LDA STRNG2+1 ;First time through? ORA STRNG2 CLC BEQ :NXD ;Branch if so JSR MULT ;Compute product of dims TXA ADC FAC+3 TAX TYA LDY INDEX ;Retrieve Y saved by MULT :NXD ADC FAC+4 ;Next dim STX STRNG2 DEC NUMDIM BNE DIMLUP ;Loop till all subs done STA STRNG2+1 LDX #5 LDA VARNAM BPL :OV ;Branch if not int DEX :OV LDA VARNAM+1 BPL :RA ;Branch if real DEX DEX :RA STX RESULT+2 LDA #0 JSR MU1 ;Mult prod of dims by TXA ; size of each entry ADC ARYPNT ;Add array adrs STA VARPNT ; to get final ptr TYA ADC ARYPNT+1 STA VARPNT+1 TAY LDA VARPNT RTN2 RTS * 16 bit (non floating) multiply of (LOWTR),Y * by STRNG2 leaving product in A,X. * Used only by array subscript routines. MULT STY INDEX ;Save Y to retrieve after RTS LDA (LOWTR),Y STA RESULT+2 DEY LDA (LOWTR),Y MU1 STA RESULT+3 LDA #$10 ;Index for 16 bit mult STA INDX LDX #0 LDY #0 :M2 TXA ;Shift X,Y left one bit ASL TAX TYA ROL TAY BCS GME ;Error if > 16 bit product ASL STRNG2 ;Shift off high bit of ROL STRNG2+1 ; multiplier BCC :M3 ;Branch if bit = 0 CLC TXA ADC RESULT+2 ;Add other multiplier TAX ; to X,Y TYA ADC RESULT+3 TAY BCS GME ;Error if > 16 bit product :M3 DEC INDX BNE :M2 ;Loop till done RTS FRE LDA VALTYP BEQ :OV JSR FREFAC :OV JSR GARBAG SEC LDA FRETOP SBC STREND TAY LDA FRETOP+1 SBC STREND+1 GIVAYF LDX #0 ;Float signed integer in A,Y STX VALTYP ;Flag as number STA FAC+1 STY FAC+2 LDX #$90 ;DP 16 bits to right JMP FLO1 POS LDY CH SNGFLT LDA #0 SEC BEQ GIVAYF ERRDIR LDX CURLIN+1 INX BNE RTN2 ;Return if deferred mode LDX #ILLDIR-ERRMSG HEX 2C ;Trick UNDFNC LDX #UNDFUNC-ERRMSG JMP ERROR DEF JSR FNC? ;Set up function name varl JSR ERRDIR JSR CHKOPN LDA #$80 STA SUBFLG ;Disallow int vars, etc JSR PTRGET ;Get ptr to argument JSR CHKNUM JSR CHKCLS LDA #equal JSR SYNCHR PHA ;1st chr follg = PUSH VARPNT PUSH TXTPTR JSR DATA ;Skip to next statement JMP FNCDATA ;Set up pointers in "value" * A Function Name is a simple variable whose name * has form (neg,pos); its "value" contains: * Pointer to defn * Pointer to argument variable * 1st chr of def FNC? LDA #fn JSR SYNCHR ORA #$80 STA SUBFLG ;Flag as simple variable and JSR PTRGET3 ; set high byte of 1st name chr STA FNCNAM ;Save pointer STY FNCNAM+1 JMP CHKNUM FUNCT JSR FNC? ;Get pointer to func name PUSH FNCNAM JSR PARCHK ;Evaluate argument (to FAC) JSR CHKNUM PULL FNCNAM LDY #2 LDA (FNCNAM),Y ;Get pointer to argument STA VARPNT TAX INY LDA (FNCNAM),Y BEQ UNDFNC ;Wasn't defnd if high byte 0 STA VARPNT+1 INY SAVOLD LDA (VARPNT),Y ;Save value of dummy var PHA DEY BPL SAVOLD LDY VARPNT+1 ;Point to val of argument JSR MOVMF ;FAC -> (VARPNT) PUSH TXTPTR ;Remember position LDA (FNCNAM),Y ;Y=0 STA TXTPTR ;Point to fnc defn INY LDA (FNCNAM),Y STA TXTPTR+1 PUSH VARPNT JSR FRMNUM ;Evaluate fnc PULL FNCNAM JSR CHRGOT ;Must be end of stmnt BEQ GETOLD JMP SYNERR GETOLD PULL TXTPTR ;Retrieve prog position FNCDATA LDY #0 ;Retrieve value of dummy var PLA LUP 4 STA (FNCNAM),Y PLA INY --^ STA (FNCNAM),Y RTS STR JSR CHKNUM ;Make sure it is a number LDY #0 JSR FACSTRNG ;Convert to string in stack PLA PLA LDA #$FF ;Point to STACK-1 to force LDY #0 ; moving string BEQ STRLIT ;Create desc & move string * Create string descriptor: STRINI TRXY FAC+3;DSCPTR STRSPA JSR GETSPA ;A holds length STX FAC+1 ;Save descriptor in FAC STY FAC+2 STA FAC RTS STRLIT LDX #'"' STX CHARAC ;Set up literal STX ENDCHR ; delimiters. STRLT2 STA STRNG1 STY STRNG1+1 STA FAC+1 ;For descriptor STY FAC+2 LDY #$FF :FEND INY ;Find end of string LDA (STRNG1),Y BEQ :ZE CMP CHARAC BEQ :Q CMP ENDCHR BNE :FEND :Q CMP #'"' BEQ :NZ :ZE CLC :NZ STY FAC ;Length in temp descriptor TYA ADC STRNG1 STA STRNG2 ;Point to string end LDX STRNG1+1 BCC :F1 INX :F1 STX STRNG2+1 LDA STRNG1+1 BEQ :F2 ;Must move string if it is at CMP #2 ; $FF or in input buffer. BNE PUTNEW ;Otherwise just set descriptor :F2 TYA ;Get length in A JSR STRINI ;Make room for string LDX STRNG1 LDY STRNG1+1 JSR MOVSTR ;and move it PUTNEW LDX TEMPPT CPX #TEMPST+9 ;Too many temp descrs? BNE PUTEMP LDX #FORMtoCX-ERRMSG JERR JMP ERROR PUTEMP LDA FAC ;Set up temp descriptor STA 0,X LDA FAC+1 STA 1,X LDA FAC+2 STA 2,X LDY #0 STX FAC+3 STY FAC+4 DEY STY VALTYP ;Flag as string STX LASTPT ;Point to next descriptor INX INX INX STX TEMPPT RTS * Make space for string, length in A: GETSPA LSR GARFLG ;Enable garbage collect GETSPC PHA EOR #$FF SEC ADC FRETOP ;Subtract length from FRETOP LDY FRETOP+1 BCS :OV DEY :OV CPY STREND+1 BCC FULL ;Branch if no room BNE GOTSPA CMP STREND BCC FULL GOTSPA STA FRETOP STY FRETOP+1 STA FRESPC STY FRESPC+1 TAX PLA RTS FULL LDX #OofMEM-ERRMSG LDA GARFLG ;Garbage done yet? BMI JERR ;Error if so JSR GARBAG LDA #$80 ;Flag garbage done STA GARFLG PLA BNE GETSPC GARBAG LDX MEMSIZ ;Collect from top down LDA MEMSIZ+1 FNDVAR STX FRETOP ;One pass through all vars STA FRETOP+1 ; for each active string! LDY #0 STY FNCNAM+1 ;Flag no collection yet done * Point LOWTR to bottom of string space: TRAX STREND;LOWTR LDA #TEMPST ;Point to temp LDX #>TEMPST ; string descriptors STA INDEX STX INDEX+1 TVAR CMP TEMPPT ;Done with temps? BEQ SVARS ;Go to simple vars if so JSR DVAR ;Do a temp BEQ TVAR ;Always taken SVARS LDA #7 STA DSCLEN TRAX VARTAB;INDEX SVAR CPX ARYTAB+1 ;Simple vars done? BNE SVARGO ;Continue if not CMP ARYTAB BEQ ARYVAR ;Do arrays if so SVARGO JSR DVARS ;Do a simple var BEQ SVAR ;Always taken ARYVAR STA ARYPNT STX ARYPNT+1 LDA #3 STA DSCLEN ARYVA2 LDA ARYPNT LDX ARYPNT+1 ARYVA3 CPX STREND+1 ;Arrays done? BNE ARYVGO ;Do one if not CMP STREND BNE ARYVGO JMP GRBPAS ;All varls checked, move top one ARYVGO STA INDEX STX INDEX+1 LDY #0 LDA (INDEX),Y ;Get array name TAX INY LDA (INDEX),Y PHP ;Save its type INY LDA (INDEX),Y ;Get offset to next array ADC ARYPNT ;Compute adrs STA ARYPNT ;& set pntr to it INY LDA (INDEX),Y ADC ARYPNT+1 STA ARYPNT+1 PLP BPL ARYVA2 ;Branch if not string TXA BMI ARYVA2 ; " INY LDA (INDEX),Y ;Get # of dims LDY #0 ASL ADC #5 BUMP INDEX ;Point to 1st array element LDX INDEX+1 ARYSTR CPX ARYPNT+1 ;Array done? BNE GOGO ;Do next element if not CMP ARYPNT BEQ ARYVA3 ;Next array if so GOGO JSR DVAR BEQ ARYSTR ;Always taken DVARS LDA (INDEX),Y ;Integer var or func def? BMI DVARTS ;Skip if so INY LDA (INDEX),Y ;String var? BPL DVARTS ;Skip if not INY DVAR LDA (INDEX),Y ;Get length BEQ DVARTS ;Ignore if len 0 INY LDA (INDEX),Y ;Get adrs of string TAX INY LDA (INDEX),Y CMP FRETOP+1 BCC :D1 BNE DVARTS CPX FRETOP BCS DVARTS ;Skip if collected already :D1 CMP LOWTR+1 ;Above highest string found? BCC DVARTS ;Skip if not BNE :D2 ;Yes set pointer to it CPX LOWTR BCC DVARTS :D2 STX LOWTR STA LOWTR+1 TRAX INDEX;FNCNAM MOV DSCLEN;LENGTH DVARTS LDA DSCLEN ;Set up for next var CLC BUMP INDEX VDONE LDX INDEX+1 LDY #0 RTS * Pass through vars done, now move the highest * string found to top and go back for another: * * (Collection ends if FNCNAM+1 is still 0. This means * that an attempt to collect a temp string will abort * collection. This bug is rarely a problem, but could * be if collection is forced by a concatination and the * string space just has room for the new string after * collection. For example: * LOMEM:10000: HIMEM:10012: A$="A":A$=A$+"B":A$=A$+"C": * PRINT A$ gives "ABA".) GRBPAS LDX FNCNAM+1 ;Garbage done? BEQ VDONE ;Yes, return LDA LENGTH AND #4 ;4 if simple, else 0 LSR TAY STA LENGTH ;2 if simple, else 0 AD (FNCNAM),Y;LOWTR;HIGHTR AD LOWTR+1;#0;HIGHTR+1 TRAX FRETOP;HIGHDS JSR BLTU2 ;Move string up and LDY LENGTH ; fix its descriptor INY LDA HIGHDS STA (FNCNAM),Y TAX INC HIGHDS+1 LDA HIGHDS+1 INY STA (FNCNAM),Y ;X,A now points to moved string JMP FNDVAR ;Look for next one to collect CAT PUSH FAC+3 ;Save 1st desc ptr JSR GETVAL JSR CHKSTR ;Get desc ptr to 2nd str PULL STRNG1 ;Recover 1st desc ptr LDY #0 LDA (STRNG1),Y ;Add lengths CLC ADC (FAC+3),Y BCC NTL ;Ok if < $100 LDX #STRtoLNG-ERRMSG JMP ERROR NTL JSR STRINI ;Get space for concat str JSR MOVINS ;Move 1st string LDA DSCPTR ;Free the 2nd LDY DSCPTR+1 JSR FRETMP JSR MOVESTR ;Move 2nd string LDA STRNG1 ;Free the 1st LDY STRNG1+1 JSR FRETMP JSR PUTNEW ;Set up desc JMP FRMEVL2 ;Back for more formula MOVINS LDY #0 ;Move str whose desc is at LDA (STRNG1),Y ; (STRNG1) to (FRESPC) PHA ;Length INY LDA (STRNG1),Y TAX ;Put string pointer in X,Y INY LDA (STRNG1),Y TAY PLA ;Retrieve length MOVSTR STX INDEX ;Move string at X,Y STY INDEX+1 ; [at INDEX] to (FRESPC) MOVESTR TAY ; (length in A) BEQ :M3 PHA :M2 DEY LDA (INDEX),Y STA (FRESPC),Y TYA BNE :M2 PLA :M3 CLC BUMP FRESPC ;Point FRESPC above string RTS FRESTR JSR CHKSTR ;Last result a string? FREFAC LDA FAC+3 ;Get descriptor pointer LDY FAC+4 FRETMP STA INDEX ;Free temp descriptor STY INDEX+1 ; whose pointer is in (A,Y). JSR FRETMS ;Free descriptor if temp PHP ;Remember if last freed LDY #0 LDA (INDEX),Y PHA ;Push length INY LDA (INDEX),Y TAX ;Get pointer to string in X,Y INY LDA (INDEX),Y TAY PLA ;Retrieve length PLP ; and status BNE :OV ;Branch if not a freed temp CPY FRETOP+1 ;Was it the lowest string BNE :OV ; in memory? CPX FRETOP BNE :OV ;Branch if not PHA CLC ;"Delete" string if so BUMP FRETOP PLA :OV STX INDEX ;X,Y hold address of string STY INDEX+1 ; and A holds length. RTS FRETMS CPY LASTPT+1 ;Free temp descriptor BNE :RET CMP LASTPT BNE :RET STA TEMPPT SBC #3 STA LASTPT LDY #0 :RET RTS CHRSTR JSR CONINT ;Convert to byte in X TXA PHA ;Save it LDA #1 ;Get space for string of length 1 JSR STRSPA PLA ;Recall # LDY #0 ;Put in string STA (FAC+1),Y PLA PLA JMP PUTNEW LEFTSTR JSR INSTRNG ;Get parameter I CMP (DSCPTR),Y ;Less than length? TYA ;=0 (index to string start) INS1 BCC INS2 ;Branch if param < length LDA (DSCPTR),Y ;Get length TAX TYA INS2 PHA ;Save index to string start INS3 TXA INS4 PHA ;Save new length JSR STRSPA ;Get space for string LDA DSCPTR LDY DSCPTR+1 JSR FRETMP ;Free temp descriptor PLA ;Get length TAY PLA ;Get string offset CLC ; & add to pointer BUMP INDEX TYA ;Retrieve length JSR MOVESTR ;Put string in string space JMP PUTNEW RIGHTSTR JSR INSTRNG ;Get parameter I CLC SBC (DSCPTR),Y ; -length-1 EOR #$FF ;Length - I JMP INS1 MIDSTR LDA #$FF ;Set up large fake STA FAC+4 ; 2nd parameter (len) JSR CHRGOT CMP #')' ;2nd param given? BEQ INS5 ;Branch if not JSR CHKCOM JSR GETBYT ;Get 2nd param in FAC+4 INS5 JSR INSTRNG ;Get 1st param DEX TXA PHA ;Push specified offset CLC LDX #0 SBC (DSCPTR),Y ;-orig len -1 BCS INS3 ;Branch if offset>old len EOR #$FF ;Length of remainder CMP FAC+4 ;< specified length? BCC INS4 ;Branch if so LDA FAC+4 ;Get specified length BCS INS4 ;Always * Common routine for LEFT$, RIGHT$, MID$ to check * for ")", pop return adrs, get descriptor pointer, * and get 1st parameter of command: INSTRNG JSR CHKCLS PLA ;Pull return address TAY ; and save it PLA STA LENGTH PLA ;Pop previous return adrs PLA ; (from GOROUT). PLA ;Retrieve 1st parameter TAX PULL DSCPTR LDA LENGTH PHA ;Push back return adrs TYA PHA LDY #0 TXA ;Transfer 1st parameter to A BEQ GOIQ ;Error if 0 RTS LEN JSR GETSTR JMP SNGFLT GETSTR JSR FRESTR LDX #0 STX VALTYP TAY ;Holds length RTS ASC JSR GETSTR ;Get string ptr in INDEX BEQ GOIQ ;Error if length 0 LDY #0 LDA (INDEX),Y ;Get 1st chr of string TAY JMP SNGFLT ;Float it GOIQ JMP IQERR GTBYTC JSR CHRGET GETBYT JSR FRMNUM CONINT JSR MKINT LDX FAC+3 ;<256? BNE GOIQ ;Error if not LDX FAC+4 JMP CHRGOT VAL JSR GETSTR ;Get pointer to string in INDEX BNE :V2 JMP ZEROFAC ;Return 0 if length=0 :V2 TRXY TXTPTR;STRNG2 LDX INDEX STX TXTPTR ;Point TXTPTR to start of string CLC ADC INDEX ;Add length STA DEST ;Point DEST to end of stg + 1 LDX INDEX+1 STX TXTPTR+1 BCC :V3 INX :V3 STX DEST+1 LDY #0 LDA (DEST),Y ;Get byte following string PHA ;Save it LDA #0 STA (DEST),Y ;Put 0 there JSR CHRGOT JSR FIN ;Evaluate string PLA LDY #0 STA (DEST),Y ;Replace byte at end POINT TRXY STRNG2;TXTPTR RTS GTNUM JSR FRMNUM ;Evaluate syntax: twobyte,byte JSR GETADR ; twobyte -> LINNUM COMBYTE JSR CHKCOM JMP GETBYT ; byte -> X GETADR LDA FAC ;FAC <= $FFFF? CMP #$91 BGE GOIQ ;Error if not. JSR QINT ;Convert to integer LDA FAC+3 ; and move it LDY FAC+4 STY LINNUM ; to LINNUM STA LINNUM+1 RTS PEEK LDA LINNUM ;Protect LINNUM PHA LDA LINNUM+1 PHA JSR GETADR LDY #0 LDA (LINNUM),Y ;Do the PEEK TAY PLA ;Retrieve LINNUM STA LINNUM+1 PLA STA LINNUM JMP SNGFLT ;Float Y POKE JSR GTNUM ;Get byte to POKE in X TXA ; and adrs in LINNUM LDY #0 STA (LINNUM),Y RTS WAIT JSR GTNUM ;Get address in LINNUM STX FORPNT ; & specified mask in FORPNT LDX #0 JSR CHRGOT ;Inversion byte specified? BEQ :W2 ;Branch if not JSR COMBYTE ;Get it :W2 STX FORPNT+1 ;Set up inversion byte LDY #0 :W3 LDA (LINNUM),Y ;Get byte at address EOR FORPNT+1 ;Invert as specified AND FORPNT ;Mask it BEQ :W3 ;Loop till not 0 RTN4 RTS