goapple2/source/applesoft/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 *--------------------------------
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 *--------------------------------