goapple2/source/applesoft/S.E1B8
2014-05-09 17:59:16 -07:00

363 lines
14 KiB
Plaintext

1010 *--------------------------------
1020 * CREATE A NEW ARRAY, UNLESS CALLED FROM GETARYPT
1030 *--------------------------------
1040 MAKE.NEW.ARRAY
1050 LDA SUBFLG CALLED FROM GETARYPT?
1060 BEQ .1 NO
1070 LDX #ERR.NODATA YES, GIVE "OUT OF DATA" ERROR
1080 JMP ERROR
1090 .1 JSR GETARY PUT ADDR OF 1ST ELEMENT IN ARYPNT
1100 JSR REASON MAKE SURE ENOUGH MEMORY LEFT
1110 *--------------------------------
1120 * <<< NEXT 3 LINES COULD BE WRITTEN: >>>
1130 * LDY #0
1140 * STY STRNG2+1
1150 *--------------------------------
1160 LDA #0 POINT Y-REG AT VARIABLE NAME SLOT
1170 TAY
1180 STA STRNG2+1 START SIZE COMPUTATION
1190 LDX #5 ASSUME 5-BYTES PER ELEMENT
1200 LDA VARNAM STUFF VARIABLE NAME IN ARRAY
1210 STA (LOWTR),Y
1220 BPL .2 NOT INTEGER ARRAY
1230 DEX INTEGER ARRAY, DECR. SIZE TO 4-BYTES
1240 .2 INY POINT Y-REG AT NEXT CHAR OF NAME
1250 LDA VARNAM+1 REST OF ARRAY NAME
1260 STA (LOWTR),Y
1270 BPL .3 REAL ARRAY, STICK WITH SIZE = 5 BYTES
1280 DEX INTEGER OR STRING ARRAY, ADJUST SIZE
1290 DEX TO INTEGER=3, STRING=2 BYTES
1300 .3 STX STRNG2 STORE LOW-BYTE OF ARRAY ELEMENT SIZE
1310 LDA NUMDIM STORE NUMBER OF DIMENSIONS
1320 INY IN 5TH BYTE OF ARRAY
1330 INY
1340 INY
1350 STA (LOWTR),Y
1360 .4 LDX #11 DEFAULT DIMENSION = 11 ELEMENTS
1370 LDA #0 FOR HI-BYTE OF DIMENSION IF DEFAULT
1380 BIT DIMFLG DIMENSIONED ARRAY?
1390 BVC .5 NO, USE DEFAULT VALUE
1400 PLA GET SPECIFIED DIM IN A,X
1410 CLC # ELEMENTS IS 1 LARGER THAN
1420 ADC #1 DIMENSION VALUE
1430 TAX
1440 PLA
1450 ADC #0
1460 .5 INY ADD THIS DIMENSION TO ARRAY DESCRIPTOR
1470 STA (LOWTR),Y
1480 INY
1490 TXA
1500 STA (LOWTR),Y
1510 JSR MULTIPLY.SUBSCRIPT MULTIPLY THIS
1520 * DIMENSION BY RUNNING SIZE
1530 * ((LOWTR)) * (STRNG2) --> A,X
1540 STX STRNG2 STORE RUNNING SIZE IN STRNG2
1550 STA STRNG2+1
1560 LDY INDEX RETRIEVE Y SAVED BY MULTIPLY.SUBSCRIPT
1570 DEC NUMDIM COUNT DOWN # DIMS
1580 BNE .4 LOOP TILL DONE
1590 *--------------------------------
1600 * NOW A,X HAS TOTAL # BYTES OF ARRAY ELEMENTS
1610 *--------------------------------
1620 ADC ARYPNT+1 COMPUTE ADDRESS OF END OF THIS ARRAY
1630 BCS GME ...TOO LARGE, ERROR
1640 STA ARYPNT+1
1650 TAY
1660 TXA
1670 ADC ARYPNT
1680 BCC .6
1690 INY
1700 BEQ GME ...TOO LARGE, ERROR
1710 .6 JSR REASON MAKE SURE THERE IS ROOM UP TO Y,A
1720 STA STREND THERE IS ROOM SO SAVE NEW END OF TABLE
1730 STY STREND+1 AND ZERO THE ARRAY
1740 LDA #0
1750 INC STRNG2+1 PREPARE FOR FAST ZEROING LOOP
1760 LDY STRNG2 # BYTES MOD 256
1770 BEQ .8 FULL PAGE
1780 .7 DEY CLEAR PAGE FULL
1790 STA (ARYPNT),Y
1800 BNE .7
1810 .8 DEC ARYPNT+1 POINT TO NEXT PAGE
1820 DEC STRNG2+1 COUNT THE PAGES
1830 BNE .7 STILL MORE TO CLEAR
1840 INC ARYPNT+1 RECOVER LAST DEC, POINT AT 1ST ELEMENT
1850 SEC
1860 LDA STREND COMPUTE OFFSET TO END OF ARRAYS
1870 SBC LOWTR AND STORE IN ARRAY DESCRIPTOR
1880 LDY #2
1890 STA (LOWTR),Y
1900 LDA STREND+1
1910 INY
1920 SBC LOWTR+1
1930 STA (LOWTR),Y
1940 LDA DIMFLG WAS THIS CALLED FROM "DIM" STATEMENT?
1950 BNE RTS.9 YES, WE ARE FINISHED
1960 INY NO, NOW NEED TO FIND THE ELEMENT
1970 *--------------------------------
1980 * FIND SPECIFIED ARRAY ELEMENT
1990 *
2000 * (LOWTR),Y POINTS AT # OF DIMS IN ARRAY DESCRIPTOR
2010 * THE SUBSCRIPTS ARE ALL ON THE STACK AS INTEGERS
2020 *--------------------------------
2030 FIND.ARRAY.ELEMENT
2040 LDA (LOWTR),Y GET # OF DIMENSIONS
2050 STA NUMDIM
2060 LDA #0 ZERO SUBSCRIPT ACCUMULATOR
2070 STA STRNG2
2080 FAE.1 STA STRNG2+1
2090 INY
2100 PLA PULL NEXT SUBSCRIPT FROM STACK
2110 TAX SAVE IN FAC+3,4
2120 STA FAC+3 AND COMPARE WITH DIMENSIONED SIZE
2130 PLA
2140 STA FAC+4
2150 CMP (LOWTR),Y
2160 BCC FAE.2 SUBSCRIPT NOT TOO LARGE
2170 BNE GSE SUBSCRIPT IS TOO LARGE
2180 INY CHECK LOW-BYTE OF SUBSCRIPT
2190 TXA
2200 CMP (LOWTR),Y
2210 BCC FAE.3 NOT TOO LARGE
2220 *--------------------------------
2230 GSE JMP SUBERR BAD SUBSCRIPTS ERROR
2240 GME JMP MEMERR MEM FULL ERROR
2250 *--------------------------------
2260 FAE.2 INY BUMP POINTER INTO DESCRIPTOR
2270 FAE.3 LDA STRNG2+1 BYPASS MULTIPLICATION IF VALUE SO
2280 ORA STRNG2 FAR = 0
2290 CLC
2300 BEQ .1 IT IS ZERO SO FAR
2310 JSR MULTIPLY.SUBSCRIPT NOT ZERO, SO MULTIPLY
2320 TXA ADD CURRENT SUBSCRIPT
2330 ADC FAC+3
2340 TAX
2350 TYA
2360 LDY INDEX RETRIEVE Y SAVED BY MULTIPLY.SUBSCRIPT
2370 .1 ADC FAC+4 FINISH ADDING CURRENT SUBSCRIPT
2380 STX STRNG2 STORE ACCUMULATED OFFSET
2390 DEC NUMDIM LAST SUBSCRIPT YET?
2400 BNE FAE.1 NO, LOOP TILL DONE
2410 STA STRNG2+1 YES, NOW MULTIPLY BE ELEMENT SIZE
2420 LDX #5 START WITH SIZE = 5
2430 LDA VARNAM DETERMINE VARIABLE TYPE
2440 BPL .2 NOT INTEGER
2450 DEX INTEGER, BACK DOWN SIZE TO 4 BYTES
2460 .2 LDA VARNAM+1 DISCRIMINATE BETWEEN REAL AND STR
2470 BPL .3 IT IS REAL
2480 DEX SIZE = 3 IF STRING, =2 IF INTEGER
2490 DEX
2500 .3 STX RESULT+2 SET UP MULTIPLIER
2510 LDA #0 HI-BYTE OF MULTIPLIER
2520 JSR MULTIPLY.SUBS.1 (STRNG2) BY ELEMENT SIZE
2530 TXA ADD ACCUMULATED OFFSET
2540 ADC ARYPNT TO ADDRESS OF 1ST ELEMENT
2550 STA VARPNT TO GET ADDRESS OF SPECIFIED ELEMENT
2560 TYA
2570 ADC ARYPNT+1
2580 STA VARPNT+1
2590 TAY RETURN WITH ADDR IN VARPNT
2600 LDA VARPNT AND IN Y,A
2610 RTS.9 RTS
2620 *--------------------------------
2630 * MULTIPLY (STRNG2) BY ((LOWTR),Y)
2640 * LEAVING PRODUCT IN A,X. (HI-BYTE ALSO IN Y.)
2650 * USED ONLY BY ARRAY SUBSCRIPT ROUTINES
2660 *--------------------------------
2670 MULTIPLY.SUBSCRIPT STY INDEX SAVE Y-REG
2680 LDA (LOWTR),Y GET MULTIPLIER
2690 STA RESULT+2 SAVE IN RESULT+2,3
2700 DEY
2710 LDA (LOWTR),Y
2720 *--------------------------------
2730 MULTIPLY.SUBS.1
2740 STA RESULT+3 LOW BYTE OF MULTIPLIER
2750 LDA #16 MULTIPLY 16 BITS
2760 STA INDX
2770 LDX #0 PRODUCT = 0 INITIALLY
2780 LDY #0
2790 .1 TXA DOUBLE PRODUCT
2800 ASL LOW BYTE
2810 TAX
2820 TYA HIGH BYTE
2830 ROL IF TOO LARGE, SET CARRY
2840 TAY
2850 BCS GME TOO LARGE, "MEM FULL ERROR"
2860 ASL STRNG2 NEXT BIT OF MUTLPLICAND
2870 ROL STRNG2+1 INTO CARRY
2880 BCC .2 BIT=0, DON'T NEED TO ADD
2890 CLC BIT=1, ADD INTO PARTIAL PRODUCT
2900 TXA
2910 ADC RESULT+2
2920 TAX
2930 TYA
2940 ADC RESULT+3
2950 TAY
2960 BCS GME TOO LARGE, "MEM FULL ERROR"
2970 .2 DEC INDX 16-BITS YET?
2980 BNE .1 NO, KEEP SHUFFLING
2990 RTS YES, PRODUCT IN Y,X AND A,X
3000 *--------------------------------
3010 * "FRE" FUNCTION
3020 *
3030 * COLLECTS GARBAGE AND RETURNS # BYTES OF MEMORY LEFT
3040 *--------------------------------
3050 FRE LDA VALTYP LOOK AT VALUE OF ARGUMENT
3060 BEQ .1 =0 MEANS REAL, =$FF MEANS STRING
3070 JSR FREFAC STRING, SO SET IT FREE IS TEMP
3080 .1 JSR GARBAG COLLECT ALL THE GARBAGE IN SIGHT
3090 SEC COMPUTE SPACE BETWEEN ARRAYS AND
3100 LDA FRETOP STRING TEMP AREA
3110 SBC STREND
3120 TAY
3130 LDA FRETOP+1
3140 SBC STREND+1 FREE SPACE IN Y,A
3150 * FALL INTO GIVAYF TO FLOAT THE VALUE
3160 * NOTE THAT VALUES OVER 32767 WILL RETURN AS NEGATIVE
3170 *--------------------------------
3180 * FLOAT THE SIGNED INTEGER IN A,Y
3190 *--------------------------------
3200 GIVAYF LDX #0 MARK FAC VALUE TYPE REAL
3210 STX VALTYP
3220 STA FAC+1 SAVE VALUE FROM A,Y IN MANTISSA
3230 STY FAC+2
3240 LDX #$90 SET EXPONENT TO 2^16
3250 JMP FLOAT.1 CONVERT TO SIGNED FP
3260 *--------------------------------
3270 * "POS" FUNCTION
3280 *
3290 * RETURNS CURRENT LINE POSITION FROM MON.CH
3300 *--------------------------------
3310 POS LDY MON.CH GET A,Y = (MON.CH, GO TO GIVAYF
3320 *--------------------------------
3330 * FLOAT (Y) INTO FAC, GIVING VALUE 0-255
3340 *--------------------------------
3350 SNGFLT LDA #0 MSB = 0
3360 SEC <<< NO PURPOSE WHATSOEVER >>>
3370 BEQ GIVAYF ...ALWAYS
3380 *--------------------------------
3390 * CHECK FOR DIRECT OR RUNNING MODE
3400 * GIVING ERROR IF DIRECT MODE
3410 *--------------------------------
3420 ERRDIR LDX CURLIN+1 =$FF IF DIRECT MODE
3430 INX MAKES $FF INTO ZERO
3440 BNE RTS.9 RETURN IF RUNNING MODE
3450 LDX #ERR.ILLDIR DIRECT MODE, GIVE ERROR
3460 .HS 2C TRICK TO SKIP NEXT 2 BYTES
3470 *--------------------------------
3480 UNDFNC LDX #ERR.UNDEFFUNC UNDEFINDED FUNCTION ERROR
3490 JMP ERROR
3500 *--------------------------------
3510 * "DEF" STATEMENT
3520 *--------------------------------
3530 DEF JSR FNC. PARSE "FN", FUNCTION NAME
3540 JSR ERRDIR ERROR IF IN DIRECT MODE
3550 JSR CHKOPN NEED "("
3560 LDA #$80 FLAG PTRGET THAT CALLED FROM "DEF FN"
3570 STA SUBFLG ALLOW ONLY SIMPLE FP VARIABLE FOR ARG
3580 JSR PTRGET GET PNTR TO ARGUMENT
3590 JSR CHKNUM MUST BE NUMERIC
3600 JSR CHKCLS MUST HAVE ")" NOW
3610 LDA #TOKEN.EQUAL NOW NEED "="
3620 JSR SYNCHR OR ELSE SYNTAX ERROR
3630 PHA SAVE CHAR AFTER "="
3640 LDA VARPNT+1 SAVE PNTR TO ARGUMENT
3650 PHA
3660 LDA VARPNT
3670 PHA
3680 LDA TXTPTR+1 SAVE TXTPTR
3690 PHA
3700 LDA TXTPTR
3710 PHA
3720 JSR DATA SCAN TO NEXT STATEMENT
3730 JMP FNCDATA STORE ABOVE 5 BYTES IN "VALUE"
3740 *--------------------------------
3750 * COMMON ROUTINE FOR "DEFFN" AND "FN", TO
3760 * PARSE "FN" AND THE FUNCTION NAME
3770 *--------------------------------
3780 FNC. LDA #TOKEN.FN MUST NOW SEE "FN" TOKEN
3790 JSR SYNCHR OR ELSE SYNTAX ERROR
3800 ORA #$80 SET SIGN BIT ON 1ST CHAR OF NAME,
3810 STA SUBFLG MAKING $C0 < SUBFLG < $DB
3820 JSR PTRGET3 WHICH TELLS PTRGET WHO CALLED
3830 STA FNCNAM FOUND VALID FUNCTION NAME, SO
3840 STY FNCNAM+1 SAVE ADDRESS
3850 JMP CHKNUM MUST BE NUMERIC
3860 *--------------------------------
3870 * "FN" FUNCTION CALL
3880 *--------------------------------
3890 FUNCT JSR FNC. PARSE "FN", FUNCTION NAME
3900 LDA FNCNAM+1 STACK FUNCTION ADDRESS
3910 PHA IN CASE OF A NESTED FN CALL
3920 LDA FNCNAM
3930 PHA
3940 JSR PARCHK MUST NOW HAVE "(EXPRESSION)"
3950 JSR CHKNUM MUST BE NUMERIC EXPRESSION
3960 PLA GET FUNCTION ADDRESS BACK
3970 STA FNCNAM
3980 PLA
3990 STA FNCNAM+1
4000 LDY #2 POINT AT ADD OF ARGUMENT VARIABLE
4010 LDA (FNCNAM),Y
4020 STA VARPNT
4030 TAX
4040 INY
4050 LDA (FNCNAM),Y
4060 BEQ UNDFNC UNDEFINED FUNCTION
4070 STA VARPNT+1
4080 INY Y=4 NOW
4090 .1 LDA (VARPNT),Y SAVE OLD VALUE OF ARGUMENT VARIABLE
4100 PHA ON STACK, IN CASE ALSO USED AS
4110 DEY A NORMAL VARIABLE!
4120 BPL .1
4130 LDY VARPNT+1 (Y,X)= ADDRESS, STORE FAC IN VARIABLE
4140 JSR STORE.FAC.AT.YX.ROUNDED
4150 LDA TXTPTR+1 REMEMBER TXTPTR AFTER FN CALL
4160 PHA
4170 LDA TXTPTR
4180 PHA
4190 LDA (FNCNAM),Y Y=0 FROM MOVMF
4200 STA TXTPTR POINT TO FUNCTION DEF'N
4210 INY
4220 LDA (FNCNAM),Y
4230 STA TXTPTR+1
4240 LDA VARPNT+1 SAVE ADDRESS OF ARGUMENT VARIABLE
4250 PHA
4260 LDA VARPNT
4270 PHA
4280 JSR FRMNUM EVALUATE THE FUNCTION EXPRESSION
4290 PLA GET ADDRESS OF ARGUMENT VARIABLE
4300 STA FNCNAM AND SAVE IT
4310 PLA
4320 STA FNCNAM+1
4330 JSR CHRGOT MUST BE AT ":" OR EOL
4340 BEQ .2 WE ARE
4350 JMP SYNERR WE ARE NOT, SLYNTAX ERROR
4360 .2 PLA RETRIEVE TXTPTR AFTER "FN" CALL
4370 STA TXTPTR
4380 PLA
4390 STA TXTPTR+1
4400 * STACK NOW HAS 5-BYTE VALUE
4410 * OF THE ARGUMENT VARIABLE,
4420 * AND FNCNAM POINTS AT THE VARIABLE
4430 *--------------------------------
4440 * STORE FIVE BYTES FROM STACK AT (FNCNAM)
4450 *--------------------------------
4460 FNCDATA
4470 LDY #0
4480 PLA
4490 STA (FNCNAM),Y
4500 PLA
4510 INY
4520 STA (FNCNAM),Y
4530 PLA
4540 INY
4550 STA (FNCNAM),Y
4560 PLA
4570 INY
4580 STA (FNCNAM),Y
4590 PLA
4600 INY
4610 STA (FNCNAM),Y
4620 RTS