363 lines
14 KiB
Plaintext
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
|