1010 *-------------------------------- 1020 * PTRGET -- GENERAL VARIABLE SCAN 1030 * 1040 * SCANS VARIABLE NAME AT TXTPTR, AND SEARCHES THE 1050 * VARTAB AND ARYTAB FOR THE NAME. 1060 * IF NOT FOUND, CREATE VARIABLE OF APPROPRIATE TYPE. 1070 * RETURN WITH ADDRESS IN VARPNT AND Y,A 1080 * 1090 * ACTUAL ACTIVITY CONTROLLED SOMEWHAT BY TWO FLAGS: 1100 * DIMFLG -- NONZERO IF CALLED FROM "DIM" 1110 * ELSE = 0 1120 * 1130 * SUBFLG -- = $00 1140 * = $40 IF CALLED FROM "GETARYPT" 1150 * = $80 IF CALLED FROM "DEF FN" 1160 * = $C1-DA IF CALLED FROM "FN" 1170 *-------------------------------- 1180 PTRGET LDX #0 1190 JSR CHRGOT GET FIRST CHAR OF VARIABLE NAME 1200 *-------------------------------- 1210 PTRGET2 1220 STX DIMFLG X IS NONZERO IF FROM DIM 1230 *-------------------------------- 1240 PTRGET3 1250 STA VARNAM 1260 JSR CHRGOT 1270 JSR ISLETC IS IT A LETTER? 1280 BCS NAMOK YES, OKAY SO FAR 1290 BADNAM JMP SYNERR NO, SYNTAX ERROR 1300 NAMOK LDX #0 1310 STX VALTYP 1320 STX VALTYP+1 1330 JMP PTRGET4 TO BRANCH ACROSS $E000 VECTORS 1340 *-------------------------------- 1350 * DOS AND MONITOR CALL BASIC AT $E000 AND $E003 1360 *-------------------------------- 1370 JMP COLD.START 1380 JMP RESTART 1390 BRK <<< WASTED BYTE >>> 1400 *-------------------------------- 1410 PTRGET4 1420 JSR CHRGET SECOND CHAR OF VARIABLE NAME 1430 BCC .1 NUMERIC 1440 JSR ISLETC LETTER? 1450 BCC .3 NO, END OF NAME 1460 .1 TAX SAVE SECOND CHAR OF NAME IN X 1470 .2 JSR CHRGET SCAN TO END OF VARIABLE NAME 1480 BCC .2 NUMERIC 1490 JSR ISLETC 1500 BCS .2 ALPHA 1510 .3 CMP #'$' STRING? 1520 BNE .4 NO 1530 LDA #$FF 1540 STA VALTYP 1550 BNE .5 ...ALWAYS 1560 .4 CMP #'%' INTEGER? 1570 BNE .6 NO 1580 LDA SUBFLG YES; INTEGER VARIABLE ALLOWED? 1590 BMI BADNAM NO, SYNTAX ERROR 1600 LDA #$80 YES 1610 STA VALTYP+1 FLAG INTEGER MODE 1620 ORA VARNAM 1630 STA VARNAM SET SIGN BIT ON VARNAME 1640 .5 TXA SECOND CHAR OF NAME 1650 ORA #$80 SET SIGN 1660 TAX 1670 JSR CHRGET GET TERMINATING CHAR 1680 .6 STX VARNAM+1 STORE SECOND CHAR OF NAME 1690 SEC 1700 ORA SUBFLG $00 OR $40 IF SUBSCRIPTS OK, ELSE $80 1710 SBC #'(' IF SUBFLG=$00 AND CHAR="("... 1720 BNE .8 NOPE 1730 .7 JMP ARRAY YES 1740 .8 BIT SUBFLG CHECK TOP TWO BITS OF SUBFLG 1750 BMI .9 $80 1760 BVS .7 $40, CALLED FROM GETARYPT 1770 .9 LDA #0 CLEAR SUBFLG 1780 STA SUBFLG 1790 LDA VARTAB START LOWTR AT SIMPLE VARIABLE TABLE 1800 LDX VARTAB+1 1810 LDY #0 1820 .10 STX LOWTR+1 1830 .11 STA LOWTR 1840 CPX ARYTAB+1 END OF SIMPLE VARIABLES? 1850 BNE .12 NO, GO ON 1860 CMP ARYTAB YES; END OF ARRAYS? 1870 BEQ NAME.NOT.FOUND YES, MAKE ONE 1880 .12 LDA VARNAM SAME FIRST LETTER? 1890 CMP (LOWTR),Y 1900 BNE .13 NOT SAME FIRST LETTER 1910 LDA VARNAM+1 SAME SECOND LETTER? 1920 INY 1930 CMP (LOWTR),Y 1940 BEQ SET.VARPNT.AND.YA YES, SAME VARIABLE NAME 1950 DEY NO, BUMP TO NEXT NAME 1960 .13 CLC 1970 LDA LOWTR 1980 ADC #7 1990 BCC .11 2000 INX 2010 BNE .10 ...ALWAYS 2020 *-------------------------------- 2030 * CHECK IF (A) IS ASCII LETTER A-Z 2040 * 2050 * RETURN CARRY = 1 IF A-Z 2060 * = 0 IF NOT 2070 * 2080 * <<<NOTE FASTER AND SHORTER CODE: >>> 2090 * <<< CMP #'Z'+1 COMPARE HI END 2100 * <<< BCS .1 ABOVE A-Z 2110 * <<< CMP #'A' COMPARE LO END 2120 * <<< RTS C=0 IF LO, C=1 IF A-Z 2130 * <<<.1 CLC C=0 IF HI 2140 * <<< RTS 2150 *-------------------------------- 2160 ISLETC CMP #'A' COMPARE LO END 2170 BCC .1 C=0 IF LOW 2180 SBC #'Z'+1 PREPARE HI END TEST 2190 SEC TEST HI END, RESTORING (A) 2200 SBC #-1-'Z' C=0 IF LO, C=1 IF A-Z 2210 .1 RTS 2220 *-------------------------------- 2230 * VARIABLE NOT FOUND, SO MAKE ONE 2240 *-------------------------------- 2250 NAME.NOT.FOUND 2260 PLA LOOK AT RETURN ADDRESS ON STACK TO 2270 PHA SEE IF CALLED FROM FRM.VARIABLE 2280 CMP #FRM.VARIABLE.CALL 2290 BNE MAKE.NEW.VARIABLE NO 2300 TSX 2310 LDA STACK+2,X 2320 CMP /FRM.VARIABLE.CALL 2330 BNE MAKE.NEW.VARIABLE NO 2340 LDA #C.ZERO YES, CALLED FROM FRM.VARIABLE 2350 LDY /C.ZERO POINT TO A CONSTANT ZERO 2360 RTS NEW VARIABLE USED IN EXPRESSION = 0 2370 *-------------------------------- 2380 C.ZERO .HS 0000 INTEGER OR REAL ZERO, OR NULL STRING 2390 *-------------------------------- 2400 * MAKE A NEW SIMPLE VARIABLE 2410 * 2420 * MOVE ARRAYS UP 7 BYTES TO MAKE ROOM FOR NEW VARIABLE 2430 * ENTER 7-BYTE VARIABLE DATA IN THE HOLE 2440 *-------------------------------- 2450 MAKE.NEW.VARIABLE 2460 LDA ARYTAB SET UP CALL TO BLTU TO 2470 LDY ARYTAB+1 TO MOVE FROM ARYTAB THRU STREND-1 2480 STA LOWTR 7 BYTES HIGHER 2490 STY LOWTR+1 2500 LDA STREND 2510 LDY STREND+1 2520 STA HIGHTR 2530 STY HIGHTR+1 2540 CLC 2550 ADC #7 2560 BCC .1 2570 INY 2580 .1 STA ARYPNT 2590 STY ARYPNT+1 2600 JSR BLTU MOVE ARRAY BLOCK UP 2610 LDA ARYPNT STORE NEW START OF ARRAYS 2620 LDY ARYPNT+1 2630 INY 2640 STA ARYTAB 2650 STY ARYTAB+1 2660 LDY #0 2670 LDA VARNAM FIRST CHAR OF NAME 2680 STA (LOWTR),Y 2690 INY 2700 LDA VARNAM+1 SECOND CHAR OF NAME 2710 STA (LOWTR),Y 2720 LDA #0 SET FIVE-BYTE VALUE TO 0 2730 INY 2740 STA (LOWTR),Y 2750 INY 2760 STA (LOWTR),Y 2770 INY 2780 STA (LOWTR),Y 2790 INY 2800 STA (LOWTR),Y 2810 INY 2820 STA (LOWTR),Y 2830 *-------------------------------- 2840 * PUT ADDRESS OF VALUE OF VARIABLE IN VARPNT AND Y,A 2850 *-------------------------------- 2860 SET.VARPNT.AND.YA 2870 LDA LOWTR LOWTR POINTS AT NAME OF VARIABLE, 2880 CLC SO ADD 2 TO GET TO VALUE 2890 ADC #2 2900 LDY LOWTR+1 2910 BCC .1 2920 INY 2930 .1 STA VARPNT ADDRESS IN VARPNT AND Y,A 2940 STY VARPNT+1 2950 RTS 2960 *-------------------------------- 2970 * COMPUTE ADDRESS OF FIRST VALUE IN ARRAY 2980 * ARYPNT = (LOWTR) + #DIMS*2 + 5 2990 *-------------------------------- 3000 GETARY LDA NUMDIM GET # OF DIMENSIONS 3010 *-------------------------------- 3020 GETARY2 3030 ASL #DIMS*2 (SIZE OF EACH DIM IN 2 BYTES) 3040 ADC #5 + 5 (2 FOR NAME, 2 FOR OFFSET TO NEXT 3050 * ARRAY, AND 1 FOR #DIMS 3060 ADC LOWTR ADDRESS OF TH IS ARRAY IN ARYTAB 3070 LDY LOWTR+1 3080 BCC .1 3090 INY 3100 .1 STA ARYPNT ADDRESS OF FIRST VALUE IN ARRAY 3110 STY ARYPNT+1 3120 RTS 3130 *-------------------------------- 3140 NEG32768 .HS 90800000 -32768.00049 IN FLOATING POINT 3150 * <<< MEANT TO BE -32768, WHICH WOULD BE 9080000000 >>> 3160 * <<< 1 BYTE SHORT, SO PICKS UP $20 FROM NEXT INSTRUCTION 3170 *-------------------------------- 3180 * EVALUATE NUMERIC FORMULA AT TXTPTR 3190 * CONVERTING RESULT TO INTEGER 0 <= X <= 32767 3200 * IN FAC+3,4 3210 *-------------------------------- 3220 MAKINT JSR CHRGET 3230 JSR FRMNUM 3240 *-------------------------------- 3250 * CONVERT FAC TO INTEGER 3260 * MUST BE POSITIVE AND LESS THAN 32768 3270 *-------------------------------- 3280 MKINT LDA FAC.SIGN ERROR IF - 3290 BMI MI1 3300 *-------------------------------- 3310 * CONVERT FAC TO INTEGER 3320 * MUST BE -32767 <= FAC <= 32767 3330 *-------------------------------- 3340 AYINT LDA FAC EXPONENT OF VALUE IN FAC 3350 CMP #$90 ABS(VALUE) < 32768? 3360 BCC MI2 YES, OK FOR INTEGER 3370 LDA #NEG32768 NO; NEXT FEW LINES ARE SUPPOSED TO 3380 LDY /NEG32768 ALLOW -32768 ($8000), BUT DO NOT! 3390 JSR FCOMP BECAUSE COMPARED TO -32768.00049 3400 * <<< BUG: A=-32768.00049:A%=A IS ACCEPTED >>> 3410 * <<< BUT PRINT A,A% SHOWS THAT >>> 3420 * <<< A=-32768.0005 (OK), A%=32767 >>> 3430 * <<< WRONG! WRONG! WRONG! >>> 3440 *-------------------------------- 3450 MI1 BNE IQERR ILLEGAL QUANTITY 3460 MI2 JMP QINT CONVERT TO INTEGER 3470 *-------------------------------- 3480 * LOCATE ARRAY ELEMENT OR CREATE AN ARRAY 3490 *-------------------------------- 3500 ARRAY LDA SUBFLG SUBSCRIPTS GIVEN? 3510 BNE .2 NO 3520 *-------------------------------- 3530 * PARSE THE SUBSCRIPT LIST 3540 *-------------------------------- 3550 LDA DIMFLG YES 3560 ORA VALTYP+1 SET HIGH BIT IF % 3570 PHA SAVE VALTYP AND DIMFLG ON STACK 3580 LDA VALTYP 3590 PHA 3600 LDY #0 COUNT # DIMENSIONS IN Y-REG 3610 .1 TYA SAVE #DIMS ON STACK 3620 PHA 3630 LDA VARNAM+1 SAVE VARIABLE NAME ON STACK 3640 PHA 3650 LDA VARNAM 3660 PHA 3670 JSR MAKINT EVALUATE SUBSCRIPT AS INTEGER 3680 PLA RESTORE VARIABLE NAME 3690 STA VARNAM 3700 PLA 3710 STA VARNAM+1 3720 PLA RESTORE # DIMS TO Y-REG 3730 TAY 3740 TSX COPY VALTYP AND DIMFLG ON STACK 3750 LDA STACK+2,X TO LEAVE ROOM FOR THE SUBSCRIPT 3760 PHA 3770 LDA STACK+1,X 3780 PHA 3790 LDA FAC+3 GET SUBSCRIPT VALUE AND PLACE IN THE 3800 STA STACK+2,X STACK WHERE VALTYP & DIMFLG WERE 3810 LDA FAC+4 3820 STA STACK+1,X 3830 INY COUNT THE SUBSCRIPT 3840 JSR CHRGOT NEXT CHAR 3850 CMP #',' 3860 BEQ .1 COMMA, PARSE ANOTHER SUBSCRIPT 3870 STY NUMDIM NO MORE SUBSCRIPTS, SAVE # 3880 JSR CHKCLS NOW NEED ")" 3890 PLA RESTORE VALTYPE AND DIMFLG 3900 STA VALTYP 3910 PLA 3920 STA VALTYP+1 3930 AND #$7F ISOLATE DIMFLG 3940 STA DIMFLG 3950 *-------------------------------- 3960 * SEARCH ARRAY TABLE FOR THIS ARRAY NAME 3970 *-------------------------------- 3980 .2 LDX ARYTAB (A,X) = START OF ARRAY TABLE 3990 LDA ARYTAB+1 4000 .3 STX LOWTR USE LOWTR FOR RUNNING POINTER 4010 STA LOWTR+1 4020 CMP STREND+1 DID WE REACH THE END OF ARRAYS YET? 4030 BNE .4 NO, KEEP SEARCHING 4040 CPX STREND 4050 BEQ MAKE.NEW.ARRAY YES, THIS IS A NEW ARRAY NAME 4060 .4 LDY #0 POINT AT 1ST CHAR OF ARRAY NAME 4070 LDA (LOWTR),Y GET 1ST CHAR OF NAME 4080 INY POINT AT 2ND CHAR 4090 CMP VARNAM 1ST CHAR SAME? 4100 BNE .5 NO, MOVE TO NEXT ARRAY 4110 LDA VARNAM+1 YES, TRY 2ND CHAR 4120 CMP (LOWTR),Y SAME? 4130 BEQ USE.OLD.ARRAY YES, ARRAY FOUND 4140 .5 INY POINT AT OFFSET TO NEXT ARRAY 4150 LDA (LOWTR),Y ADD OFFSET TO RUNNING POINTER 4160 CLC 4170 ADC LOWTR 4180 TAX 4190 INY 4200 LDA (LOWTR),Y 4210 ADC LOWTR+1 4220 BCC .3 ...ALWAYS 4230 *-------------------------------- 4240 * ERROR: BAD SUBSCRIPTS 4250 *-------------------------------- 4260 SUBERR LDX #ERR.BADSUBS 4270 .HS 2C TRICK TO SKIP NEXT LINE 4280 *-------------------------------- 4290 * ERROR: ILLEGAL QUANTITY 4300 *-------------------------------- 4310 IQERR LDX #ERR.ILLQTY 4320 JER JMP ERROR 4330 *-------------------------------- 4340 * FOUND THE ARRAY 4350 *-------------------------------- 4360 USE.OLD.ARRAY 4370 LDX #ERR.REDIMD SET UP FOR REDIM'D ARRAY ERROR 4380 LDA DIMFLG CALLED FROM "DIM" STATEMENT? 4390 BNE JER YES, ERROR 4400 LDA SUBFLG NO, CHECK IF ANY SUBSCRIPTS 4410 BEQ .1 YES, NEED TO CHECK THE NUMBER 4420 SEC NO, SIGNAL ARRAY FOUND 4430 RTS 4440 *-------------------------------- 4450 .1 JSR GETARY SET (ARYPNT) = ADDR OF FIRST ELEMENT 4460 LDA NUMDIM COMPARE NUMBER OF DIMENSIONS 4470 LDY #4 4480 CMP (LOWTR),Y 4490 BNE SUBERR NOT SAME, SUBSCRIPT ERROR 4500 JMP FIND.ARRAY.ELEMENT 4510 *--------------------------------