S-C DocuMentor — Applesoft
SAVE S.DFE3
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 *--------------------------------
DFE3- A2 00 1180 PTRGET LDX #0
DFE5- 20 B7 00 1190 JSR CHRGOT GET FIRST CHAR OF VARIABLE NAME
1200 *--------------------------------
1210 PTRGET2
DFE8- 86 10 1220 STX DIMFLG X IS NONZERO IF FROM DIM
1230 *--------------------------------
1240 PTRGET3
DFEA- 85 81 1250 STA VARNAM
DFEC- 20 B7 00 1260 JSR CHRGOT
DFEF- 20 7D E0 1270 JSR ISLETC IS IT A LETTER?
DFF2- B0 03 1280 BCS NAMOK YES, OKAY SO FAR
DFF4- 4C C9 DE 1290 BADNAM JMP SYNERR NO, SYNTAX ERROR
DFF7- A2 00 1300 NAMOK LDX #0
DFF9- 86 11 1310 STX VALTYP
DFFB- 86 12 1320 STX VALTYP+1
DFFD- 4C 07 E0 1330 JMP PTRGET4 TO BRANCH ACROSS $E000 VECTORS
1340 *--------------------------------
1350 * DOS AND MONITOR CALL BASIC AT $E000 AND $E003
1360 *--------------------------------
E000- 4C 28 F1 1370 JMP COLD.START
E003- 4C 3C D4 1380 JMP RESTART
E006- 00 1390 BRK <<< WASTED BYTE >>>
1400 *--------------------------------
1410 PTRGET4
E007- 20 B1 00 1420 JSR CHRGET SECOND CHAR OF VARIABLE NAME
E00A- 90 05 1430 BCC .1 NUMERIC
E00C- 20 7D E0 1440 JSR ISLETC LETTER?
E00F- 90 0B 1450 BCC .3 NO, END OF NAME
E011- AA 1460 .1 TAX SAVE SECOND CHAR OF NAME IN X
E012- 20 B1 00 1470 .2 JSR CHRGET SCAN TO END OF VARIABLE NAME
E015- 90 FB 1480 BCC .2 NUMERIC
E017- 20 7D E0 1490 JSR ISLETC
E01A- B0 F6 1500 BCS .2 ALPHA
E01C- C9 24 1510 .3 CMP #'$' STRING?
E01E- D0 06 1520 BNE .4 NO
E020- A9 FF 1530 LDA #$FF
E022- 85 11 1540 STA VALTYP
E024- D0 10 1550 BNE .5 ...ALWAYS
E026- C9 25 1560 .4 CMP #'%' INTEGER?
E028- D0 13 1570 BNE .6 NO
E02A- A5 14 1580 LDA SUBFLG YES; INTEGER VARIABLE ALLOWED?
E02C- 30 C6 1590 BMI BADNAM NO, SYNTAX ERROR
E02E- A9 80 1600 LDA #$80 YES
E030- 85 12 1610 STA VALTYP+1 FLAG INTEGER MODE
E032- 05 81 1620 ORA VARNAM
E034- 85 81 1630 STA VARNAM SET SIGN BIT ON VARNAME
E036- 8A 1640 .5 TXA SECOND CHAR OF NAME
E037- 09 80 1650 ORA #$80 SET SIGN
E039- AA 1660 TAX
E03A- 20 B1 00 1670 JSR CHRGET GET TERMINATING CHAR
E03D- 86 82 1680 .6 STX VARNAM+1 STORE SECOND CHAR OF NAME
E03F- 38 1690 SEC
E040- 05 14 1700 ORA SUBFLG $00 OR $40 IF SUBSCRIPTS OK, ELSE $80
E042- E9 28 1710 SBC #'(' IF SUBFLG=$00 AND CHAR="("...
E044- D0 03 1720 BNE .8 NOPE
E046- 4C 1E E1 1730 .7 JMP ARRAY YES
E049- 24 14 1740 .8 BIT SUBFLG CHECK TOP TWO BITS OF SUBFLG
E04B- 30 02 1750 BMI .9 $80
E04D- 70 F7 1760 BVS .7 $40, CALLED FROM GETARYPT
E04F- A9 00 1770 .9 LDA #0 CLEAR SUBFLG
E051- 85 14 1780 STA SUBFLG
E053- A5 69 1790 LDA VARTAB START LOWTR AT SIMPLE VARIABLE TABLE
E055- A6 6A 1800 LDX VARTAB+1
E057- A0 00 1810 LDY #0
E059- 86 9C 1820 .10 STX LOWTR+1
E05B- 85 9B 1830 .11 STA LOWTR
E05D- E4 6C 1840 CPX ARYTAB+1 END OF SIMPLE VARIABLES?
E05F- D0 04 1850 BNE .12 NO, GO ON
E061- C5 6B 1860 CMP ARYTAB YES; END OF ARRAYS?
E063- F0 22 1870 BEQ NAME.NOT.FOUND YES, MAKE ONE
E065- A5 81 1880 .12 LDA VARNAM SAME FIRST LETTER?
E067- D1 9B 1890 CMP (LOWTR),Y
E069- D0 08 1900 BNE .13 NOT SAME FIRST LETTER
E06B- A5 82 1910 LDA VARNAM+1 SAME SECOND LETTER?
E06D- C8 1920 INY
E06E- D1 9B 1930 CMP (LOWTR),Y
E070- F0 6C 1940 BEQ SET.VARPNT.AND.YA YES, SAME VARIABLE NAME
E072- 88 1950 DEY NO, BUMP TO NEXT NAME
E073- 18 1960 .13 CLC
E074- A5 9B 1970 LDA LOWTR
E076- 69 07 1980 ADC #7
E078- 90 E1 1990 BCC .11
E07A- E8 2000 INX
E07B- D0 DC 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 *--------------------------------
E07D- C9 41 2160 ISLETC CMP #'A' COMPARE LO END
E07F- 90 05 2170 BCC .1 C=0 IF LOW
E081- E9 5B 2180 SBC #'Z'+1 PREPARE HI END TEST
E083- 38 2190 SEC TEST HI END, RESTORING (A)
E084- E9 A5 2200 SBC #-1-'Z' C=0 IF LO, C=1 IF A-Z
E086- 60 2210 .1 RTS
2220 *--------------------------------
2230 * VARIABLE NOT FOUND, SO MAKE ONE
2240 *--------------------------------
2250 NAME.NOT.FOUND
E087- 68 2260 PLA LOOK AT RETURN ADDRESS ON STACK TO
E088- 48 2270 PHA SEE IF CALLED FROM FRM.VARIABLE
E089- C9 D7 2280 CMP #FRM.VARIABLE.CALL
E08B- D0 0F 2290 BNE MAKE.NEW.VARIABLE NO
E08D- BA 2300 TSX
E08E- BD 02 01 2310 LDA STACK+2,X
E091- C9 DE 2320 CMP /FRM.VARIABLE.CALL
E093- D0 07 2330 BNE MAKE.NEW.VARIABLE NO
E095- A9 9A 2340 LDA #C.ZERO YES, CALLED FROM FRM.VARIABLE
E097- A0 E0 2350 LDY /C.ZERO POINT TO A CONSTANT ZERO
E099- 60 2360 RTS NEW VARIABLE USED IN EXPRESSION = 0
2370 *--------------------------------
E09A- 00 00 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
E09C- A5 6B 2460 LDA ARYTAB SET UP CALL TO BLTU TO
E09E- A4 6C 2470 LDY ARYTAB+1 TO MOVE FROM ARYTAB THRU STREND-1
E0A0- 85 9B 2480 STA LOWTR 7 BYTES HIGHER
E0A2- 84 9C 2490 STY LOWTR+1
E0A4- A5 6D 2500 LDA STREND
E0A6- A4 6E 2510 LDY STREND+1
E0A8- 85 96 2520 STA HIGHTR
E0AA- 84 97 2530 STY HIGHTR+1
E0AC- 18 2540 CLC
E0AD- 69 07 2550 ADC #7
E0AF- 90 01 2560 BCC .1
E0B1- C8 2570 INY
E0B2- 85 94 2580 .1 STA ARYPNT
E0B4- 84 95 2590 STY ARYPNT+1
E0B6- 20 93 D3 2600 JSR BLTU MOVE ARRAY BLOCK UP
E0B9- A5 94 2610 LDA ARYPNT STORE NEW START OF ARRAYS
E0BB- A4 95 2620 LDY ARYPNT+1
E0BD- C8 2630 INY
E0BE- 85 6B 2640 STA ARYTAB
E0C0- 84 6C 2650 STY ARYTAB+1
E0C2- A0 00 2660 LDY #0
E0C4- A5 81 2670 LDA VARNAM FIRST CHAR OF NAME
E0C6- 91 9B 2680 STA (LOWTR),Y
E0C8- C8 2690 INY
E0C9- A5 82 2700 LDA VARNAM+1 SECOND CHAR OF NAME
E0CB- 91 9B 2710 STA (LOWTR),Y
E0CD- A9 00 2720 LDA #0 SET FIVE-BYTE VALUE TO 0
E0CF- C8 2730 INY
E0D0- 91 9B 2740 STA (LOWTR),Y
E0D2- C8 2750 INY
E0D3- 91 9B 2760 STA (LOWTR),Y
E0D5- C8 2770 INY
E0D6- 91 9B 2780 STA (LOWTR),Y
E0D8- C8 2790 INY
E0D9- 91 9B 2800 STA (LOWTR),Y
E0DB- C8 2810 INY
E0DC- 91 9B 2820 STA (LOWTR),Y
2830 *--------------------------------
2840 * PUT ADDRESS OF VALUE OF VARIABLE IN VARPNT AND Y,A
2850 *--------------------------------
2860 SET.VARPNT.AND.YA
E0DE- A5 9B 2870 LDA LOWTR LOWTR POINTS AT NAME OF VARIABLE,
E0E0- 18 2880 CLC SO ADD 2 TO GET TO VALUE
E0E1- 69 02 2890 ADC #2
E0E3- A4 9C 2900 LDY LOWTR+1
E0E5- 90 01 2910 BCC .1
E0E7- C8 2920 INY
E0E8- 85 83 2930 .1 STA VARPNT ADDRESS IN VARPNT AND Y,A
E0EA- 84 84 2940 STY VARPNT+1
E0EC- 60 2950 RTS
2960 *--------------------------------
2970 * COMPUTE ADDRESS OF FIRST VALUE IN ARRAY
2980 * ARYPNT = (LOWTR) + #DIMS*2 + 5
2990 *--------------------------------
E0ED- A5 0F 3000 GETARY LDA NUMDIM GET # OF DIMENSIONS
3010 *--------------------------------
3020 GETARY2
E0EF- 0A 3030 ASL #DIMS*2 (SIZE OF EACH DIM IN 2 BYTES)
E0F0- 69 05 3040 ADC #5 + 5 (2 FOR NAME, 2 FOR OFFSET TO NEXT
3050 * ARRAY, AND 1 FOR #DIMS
E0F2- 65 9B 3060 ADC LOWTR ADDRESS OF TH IS ARRAY IN ARYTAB
E0F4- A4 9C 3070 LDY LOWTR+1
E0F6- 90 01 3080 BCC .1
E0F8- C8 3090 INY
E0F9- 85 94 3100 .1 STA ARYPNT ADDRESS OF FIRST VALUE IN ARRAY
E0FB- 84 95 3110 STY ARYPNT+1
E0FD- 60 3120 RTS
3130 *--------------------------------
E0FE- 90 80 00
E101- 00 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 *--------------------------------
E102- 20 B1 00 3220 MAKINT JSR CHRGET
E105- 20 67 DD 3230 JSR FRMNUM
3240 *--------------------------------
3250 * CONVERT FAC TO INTEGER
3260 * MUST BE POSITIVE AND LESS THAN 32768
3270 *--------------------------------
E108- A5 A2 3280 MKINT LDA FAC.SIGN ERROR IF -
E10A- 30 0D 3290 BMI MI1
3300 *--------------------------------
3310 * CONVERT FAC TO INTEGER
3320 * MUST BE -32767 <= FAC <= 32767
3330 *--------------------------------
E10C- A5 9D 3340 AYINT LDA FAC EXPONENT OF VALUE IN FAC
E10E- C9 90 3350 CMP #$90 ABS(VALUE) < 32768?
E110- 90 09 3360 BCC MI2 YES, OK FOR INTEGER
E112- A9 FE 3370 LDA #NEG32768 NO; NEXT FEW LINES ARE SUPPOSED TO
E114- A0 E0 3380 LDY /NEG32768 ALLOW -32768 ($8000), BUT DO NOT!
E116- 20 B2 EB 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 *--------------------------------
E119- D0 7E 3450 MI1 BNE IQERR ILLEGAL QUANTITY
E11B- 4C F2 EB 3460 MI2 JMP QINT CONVERT TO INTEGER
3470 *--------------------------------
3480 * LOCATE ARRAY ELEMENT OR CREATE AN ARRAY
3490 *--------------------------------
E11E- A5 14 3500 ARRAY LDA SUBFLG SUBSCRIPTS GIVEN?
E120- D0 47 3510 BNE .2 NO
3520 *--------------------------------
3530 * PARSE THE SUBSCRIPT LIST
3540 *--------------------------------
E122- A5 10 3550 LDA DIMFLG YES
E124- 05 12 3560 ORA VALTYP+1 SET HIGH BIT IF %
E126- 48 3570 PHA SAVE VALTYP AND DIMFLG ON STACK
E127- A5 11 3580 LDA VALTYP
E129- 48 3590 PHA
E12A- A0 00 3600 LDY #0 COUNT # DIMENSIONS IN Y-REG
E12C- 98 3610 .1 TYA SAVE #DIMS ON STACK
E12D- 48 3620 PHA
E12E- A5 82 3630 LDA VARNAM+1 SAVE VARIABLE NAME ON STACK
E130- 48 3640 PHA
E131- A5 81 3650 LDA VARNAM
E133- 48 3660 PHA
E134- 20 02 E1 3670 JSR MAKINT EVALUATE SUBSCRIPT AS INTEGER
E137- 68 3680 PLA RESTORE VARIABLE NAME
E138- 85 81 3690 STA VARNAM
E13A- 68 3700 PLA
E13B- 85 82 3710 STA VARNAM+1
E13D- 68 3720 PLA RESTORE # DIMS TO Y-REG
E13E- A8 3730 TAY
E13F- BA 3740 TSX COPY VALTYP AND DIMFLG ON STACK
E140- BD 02 01 3750 LDA STACK+2,X TO LEAVE ROOM FOR THE SUBSCRIPT
E143- 48 3760 PHA
E144- BD 01 01 3770 LDA STACK+1,X
E147- 48 3780 PHA
E148- A5 A0 3790 LDA FAC+3 GET SUBSCRIPT VALUE AND PLACE IN THE
E14A- 9D 02 01 3800 STA STACK+2,X STACK WHERE VALTYP & DIMFLG WERE
E14D- A5 A1 3810 LDA FAC+4
E14F- 9D 01 01 3820 STA STACK+1,X
E152- C8 3830 INY COUNT THE SUBSCRIPT
E153- 20 B7 00 3840 JSR CHRGOT NEXT CHAR
E156- C9 2C 3850 CMP #','
E158- F0 D2 3860 BEQ .1 COMMA, PARSE ANOTHER SUBSCRIPT
E15A- 84 0F 3870 STY NUMDIM NO MORE SUBSCRIPTS, SAVE #
E15C- 20 B8 DE 3880 JSR CHKCLS NOW NEED ")"
E15F- 68 3890 PLA RESTORE VALTYPE AND DIMFLG
E160- 85 11 3900 STA VALTYP
E162- 68 3910 PLA
E163- 85 12 3920 STA VALTYP+1
E165- 29 7F 3930 AND #$7F ISOLATE DIMFLG
E167- 85 10 3940 STA DIMFLG
3950 *--------------------------------
3960 * SEARCH ARRAY TABLE FOR THIS ARRAY NAME
3970 *--------------------------------
E169- A6 6B 3980 .2 LDX ARYTAB (A,X) = START OF ARRAY TABLE
E16B- A5 6C 3990 LDA ARYTAB+1
E16D- 86 9B 4000 .3 STX LOWTR USE LOWTR FOR RUNNING POINTER
E16F- 85 9C 4010 STA LOWTR+1
E171- C5 6E 4020 CMP STREND+1 DID WE REACH THE END OF ARRAYS YET?
E173- D0 04 4030 BNE .4 NO, KEEP SEARCHING
E175- E4 6D 4040 CPX STREND
E177- F0 3F 4050 BEQ MAKE.NEW.ARRAY YES, THIS IS A NEW ARRAY NAME
E179- A0 00 4060 .4 LDY #0 POINT AT 1ST CHAR OF ARRAY NAME
E17B- B1 9B 4070 LDA (LOWTR),Y GET 1ST CHAR OF NAME
E17D- C8 4080 INY POINT AT 2ND CHAR
E17E- C5 81 4090 CMP VARNAM 1ST CHAR SAME?
E180- D0 06 4100 BNE .5 NO, MOVE TO NEXT ARRAY
E182- A5 82 4110 LDA VARNAM+1 YES, TRY 2ND CHAR
E184- D1 9B 4120 CMP (LOWTR),Y SAME?
E186- F0 16 4130 BEQ USE.OLD.ARRAY YES, ARRAY FOUND
E188- C8 4140 .5 INY POINT AT OFFSET TO NEXT ARRAY
E189- B1 9B 4150 LDA (LOWTR),Y ADD OFFSET TO RUNNING POINTER
E18B- 18 4160 CLC
E18C- 65 9B 4170 ADC LOWTR
E18E- AA 4180 TAX
E18F- C8 4190 INY
E190- B1 9B 4200 LDA (LOWTR),Y
E192- 65 9C 4210 ADC LOWTR+1
E194- 90 D7 4220 BCC .3 ...ALWAYS
4230 *--------------------------------
4240 * ERROR: BAD SUBSCRIPTS
4250 *--------------------------------
E196- A2 6B 4260 SUBERR LDX #ERR.BADSUBS
E198- 2C 4270 .HS 2C TRICK TO SKIP NEXT LINE
4280 *--------------------------------
4290 * ERROR: ILLEGAL QUANTITY
4300 *--------------------------------
E199- A2 35 4310 IQERR LDX #ERR.ILLQTY
E19B- 4C 12 D4 4320 JER JMP ERROR
4330 *--------------------------------
4340 * FOUND THE ARRAY
4350 *--------------------------------
4360 USE.OLD.ARRAY
E19E- A2 78 4370 LDX #ERR.REDIMD SET UP FOR REDIM'D ARRAY ERROR
E1A0- A5 10 4380 LDA DIMFLG CALLED FROM "DIM" STATEMENT?
E1A2- D0 F7 4390 BNE JER YES, ERROR
E1A4- A5 14 4400 LDA SUBFLG NO, CHECK IF ANY SUBSCRIPTS
E1A6- F0 02 4410 BEQ .1 YES, NEED TO CHECK THE NUMBER
E1A8- 38 4420 SEC NO, SIGNAL ARRAY FOUND
E1A9- 60 4430 RTS
4440 *--------------------------------
E1AA- 20 ED E0 4450 .1 JSR GETARY SET (ARYPNT) = ADDR OF FIRST ELEMENT
E1AD- A5 0F 4460 LDA NUMDIM COMPARE NUMBER OF DIMENSIONS
E1AF- A0 04 4470 LDY #4
E1B1- D1 9B 4480 CMP (LOWTR),Y
E1B3- D0 E1 4490 BNE SUBERR NOT SAME, SUBSCRIPT ERROR
E1B5- 4C 4B E2 4500 JMP FIND.ARRAY.ELEMENT
4510 *--------------------------------
S.DEF9
