mirror of
https://github.com/zellyn/goapple2.git
synced 2025-04-20 04:37:55 +00:00
Add AppleSoft basic source
This commit is contained in:
Zellyn Hunter
parent
956db465b2
commit
5c89db1649
41
source/applesoft/README.org
Normal file
41
source/applesoft/README.org
Normal file
@ -0,0 +1,41 @@
|
||||
* Source
|
||||
|
||||
The files in this directory come from
|
||||
http://www.txbobsc.com/scsc/scdocumentor/. As documented below, I
|
||||
obtained permission from Bob Sander-Cederlof to include the source
|
||||
code with my emulator.
|
||||
|
||||
* Permission from Bob Sander-Cederlof
|
||||
|
||||
** My email: 2013-04-11
|
||||
|
||||
Hi Mr. Sander-Cederlof,
|
||||
|
||||
I am slowly working on building a 6502 and Apple II emulator in Go
|
||||
(you can see the code here (https://github.com/zellyn/go6502,
|
||||
https://github.com/zellyn/goapple2), and I ran across your fantastic
|
||||
S-C assembler listings of various ROMs: Applesoft Basic, DOS, etc.
|
||||
|
||||
I was toying with the idea of writing an S-C
|
||||
Assembler-syntax-compatible assembler in Go too, and including the
|
||||
source listings instead of the ROM images in my Apple II emulator: I
|
||||
thought it would be fun, and they'd compile in a fraction of a
|
||||
second. It would also make it interesting to be able to modify them on
|
||||
the fly and restart to see the changes.
|
||||
|
||||
Anyway, I was wondering whether you were okay with (a) me building an
|
||||
S-C Assembler-compatible assembler of my own, and (b) including your
|
||||
source listings with my Apple II emulator. I completely understand if
|
||||
there are reasons that would not be okay with you, but I thought I'd
|
||||
check.
|
||||
|
||||
Yours,
|
||||
|
||||
Zellyn Hunter
|
||||
|
||||
** Bob Sander-Cederlof's reply: 2013-04-11
|
||||
|
||||
Sounds like lots of fun!
|
||||
You have my permission.
|
||||
I will be interested in how it turns out!
|
||||
|
||||
34
source/applesoft/S.ACF
Normal file
34
source/applesoft/S.ACF
Normal file
@ -0,0 +1,34 @@
|
||||
1000 *SAVE S.ACF
|
||||
1010 .TI 76,APPLESOFT............COMMENTS BY BOB SANDER-CEDERLOF.....
|
||||
1020 .OR $D000
|
||||
1030 .TF B.FP
|
||||
1040 .IN S.DEFINITIONS
|
||||
1060 .IN S.D000
|
||||
1080 .IN S.D260
|
||||
1100 .IN S.D365
|
||||
1120 .IN S.D52C
|
||||
1140 .IN S.D766
|
||||
|
||||
1160 .IN S.D912
|
||||
1180 .IN S.DACF
|
||||
1200 .IN S.DCF9
|
||||
1220 .IN S.DD7B
|
||||
1240 .IN S.DEF9
|
||||
|
||||
1260 .IN S.DFE3
|
||||
1280 .IN S.E1B8
|
||||
1300 .IN S.E3C5
|
||||
1320 .IN S.E597
|
||||
1340 .IN S.E7A0
|
||||
|
||||
1360 .IN S.E913
|
||||
1380 .IN S.EB72
|
||||
1400 .IN S.EC4A
|
||||
1420 .IN S.ED0A
|
||||
1440 .IN S.EE8D
|
||||
|
||||
1460 .IN S.EFEA
|
||||
1480 .IN S.F1D5
|
||||
1500 .IN S.F3D8
|
||||
1520 .IN S.F49C
|
||||
1540 .IN S.F5BA
|
||||
258
source/applesoft/S.D000
Normal file
258
source/applesoft/S.D000
Normal file
@ -0,0 +1,258 @@
|
||||
1010 *--------------------------------
|
||||
1020 * APPLESOFT TOKENS
|
||||
1030 *--------------------------------
|
||||
1040 TOKEN.FOR .EQ $81
|
||||
1050 TOKEN.DATA .EQ $83
|
||||
1060 TOKEN.POP .EQ $A1
|
||||
1070 TOKEN.GOTO .EQ $AB
|
||||
1080 TOKEN.GOSUB .EQ $B0
|
||||
1090 TOKEN.REM .EQ $B2
|
||||
1100 TOKEN.PRINT .EQ $BA
|
||||
1110 TOKEN.TAB .EQ $C0
|
||||
1120 TOKEN.TO .EQ $C1
|
||||
1130 TOKEN.FN .EQ $C2
|
||||
1140 TOKEN.SPC .EQ $C3
|
||||
1150 TOKEN.THEN .EQ $C4
|
||||
1160 TOKEN.AT .EQ $C5
|
||||
1170 TOKEN.NOT .EQ $C6
|
||||
1180 TOKEN.STEP .EQ $C7
|
||||
1190 TOKEN.PLUS .EQ $C8
|
||||
1200 TOKEN.MINUS .EQ $C9
|
||||
1210 TOKEN.GREATER .EQ $CF
|
||||
1220 TOKEN.EQUAL .EQ $D0
|
||||
1230 TOKEN.SGN .EQ $D2
|
||||
1240 TOKEN.SCRN .EQ $D7
|
||||
1250 TOKEN.LEFTSTR .EQ $E8
|
||||
1260 *--------------------------------
|
||||
1270 * BRANCH TABLE FOR TOKENS
|
||||
1280 *--------------------------------
|
||||
1290 TOKEN.ADDRESS.TABLE
|
||||
1300 .DA END-1 $80...128...END
|
||||
1310 .DA FOR-1 $81...129...FOR
|
||||
1320 .DA NEXT-1 $82...130...NEXT
|
||||
1330 .DA DATA-1 $83...131...DATA
|
||||
1340 .DA INPUT-1 $84...132...INPUT
|
||||
1350 .DA DEL-1 $85...133...DEL
|
||||
1360 .DA DIM-1 $86...134...DIM
|
||||
1370 .DA READ-1 $87...135...READ
|
||||
1380 .DA GR-1 $88...136...GR
|
||||
1390 .DA TEXT-1 $89...137...TEXT
|
||||
1400 .DA PR.NUMBER-1 $8A...138...PR#
|
||||
1410 .DA IN.NUMBER-1 $8B...139...IN#
|
||||
1420 .DA CALL-1 $8C...140...CALL
|
||||
1430 .DA PLOT-1 $8D...141...PLOT
|
||||
1440 .DA HLIN-1 $8E...142...HLIN
|
||||
1450 .DA VLIN-1 $8F...143...VLIN
|
||||
1460 .DA HGR2-1 $90...144...HGR2
|
||||
1470 .DA HGR-1 $91...145...HGR
|
||||
1480 .DA HCOLOR-1 $92...146...HCOLOR=
|
||||
1490 .DA HPLOT-1 $93...147...HPLOT
|
||||
1500 .DA DRAW-1 $94...148...DRAW
|
||||
1510 .DA XDRAW-1 $95...149...XDRAW
|
||||
1520 .DA HTAB-1 $96...150...HTAB
|
||||
1530 .DA MON.HOME-1 $97...151...HOME
|
||||
1540 .DA ROT-1 $98...152...ROT=
|
||||
1550 .DA SCALE-1 $99...153...SCALE=
|
||||
1560 .DA SHLOAD-1 $9A...154...SHLOAD
|
||||
1570 .DA TRACE-1 $9B...155...TRACE
|
||||
1580 .DA NOTRACE-1 $9C...156...NOTRACE
|
||||
1590 .DA NORMAL-1 $9D...157...NORMAL
|
||||
1600 .DA INVERSE-1 $9E...158...INVERSE
|
||||
1610 .DA FLASH-1 $9F...159...FLASH
|
||||
1620 .DA COLOR-1 $A0...160...COLOR=
|
||||
1630 .DA POP-1 $A1...161...POP
|
||||
1640 .DA VTAB-1 $A2...162...VTAB
|
||||
1650 .DA HIMEM-1 $A3...163...HIMEM:
|
||||
1660 .DA LOMEM-1 $A4...164...LOMEM:
|
||||
1670 .DA ONERR-1 $A5...165...ONERR
|
||||
1680 .DA RESUME-1 $A6...166...RESUME
|
||||
1690 .DA RECALL-1 $A7...167...RECALL
|
||||
1700 .DA STORE-1 $A8...168...STORE
|
||||
1710 .DA SPEED-1 $A9...169...SPEED=
|
||||
1720 .DA LET-1 $AA...170...LET
|
||||
1730 .DA GOTO-1 $AB...171...GOTO
|
||||
1740 .DA RUN-1 $AC...172...RUN
|
||||
1750 .DA IF-1 $AD...173...IF
|
||||
1760 .DA RESTORE-1 $AE...174...RESTORE
|
||||
1770 .DA AMPERSAND.VECTOR-1 $AF...175...&
|
||||
1780 .DA GOSUB-1 $B0...176...GOSUB
|
||||
1790 .DA POP-1 $B1...177...RETURN
|
||||
1800 .DA REM-1 $B2...178...REM
|
||||
1810 .DA STOP-1 $B3...179...STOP
|
||||
1820 .DA ONGOTO-1 $B4...180...ON
|
||||
1830 .DA WAIT-1 $B5...181...WAIT
|
||||
1840 .DA LOAD-1 $B6...182...LOAD
|
||||
1850 .DA SAVE-1 $B7...183...SAVE
|
||||
1860 .DA DEF-1 $B8...184...DEF
|
||||
1870 .DA POKE-1 $B9...185...POKE
|
||||
1880 .DA PRINT-1 $BA...186...PRINT
|
||||
1890 .DA CONT-1 $BB...187...CONT
|
||||
1900 .DA LIST-1 $BC...188...LIST
|
||||
1910 .DA CLEAR-1 $BD...189...CLEAR
|
||||
1920 .DA GET-1 $BE...190...GET
|
||||
1930 .DA NEW-1 $BF...191...NEW
|
||||
1940 *--------------------------------
|
||||
1950 UNFNC
|
||||
1960 .DA SGN $D2...210...SGN
|
||||
1970 .DA INT $D3...211...INT
|
||||
1980 .DA ABS $D4...212...ABS
|
||||
1990 .DA USR $D5...213...USR
|
||||
2000 .DA FRE $D6...214...FRE
|
||||
2010 .DA ERROR $D7...215...SCRN(
|
||||
2020 .DA PDL $D8...216...PDL
|
||||
2030 .DA POS $D9...217...POS
|
||||
2040 .DA SQR $DA...218...SQR
|
||||
2050 .DA RND $DB...219...RND
|
||||
2060 .DA LOG $DC...220...LOG
|
||||
2070 .DA EXP $DD...221...EXP
|
||||
2080 .DA COS $DE...222...COS
|
||||
2090 .DA SIN $DF...223...SIN
|
||||
2100 .DA TAN $E0...224...TAN
|
||||
2110 .DA ATN $E1...225...ATN
|
||||
2120 .DA PEEK $E2...226...PEEK
|
||||
2130 .DA LEN $E3...227...LEN
|
||||
2140 .DA STR $E4...228...STR$
|
||||
2150 .DA VAL $E5...229...VAL
|
||||
2160 .DA ASC $E6...230...ASC
|
||||
2170 .DA CHRSTR $E7...231...CHR$
|
||||
2180 .DA LEFTSTR $E8...232...LEFT$
|
||||
2190 .DA RIGHTSTR $E9...233...RIGHT$
|
||||
2200 .DA MIDSTR $EA...234...MID$
|
||||
2210 *--------------------------------
|
||||
2220 * MATH OPERATOR BRANCH TABLE
|
||||
2230 *
|
||||
2240 * ONE-BYTE PRECEDENCE CODE
|
||||
2250 * TWO-BYTE ADDRESS
|
||||
2260 *--------------------------------
|
||||
2270 P.OR .EQ $46 "OR" IS LOWEST PRECEDENCE
|
||||
2280 P.AND .EQ $50
|
||||
2290 P.REL .EQ $64 RELATIONAL OPERATORS
|
||||
2300 P.ADD .EQ $79 BINARY + AND -
|
||||
2310 P.MUL .EQ $7B * AND /
|
||||
2320 P.PWR .EQ $7D EXPONENTIATION
|
||||
2330 P.NEQ .EQ $7F UNARY - AND COMPARISON =
|
||||
2340 *--------------------------------
|
||||
2350 MATHTBL
|
||||
2360 .DA #P.ADD,FADDT-1 $C8...200...+
|
||||
2370 .DA #P.ADD,FSUBT-1 $C9...201...-
|
||||
2380 .DA #P.MUL,FMULTT-1 $CA...202...*
|
||||
2390 .DA #P.MUL,FDIVT-1 $CB...203.../
|
||||
2400 .DA #P.PWR,FPWRT-1 $CC...204...^
|
||||
2410 .DA #P.AND,AND-1 $CD...205...AND
|
||||
2420 .DA #P.OR,OR-1 $CE...206...OR
|
||||
2430 M.NEG .DA #P.NEQ,NEGOP-1 $CF...207...>
|
||||
2440 M.EQU .DA #P.NEQ,EQUOP-1 $D0...208...=
|
||||
2450 M.REL .DA #P.REL,RELOPS-1 $D1...209...<
|
||||
2460 *--------------------------------
|
||||
2470 * TOKEN NAME TABLE
|
||||
2480 *--------------------------------
|
||||
2490 TOKEN.NAME.TABLE
|
||||
2500 .AT "END" $80...128
|
||||
2510 .AT "FOR" $81...129
|
||||
2520 .AT "NEXT" $82...130
|
||||
2530 .AT "DATA" $83...131
|
||||
2540 .AT "INPUT" $84...132
|
||||
2550 .AT "DEL" $85...133
|
||||
2560 .AT "DIM" $86...134
|
||||
2570 .AT "READ" $87...135
|
||||
2580 .AT "GR" $88...136
|
||||
2590 .AT "TEXT" $89...137
|
||||
2600 .AT "PR#" $8A...138
|
||||
2610 .AT "IN#" $8B...139
|
||||
2620 .AT "CALL" $8C...140
|
||||
2630 .AT "PLOT" $8D...141
|
||||
2640 .AT "HLIN" $8E...142
|
||||
2650 .AT "VLIN" $8F...143
|
||||
2660 .AT "HGR2" $90...144
|
||||
2670 .AT "HGR" $91...145
|
||||
2680 .AT "HCOLOR=" $92...146
|
||||
2690 .AT "HPLOT" $93...147
|
||||
2700 .AT "DRAW" $94...148
|
||||
2710 .AT "XDRAW" $95...149
|
||||
2720 .AT "HTAB" $96...150
|
||||
2730 .AT "HOME" $97...151
|
||||
2740 .AT "ROT=" $98...152
|
||||
2750 .AT "SCALE=" $99...153
|
||||
2760 .AT "SHLOAD" $9A...154
|
||||
2770 .AT "TRACE" $9B...155
|
||||
2780 .AT "NOTRACE" $9C...156
|
||||
2790 .AT "NORMAL" $9D...157
|
||||
2800 .AT "INVERSE" $9E...158
|
||||
2810 .AT "FLASH" $9F...159
|
||||
2820 .AT "COLOR=" $A0...160
|
||||
2830 .AT "POP" $A1...161
|
||||
2840 .AT "VTAB" $A2...162
|
||||
2850 .AT "HIMEM:" $A3...163
|
||||
2860 .AT "LOMEM:" $A4...164
|
||||
2870 .AT "ONERR" $A5...165
|
||||
2880 .AT "RESUME" $A6...166
|
||||
2890 .AT "RECALL" $A7...167
|
||||
2900 .AT "STORE" $A8...168
|
||||
2910 .AT "SPEED=" $A9...169
|
||||
2920 .AT "LET" $AA...170
|
||||
2930 .AT "GOTO" $AB...171
|
||||
2940 .AT "RUN" $AC...172
|
||||
2950 .AT "IF" $AD...173
|
||||
2960 .AT "RESTORE" $AE...174
|
||||
2970 .AT "&" $AF...175
|
||||
2980 .AT "GOSUB" $B0...176
|
||||
2990 .AT "RETURN" $B1...177
|
||||
3000 .AT "REM" $B2...178
|
||||
3010 .AT "STOP" $B3...179
|
||||
3020 .AT "ON" $B4...180
|
||||
3030 .AT "WAIT" $B5...181
|
||||
3040 .AT "LOAD" $B6...182
|
||||
3050 .AT "SAVE" $B7...183
|
||||
3060 .AT "DEF" $B8...184
|
||||
3070 .AT "POKE" $B9...185
|
||||
3080 .AT "PRINT" $BA...186
|
||||
3090 .AT "CONT" $BB...187
|
||||
3100 .AT "LIST" $BC...188
|
||||
3110 .AT "CLEAR" $BD...189
|
||||
3120 .AT "GET" $BE...190
|
||||
3130 .AT "NEW" $BF...191
|
||||
3140 .AT "TAB(" $C0...192
|
||||
3150 .AT "TO" $C1...193
|
||||
3160 .AT "FN" $C2...194
|
||||
3170 .AT "SPC(" $C3...195
|
||||
3180 .AT "THEN" $C4...196
|
||||
3190 .AT "AT" $C5...197
|
||||
3200 .AT "NOT" $C6...198
|
||||
3210 .AT "STEP" $C7...199
|
||||
3220 .AT "+" $C8...200
|
||||
3230 .AT "-" $C9...201
|
||||
3240 .AT "*" $CA...202
|
||||
3250 .AT "/" $CB...203
|
||||
3260 .AT "^" $CC...204
|
||||
3270 .AT "AND" $CD...205
|
||||
3280 .AT "OR" $CE...206
|
||||
3290 .AT ">" $CF...207
|
||||
3300 .AT "=" $D0...208
|
||||
3310 .AT "<" $D1...209
|
||||
3320 .AT "SGN" $D2...210
|
||||
3330 .AT "INT" $D3...211
|
||||
3340 .AT "ABS" $D4...212
|
||||
3350 .AT "USR" $D5...213
|
||||
3360 .AT "FRE" $D6...214
|
||||
3370 .AT "SCRN(" $D7...215
|
||||
3380 .AT "PDL" $D8...216
|
||||
3390 .AT "POS" $D9...217
|
||||
3400 .AT "SQR" $DA...218
|
||||
3410 .AT "RND" $DB...219
|
||||
3420 .AT "LOG" $DC...220
|
||||
3430 .AT "EXP" $DD...221
|
||||
3440 .AT "COS" $DE...222
|
||||
3450 .AT "SIN" $DF...223
|
||||
3460 .AT "TAN" $E0...224
|
||||
3470 .AT "ATN" $E1...225
|
||||
3480 .AT "PEEK" $E2...226
|
||||
3490 .AT "LEN" $E3...227
|
||||
3500 .AT "STR$" $E4...228
|
||||
3510 .AT "VAL" $E5...229
|
||||
3520 .AT "ASC" $E6...230
|
||||
3530 .AT "CHR$" $E7...231
|
||||
3540 .AT "LEFT$" $E8...232
|
||||
3550 .AT "RIGHT$" $E9...233
|
||||
3560 .AT "MID$" $EA...234
|
||||
3570 .HS 00 END OF TOKEN NAME TABLE
|
||||
3580 *--------------------------------
|
||||
46
source/applesoft/S.D260
Normal file
46
source/applesoft/S.D260
Normal file
@ -0,0 +1,46 @@
|
||||
1010 *--------------------------------
|
||||
1020 * ERROR MESSAGES
|
||||
1030 *--------------------------------
|
||||
1040 ERROR.MESSAGES
|
||||
1050 ERR.NOFOR .EQ *-ERROR.MESSAGES
|
||||
1060 .AT /NEXT WITHOUT FOR/
|
||||
1070 ERR.SYNTAX .EQ *-ERROR.MESSAGES
|
||||
1080 .AT /SYNTAX/
|
||||
1090 ERR.NOGOSUB .EQ *-ERROR.MESSAGES
|
||||
1100 .AT /RETURN WITHOUT GOSUB/
|
||||
1110 ERR.NODATA .EQ *-ERROR.MESSAGES
|
||||
1120 .AT /OUT OF DATA/
|
||||
1130 ERR.ILLQTY .EQ *-ERROR.MESSAGES
|
||||
1140 .AT /ILLEGAL QUANTITY/
|
||||
1150 ERR.OVERFLOW .EQ *-ERROR.MESSAGES
|
||||
1160 .AT /OVERFLOW/
|
||||
1170 ERR.MEMFULL .EQ *-ERROR.MESSAGES
|
||||
1180 .AT /OUT OF MEMORY/
|
||||
1190 ERR.UNDEFSTAT .EQ *-ERROR.MESSAGES
|
||||
1200 .AT /UNDEF'D STATEMENT/
|
||||
1210 ERR.BADSUBS .EQ *-ERROR.MESSAGES
|
||||
1220 .AT /BAD SUBSCRIPT/
|
||||
1230 ERR.REDIMD .EQ *-ERROR.MESSAGES
|
||||
1240 .AT /REDIM'D ARRAY/
|
||||
1250 ERR.ZERODIV .EQ *-ERROR.MESSAGES
|
||||
1260 .AT /DIVISION BY ZERO/
|
||||
1270 ERR.ILLDIR .EQ *-ERROR.MESSAGES
|
||||
1280 .AT /ILLEGAL DIRECT/
|
||||
1290 ERR.BADTYPE .EQ *-ERROR.MESSAGES
|
||||
1300 .AT /TYPE MISMATCH/
|
||||
1310 ERR.STRLONG .EQ *-ERROR.MESSAGES
|
||||
1320 .AT /STRING TOO LONG/
|
||||
1330 ERR.FRMCPX .EQ *-ERROR.MESSAGES
|
||||
1340 .AT /FORMULA TOO COMPLEX/
|
||||
1350 ERR.CANTCONT .EQ *-ERROR.MESSAGES
|
||||
1360 .AT /CAN'T CONTINUE/
|
||||
1370 ERR.UNDEFFUNC .EQ *-ERROR.MESSAGES
|
||||
1380 .AT /UNDEF'D FUNCTION/
|
||||
1390 *--------------------------------
|
||||
1400 QT.ERROR .AS / ERROR/
|
||||
1410 .HS 0700 BELL
|
||||
1420 QT.IN .AS / IN /
|
||||
1430 .HS 00
|
||||
1440 QT.BREAK .HS 0D
|
||||
1450 .AS /BREAK/
|
||||
1460 .HS 0700 BELL
|
||||
306
source/applesoft/S.D365
Normal file
306
source/applesoft/S.D365
Normal file
@ -0,0 +1,306 @@
|
||||
1010 *--------------------------------
|
||||
1020 * CALLED BY "NEXT" AND "FOR" TO SCAN THROUGH
|
||||
1030 * THE STACK FOR A FRAME WITH THE SAME VARIABLE.
|
||||
1040 *
|
||||
1050 * (FORPNT) = ADDRESS OF VARIABLE IF "FOR" OR "NEXT"
|
||||
1060 * = $XXFF IF CALLED FROM "RETURN"
|
||||
1070 * <<< BUG: SHOULD BE $FFXX >>>
|
||||
1080 *
|
||||
1090 * RETURNS .NE. IF VARIABLE NOT FOUND,
|
||||
1100 * (X) = STACK PNTR AFTER SKIPPING ALL FRAMES
|
||||
1110 *
|
||||
1120 * .EQ. IF FOUND
|
||||
1130 * (X) = STACK PNTR OF FRAME FOUND
|
||||
1140 *--------------------------------
|
||||
1150 GTFORPNT
|
||||
1160 TSX
|
||||
1170 INX
|
||||
1180 INX
|
||||
1190 INX
|
||||
1200 INX
|
||||
1210 .1 LDA STACK+1,X "FOR" FRAME HERE?
|
||||
1220 CMP #TOKEN.FOR
|
||||
1230 BNE .4 NO
|
||||
1240 LDA FORPNT+1 YES -- "NEXT" WITH NO VARIABLE?
|
||||
1250 BNE .2 NO, VARIABLE SPECIFIED
|
||||
1260 LDA STACK+2,X YES, SO USE THIS FRAME
|
||||
1270 STA FORPNT
|
||||
1280 LDA STACK+3,X
|
||||
1290 STA FORPNT+1
|
||||
1300 .2 CMP STACK+3,X IS VARIABLE IN THIS FRAME?
|
||||
1310 BNE .3 NO
|
||||
1320 LDA FORPNT LOOK AT 2ND BYTE TOO
|
||||
1330 CMP STACK+2,X SAME VARIABLE?
|
||||
1340 BEQ .4 YES
|
||||
1350 .3 TXA NO, SO TRY NEXT FRAME (IF ANY)
|
||||
1360 CLC 18 BYTES PER FRAME
|
||||
1370 ADC #18
|
||||
1380 TAX
|
||||
1390 BNE .1 ...ALWAYS?
|
||||
1400 .4 RTS
|
||||
1410 *--------------------------------
|
||||
1420 * MOVE BLOCK OF MEMORY UP
|
||||
1430 *
|
||||
1440 * ON ENTRY:
|
||||
1450 * (Y,A) = (HIGHDS) = DESTINATION END+1
|
||||
1460 * (LOWTR) = LOWEST ADDRESS OF SOURCE
|
||||
1470 * (HIGHTR) = HIGHEST SOURCE ADDRESS+1
|
||||
1480 *--------------------------------
|
||||
1490 BLTU JSR REASON BE SURE (Y,A) < FRETOP
|
||||
1500 STA STREND NEW TOP OF ARRAY STORAGE
|
||||
1510 STY STREND+1
|
||||
1520 BLTU2 SEC
|
||||
1530 LDA HIGHTR COMPUTE # OF BYTES TO BE MOVED
|
||||
1540 SBC LOWTR (FROM LOWTR THRU HIGHTR-1)
|
||||
1550 STA INDEX PARTIAL PAGE AMOUNT
|
||||
1560 TAY
|
||||
1570 LDA HIGHTR+1
|
||||
1580 SBC LOWTR+1
|
||||
1590 TAX # OF WHOLE PAGES IN X-REG
|
||||
1600 INX
|
||||
1610 TYA # BYTES IN PARTIAL PAGE
|
||||
1620 BEQ .4 NO PARTIAL PAGE
|
||||
1630 LDA HIGHTR BACK UP HIGHTR # BYTES IN PARTIAL PAGE
|
||||
1640 SEC
|
||||
1650 SBC INDEX
|
||||
1660 STA HIGHTR
|
||||
1670 BCS .1
|
||||
1680 DEC HIGHTR+1
|
||||
1690 SEC
|
||||
1700 .1 LDA HIGHDS BACK UP HIGHDS # BYTES IN PARTIAL PAGE
|
||||
1710 SBC INDEX
|
||||
1720 STA HIGHDS
|
||||
1730 BCS .3
|
||||
1740 DEC HIGHDS+1
|
||||
1750 BCC .3 ...ALWAYS
|
||||
1760 .2 LDA (HIGHTR),Y MOVE THE BYTES
|
||||
1770 STA (HIGHDS),Y
|
||||
1780 .3 DEY
|
||||
1790 BNE .2 LOOP TO END OF THIS 256 BYTES
|
||||
1800 LDA (HIGHTR),Y MOVE ONE MORE BYTE
|
||||
1810 STA (HIGHDS),Y
|
||||
1820 .4 DEC HIGHTR+1 DOWN TO NEXT BLOCK OF 256
|
||||
1830 DEC HIGHDS+1
|
||||
1840 DEX ANOTHER BLOCK OF 256 TO MOVE?
|
||||
1850 BNE .3 YES
|
||||
1860 RTS NO, FINISHED
|
||||
1870 *--------------------------------
|
||||
1880 * CHECK IF ENOUGH ROOM LEFT ON STACK
|
||||
1890 * FOR "FOR", "GOSUB", OR EXPRESSION EVALUATION
|
||||
1900 *--------------------------------
|
||||
1910 CHKMEM ASL
|
||||
1920 ADC #54
|
||||
1930 BCS MEMERR ...MEM FULL ERR
|
||||
1940 STA INDEX
|
||||
1950 TSX
|
||||
1960 CPX INDEX
|
||||
1970 BCC MEMERR ...MEM FULL ERR
|
||||
1980 RTS
|
||||
1990 *--------------------------------
|
||||
2000 * CHECK IF ENOUGH ROOM BETWEEN ARRAYS AND STRINGS
|
||||
2010 * (Y,A) = ADDR ARRAYS NEED TO GROW TO
|
||||
2020 *--------------------------------
|
||||
2030 REASON CPY FRETOP+1 HIGH BYTE
|
||||
2040 BCC .4 PLENTY OF ROOM
|
||||
2050 BNE .1 NOT ENOUGH, TRY GARBAGE COLLECTION
|
||||
2060 CMP FRETOP LOW BYTE
|
||||
2070 BCC .4 ENOUGH ROOM
|
||||
2080 *--------------------------------
|
||||
2090 .1 PHA SAVE (Y,A), TEMP1, AND TEMP2
|
||||
2100 LDX #FAC-TEMP1-1
|
||||
2110 TYA
|
||||
2120 .2 PHA
|
||||
2130 LDA TEMP1,X
|
||||
2140 DEX
|
||||
2150 BPL .2
|
||||
2160 JSR GARBAG MAKE AS MUCH ROOM AS POSSIBLE
|
||||
2170 LDX #TEMP1-FAC+1 RESTORE TEMP1 AND TEMP2
|
||||
2180 .3 PLA AND (Y,A)
|
||||
2190 STA FAC,X
|
||||
2200 INX
|
||||
2210 BMI .3
|
||||
2220 PLA
|
||||
2230 TAY
|
||||
2240 PLA DID WE FIND ENOUGH ROOM?
|
||||
2250 CPY FRETOP+1 HIGH BYTE
|
||||
2260 BCC .4 YES, AT LEAST A PAGE
|
||||
2270 BNE MEMERR NO, MEM FULL ERR
|
||||
2280 CMP FRETOP LOW BYTE
|
||||
2290 BCS MEMERR NO, MEM FULL ERR
|
||||
2300 .4 RTS YES, RETURN
|
||||
2310 *--------------------------------
|
||||
2320 MEMERR LDX #ERR.MEMFULL
|
||||
2330 *--------------------------------
|
||||
2340 * HANDLE AN ERROR
|
||||
2350 *
|
||||
2360 * (X)=OFFSET IN ERROR MESSAGE TABLE
|
||||
2370 * (ERRFLG) > 128 IF "ON ERR" TURNED ON
|
||||
2380 * (CURLIN+1) = $FF IF IN DIRECT MODE
|
||||
2390 *--------------------------------
|
||||
2400 ERROR BIT ERRFLG "ON ERR" TURNED ON?
|
||||
2410 BPL .1 NO
|
||||
2420 JMP HANDLERR YES
|
||||
2430 .1 JSR CRDO PRINT <RETURN>
|
||||
2440 JSR OUTQUES PRINT "?"
|
||||
2450 .2 LDA ERROR.MESSAGES,X
|
||||
2460 PHA PRINT MESSAGE
|
||||
2470 JSR OUTDO
|
||||
2480 INX
|
||||
2490 PLA
|
||||
2500 BPL .2
|
||||
2510 JSR STKINI FIX STACK, ET AL
|
||||
2520 LDA #QT.ERROR PRINT " ERROR" AND BELL
|
||||
2530 LDY /QT.ERROR
|
||||
2540 *--------------------------------
|
||||
2550 * PRINT STRING AT (Y,A)
|
||||
2560 * PRINT CURRENT LINE # UNLESS IN DIRECT MODE
|
||||
2570 * FALL INTO WARM RESTART
|
||||
2580 *--------------------------------
|
||||
2590 PRINT.ERROR.LINNUM
|
||||
2600 JSR STROUT PRINT STRING AT (Y,A)
|
||||
2610 LDY CURLIN+1 RUNNING, OR DIRECT?
|
||||
2620 INY
|
||||
2630 BEQ RESTART WAS $FF, SO DIRECT MODE
|
||||
2640 JSR INPRT RUNNING, SO PRINT LINE NUMBER
|
||||
2650 *--------------------------------
|
||||
2660 * WARM RESTART ENTRY
|
||||
2670 *
|
||||
2680 * COME HERE FROM MONITOR BY CTL-C, 0G, 3D0G, OR E003G
|
||||
2690 *--------------------------------
|
||||
2700 RESTART
|
||||
2710 JSR CRDO PRINT <RETURN>
|
||||
2720 LDX #']+$80 PROMPT CHARACTER
|
||||
2730 JSR INLIN2 READ A LINE
|
||||
2740 STX TXTPTR SET UP CHRGET TO SCAN THE LINE
|
||||
2750 STY TXTPTR+1
|
||||
2760 LSR ERRFLG CLEAR FLAG
|
||||
2770 JSR CHRGET
|
||||
2780 TAX
|
||||
2790 BEQ RESTART EMPTY LINE
|
||||
2800 LDX #$FF $FF IN HI-BYTE OF CURLIN MEANS
|
||||
2810 STX CURLIN+1 WE ARE IN DIRECT MODE
|
||||
2820 BCC NUMBERED.LINE CHRGET SAW DIGIT, NUMBERED LINE
|
||||
2830 JSR PARSE.INPUT.LINE NO NUMBER, SO PARSE IT
|
||||
2840 JMP TRACE. AND TRY EXECUTING IT
|
||||
2850 *--------------------------------
|
||||
2860 * HANDLE NUMBERED LINE
|
||||
2870 *--------------------------------
|
||||
2880 NUMBERED.LINE
|
||||
2890 LDX PRGEND SQUASH VARIABLE TABLE
|
||||
2900 STX VARTAB
|
||||
2910 LDX PRGEND+1
|
||||
2920 STX VARTAB+1
|
||||
2930 JSR LINGET GET LINE #
|
||||
2940 JSR PARSE.INPUT.LINE AND PARSE THE INPUT LINE
|
||||
2950 STY EOL.PNTR SAVE INDEX TO INPUT BUFFER
|
||||
2960 JSR FNDLIN IS THIS LINE # ALREADY IN PROGRAM?
|
||||
2970 BCC PUT.NEW.LINE NO
|
||||
2980 LDY #1 YES, SO DELETE IT
|
||||
2990 LDA (LOWTR),Y LOWTR POINTS AT LINE
|
||||
3000 STA INDEX+1 GET HIGH BYTE OF FORWARD PNTR
|
||||
3010 LDA VARTAB
|
||||
3020 STA INDEX
|
||||
3030 LDA LOWTR+1
|
||||
3040 STA DEST+1
|
||||
3050 LDA LOWTR
|
||||
3060 DEY
|
||||
3070 SBC (LOWTR),Y
|
||||
3080 CLC
|
||||
3090 ADC VARTAB
|
||||
3100 STA VARTAB
|
||||
3110 STA DEST
|
||||
3120 LDA VARTAB+1
|
||||
3130 ADC #$FF
|
||||
3140 STA VARTAB+1
|
||||
3150 SBC LOWTR+1
|
||||
3160 TAX
|
||||
3170 SEC
|
||||
3180 LDA LOWTR
|
||||
3190 SBC VARTAB
|
||||
3200 TAY
|
||||
3210 BCS .1
|
||||
3220 INX
|
||||
3230 DEC DEST+1
|
||||
3240 .1 CLC
|
||||
3250 ADC INDEX
|
||||
3260 BCC .2
|
||||
3270 DEC INDEX+1
|
||||
3280 CLC
|
||||
3290 *--------------------------------
|
||||
3300 .2 LDA (INDEX),Y MOVE HIGHER LINES OF PROGRAM
|
||||
3310 STA (DEST),Y DOWN OVER THE DELETED LINE.
|
||||
3320 INY
|
||||
3330 BNE .2
|
||||
3340 INC INDEX+1
|
||||
3350 INC DEST+1
|
||||
3360 DEX
|
||||
3370 BNE .2
|
||||
3380 *--------------------------------
|
||||
3390 PUT.NEW.LINE
|
||||
3400 LDA INPUT.BUFFER ANY CHARACTERS AFTER LINE #?
|
||||
3410 BEQ FIX.LINKS NO, SO NOTHING TO INSERT.
|
||||
3420 LDA MEMSIZ YES, SO MAKE ROOM AND INSERT LINE
|
||||
3430 LDY MEMSIZ+1 WIPE STRING AREA CLEAN
|
||||
3440 STA FRETOP
|
||||
3450 STY FRETOP+1
|
||||
3460 LDA VARTAB SET UP BLTU SUBROUTINE
|
||||
3470 STA HIGHTR INSERT NEW LINE.
|
||||
3480 ADC EOL.PNTR
|
||||
3490 STA HIGHDS
|
||||
3500 LDY VARTAB+1
|
||||
3510 STY HIGHTR+1
|
||||
3520 BCC .1
|
||||
3530 INY
|
||||
3540 .1 STY HIGHDS+1
|
||||
3550 JSR BLTU MAKE ROOM FOR THE LINE
|
||||
3560 LDA LINNUM PUT LINE NUMBER IN LINE IMAGE
|
||||
3570 LDY LINNUM+1
|
||||
3580 STA INPUT.BUFFER-2
|
||||
3590 STY INPUT.BUFFER-1
|
||||
3600 LDA STREND
|
||||
3610 LDY STREND+1
|
||||
3620 STA VARTAB
|
||||
3630 STY VARTAB+1
|
||||
3640 LDY EOL.PNTR
|
||||
3650 *---COPY LINE INTO PROGRAM-------
|
||||
3660 .2 LDA INPUT.BUFFER-5,Y
|
||||
3670 DEY
|
||||
3680 STA (LOWTR),Y
|
||||
3690 BNE .2
|
||||
3700 *--------------------------------
|
||||
3710 * CLEAR ALL VARIABLES
|
||||
3720 * RE-ESTABLISH ALL FORWARD LINKS
|
||||
3730 *--------------------------------
|
||||
3740 FIX.LINKS
|
||||
3750 JSR SETPTRS CLEAR ALL VARIABLES
|
||||
3760 LDA TXTTAB POINT INDEX AT START OF PROGRAM
|
||||
3770 LDY TXTTAB+1
|
||||
3780 STA INDEX
|
||||
3790 STY INDEX+1
|
||||
3800 CLC
|
||||
3810 .1 LDY #1 HI-BYTE OF NEXT FORWARD PNTR
|
||||
3820 LDA (INDEX),Y END OF PROGRAM YET?
|
||||
3830 BNE .2 NO, KEEP GOING
|
||||
3840 LDA VARTAB YES
|
||||
3850 STA PRGEND
|
||||
3860 LDA VARTAB+1
|
||||
3870 STA PRGEND+1
|
||||
3880 JMP RESTART
|
||||
3890 .2 LDY #4 FIND END OF THIS LINE
|
||||
3900 .3 INY (NOTE MAXIMUM LENGTH < 256)
|
||||
3910 LDA (INDEX),Y
|
||||
3920 BNE .3
|
||||
3930 INY COMPUTE ADDRESS OF NEXT LINE
|
||||
3940 TYA
|
||||
3950 ADC INDEX
|
||||
3960 TAX
|
||||
3970 LDY #0 STORE FORWARD PNTR IN THIS LINE
|
||||
3980 STA (INDEX),Y
|
||||
3990 LDA INDEX+1
|
||||
4000 ADC #0 (NOTE: THIS CLEARS CARRY)
|
||||
4010 INY
|
||||
4020 STA (INDEX),Y
|
||||
4030 STX INDEX
|
||||
4040 STA INDEX+1
|
||||
4050 BCC .1 ...ALWAYS
|
||||
4060 *--------------------------------
|
||||
347
source/applesoft/S.D52C
Normal file
347
source/applesoft/S.D52C
Normal file
@ -0,0 +1,347 @@
|
||||
1010 *--------------------------------
|
||||
1020 * READ A LINE, AND STRIP OFF SIGN BITS
|
||||
1030 *--------------------------------
|
||||
1040 INLIN LDX #$80 NULL PROMPT
|
||||
1050 INLIN2 STX MON.PROMPT
|
||||
1060 JSR MON.GETLN
|
||||
1070 CPX #239 MAXIMUM LINE LENGTH
|
||||
1080 BCC .1
|
||||
1090 LDX #239 TRUNCATE AT 239 CHARS
|
||||
1100 .1 LDA #0 MARK END OF LINE WITH $00 BYTE
|
||||
1110 STA INPUT.BUFFER,X
|
||||
1120 TXA
|
||||
1130 BEQ .3 NULL INPUT LINE
|
||||
1140 .2 LDA INPUT.BUFFER-1,X DROP SIGN BITS
|
||||
1150 AND #$7F
|
||||
1160 STA INPUT.BUFFER-1,X
|
||||
1170 DEX
|
||||
1180 BNE .2
|
||||
1190 .3 LDA #0 (Y,X) POINTS AT BUFFER-1
|
||||
1200 LDX #INPUT.BUFFER-1
|
||||
1210 LDY /INPUT.BUFFER-1
|
||||
1220 RTS
|
||||
1230 *--------------------------------
|
||||
1240 INCHR JSR MON.RDKEY *** OUGHT TO BE "BIT $C010" ***
|
||||
1250 AND #$7F
|
||||
1260 RTS
|
||||
1270 *--------------------------------
|
||||
1280 * TOKENIZE THE INPUT LINE
|
||||
1290 *--------------------------------
|
||||
1300 PARSE.INPUT.LINE
|
||||
1310 LDX TXTPTR INDEX INTO UNPARSED LINE
|
||||
1320 DEX PREPARE FOR INX AT "PARSE"
|
||||
1330 LDY #4 INDEX TO PARSED OUTPUT LINE
|
||||
1340 STY DATAFLG CLEAR SIGN-BIT OF DATAFLG
|
||||
1350 BIT LOCK IS THIS PROGRAM LOCKED?
|
||||
1360 BPL PARSE NO, GO AHEAD AND PARSE THE LINE
|
||||
1370 PLA YES, IGNORE INPUT AND "RUN"
|
||||
1380 PLA THE PROGRAM
|
||||
1390 JSR SETPTRS CLEAR ALL VARIABLES
|
||||
1400 JMP NEWSTT START RUNNING
|
||||
1410 *--------------------------------
|
||||
1420 PARSE INX NEXT INPUT CHARACTER
|
||||
1430 .1 LDA INPUT.BUFFER,X
|
||||
1440 BIT DATAFLG IN A "DATA" STATEMENT?
|
||||
1450 BVS .2 YES (DATAFLG = $49)
|
||||
1460 CMP #' ' IGNORE BLANKS
|
||||
1470 BEQ PARSE
|
||||
1480 .2 STA ENDCHR
|
||||
1490 CMP #'" START OF QUOTATION?
|
||||
1500 BEQ .13
|
||||
1510 BVS .9 BRANCH IF IN "DATA" STATEMENT
|
||||
1520 CMP #'? SHORTHAND FOR "PRINT"?
|
||||
1530 BNE .3 NO
|
||||
1540 LDA #TOKEN.PRINT YES, REPLACE WITH "PRINT" TOKEN
|
||||
1550 BNE .9 ...ALWAYS
|
||||
1560 .3 CMP #'0 IS IT A DIGIT, COLON, OR SEMI-COLON?
|
||||
1570 BCC .4 NO, PUNCTUATION !"#$%&'()*+,-./
|
||||
1580 CMP #';'+1
|
||||
1590 BCC .9 YES, NOT A TOKEN
|
||||
1600 *--------------------------------
|
||||
1610 * SEARCH TOKEN NAME TABLE FOR MATCH STARTING
|
||||
1620 * WITH CURRENT CHAR FROM INPUT LINE
|
||||
1630 *--------------------------------
|
||||
1640 .4 STY STRNG2 SAVE INDEX TO OUTPUT LINE
|
||||
1650 LDA #TOKEN.NAME.TABLE-$100
|
||||
1660 STA FAC MAKE PNTR FOR SEARCH
|
||||
1670 LDA /TOKEN.NAME.TABLE-$100
|
||||
1680 STA FAC+1
|
||||
1690 LDY #0 USE Y-REG WITH (FAC) TO ADDRESS TABLE
|
||||
1700 STY TKN.CNTR HOLDS CURRENT TOKEN-$80
|
||||
1710 DEY PREPARE FOR "INY" A FEW LINES DOWN
|
||||
1720 STX TXTPTR SAVE POSITION IN INPUT LINE
|
||||
1730 DEX PREPARE FOR "INX" A FEW LINES DOWN
|
||||
1740 .5 INY ADVANCE POINTER TO TOKEN TABLE
|
||||
1750 BNE .6 Y=Y+1 IS ENOUGH
|
||||
1760 INC FAC+1 ALSO NEED TO BUMP THE PAGE
|
||||
1770 .6 INX ADVANCE POINTER TO INPUT LINE
|
||||
1780 .7 LDA INPUT.BUFFER,X NEXT CHAR FROM INPUT LINE
|
||||
1790 CMP #' ' THIS CHAR A BLANK?
|
||||
1800 BEQ .6 YES, IGNORE ALL BLANKS
|
||||
1810 SEC NO, COMPARE TO CHAR IN TABLE
|
||||
1820 SBC (FAC),Y SAME AS NEXT CHAR OF TOKEN NAME?
|
||||
1830 BEQ .5 YES, CONTINUE MATCHING
|
||||
1840 CMP #$80 MAYBE; WAS IT SAME EXCEPT FOR BIT 7?
|
||||
1850 BNE .14 NO, SKIP TO NEXT TOKEN
|
||||
1860 ORA TKN.CNTR YES, END OF TOKEN; GET TOKEN #
|
||||
1870 CMP #TOKEN.AT DID WE MATCH "AT"?
|
||||
1880 BNE .8 NO, SO NO AMBIGUITY
|
||||
1890 LDA INPUT.BUFFER+1,X "AT" COULD BE "ATN" OR "A TO"
|
||||
1900 CMP #'N "ATN" HAS PRECEDENCE OVER "AT"
|
||||
1910 BEQ .14 IT IS "ATN", FIND IT THE HARD WAY
|
||||
1920 CMP #'O "TO" HAS PRECEDENCE OVER "AT"
|
||||
1930 BEQ .14 IT IS "A TO", FIN IT THE HARD WAY
|
||||
1940 LDA #TOKEN.AT NOT "ATN" OR "A TO", SO USE "AT"
|
||||
1950 *--------------------------------
|
||||
1960 * STORE CHARACTER OR TOKEN IN OUTPUT LINE
|
||||
1970 *--------------------------------
|
||||
1980 .8 LDY STRNG2 GET INDEX TO OUTPUT LINE IN Y-REG
|
||||
1990 .9 INX ADVANCE INPUT INDEX
|
||||
2000 INY ADVANCE OUTPUT INDEX
|
||||
2010 STA INPUT.BUFFER-5,Y STORE CHAR OR TOKEN
|
||||
2020 LDA INPUT.BUFFER-5,Y TEST FOR EOL OR EOS
|
||||
2030 BEQ .17 END OF LINE
|
||||
2040 SEC
|
||||
2050 SBC #': END OF STATEMENT?
|
||||
2060 BEQ .10 YES, CLEAR DATAFLG
|
||||
2070 CMP #TOKEN.DATA-':' "DATA" TOKEN?
|
||||
2080 BNE .11 NO, LEAVE DATAFLG ALONE
|
||||
2090 .10 STA DATAFLG DATAFLG = 0 OR $83-$3A = $49
|
||||
2100 .11 SEC IS IT A "REM" TOKEN?
|
||||
2110 SBC #TOKEN.REM-':'
|
||||
2120 BNE .1 NO, CONTINUE PARSING LINE
|
||||
2130 STA ENDCHR YES, CLEAR LITERAL FLAG
|
||||
2140 *--------------------------------
|
||||
2150 * HANDLE LITERAL (BETWEEN QUOTES) OR REMARK,
|
||||
2160 * BY COPYING CHARS UP TO ENDCHR.
|
||||
2170 *--------------------------------
|
||||
2180 .12 LDA INPUT.BUFFER,X
|
||||
2190 BEQ .9 END OF LINE
|
||||
2200 CMP ENDCHR
|
||||
2210 BEQ .9 FOUND ENDCHR
|
||||
2220 .13 INY NEXT OUTPUT CHAR
|
||||
2230 STA INPUT.BUFFER-5,Y
|
||||
2240 INX NEXT INPUT CHAR
|
||||
2250 BNE .12 ...ALWAYS
|
||||
2260 *--------------------------------
|
||||
2270 * ADVANCE POINTER TO NEXT TOKEN NAME
|
||||
2280 *--------------------------------
|
||||
2290 .14 LDX TXTPTR GET POINTER TO INPUT LINE IN X-REG
|
||||
2300 INC TKN.CNTR BUMP (TOKEN # - $80)
|
||||
2310 .15 LDA (FAC),Y SCAN THROUGH TABLE FOR BIT7 = 1
|
||||
2320 INY NEXT TOKEN ONE BEYOND THAT
|
||||
2330 BNE .16 ...USUALLY ENOUGH TO BUMP Y-REG
|
||||
2340 INC FAC+1 NEXT SET OF 256 TOKEN CHARS
|
||||
2350 .16 ASL SEE IF SIGN BIT SET ON CHAR
|
||||
2360 BCC .15 NO, MORE IN THIS NAME
|
||||
2370 LDA (FAC),Y YES, AT NEXT NAME. END OF TABLE?
|
||||
2380 BNE .7 NO, NOT END OF TABLE
|
||||
2390 LDA INPUT.BUFFER,X YES, SO NOT A KEYWORD
|
||||
2400 BPL .8 ...ALWAYS, COPY CHAR AS IS
|
||||
2410 *---END OF LINE------------------
|
||||
2420 .17 STA INPUT.BUFFER-3,Y STORE ANOTHER 00 ON END
|
||||
2430 DEC TXTPTR+1 SET TXTPTR = INPUT.BUFFER-1
|
||||
2440 LDA #INPUT.BUFFER-1
|
||||
2450 STA TXTPTR
|
||||
2460 RTS
|
||||
2470 *--------------------------------
|
||||
2480 * SEARCH FOR LINE
|
||||
2490 *
|
||||
2500 * (LINNUM) = LINE # TO FIND
|
||||
2510 * IF NOT FOUND: CARRY = 0
|
||||
2520 * LOWTR POINTS AT NEXT LINE
|
||||
2530 * IF FOUND: CARRY = 1
|
||||
2540 * LOWTR POINTS AT LINE
|
||||
2550 *--------------------------------
|
||||
2560 FNDLIN LDA TXTTAB SEARCH FROM BEGINNING OF PROGRAM
|
||||
2570 LDX TXTTAB+1
|
||||
2580 FL1 LDY #1 SEARCH FROM (X,A)
|
||||
2590 STA LOWTR
|
||||
2600 STX LOWTR+1
|
||||
2610 LDA (LOWTR),Y
|
||||
2620 BEQ .3 END OF PROGRAM, AND NOT FOUND
|
||||
2630 INY
|
||||
2640 INY
|
||||
2650 LDA LINNUM+1
|
||||
2660 CMP (LOWTR),Y
|
||||
2670 BCC RTS.1 IF NOT FOUND
|
||||
2680 BEQ .1
|
||||
2690 DEY
|
||||
2700 BNE .2
|
||||
2710 .1 LDA LINNUM
|
||||
2720 DEY
|
||||
2730 CMP (LOWTR),Y
|
||||
2740 BCC RTS.1 PAST LINE, NOT FOUND
|
||||
2750 BEQ RTS.1 IF FOUND
|
||||
2760 .2 DEY
|
||||
2770 LDA (LOWTR),Y
|
||||
2780 TAX
|
||||
2790 DEY
|
||||
2800 LDA (LOWTR),Y
|
||||
2810 BCS FL1 ALWAYS
|
||||
2820 .3 CLC RETURN CARRY = 0
|
||||
2830 RTS.1 RTS
|
||||
2840 *--------------------------------
|
||||
2850 * "NEW" STATEMENT
|
||||
2860 *--------------------------------
|
||||
2870 NEW BNE RTS.1 IGNORE IF MORE TO THE STATEMENT
|
||||
2880 SCRTCH LDA #0
|
||||
2890 STA LOCK
|
||||
2900 TAY
|
||||
2910 STA (TXTTAB),Y
|
||||
2920 INY
|
||||
2930 STA (TXTTAB),Y
|
||||
2940 LDA TXTTAB
|
||||
2950 ADC #2 (CARRY WASN'T CLEARED, SO "NEW" USUALLY
|
||||
2960 STA VARTAB ADDS 3, WHEREAS "FP" ADDS 2.)
|
||||
2970 STA PRGEND
|
||||
2980 LDA TXTTAB+1
|
||||
2990 ADC #0
|
||||
3000 STA VARTAB+1
|
||||
3010 STA PRGEND+1
|
||||
3020 *--------------------------------
|
||||
3030 SETPTRS
|
||||
3040 JSR STXTPT SET TXTPTR TO TXTTAB - 1
|
||||
3050 LDA #0 (THIS COULD HAVE BEEN ".HS 2C")
|
||||
3060 *--------------------------------
|
||||
3070 * "CLEAR" STATEMENT
|
||||
3080 *--------------------------------
|
||||
3090 CLEAR BNE RTS.2 IGNORE IF NOT AT END OF STATEMENT
|
||||
3100 CLEARC LDA MEMSIZ CLEAR STRING AREA
|
||||
3110 LDY MEMSIZ+1
|
||||
3120 STA FRETOP
|
||||
3130 STY FRETOP+1
|
||||
3140 LDA VARTAB CLEAR ARRAY AREA
|
||||
3150 LDY VARTAB+1
|
||||
3160 STA ARYTAB
|
||||
3170 STY ARYTAB+1
|
||||
3180 STA STREND LOW END OF FREE SPACE
|
||||
3190 STY STREND+1
|
||||
3200 JSR RESTORE SET "DATA" POINTER TO BEGINNING
|
||||
3210 *--------------------------------
|
||||
3220 STKINI LDX #TEMPST
|
||||
3230 STX TEMPPT
|
||||
3240 PLA SAVE RETURN ADDRESS
|
||||
3250 TAY
|
||||
3260 PLA
|
||||
3270 LDX #$F8 START STACK AT $F8,
|
||||
3280 TXS LEAVING ROOM FOR PARSING LINES
|
||||
3290 PHA RESTORE RETURN ADDRESS
|
||||
3300 TYA
|
||||
3310 PHA
|
||||
3320 LDA #0
|
||||
3330 STA OLDTEXT+1
|
||||
3340 STA SUBFLG
|
||||
3350 RTS.2 RTS
|
||||
3360 *--------------------------------
|
||||
3370 * SET TXTPTR TO BEGINNING OF PROGRAM
|
||||
3380 *--------------------------------
|
||||
3390 STXTPT CLC TXTPTR = TXTTAB - 1
|
||||
3400 LDA TXTTAB
|
||||
3410 ADC #$FF
|
||||
3420 STA TXTPTR
|
||||
3430 LDA TXTTAB+1
|
||||
3440 ADC #$FF
|
||||
3450 STA TXTPTR+1
|
||||
3460 RTS
|
||||
3470 *--------------------------------
|
||||
3480 * "LIST" STATEMENT
|
||||
3490 *--------------------------------
|
||||
3500 LIST BCC .1 NO LINE # SPECIFIED
|
||||
3510 BEQ .1 ---DITTO---
|
||||
3520 CMP #TOKEN.MINUS IF DASH OR COMMA, START AT LINE 0
|
||||
3530 BEQ .1 IS IS A DASH
|
||||
3540 CMP #', COMMA?
|
||||
3550 BNE RTS.2 NO, ERROR
|
||||
3560 .1 JSR LINGET CONVERT LINE NUMBER IF ANY
|
||||
3570 JSR FNDLIN POINT LOWTR TO 1ST LINE
|
||||
3580 JSR CHRGOT RANGE SPECIFIED?
|
||||
3590 BEQ .3 NO
|
||||
3600 CMP #TOKEN.MINUS
|
||||
3610 BEQ .2
|
||||
3620 CMP #',
|
||||
3630 BNE RTS.1
|
||||
3640 .2 JSR CHRGET GET NEXT CHAR
|
||||
3650 JSR LINGET CONVERT SECOND LINE #
|
||||
3660 BNE RTS.2 BRANCH IF SYNTAX ERR
|
||||
3670 .3 PLA POP RETURN ADRESS
|
||||
3680 PLA (GET BACK BY "JMP NEWSTT")
|
||||
3690 LDA LINNUM IF NO SECOND NUMBER, USE $FFFF
|
||||
3700 ORA LINNUM+1
|
||||
3710 BNE LIST.0 THERE WAS A SECOND NUMBER
|
||||
3720 LDA #$FF MAX END RANGE
|
||||
3730 STA LINNUM
|
||||
3740 STA LINNUM+1
|
||||
3750 LIST.0 LDY #1
|
||||
3760 LDA (LOWTR),Y HIGH BYTE OF LINK
|
||||
3770 BEQ LIST.3 END OF PROGRAM
|
||||
3780 JSR ISCNTC CHECK IF CONTROL-C HAS BEEN TYPED
|
||||
3790 JSR CRDO NO, PRINT <RETURN>
|
||||
3800 INY
|
||||
3810 LDA (LOWTR),Y GET LINE #, COMPARE WITH END RANGE
|
||||
3820 TAX
|
||||
3830 INY
|
||||
3840 LDA (LOWTR),Y
|
||||
3850 CMP LINNUM+1
|
||||
3860 BNE .5
|
||||
3870 CPX LINNUM
|
||||
3880 BEQ .6 ON LAST LINE OF RANGE
|
||||
3890 .5 BCS LIST.3 FINISHED THE RANGE
|
||||
3900 *---LIST ONE LINE----------------
|
||||
3910 .6 STY FORPNT
|
||||
3920 JSR LINPRT PRINT LINE # FROM X,A
|
||||
3930 LDA #' ' PRINT SPACE AFTER LINE #
|
||||
3940 LIST.1 LDY FORPNT
|
||||
3950 AND #$7F
|
||||
3960 LIST.2 JSR OUTDO
|
||||
3970 LDA MON.CH IF PAST COLUMN 33, START A NEW LINE
|
||||
3980 CMP #33
|
||||
3990 BCC .1 < 33
|
||||
4000 JSR CRDO PRINT <RETURN>
|
||||
4010 LDA #5 AND TAB OVER 5
|
||||
4020 STA MON.CH
|
||||
4030 .1 INY
|
||||
4040 LDA (LOWTR),Y
|
||||
4050 BNE LIST.4 NOT END OF LINE YET
|
||||
4060 TAY END OF LINE
|
||||
4070 LDA (LOWTR),Y GET LINK TO NEXT LINE
|
||||
4080 TAX
|
||||
4090 INY
|
||||
4100 LDA (LOWTR),Y
|
||||
4110 STX LOWTR POINT TO NEXT LINE
|
||||
4120 STA LOWTR+1
|
||||
4130 BNE LIST.0 BRANCH IF NOT END OF PROGRAM
|
||||
4140 LIST.3 LDA #$0D PRINT <RETURN>
|
||||
4150 JSR OUTDO
|
||||
4160 JMP NEWSTT TO NEXT STATEMENT
|
||||
4170 *--------------------------------
|
||||
4180 GETCHR INY PICK UP CHAR FROM TABLE
|
||||
4190 BNE .1
|
||||
4200 INC FAC+1
|
||||
4210 .1 LDA (FAC),Y
|
||||
4220 RTS
|
||||
4230 *--------------------------------
|
||||
4240 LIST.4 BPL LIST.2 BRANCH IF NOT A TOKEN
|
||||
4250 SEC
|
||||
4260 SBC #$7F CONVERT TOKEN TO INDEX
|
||||
4270 TAX
|
||||
4280 STY FORPNT SAVE LINE POINTER
|
||||
4290 LDY #TOKEN.NAME.TABLE-$100
|
||||
4300 STY FAC POINT FAC TO TABLE
|
||||
4310 LDY /TOKEN.NAME.TABLE-$100
|
||||
4320 STY FAC+1
|
||||
4330 LDY #-1
|
||||
4340 .1 DEX SKIP KEYWORDS UNTIL REACH THIS ONE
|
||||
4350 BEQ .3
|
||||
4360 .2 JSR GETCHR BUMP Y, GET CHAR FROM TABLE
|
||||
4370 BPL .2 NOT AT END OF KEYWORD YET
|
||||
4380 BMI .1 END OF KEYWORD, ALWAYS BRANCHES
|
||||
4390 .3 LDA #' ' FOUND THE RIGHT KEYWORD
|
||||
4400 JSR OUTDO PRINT LEADING SPACE
|
||||
4410 .4 JSR GETCHR PRINT THE KEYWORD
|
||||
4420 BMI .5 LAST CHAR OF KEYWORD
|
||||
4430 JSR OUTDO
|
||||
4440 BNE .4 ...ALWAYS
|
||||
4450 .5 JSR OUTDO PRINT LAST CHAR OF KEYWORD
|
||||
4460 LDA #' ' PRINT TRAILING SPACE
|
||||
4470 BNE LIST.1 ...ALWAYS, BACK TO ACTUAL LINE
|
||||
272
source/applesoft/S.D766
Normal file
272
source/applesoft/S.D766
Normal file
@ -0,0 +1,272 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "FOR" STATEMENT
|
||||
1030 *
|
||||
1040 * FOR PUSHES 18 BYTES ON THE STACK:
|
||||
1050 * 2 -- TXTPTR
|
||||
1060 * 2 -- LINE NUMBER
|
||||
1070 * 5 -- INITIAL (CURRENT) FOR VARIABLE VALUE
|
||||
1080 * 1 -- STEP SIGN
|
||||
1090 * 5 -- STEP VALUE
|
||||
1100 * 2 -- ADDRESS OF FOR VARIABLE IN VARTAB
|
||||
1110 * 1 -- FOR TOKEN ($81)
|
||||
1120 *--------------------------------
|
||||
1130 FOR LDA #$80
|
||||
1140 STA SUBFLG SUBSCRIPTS NOT ALLOWED
|
||||
1150 JSR LET DO <VAR> = <EXP>, STORE ADDR IN FORPNT
|
||||
1160 JSR GTFORPNT IS THIS FOR VARIABLE ACTIVE?
|
||||
1170 BNE .1 NO
|
||||
1180 TXA YES, CANCEL IT AND ENCLOSED LOOPS
|
||||
1190 ADC #15 CARRY=1, THIS ADDS 16
|
||||
1200 TAX X WAS ALREADY S+2
|
||||
1210 TXS
|
||||
1220 .1 PLA POP RETURN ADDRESS TOO
|
||||
1230 PLA
|
||||
1240 LDA #9 BE CERTAIN ENOUGH ROOM IN STACK
|
||||
1250 JSR CHKMEM
|
||||
1260 JSR DATAN SCAN AHEAD TO NEXT STATEMENT
|
||||
1270 CLC PUSH STATEMENT ADDRESS ON STACK
|
||||
1280 TYA
|
||||
1290 ADC TXTPTR
|
||||
1300 PHA
|
||||
1310 LDA TXTPTR+1
|
||||
1320 ADC #0
|
||||
1330 PHA
|
||||
1340 LDA CURLIN+1 PUSH LINE NUMBER ON STACK
|
||||
1350 PHA
|
||||
1360 LDA CURLIN
|
||||
1370 PHA
|
||||
1380 LDA #TOKEN.TO
|
||||
1390 JSR SYNCHR REQUIRE "TO"
|
||||
1400 JSR CHKNUM <VAR> = <EXP> MUST BE NUMERIC
|
||||
1410 JSR FRMNUM GET FINAL VALUE, MUST BE NUMERIC
|
||||
1420 LDA FAC.SIGN PUT SIGN INTO VALUE IN FAC
|
||||
1430 ORA #$7F
|
||||
1440 AND FAC+1
|
||||
1450 STA FAC+1
|
||||
1460 LDA #STEP SET UP FOR RETURN
|
||||
1470 LDY /STEP TO STEP
|
||||
1480 STA INDEX
|
||||
1490 STY INDEX+1
|
||||
1500 JMP FRM.STACK.3 RETURNS BY "JMP (INDEX)"
|
||||
1510 *--------------------------------
|
||||
1520 * "STEP" PHRASE OF "FOR" STATEMENT
|
||||
1530 *--------------------------------
|
||||
1540 STEP LDA #CON.ONE STEP DEFAULT=1
|
||||
1550 LDY /CON.ONE
|
||||
1560 JSR LOAD.FAC.FROM.YA
|
||||
1570 JSR CHRGOT
|
||||
1580 CMP #TOKEN.STEP
|
||||
1590 BNE .1 USE DEFAULT VALUE OF 1.0
|
||||
1600 JSR CHRGET STEP SPECIFIED, GET IT
|
||||
1610 JSR FRMNUM
|
||||
1620 .1 JSR SIGN
|
||||
1630 JSR FRM.STACK.2
|
||||
1640 LDA FORPNT+1
|
||||
1650 PHA
|
||||
1660 LDA FORPNT
|
||||
1670 PHA
|
||||
1680 LDA #TOKEN.FOR
|
||||
1690 PHA
|
||||
1700 *--------------------------------
|
||||
1710 * PERFORM NEXT STATEMENT
|
||||
1720 *--------------------------------
|
||||
1730 NEWSTT TSX REMEMBER THE STACK POSITION
|
||||
1740 STX REMSTK
|
||||
1750 JSR ISCNTC SEE IF CONTROL-C HAS BEEN TYPED
|
||||
1760 LDA TXTPTR NO, KEEP EXECUTING
|
||||
1770 LDY TXTPTR+1
|
||||
1780 LDX CURLIN+1 =$FF IF IN DIRECT MODE
|
||||
1790 INX $FF TURNS INTO $00
|
||||
1800 BEQ .1 IN DIRECT MODE
|
||||
1810 STA OLDTEXT IN RUNNING MODE
|
||||
1820 STY OLDTEXT+1
|
||||
1830 .1 LDY #0
|
||||
1840 LDA (TXTPTR),Y END OF LINE YET?
|
||||
1850 BNE COLON. NO
|
||||
1860 LDY #2 YES, SEE IF END OF PROGRAM
|
||||
1870 LDA (TXTPTR),Y
|
||||
1880 CLC
|
||||
1890 BEQ GOEND YES, END OF PROGRAM
|
||||
1900 INY
|
||||
1910 LDA (TXTPTR),Y GET LINE # OF NEXT LINE
|
||||
1920 STA CURLIN
|
||||
1930 INY
|
||||
1940 LDA (TXTPTR),Y
|
||||
1950 STA CURLIN+1
|
||||
1960 TYA ADJUST TXTPTR TO START
|
||||
1970 ADC TXTPTR OF NEW LINE
|
||||
1980 STA TXTPTR
|
||||
1990 BCC .2
|
||||
2000 INC TXTPTR+1
|
||||
2010 .2
|
||||
2020 *--------------------------------
|
||||
2030 TRACE. BIT TRCFLG IS TRACE ON?
|
||||
2040 BPL .1 NO
|
||||
2050 LDX CURLIN+1 YES, ARE WE RUNNING?
|
||||
2060 INX
|
||||
2070 BEQ .1 NOT RUNNING, SO DON'T TRACE
|
||||
2080 LDA #'#' PRINT "#"
|
||||
2090 JSR OUTDO
|
||||
2100 LDX CURLIN
|
||||
2110 LDA CURLIN+1
|
||||
2120 JSR LINPRT PRINT LINE NUMBER
|
||||
2130 JSR OUTSP PRINT TRAILING SPACE
|
||||
2140 .1 JSR CHRGET GET FIRST CHR OF STATEMENT
|
||||
2150 JSR EXECUTE.STATEMENT AND START PROCESSING
|
||||
2160 JMP NEWSTT BACK FOR MORE
|
||||
2170 *--------------------------------
|
||||
2180 GOEND BEQ END4
|
||||
2190 *--------------------------------
|
||||
2200 * EXECUTE A STATEMENT
|
||||
2210 *
|
||||
2220 * (A) IS FIRST CHAR OF STATEMENT
|
||||
2230 * CARRY IS SET
|
||||
2240 *--------------------------------
|
||||
2250 EXECUTE.STATEMENT
|
||||
2260 BEQ RTS.3 END OF LINE, NULL STATEMENT
|
||||
2270 EXECUTE.STATEMENT.1
|
||||
2280 SBC #$80 FIRST CHAR A TOKEN?
|
||||
2290 BCC .1 NOT TOKEN, MUST BE "LET"
|
||||
2300 CMP #$40 STATEMENT-TYPE TOKEN?
|
||||
2310 BCS SYNERR.1 NO, SYNTAX ERROR
|
||||
2320 ASL DOUBLE TO GET INDEX
|
||||
2330 TAY INTO ADDRESS TABLE
|
||||
2340 LDA TOKEN.ADDRESS.TABLE+1,Y
|
||||
2350 PHA PUT ADDRESS ON STACK
|
||||
2360 LDA TOKEN.ADDRESS.TABLE,Y
|
||||
2370 PHA
|
||||
2380 JMP CHRGET GET NEXT CHR & RTS TO ROUTINE
|
||||
2390 *--------------------------------
|
||||
2400 .1 JMP LET MUST BE <VAR> = <EXP>
|
||||
2410 *--------------------------------
|
||||
2420 COLON. CMP #':'
|
||||
2430 BEQ TRACE.
|
||||
2440 SYNERR.1 JMP SYNERR
|
||||
2450 *--------------------------------
|
||||
2460 * "RESTORE" STATEMENT
|
||||
2470 *--------------------------------
|
||||
2480 RESTORE
|
||||
2490 SEC SET DATPTR TO BEGINNING OF PROGRAM
|
||||
2500 LDA TXTTAB
|
||||
2510 SBC #1
|
||||
2520 LDY TXTTAB+1
|
||||
2530 BCS SETDA
|
||||
2540 DEY
|
||||
2550 *---SET DATPTR TO Y,A------------
|
||||
2560 SETDA STA DATPTR
|
||||
2570 STY DATPTR+1
|
||||
2580 RTS.3 RTS
|
||||
2590 *--------------------------------
|
||||
2600 * SEE IF CONTROL-C TYPED
|
||||
2610 *--------------------------------
|
||||
2620 ISCNTC LDA KEYBOARD
|
||||
2630 CMP #$83
|
||||
2640 BEQ .1
|
||||
2650 RTS
|
||||
2660 .1 JSR INCHR <<< SHOULD BE "BIT $C010" >>>
|
||||
2670 CONTROL.C.TYPED
|
||||
2680 LDX #$FF CONTROL C ATTEMPTED
|
||||
2690 BIT ERRFLG "ON ERR" ENABLED?
|
||||
2700 BPL .2 NO
|
||||
2710 JMP HANDLERR YES, RETURN ERR CODE = 255
|
||||
2720 .2 CMP #3 SINCE IT IS CTRL-C, SET Z AND C BITS
|
||||
2730 *--------------------------------
|
||||
2740 * "STOP" STATEMENT
|
||||
2750 *--------------------------------
|
||||
2760 STOP BCS END2 CARRY=1 TO FORCE PRINTING "BREAK AT.."
|
||||
2770 *--------------------------------
|
||||
2780 * "END" STATEMENT
|
||||
2790 *--------------------------------
|
||||
2800 END CLC CARRY=0 TO AVOID PRINTING MESSAGE
|
||||
2810 END2 BNE RTS.4 IF NOT END OF STATEMENT, DO NOTHING
|
||||
2820 LDA TXTPTR
|
||||
2830 LDY TXTPTR+1
|
||||
2840 LDX CURLIN+1
|
||||
2850 INX RUNNING?
|
||||
2860 BEQ .1 NO, DIRECT MODE
|
||||
2870 STA OLDTEXT
|
||||
2880 STY OLDTEXT+1
|
||||
2890 LDA CURLIN
|
||||
2900 LDY CURLIN+1
|
||||
2910 STA OLDLIN
|
||||
2920 STY OLDLIN+1
|
||||
2930 .1 PLA
|
||||
2940 PLA
|
||||
2950 END4 LDA #QT.BREAK " BREAK" AND BELL
|
||||
2960 LDY /QT.BREAK
|
||||
2970 BCC .1
|
||||
2980 JMP PRINT.ERROR.LINNUM
|
||||
2990 .1 JMP RESTART
|
||||
3000 *--------------------------------
|
||||
3010 * "CONT" COMMAND
|
||||
3020 *--------------------------------
|
||||
3030 CONT BNE RTS.4 IF NOT END OF STATEMENT, DO NOTHING
|
||||
3040 LDX #ERR.CANTCONT
|
||||
3050 LDY OLDTEXT+1 MEANINGFUL RE-ENTRY?
|
||||
3060 BNE .1 YES
|
||||
3070 JMP ERROR NO
|
||||
3080 .1 LDA OLDTEXT RESTORE TXTPTR
|
||||
3090 STA TXTPTR
|
||||
3100 STY TXTPTR+1
|
||||
3110 LDA OLDLIN RESTORE LINE NUMBER
|
||||
3120 LDY OLDLIN+1
|
||||
3130 STA CURLIN
|
||||
3140 STY CURLIN+1
|
||||
3150 RTS.4 RTS
|
||||
3160 *--------------------------------
|
||||
3170 * "SAVE" COMMAND
|
||||
3180 * WRITES PROGRAM ON CASSETTE TAPE
|
||||
3190 *--------------------------------
|
||||
3200 SAVE SEC
|
||||
3210 LDA PRGEND COMPUTE PROGRAM LENGTH
|
||||
3220 SBC TXTTAB
|
||||
3230 STA LINNUM
|
||||
3240 LDA PRGEND+1
|
||||
3250 SBC TXTTAB+1
|
||||
3260 STA LINNUM+1
|
||||
3270 JSR VARTIO SET UP TO WRITE 3 BYTE HEADER
|
||||
3280 JSR MON.WRITE WRITE 'EM
|
||||
3290 JSR PROGIO SET UP TO WRITE THE PROGRAM
|
||||
3300 JMP MON.WRITE WRITE IT
|
||||
3310 *--------------------------------
|
||||
3320 * "LOAD" COMMAND
|
||||
3330 * READS A PROGRAM FROM CASSETTE TAPE
|
||||
3340 *--------------------------------
|
||||
3350 LOAD JSR VARTIO SET UP TO READ 3 BYTE HEADER
|
||||
3360 JSR MON.READ READ LENGTH, LOCK BYTE
|
||||
3370 CLC
|
||||
3380 LDA TXTTAB COMPUTE END ADDRESS
|
||||
3390 ADC LINNUM
|
||||
3400 STA VARTAB
|
||||
3410 LDA TXTTAB+1
|
||||
3420 ADC LINNUM+1
|
||||
3430 STA VARTAB+1
|
||||
3440 LDA TEMPPT LOCK BYTE
|
||||
3450 STA LOCK
|
||||
3460 JSR PROGIO SET UP TO READ PROGRAM
|
||||
3470 JSR MON.READ READ IT
|
||||
3480 BIT LOCK IF LOCKED, START RUNNING NOW
|
||||
3490 BPL .1 NOT LOCKED
|
||||
3500 JMP SETPTRS LOCKED, START RUNNING
|
||||
3510 .1 JMP FIX.LINKS JUST FIX FORWARD POINTERS
|
||||
3520 *--------------------------------
|
||||
3530 VARTIO LDA #LINNUM SET UP TO READ/WRITE 3 BYTE HEADER
|
||||
3540 LDY #0
|
||||
3550 STA MON.A1L
|
||||
3560 STY MON.A1H
|
||||
3570 LDA #TEMPPT
|
||||
3580 STA MON.A2L
|
||||
3590 STY MON.A2H
|
||||
3600 STY LOCK
|
||||
3610 RTS
|
||||
3620 *--------------------------------
|
||||
3630 PROGIO LDA TXTTAB SET UP TO READ/WRITE PROGRAM
|
||||
3640 LDY TXTTAB+1
|
||||
3650 STA MON.A1L
|
||||
3660 STY MON.A1H
|
||||
3670 LDA VARTAB
|
||||
3680 LDY VARTAB+1
|
||||
3690 STA MON.A2L
|
||||
3700 STY MON.A2H
|
||||
3710 RTS
|
||||
3720 *--------------------------------
|
||||
312
source/applesoft/S.D912
Normal file
312
source/applesoft/S.D912
Normal file
@ -0,0 +1,312 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "RUN" COMMAND
|
||||
1030 *--------------------------------
|
||||
1040 RUN PHP SAVE STATUS WHILE SUBTRACTING
|
||||
1050 DEC CURLIN+1 IF WAS $FF (MEANING DIRECT MODE)
|
||||
1060 * MAKE IT "RUNNING MODE"
|
||||
1070 PLP GET STATUS AGAIN (FROM CHRGET)
|
||||
1080 BNE .1 PROBABLY A LINE NUMBER
|
||||
1090 JMP SETPTRS START AT BEGINNING OF PROGRAM
|
||||
1100 .1 JSR CLEARC CLEAR VARIABLES
|
||||
1110 JMP GO.TO.LINE JOIN GOSUB STATEMENT
|
||||
1120 *--------------------------------
|
||||
1130 * "GOSUB" STATEMENT
|
||||
1140 *
|
||||
1150 * LEAVES 7 BYTES ON STACK:
|
||||
1160 * 2 -- RETURN ADDRESS (NEWSTT)
|
||||
1170 * 2 -- TXTPTR
|
||||
1180 * 2 -- LINE #
|
||||
1190 * 1 -- GOSUB TOKEN ($B0)
|
||||
1200 *--------------------------------
|
||||
1210 GOSUB LDA #3 BE SURE ENOUGH ROOM ON STACK
|
||||
1220 JSR CHKMEM
|
||||
1230 LDA TXTPTR+1
|
||||
1240 PHA
|
||||
1250 LDA TXTPTR
|
||||
1260 PHA
|
||||
1270 LDA CURLIN+1
|
||||
1280 PHA
|
||||
1290 LDA CURLIN
|
||||
1300 PHA
|
||||
1310 LDA #TOKEN.GOSUB
|
||||
1320 PHA
|
||||
1330 GO.TO.LINE
|
||||
1340 JSR CHRGOT
|
||||
1350 JSR GOTO
|
||||
1360 JMP NEWSTT
|
||||
1370 *--------------------------------
|
||||
1380 * "GOTO" STATEMENT
|
||||
1390 * ALSO USED BY "RUN" AND "GOSUB"
|
||||
1400 *--------------------------------
|
||||
1410 GOTO JSR LINGET GET GOTO LINE
|
||||
1420 JSR REMN POINT Y TO EOL
|
||||
1430 LDA CURLIN+1 IS CURRENT PAGE < GOTO PAGE?
|
||||
1440 CMP LINNUM+1
|
||||
1450 BCS .1 SEARCH FROM PROG START IF NOT
|
||||
1460 TYA OTHERWISE SEARCH FROM NEXT LINE
|
||||
1470 SEC
|
||||
1480 ADC TXTPTR
|
||||
1490 LDX TXTPTR+1
|
||||
1500 BCC .2
|
||||
1510 INX
|
||||
1520 BCS .2
|
||||
1530 .1 LDA TXTTAB GET PROGRAM BEGINNING
|
||||
1540 LDX TXTTAB+1
|
||||
1550 .2 JSR FL1 SEARCH FOR GOTO LINE
|
||||
1560 BCC UNDERR ERROR IF NOT THERE
|
||||
1570 LDA LOWTR TXTPTR = START OF THE DESTINATION LINE
|
||||
1580 SBC #1
|
||||
1590 STA TXTPTR
|
||||
1600 LDA LOWTR+1
|
||||
1610 SBC #0
|
||||
1620 STA TXTPTR+1
|
||||
1630 RTS.5 RTS RETURN TO NEWSTT OR GOSUB
|
||||
1640 *--------------------------------
|
||||
1650 * "POP" AND "RETURN" STATEMENTS
|
||||
1660 *--------------------------------
|
||||
1670 POP BNE RTS.5
|
||||
1680 LDA #$FF
|
||||
1690 STA FORPNT <<< BUG: SHOULD BE FORPNT+1 >>>
|
||||
1700 * <<< SEE "ALL ABOUT APPLESOFT", PAGES 100,101 >>>
|
||||
1710 JSR GTFORPNT TO CANCEL FOR/NEXT IN SUB
|
||||
1720 TXS
|
||||
1730 CMP #TOKEN.GOSUB LAST GOSUB FOUND?
|
||||
1740 BEQ RETURN
|
||||
1750 LDX #ERR.NOGOSUB
|
||||
1760 .HS 2C FAKE
|
||||
1770 UNDERR LDX #ERR.UNDEFSTAT
|
||||
1780 JMP ERROR
|
||||
1790 *--------------------------------
|
||||
1800 SYNERR.2 JMP SYNERR
|
||||
1810 *--------------------------------
|
||||
1820 RETURN PLA DISCARD GOSUB TOKEN
|
||||
1830 PLA
|
||||
1840 CPY #TOKEN.POP*2
|
||||
1850 BEQ PULL3 BRANCH IF A POP
|
||||
1860 STA CURLIN PULL LINE #
|
||||
1870 PLA
|
||||
1880 STA CURLIN+1
|
||||
1890 PLA
|
||||
1900 STA TXTPTR PULL TXTPTR
|
||||
1910 PLA
|
||||
1920 STA TXTPTR+1
|
||||
1930 *--------------------------------
|
||||
1940 * "DATA" STATEMENT
|
||||
1950 * EXECUTED BY SKIPPING TO NEXT COLON OR EOL
|
||||
1960 *--------------------------------
|
||||
1970 DATA JSR DATAN MOVE TO NEXT STATEMENT
|
||||
1980 *--------------------------------
|
||||
1990 * ADD (Y) TO TXTPTR
|
||||
2000 *--------------------------------
|
||||
2010 ADDON TYA
|
||||
2020 CLC
|
||||
2030 ADC TXTPTR
|
||||
2040 STA TXTPTR
|
||||
2050 BCC .1
|
||||
2060 INC TXTPTR+1
|
||||
2070 .1
|
||||
2080 RTS.6 RTS
|
||||
2090 *--------------------------------
|
||||
2100 * SCAN AHEAD TO NEXT ":" OR EOL
|
||||
2110 *--------------------------------
|
||||
2120 DATAN LDX #':' GET OFFSET IN Y TO EOL OR ":"
|
||||
2130 .HS 2C FAKE
|
||||
2140 *--------------------------------
|
||||
2150 REMN LDX #0 TO EOL ONLY
|
||||
2160 STX CHARAC
|
||||
2170 LDY #0
|
||||
2180 STY ENDCHR
|
||||
2190 .1 LDA ENDCHR TRICK TO COUNT QUOTE PARITY
|
||||
2200 LDX CHARAC
|
||||
2210 STA CHARAC
|
||||
2220 STX ENDCHR
|
||||
2230 .2 LDA (TXTPTR),Y
|
||||
2240 BEQ RTS.6 END OF LINE
|
||||
2250 CMP ENDCHR
|
||||
2260 BEQ RTS.6 COLON IF LOOKING FOR COLONS
|
||||
2270 INY
|
||||
2280 CMP #'"'
|
||||
2290 BNE .2
|
||||
2300 BEQ .1 ...ALWAYS
|
||||
2310 *--------------------------------
|
||||
2320 PULL3 PLA
|
||||
2330 PLA
|
||||
2340 PLA
|
||||
2350 RTS
|
||||
2360 *--------------------------------
|
||||
2370 * "IF" STATEMENT
|
||||
2380 *--------------------------------
|
||||
2390 IF JSR FRMEVL
|
||||
2400 JSR CHRGOT
|
||||
2410 CMP #TOKEN.GOTO
|
||||
2420 BEQ .1
|
||||
2430 LDA #TOKEN.THEN
|
||||
2440 JSR SYNCHR
|
||||
2450 .1 LDA FAC CONDITION TRUE OR FALSE?
|
||||
2460 BNE IF.TRUE BRANCH IF TRUE
|
||||
2470 *--------------------------------
|
||||
2480 * "REM" STATEMENT, OR FALSE "IF" STATEMENT
|
||||
2490 *--------------------------------
|
||||
2500 REM JSR REMN SKIP REST OF LINE
|
||||
2510 BEQ ADDON ...ALWAYS
|
||||
2520 *--------------------------------
|
||||
2530 IF.TRUE
|
||||
2540 JSR CHRGOT COMMAND OR NUMBER?
|
||||
2550 BCS .1 COMMAND
|
||||
2560 JMP GOTO NUMBER
|
||||
2570 .1 JMP EXECUTE.STATEMENT
|
||||
2580 *--------------------------------
|
||||
2590 * "ON" STATEMENT
|
||||
2600 *
|
||||
2610 * ON <EXP> GOTO <LIST>
|
||||
2620 * ON <EXP> GOSUB <LIST>
|
||||
2630 *--------------------------------
|
||||
2640 ONGOTO JSR GETBYT EVALUATE <EXP>, AS BYTE IN FAC+4
|
||||
2650 PHA SAVE NEXT CHAR ON STACK
|
||||
2660 CMP #TOKEN.GOSUB
|
||||
2670 BEQ ON.2
|
||||
2680 ON.1 CMP #TOKEN.GOTO
|
||||
2690 BNE SYNERR.2
|
||||
2700 ON.2 DEC FAC+4 COUNTED TO RIGHT ONE YET?
|
||||
2710 BNE .3 NO, KEEP LOOKING
|
||||
2720 PLA YES, RETRIEVE CMD
|
||||
2730 JMP EXECUTE.STATEMENT.1 AND GO.
|
||||
2740 .3 JSR CHRGET PRIME CONVERT SUBROUTINE
|
||||
2750 JSR LINGET CONVERT LINE #
|
||||
2760 CMP #',' TERMINATE WITH COMMA?
|
||||
2770 BEQ ON.2 YES
|
||||
2780 PLA NO, END OF LIST, SO IGNORE
|
||||
2790 RTS.7 RTS
|
||||
2800 *--------------------------------
|
||||
2810 * CONVERT LINE NUMBER
|
||||
2820 *--------------------------------
|
||||
2830 LINGET LDX #0 ASC # TO HEX ADDRESS
|
||||
2840 STX LINNUM IN LINNUM.
|
||||
2850 STX LINNUM+1
|
||||
2860 .1 BCS RTS.7 NOT A DIGIT
|
||||
2870 SBC #'0'-1 CONVERT DIGIT TO BINARY
|
||||
2880 STA CHARAC SAVE THE DIGIT
|
||||
2890 LDA LINNUM+1 CHECK RANGE
|
||||
2900 STA INDEX
|
||||
2910 CMP /6400 LINE # TOO LARGE?
|
||||
2920 BCS ON.1 YES, > 63999, GO INDIRECTLY TO
|
||||
2930 * "SYNTAX ERROR".
|
||||
2940 *<<<<<DANGEROUS CODE>>>>>
|
||||
2950 * NOTE THAT IF (A) = $AB ON THE LINE ABOVE,
|
||||
2960 * ON.1 WILL COMPARE = AND CAUSE A CATASTROPHIC
|
||||
2970 * JUMP TO $22D9 (FOR GOTO), OR OTHER LOCATIONS
|
||||
2980 * FOR OTHER CALLS TO LINGET.
|
||||
2990 *
|
||||
3000 * YOU CAN SEE THIS IS YOU FIRST PUT "BRK" IN $22D9,
|
||||
3010 * THEN TYPE "GO TO 437761".
|
||||
3020 *
|
||||
3030 * ANY VALUE FROM 437760 THROUGH 440319 WILL CAUSE
|
||||
3040 * THE PROBLEM. ($AB00 - $ABFF)
|
||||
3050 *<<<<<DANGEROUS CODE>>>>>
|
||||
3060 LDA LINNUM MULTIPLY BY TEN
|
||||
3070 ASL
|
||||
3080 ROL INDEX
|
||||
3090 ASL
|
||||
3100 ROL INDEX
|
||||
3110 ADC LINNUM
|
||||
3120 STA LINNUM
|
||||
3130 LDA INDEX
|
||||
3140 ADC LINNUM+1
|
||||
3150 STA LINNUM+1
|
||||
3160 ASL LINNUM
|
||||
3170 ROL LINNUM+1
|
||||
3180 LDA LINNUM
|
||||
3190 ADC CHARAC ADD DIGIT
|
||||
3200 STA LINNUM
|
||||
3210 BCC .2
|
||||
3220 INC LINNUM+1
|
||||
3230 .2 JSR CHRGET GET NEXT CHAR
|
||||
3240 JMP .1 MORE CONVERTING
|
||||
3250 *--------------------------------
|
||||
3260 * "LET" STATEMENT
|
||||
3270 *
|
||||
3280 * LET <VAR> = <EXP>
|
||||
3290 * <VAR> = <EXP>
|
||||
3300 *--------------------------------
|
||||
3310 LET JSR PTRGET GET <VAR>
|
||||
3320 STA FORPNT
|
||||
3330 STY FORPNT+1
|
||||
3340 LDA #TOKEN.EQUAL
|
||||
3350 JSR SYNCHR
|
||||
3360 LDA VALTYP+1 SAVE VARIABLE TYPE
|
||||
3370 PHA
|
||||
3380 LDA VALTYP
|
||||
3390 PHA
|
||||
3400 JSR FRMEVL EVALUATE <EXP>
|
||||
3410 PLA
|
||||
3420 ROL
|
||||
3430 JSR CHKVAL
|
||||
3440 BNE LET.STRING
|
||||
3450 PLA
|
||||
3460 *--------------------------------
|
||||
3470 LET2 BPL .1 REAL VARIABLE
|
||||
3480 JSR ROUND.FAC INTEGER VAR: ROUND TO 32 BITS
|
||||
3490 JSR AYINT TRUNCATE TO 16-BITS
|
||||
3500 LDY #0
|
||||
3510 LDA FAC+3
|
||||
3520 STA (FORPNT),Y
|
||||
3530 INY
|
||||
3540 LDA FAC+4
|
||||
3550 STA (FORPNT),Y
|
||||
3560 RTS
|
||||
3570 *--------------------------------
|
||||
3580 * REAL VARIABLE = EXPRESSION
|
||||
3590 *--------------------------------
|
||||
3600 .1 JMP SETFOR
|
||||
3610 *--------------------------------
|
||||
3620 LET.STRING
|
||||
3630 PLA
|
||||
3640 *--------------------------------
|
||||
3650 * INSTALL STRING, DESCRIPTOR ADDRESS IS AT FAC+3,4
|
||||
3660 *--------------------------------
|
||||
3670 PUTSTR LDY #2 STRING DATA ALREADY IN STRING AREA?
|
||||
3680 LDA (FAC+3),Y (STRING AREA IS BTWN FRETOP
|
||||
3690 CMP FRETOP+1 HIMEM)
|
||||
3700 BCC .2 YES, DATA ALREADY UP THERE
|
||||
3710 BNE .1 NO
|
||||
3720 DEY MAYBE, TEST LOW BYTE OF POINTER
|
||||
3730 LDA (FAC+3),Y
|
||||
3740 CMP FRETOP
|
||||
3750 BCC .2 YES, ALREADY THERE
|
||||
3760 .1 LDY FAC+4 NO. DESCRIPTOR ALREADY AMONG VARIABLES?
|
||||
3770 CPY VARTAB+1
|
||||
3780 BCC .2 NO
|
||||
3790 BNE .3 YES
|
||||
3800 LDA FAC+3 MAYBE, COMPARE LO-BYTE
|
||||
3810 CMP VARTAB
|
||||
3820 BCS .3 YES, DESCRIPTOR IS AMONG VARIABLES
|
||||
3830 .2 LDA FAC+3 EITHER STRING ALREADY ON TOP, OR
|
||||
3840 LDY FAC+4 DESCRIPTOR IS NOT A VARIABLE
|
||||
3850 JMP .4 SO JUST STORE THE DESCRIPTOR
|
||||
3860 *--------------------------------
|
||||
3870 * STRING NOT YET IN STRING AREA,
|
||||
3880 * AND DESCRIPTOR IS A VARIABLE
|
||||
3890 *--------------------------------
|
||||
3900 .3 LDY #0 POINT AT LENGTH IN DESCRIPTOR
|
||||
3910 LDA (FAC+3),Y GET LENGTH
|
||||
3920 JSR STRINI MAKE A STRING THAT LONG UP ABOVE
|
||||
3930 LDA DSCPTR SET UP SOURCE PNTR FOR MONINS
|
||||
3940 LDY DSCPTR+1
|
||||
3950 STA STRNG1
|
||||
3960 STY STRNG1+1
|
||||
3970 JSR MOVINS MOVE STRING DATA TO NEW AREA
|
||||
3980 LDA #FAC ADDRESS OF DESCRIPTOR IS IN FAC
|
||||
3990 LDY /FAC
|
||||
4000 .4 STA DSCPTR
|
||||
4010 STY DSCPTR+1
|
||||
4020 JSR FRETMS DISCARD DESCRIPTOR IF 'TWAS TEMPORARY
|
||||
4030 LDY #0 COPY STRING DESCRIPTOR
|
||||
4040 LDA (DSCPTR),Y
|
||||
4050 STA (FORPNT),Y
|
||||
4060 INY
|
||||
4070 LDA (DSCPTR),Y
|
||||
4080 STA (FORPNT),Y
|
||||
4090 INY
|
||||
4100 LDA (DSCPTR),Y
|
||||
4110 STA (FORPNT),Y
|
||||
4120 RTS
|
||||
339
source/applesoft/S.DACF
Normal file
339
source/applesoft/S.DACF
Normal file
@ -0,0 +1,339 @@
|
||||
1010 *--------------------------------
|
||||
1020 PR.STRING
|
||||
1030 JSR STRPRT
|
||||
1040 JSR CHRGOT
|
||||
1050 *--------------------------------
|
||||
1060 * "PRINT" STATEMENT
|
||||
1070 *--------------------------------
|
||||
1080 PRINT BEQ CRDO NO MORE LIST, PRINT <RETURN>
|
||||
1090 *--------------------------------
|
||||
1100 PRINT2 BEQ RTS.8 NO MORE LIST, DON'T PRINT <RETURN>
|
||||
1110 CMP #TOKEN.TAB
|
||||
1120 BEQ PR.TAB.OR.SPC C=1 FOR TAB(
|
||||
1130 CMP #TOKEN.SPC
|
||||
1140 CLC
|
||||
1150 BEQ PR.TAB.OR.SPC C=0 FOR SPC(
|
||||
1160 CMP #','
|
||||
1170 CLC <<< NO PURPOSE TO THIS >>>
|
||||
1180 BEQ PR.COMMA
|
||||
1190 CMP #';'
|
||||
1200 BEQ PR.NEXT.CHAR
|
||||
1210 JSR FRMEVL EVALUATE EXPRESSION
|
||||
1220 BIT VALTYP STRING OR FP VALUE?
|
||||
1230 BMI PR.STRING STRING
|
||||
1240 JSR FOUT FP: CONVERT INTO BUFFER
|
||||
1250 JSR STRLIT MAKE BUFFER INTO STRING
|
||||
1260 JMP PR.STRING PRINT THE STRING
|
||||
1270 *--------------------------------
|
||||
1280 CRDO LDA #$0D PRINT <RETURN>
|
||||
1290 JSR OUTDO
|
||||
1300 NEGATE EOR #$FF <<< WHY??? >>>
|
||||
1310 RTS.8 RTS
|
||||
1320 *--------------------------------
|
||||
1330 * TAB TO NEXT COMMA COLUMN
|
||||
1340 * <<< NOTE BUG IF WIDTH OF WINDOW LESS THAN 33 >>>
|
||||
1350 PR.COMMA
|
||||
1360 LDA MON.CH
|
||||
1370 CMP #24 <<< BUG: IT SHOULD BE 32 >>>
|
||||
1380 BCC .1 NEXT COLUMN, SAME LINE
|
||||
1390 JSR CRDO FIRST COLUMN, NEXT LINT
|
||||
1400 BNE PR.NEXT.CHAR ...ALWAYS
|
||||
1410 .1 ADC #16
|
||||
1420 AND #$F0 ROUND TO 16 OR 32
|
||||
1430 STA MON.CH
|
||||
1440 BCC PR.NEXT.CHAR ...ALWAYS
|
||||
1450 *--------------------------------
|
||||
1460 PR.TAB.OR.SPC
|
||||
1470 PHP C=0 FOR SPC(, C=1 FOR TAB(
|
||||
1480 JSR GTBYTC GET VALUE
|
||||
1490 CMP #')' TRAILING PARENTHESIS
|
||||
1500 BEQ .1 GOOD
|
||||
1510 JMP SYNERR NO, SYNTAX ERROR
|
||||
1520 .1 PLP TAB( OR SPC(
|
||||
1530 BCC .2 SPC(
|
||||
1540 DEX TAB(
|
||||
1550 TXA CALCULATE SPACES NEEDED FOR TAB(
|
||||
1560 SBC MON.CH
|
||||
1570 BCC PR.NEXT.CHAR ALREADY PAST THAT COLUMN
|
||||
1580 TAX NOW DO A SPC( TO THE SPECIFIED COLUMN
|
||||
1590 .2 INX
|
||||
1600 NXSPC DEX
|
||||
1610 BNE DOSPC MORE SPACES TO PRINT
|
||||
1620 *--------------------------------
|
||||
1630 PR.NEXT.CHAR
|
||||
1640 JSR CHRGET
|
||||
1650 JMP PRINT2 CONTINUE PARSING PRINT LIST
|
||||
1660 *--------------------------------
|
||||
1670 DOSPC JSR OUTSP
|
||||
1680 BNE NXSPC ...ALWAYS
|
||||
1690 *--------------------------------
|
||||
1700 * PRINT STRING AT (Y,A)
|
||||
1710 STROUT JSR STRLIT MAKE (Y,A) PRINTABLE
|
||||
1720 *--------------------------------
|
||||
1730 * PRINT STRING AT (FACMO,FACLO)
|
||||
1740 *--------------------------------
|
||||
1750 STRPRT JSR FREFAC GET ADDRESS INTO INDEX, (A)=LENGTH
|
||||
1760 TAX USE X-REG FOR COUNTER
|
||||
1770 LDY #0 USE Y-REG FOR SCANNER
|
||||
1780 INX
|
||||
1790 .1 DEX
|
||||
1800 BEQ RTS.8 FINISHED
|
||||
1810 LDA (INDEX),Y NEXT CHAR FROM STRING
|
||||
1820 JSR OUTDO PRINT THE CHAR
|
||||
1830 INY
|
||||
1840 * <<< NEXT THREE LINES ARE USELESS >>>
|
||||
1850 CMP #$0D WAS IT <RETURN>?
|
||||
1860 BNE .1 NO
|
||||
1870 JSR NEGATE EOR #$FF WOULD DO IT, BUT WHY?
|
||||
1880 * <<< ABOVE THREE LINES ARE USELESS >>>
|
||||
1890 JMP .1
|
||||
1900 *--------------------------------
|
||||
1910 OUTSP LDA #' ' PRINT A SPACE
|
||||
1920 .HS 2C SKIP OVER NEXT LINE
|
||||
1930 OUTQUES LDA #'?' PRINT QUESTION MARK
|
||||
1940 *--------------------------------
|
||||
1950 * PRINT CHAR FROM (A)
|
||||
1960 *
|
||||
1970 * NOTE: POKE 243,32 ($20 IN $F3) WILL CONVERT
|
||||
1980 * OUTPUT TO LOWER CASE. THIS CAN BE CANCELLED
|
||||
1990 * BY NORMAL, INVERSE, OR FLASH OR POKE 243,0.
|
||||
2000 *--------------------------------
|
||||
2010 OUTDO ORA #$80 PRINT (A)
|
||||
2020 CMP #$A0 CONTROL CHR?
|
||||
2030 BCC .1 SKIP IF SO
|
||||
2040 ORA FLASH.BIT =$40 FOR FLASH, ELSE $00
|
||||
2050 .1 JSR MON.COUT "AND"S WITH $3F (INVERSE), $7F (FLASH)
|
||||
2060 AND #$7F
|
||||
2070 PHA
|
||||
2080 LDA SPEEDZ COMPLEMENT OF SPEED #
|
||||
2090 JSR MON.WAIT SO SPEED=255 BECOMES (A)=1
|
||||
2100 PLA
|
||||
2110 RTS
|
||||
2120 *--------------------------------
|
||||
2130 * INPUT CONVERSION ERROR: ILLEGAL CHARACTER
|
||||
2140 * IN NUMERIC FIELD. MUST DISTINGUISH
|
||||
2150 * BETWEEN INPUT, READ, AND GET
|
||||
2160 *--------------------------------
|
||||
2170 INPUTERR
|
||||
2180 LDA INPUTFLG
|
||||
2190 BEQ RESPERR TAKEN IF INPUT
|
||||
2200 BMI READERR TAKEN IF READ
|
||||
2210 LDY #$FF FROM A GET
|
||||
2220 BNE ERLIN ...ALWAYS
|
||||
2230 *--------------------------------
|
||||
2240 READERR
|
||||
2250 LDA DATLIN TELL WHERE THE "DATA" IS, RATHER
|
||||
2260 LDY DATLIN+1 THAN THE "READ"
|
||||
2270 *--------------------------------
|
||||
2280 ERLIN STA CURLIN
|
||||
2290 STY CURLIN+1
|
||||
2300 JMP SYNERR
|
||||
2310 *--------------------------------
|
||||
2320 INPERR PLA
|
||||
2330 *--------------------------------
|
||||
2340 RESPERR
|
||||
2350 BIT ERRFLG "ON ERR" TURNED ON?
|
||||
2360 BPL .1 NO, GIVE REENTRY A TRY
|
||||
2370 LDX #254 ERROR CODE = 254
|
||||
2380 JMP HANDLERR
|
||||
2390 .1 LDA #ERR.REENTRY "?REENTER"
|
||||
2400 LDY /ERR.REENTRY
|
||||
2410 JSR STROUT
|
||||
2420 LDA OLDTEXT RE-EXECUTE THE WHOLE INPUT STATEMENT
|
||||
2430 LDY OLDTEXT+1
|
||||
2440 STA TXTPTR
|
||||
2450 STY TXTPTR+1
|
||||
2460 RTS
|
||||
2470 *--------------------------------
|
||||
2480 * "GET" STATEMENT
|
||||
2490 *--------------------------------
|
||||
2500 GET JSR ERRDIR ILLEGAL IF IN DIRECT MODE
|
||||
2510 LDX #INPUT.BUFFER+1 SIMULATE INPUT
|
||||
2520 LDY /INPUT.BUFFER+1
|
||||
2530 LDA #0
|
||||
2540 STA INPUT.BUFFER+1
|
||||
2550 LDA #$40 SET UP INPUTFLG
|
||||
2560 JSR PROCESS.INPUT.LIST <<< CAN SAVE 1 BYTE HERE>>>
|
||||
2570 RTS <<<BY "JMP PROCESS.INPUT.LIST">>>
|
||||
2580 *--------------------------------
|
||||
2590 * "INPUT" STATEMENT
|
||||
2600 *--------------------------------
|
||||
2610 INPUT CMP #'"' CHECK FOR OPTIONAL PROMPT STRING
|
||||
2620 BNE .1 NO, PRINT "?" PROMPT
|
||||
2630 JSR STRTXT MAKE A PRINTABLE STRING OUT OF IT
|
||||
2640 LDA #';' MUST HAVE ; NOW
|
||||
2650 JSR SYNCHR
|
||||
2660 JSR STRPRT PRINT THE STRING
|
||||
2670 JMP .2
|
||||
2680 .1 JSR OUTQUES NO STRING, PRINT "?"
|
||||
2690 .2 JSR ERRDIR ILLEGAL IF IN DIRECT MODE
|
||||
2700 LDA #',' PRIME THE BUFFER
|
||||
2710 STA INPUT.BUFFER-1
|
||||
2720 JSR INLIN
|
||||
2730 LDA INPUT.BUFFER
|
||||
2740 CMP #$03 CONTROL C?
|
||||
2750 BNE INPUT.FLAG.ZERO NO
|
||||
2760 JMP CONTROL.C.TYPED
|
||||
2770 *--------------------------------
|
||||
2780 NXIN JSR OUTQUES PRINT "?"
|
||||
2790 JMP INLIN
|
||||
2800 *--------------------------------
|
||||
2810 * "READ" STATEMENT
|
||||
2820 *--------------------------------
|
||||
2830 READ LDX DATPTR Y,X POINTS AT NEXT DATA STATEMENT
|
||||
2840 LDY DATPTR+1
|
||||
2850 LDA #$98 SET INPUTFLG = $98
|
||||
2860 .HS 2C TRICK TO PROCESS.INPUT.LIST
|
||||
2870 *--------------------------------
|
||||
2880 INPUT.FLAG.ZERO
|
||||
2890 LDA #0 SET INPUTFLG = $00
|
||||
2900 *--------------------------------
|
||||
2910 * PROCESS INPUT LIST
|
||||
2920 *
|
||||
2930 * (Y,X) IS ADDRESS OF INPUT DATA STRING
|
||||
2940 * (A) = VALUE FOR INPUTFLG: $00 FOR INPUT
|
||||
2950 * $40 FOR GET
|
||||
2960 * $98 FOR READ
|
||||
2970 *--------------------------------
|
||||
2980 PROCESS.INPUT.LIST
|
||||
2990 STA INPUTFLG
|
||||
3000 STX INPTR ADDRESS OF INPUT STRING
|
||||
3010 STY INPTR+1
|
||||
3020 *--------------------------------
|
||||
3030 PROCESS.INPUT.ITEM
|
||||
3040 JSR PTRGET GET ADDRESS OF VARIABLE
|
||||
3050 STA FORPNT
|
||||
3060 STY FORPNT+1
|
||||
3070 LDA TXTPTR SAVE CURRENT TXTPTR,
|
||||
3080 LDY TXTPTR+1 WHICH POINTS INTO PROGRAM
|
||||
3090 STA TXPSV
|
||||
3100 STY TXPSV+1
|
||||
3110 LDX INPTR SET TXTPTR TO POINT AT INPUT BUFFER
|
||||
3120 LDY INPTR+1 OR "DATA" LINE
|
||||
3130 STX TXTPTR
|
||||
3140 STY TXTPTR+1
|
||||
3150 JSR CHRGOT GET CHAR AT PNTR
|
||||
3160 BNE INSTART NOT END OF LINE OR COLON
|
||||
3170 BIT INPUTFLG DOING A "GET"?
|
||||
3180 BVC .1 NO
|
||||
3190 JSR MON.RDKEY YES, GET CHAR
|
||||
3200 AND #$7F
|
||||
3210 STA INPUT.BUFFER
|
||||
3220 LDX #INPUT.BUFFER-1
|
||||
3230 LDY /INPUT.BUFFER-1
|
||||
3240 BNE .2 ...ALWAYS
|
||||
3250 *--------------------------------
|
||||
3260 .1 BMI FINDATA DOING A "READ"
|
||||
3270 JSR OUTQUES DOING AN "INPUT", PRINT "?"
|
||||
3280 JSR NXIN PRINT ANOTHER "?", AND INPUT A LINE
|
||||
3290 .2 STX TXTPTR
|
||||
3300 STY TXTPTR+1
|
||||
3310 *--------------------------------
|
||||
3320 INSTART
|
||||
3330 JSR CHRGET GET NEXT INPUT CHAR
|
||||
3340 BIT VALTYP STRING OR NUMERIC?
|
||||
3350 BPL .5 NUMERIC
|
||||
3360 BIT INPUTFLG STRING -- NOW WHAT INPUT TYPE?
|
||||
3370 BVC .1 NOT A "GET"
|
||||
3380 INX "GET"
|
||||
3390 STX TXTPTR
|
||||
3400 LDA #0
|
||||
3410 STA CHARAC NO OTHER TERMINATORS THAN $00
|
||||
3420 BEQ .2 ...ALWAYS
|
||||
3430 *--------------------------------
|
||||
3440 .1 STA CHARAC
|
||||
3450 CMP #'"' TERMINATE ON $00 OR QUOTE
|
||||
3460 BEQ .3
|
||||
3470 LDA #':' TERMINATE ON $00, COLON, OR COMMA
|
||||
3480 STA CHARAC
|
||||
3490 LDA #','
|
||||
3500 .2 CLC
|
||||
3510 .3 STA ENDCHR
|
||||
3520 LDA TXTPTR
|
||||
3530 LDY TXTPTR+1
|
||||
3540 ADC #0 SKIP OVER QUOTATION MARK, IF
|
||||
3550 BCC .4 THERE WAS ONE
|
||||
3560 INY
|
||||
3570 .4 JSR STRLT2 BUILD STRING STARTING AT (Y,A)
|
||||
3580 * TERMINATED BY $00, (CHARAC), OR (ENDCHR)
|
||||
3590 JSR POINT SET TXTPTR TO POINT AT STRING
|
||||
3600 JSR PUTSTR STORE STRING IN VARIABLE
|
||||
3610 JMP INPUT.MORE
|
||||
3620 *--------------------------------
|
||||
3630 .5 PHA
|
||||
3640 LDA INPUT.BUFFER ANYTHING IN BUFFER?
|
||||
3650 BEQ INPFIN NO, SEE IF READ OR INPUT
|
||||
3660 *--------------------------------
|
||||
3670 INPUT.DATA
|
||||
3680 PLA "READ"
|
||||
3690 JSR FIN GET FP NUMBER AT TXTPTR
|
||||
3700 LDA VALTYP+1
|
||||
3710 JSR LET2 STORE RESULT IN VARIABLE
|
||||
3720 *--------------------------------
|
||||
3730 INPUT.MORE
|
||||
3740 JSR CHRGOT
|
||||
3750 BEQ .1 END OF LINE OR COLON
|
||||
3760 CMP #',' COMMA IN INPUT?
|
||||
3770 BEQ .1 YES
|
||||
3780 JMP INPUTERR NOTHING ELSE WILL DO
|
||||
3790 .1 LDA TXTPTR SAVE POSITION IN INPUT BUFFER
|
||||
3800 LDY TXTPTR+1
|
||||
3810 STA INPTR
|
||||
3820 STY INPTR+1
|
||||
3830 LDA TXPSV RESTORE PROGRAM POINTER
|
||||
3840 LDY TXPSV+1
|
||||
3850 STA TXTPTR
|
||||
3860 STY TXTPTR+1
|
||||
3870 JSR CHRGOT NEXT CHAR FROM PROGRAM
|
||||
3880 BEQ INPDONE END OF STATEMENT
|
||||
3890 JSR CHKCOM BETTER BE A COMMA THEN
|
||||
3900 JMP PROCESS.INPUT.ITEM
|
||||
3910 *--------------------------------
|
||||
3920 INPFIN LDA INPUTFLG "INPUT" OR "READ"
|
||||
3930 BNE INPUT.DATA "READ"
|
||||
3940 JMP INPERR
|
||||
3950 *--------------------------------
|
||||
3960 FINDATA
|
||||
3970 JSR DATAN GET OFFSET TO NEXT COLON OR EOL
|
||||
3980 INY TO FIRST CHAR OF NEXT LINE
|
||||
3990 TAX WHICH: EOL OR COLON?
|
||||
4000 BNE .1 COLON
|
||||
4010 LDX #ERR.NODATA EOL: MIGHT BE OUT OF DATA
|
||||
4020 INY CHECK HI-BYTE OF FORWARD PNTR
|
||||
4030 LDA (TXTPTR),Y END OF PROGRAM?
|
||||
4040 BEQ GERR YES, WE ARE OUT OF DATA
|
||||
4050 INY PICK UP THE LINE #
|
||||
4060 LDA (TXTPTR),Y
|
||||
4070 STA DATLIN
|
||||
4080 INY
|
||||
4090 LDA (TXTPTR),Y
|
||||
4100 INY POINT AT FIRST TEXT CHAR IN LINE
|
||||
4110 STA DATLIN+1
|
||||
4120 .1 LDA (TXTPTR),Y GET 1ST TOKEN OF STATEMENT
|
||||
4130 TAX SAVE TOKEN IN X-REG
|
||||
4140 JSR ADDON ADD (Y) TO TXTPTR
|
||||
4150 CPX #TOKEN.DATA DID WE FIND A "DATA" STATEMENT?
|
||||
4160 BNE FINDATA NOT YET
|
||||
4170 JMP INSTART YES, READ IT
|
||||
4180 *---NO MORE INPUT REQUESTED------
|
||||
4190 INPDONE
|
||||
4200 LDA INPTR GET POINTER IN CASE IT WAS "READ"
|
||||
4210 LDY INPTR+1
|
||||
4220 LDX INPUTFLG "READ" OR "INPUT"?
|
||||
4230 BPL .1 "INPUT"
|
||||
4240 JMP SETDA "DATA", SO STORE (Y,X) AT DATPTR
|
||||
4250 .1 LDY #0 "INPUT": ANY MORE CHARS ON LINE?
|
||||
4260 LDA (INPTR),Y
|
||||
4270 BEQ .2 NO, ALL IS WELL
|
||||
4280 LDA #ERR.EXTRA YES, ERROR
|
||||
4290 LDY /ERR.EXTRA "EXTRA IGNORED"
|
||||
4300 JMP STROUT
|
||||
4310 .2 RTS
|
||||
4320 *--------------------------------
|
||||
4330 ERR.EXTRA
|
||||
4340 .AS '?EXTRA IGNORED'
|
||||
4350 .HS 0D00
|
||||
4360 ERR.REENTRY
|
||||
4370 .AS '?REENTER'
|
||||
4380 .HS 0D00
|
||||
4390 *--------------------------------
|
||||
85
source/applesoft/S.DCF9
Normal file
85
source/applesoft/S.DCF9
Normal file
@ -0,0 +1,85 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "NEXT" STATEMENT
|
||||
1030 *--------------------------------
|
||||
1040 NEXT BNE NEXT.1 VARIABLE AFTER "NEXT"
|
||||
1050 LDY #0 FLAG BY SETTING FORPNT+1 = 0
|
||||
1060 BEQ NEXT.2 ...ALWAYS
|
||||
1070 *--------------------------------
|
||||
1080 NEXT.1 JSR PTRGET GET PNTR TO VARIABLE IN (Y,A)
|
||||
1090 NEXT.2 STA FORPNT
|
||||
1100 STY FORPNT+1
|
||||
1110 JSR GTFORPNT FIND FOR-FRAME FOR THIS VARIABLE
|
||||
1120 BEQ NEXT.3 FOUND IT
|
||||
1130 LDX #ERR.NOFOR NOT THERE, ABORT
|
||||
1140 GERR BEQ JERROR ...ALWAYS
|
||||
1150 NEXT.3 TXS SET STACK PTR TO POINT TO THIS FRAME,
|
||||
1160 INX WHICH TRIMS OFF ANY INNER LOOPS
|
||||
1170 INX
|
||||
1180 INX
|
||||
1190 INX
|
||||
1200 TXA LOW BYTE OF ADRS OF STEP VALUE
|
||||
1210 INX
|
||||
1220 INX
|
||||
1230 INX
|
||||
1240 INX
|
||||
1250 INX
|
||||
1260 INX
|
||||
1270 STX DEST LOW BYTE ADRS OF FOR VAR VALUE
|
||||
1280 LDY /STACK (Y,A) IS ADDRESS OF STEP VALUE
|
||||
1290 JSR LOAD.FAC.FROM.YA STEP TO FAC
|
||||
1300 TSX
|
||||
1310 LDA STACK+9,X
|
||||
1320 STA FAC.SIGN
|
||||
1330 LDA FORPNT
|
||||
1340 LDY FORPNT+1
|
||||
1350 JSR FADD ADD TO FOR VALUE
|
||||
1360 JSR SETFOR PUT NEW VALUE BACK
|
||||
1370 LDY /STACK (Y,A) IS ADDRESS OF END VALUE
|
||||
1380 JSR FCOMP2 COMPARE TO END VALUE
|
||||
1390 TSX
|
||||
1400 SEC
|
||||
1410 SBC STACK+9,X SIGN OF STEP
|
||||
1420 BEQ .2 BRANCH IF FOR COMPLETE
|
||||
1430 LDA STACK+15,X OTHERWISE SET UP
|
||||
1440 STA CURLIN FOR LINE #
|
||||
1450 LDA STACK+16,X
|
||||
1460 STA CURLIN+1
|
||||
1470 LDA STACK+18,X AND SET TXTPTR TO JUST
|
||||
1480 STA TXTPTR AFTER FOR STATEMENT
|
||||
1490 LDA STACK+17,X
|
||||
1500 STA TXTPTR+1
|
||||
1510 .1 JMP NEWSTT
|
||||
1520 .2 TXA POP OFF FOR-FRAME, LOOP IS DONE
|
||||
1530 ADC #17 CARRY IS SET, SO ADDS 18
|
||||
1540 TAX
|
||||
1550 TXS
|
||||
1560 JSR CHRGOT CHAR AFTER VARIABLE
|
||||
1570 CMP #',' ANOTHER VARIABLE IN NEXT?
|
||||
1580 BNE .1 NO, GO TO NEXT STATEMENT
|
||||
1590 JSR CHRGET YES, PRIME FOR NEXT VARIABLE
|
||||
1600 JSR NEXT.1 (DOES NOT RETURN)
|
||||
1610 *--------------------------------
|
||||
1620 * EVALUATE EXPRESSION, MAKE SURE IT IS NUMERIC
|
||||
1630 *--------------------------------
|
||||
1640 FRMNUM JSR FRMEVL
|
||||
1650 *--------------------------------
|
||||
1660 * MAKE SURE (FAC) IS NUMERIC
|
||||
1670 *--------------------------------
|
||||
1680 CHKNUM CLC
|
||||
1690 .HS 24 DUMMY FOR SKIP
|
||||
1700 *--------------------------------
|
||||
1710 * MAKE SURE (FAC) IS STRING
|
||||
1720 *--------------------------------
|
||||
1730 CHKSTR SEC
|
||||
1740 *--------------------------------
|
||||
1750 * MAKE SURE (FAC) IS CORRECT TYPE
|
||||
1760 * IF C=0, TYPE MUST BE NUMERIC
|
||||
1770 * IF C=1, TYPE MUST BE STRING
|
||||
1780 *--------------------------------
|
||||
1790 CHKVAL BIT VALTYP $00 IF NUMERIC, $FF IF STRING
|
||||
1800 BMI .2 TYPE IS STRING
|
||||
1810 BCS .3 NOT STRING, BUT WE NEED STRING
|
||||
1820 .1 RTS TYPE IS CORRECT
|
||||
1830 .2 BCS .1 IS STRING AND WE WANTED STRING
|
||||
1840 .3 LDX #ERR.BADTYPE TYPE MISMATCH
|
||||
1850 JERROR JMP ERROR
|
||||
292
source/applesoft/S.DD7B
Normal file
292
source/applesoft/S.DD7B
Normal file
@ -0,0 +1,292 @@
|
||||
1010 *--------------------------------
|
||||
1020 * EVALUATE THE EXPRESSION AT TXTPTR, LEAVING THE
|
||||
1030 * RESULT IN FAC. WORKS FOR BOTH STRING AND NUMERIC
|
||||
1040 * EXPRESSIONS.
|
||||
1050 *--------------------------------
|
||||
1060 FRMEVL LDX TXTPTR DECREMENT TXTPTR
|
||||
1070 BNE .1
|
||||
1080 DEC TXTPTR+1
|
||||
1090 .1 DEC TXTPTR
|
||||
1100 LDX #0 START WITH PRECEDENCE = 0
|
||||
1110 .HS 24 TRICK TO SKIP FOLLOWING "PHA"
|
||||
1120 *--------------------------------
|
||||
1130 FRMEVL.1
|
||||
1140 PHA PUSH RELOPS FLAGS
|
||||
1150 TXA
|
||||
1160 PHA SAVE LAST PRECEDENCE
|
||||
1170 LDA #1
|
||||
1180 JSR CHKMEM CHECK IF ENOUGH ROOM ON STACK
|
||||
1190 JSR FRM.ELEMENT GET AN ELEMENT
|
||||
1200 LDA #0
|
||||
1210 STA CPRTYP CLEAR COMPARISON OPERATOR FLAGS
|
||||
1220 *--------------------------------
|
||||
1230 FRMEVL.2
|
||||
1240 JSR CHRGOT CHECK FOR RELATIONAL OPERATORS
|
||||
1250 .1 SEC > IS $CF, = IS $D0, < IS $D1
|
||||
1260 SBC #TOKEN.GREATER > IS 0, = IS 1, < IS 2
|
||||
1270 BCC .2 NOT RELATIONAL OPERATOR
|
||||
1280 CMP #3
|
||||
1290 BCS .2 NOT RELATIONAL OPERATOR
|
||||
1300 CMP #1 SET CARRY IF "=" OR "<"
|
||||
1310 ROL NOW > IS 0, = IS 3, < IS 5
|
||||
1320 EOR #1 NOW > IS 1, = IS 2, < IS 4
|
||||
1330 EOR CPRTYP SET BITS OF CPRTYP: 00000<=>
|
||||
1340 CMP CPRTYP CHECK FOR ILLEGAL COMBINATIONS
|
||||
1350 BCC SNTXERR IF LESS THAN, A RELOP WAS REPEATED
|
||||
1360 STA CPRTYP
|
||||
1370 JSR CHRGET ANOTHER OPERATOR?
|
||||
1380 JMP .1 CHECK FOR <,=,> AGAIN
|
||||
1390 *--------------------------------
|
||||
1400 .2 LDX CPRTYP DID WE FIND A RELATIONAL OPERATOR?
|
||||
1410 BNE FRM.RELATIONAL YES
|
||||
1420 BCS NOTMATH NO, AND NEXT TOKEN IS > $D1
|
||||
1430 ADC #$CF-TOKEN.PLUS NO, AND NEXT TOKEN < $CF
|
||||
1440 BCC NOTMATH IF NEXT TOKEN < "+"
|
||||
1450 ADC VALTYP + AND LAST RESULT A STRING?
|
||||
1460 BNE .3 BRANCH IF NOT
|
||||
1470 JMP CAT CONCATENATE IF SO.
|
||||
1480 *--------------------------------
|
||||
1490 .3 ADC #$FF +-*/ IS 0123
|
||||
1500 STA INDEX
|
||||
1510 ASL MULTIPLY BY 3
|
||||
1520 ADC INDEX +-*/ IS 0,3,6,9
|
||||
1530 TAY
|
||||
1540 *--------------------------------
|
||||
1550 FRM.PRECEDENCE.TEST
|
||||
1560 PLA GET LAST PRECEDENCE
|
||||
1570 CMP MATHTBL,Y
|
||||
1580 BCS FRM.PERFORM.1 DO NOW IF HIGHER PRECEDENCE
|
||||
1590 JSR CHKNUM WAS LAST RESULT A #?
|
||||
1600 NXOP PHA YES, SAVE PRECEDENCE ON STACK
|
||||
1610 SAVOP JSR FRM.RECURSE SAVE REST, CALL FRMEVL RECURSIVELY
|
||||
1620 PLA
|
||||
1630 LDY LASTOP
|
||||
1640 BPL PREFNC
|
||||
1650 TAX
|
||||
1660 BEQ GOEX EXIT IF NO MATH IN EXPRESSION
|
||||
1670 BNE FRM.PERFORM.2 ...ALWAYS
|
||||
1680 *--------------------------------
|
||||
1690 * FOUND ONE OR MORE RELATIONAL OPERATORS <,=,>
|
||||
1700 *--------------------------------
|
||||
1710 FRM.RELATIONAL
|
||||
1720 LSR VALTYP (VALTYP) = 0 (NUMERIC), = $FF (STRING)
|
||||
1730 TXA SET CPRTYP TO 0000<=>C
|
||||
1740 ROL WHERE C=0 IF #, C=1 IF STRING
|
||||
1750 LDX TXTPTR BACK UP TXTPTR
|
||||
1760 BNE .1
|
||||
1770 DEC TXTPTR+1
|
||||
1780 .1 DEC TXTPTR
|
||||
1790 LDY #M.REL-MATHTBL POINT AT RELOPS ENTRY
|
||||
1800 STA CPRTYP
|
||||
1810 BNE FRM.PRECEDENCE.TEST ...ALWAYS
|
||||
1820 *--------------------------------
|
||||
1830 PREFNC CMP MATHTBL,Y
|
||||
1840 BCS FRM.PERFORM.2 DO NOW IF HIGHER PRECEDENCE
|
||||
1850 BCC NXOP ...ALWAYS
|
||||
1860 *--------------------------------
|
||||
1870 * STACK THIS OPERATION AND CALL FRMEVL FOR
|
||||
1880 * ANOTHER ONE
|
||||
1890 *--------------------------------
|
||||
1900 FRM.RECURSE
|
||||
1910 LDA MATHTBL+2,Y
|
||||
1920 PHA PUSH ADDRESS OF OPERATION PERFORMER
|
||||
1930 LDA MATHTBL+1,Y
|
||||
1940 PHA
|
||||
1950 JSR FRM.STACK.1 STACK FAC.SIGN AND FAC
|
||||
1960 LDA CPRTYP A=RELOP FLAGS, X=PRECEDENCE BYTE
|
||||
1970 JMP FRMEVL.1 RECURSIVELY CALL FRMEVL
|
||||
1980 *--------------------------------
|
||||
1990 SNTXERR JMP SYNERR
|
||||
2000 *--------------------------------
|
||||
2010 * STACK (FAC)
|
||||
2020 *
|
||||
2030 * THREE ENTRY POINTS:
|
||||
2040 * .1, FROM FRMEVL
|
||||
2050 * .2, FROM "STEP"
|
||||
2060 * .3, FROM "FOR"
|
||||
2070 *--------------------------------
|
||||
2080 FRM.STACK.1
|
||||
2090 LDA FAC.SIGN GET FAC.SIGN TO PUSH IT
|
||||
2100 LDX MATHTBL,Y PRECEDENCE BYTE FROM MATHTBL
|
||||
2110 *--------------------------------
|
||||
2120 * ENTER HERE FROM "STEP", TO PUSH STEP SIGN AND VALUE
|
||||
2130 *--------------------------------
|
||||
2140 FRM.STACK.2
|
||||
2150 TAY FAC.SIGN OR SGN(STEP VALUE)
|
||||
2160 PLA PULL RETURN ADDRESS AND ADD 1
|
||||
2170 STA INDEX <<< ASSUMES NOT ON PAGE BOUNDARY! >>>
|
||||
2180 INC INDEX PLACE BUMPED RETURN ADDRESS IN
|
||||
2190 PLA INDEX,INDEX+1
|
||||
2200 STA INDEX+1
|
||||
2210 TYA FAC.SIGN OR SGN(STEP VALUE)
|
||||
2220 PHA PUSH FAC.SIGN OR SGN(STEP VALUE)
|
||||
2230 *--------------------------------
|
||||
2240 * ENTER HERE FROM "FOR", WITH (INDEX) = STEP,
|
||||
2250 * TO PUSH INITIAL VALUE OF "FOR" VARIABLE
|
||||
2260 *--------------------------------
|
||||
2270 FRM.STACK.3
|
||||
2280 JSR ROUND.FAC ROUND TO 32 BITS
|
||||
2290 LDA FAC+4 PUSH (FAC)
|
||||
2300 PHA
|
||||
2310 LDA FAC+3
|
||||
2320 PHA
|
||||
2330 LDA FAC+2
|
||||
2340 PHA
|
||||
2350 LDA FAC+1
|
||||
2360 PHA
|
||||
2370 LDA FAC
|
||||
2380 PHA
|
||||
2390 JMP (INDEX) DO RTS FUNNY WAY
|
||||
2400 *--------------------------------
|
||||
2410 *
|
||||
2420 *--------------------------------
|
||||
2430 NOTMATH LDY #$FF SET UP TO EXIT ROUTINE
|
||||
2440 PLA
|
||||
2450 GOEX BEQ EXIT EXIT IF NO MATH TO DO
|
||||
2460 *--------------------------------
|
||||
2470 * PERFORM STACKED OPERATION
|
||||
2480 *
|
||||
2490 * (A) = PRECEDENCE BYTE
|
||||
2500 * STACK: 1 -- CPRMASK
|
||||
2510 * 5 -- (ARG)
|
||||
2520 * 2 -- ADDR OF PERFORMER
|
||||
2530 *--------------------------------
|
||||
2540 FRM.PERFORM.1
|
||||
2550 CMP #P.REL WAS IT RELATIONAL OPERATOR?
|
||||
2560 BEQ .1 YES, ALLOW STRING COMPARE
|
||||
2570 JSR CHKNUM MUST BE NUMERIC VALUE
|
||||
2580 .1 STY LASTOP
|
||||
2590 *--------------------------------
|
||||
2600 FRM.PERFORM.2
|
||||
2610 PLA GET 0000<=>C FROM STACK
|
||||
2620 LSR SHIFT TO 00000<=> FORM
|
||||
2630 STA CPRMASK 00000<=>
|
||||
2640 PLA
|
||||
2650 STA ARG GET FLOATING POINT VALUE OFF STACK,
|
||||
2660 PLA AND PUT IT IN ARG
|
||||
2670 STA ARG+1
|
||||
2680 PLA
|
||||
2690 STA ARG+2
|
||||
2700 PLA
|
||||
2710 STA ARG+3
|
||||
2720 PLA
|
||||
2730 STA ARG+4
|
||||
2740 PLA
|
||||
2750 STA ARG+5
|
||||
2760 EOR FAC.SIGN SAVE EOR OF SIGNS OF THE OPERANDS,
|
||||
2770 STA SGNCPR IN CASE OF MULTIPLY OR DIVIDE
|
||||
2780 EXIT LDA FAC FAC EXPONENT IN A-REG
|
||||
2790 RTS STATUS .EQ. IF (FAC)=0
|
||||
2800 * RTS GOES TO PERFORM OPERATION
|
||||
2810 *--------------------------------
|
||||
2820 * GET ELEMENT IN EXPRESSION
|
||||
2830 *
|
||||
2840 * GET VALUE OF VARIABLE OR NUMBER AT TXTPNT, OR POINT
|
||||
2850 * TO STRING DESCRIPTOR IF A STRING, AND PUT IN FAC.
|
||||
2860 *--------------------------------
|
||||
2870 FRM.ELEMENT
|
||||
2880 LDA #0 ASSUME NUMERIC
|
||||
2890 STA VALTYP
|
||||
2900 .1 JSR CHRGET
|
||||
2910 BCS .3 NOT A DIGIT
|
||||
2920 .2 JMP FIN NUMERIC CONSTANT
|
||||
2930 .3 JSR ISLETC VARIABLE NAME?
|
||||
2940 BCS FRM.VARIABLE YES
|
||||
2950 CMP #'.' DECIMAL POINT
|
||||
2960 BEQ .2 YES, NUMERIC CONSTANT
|
||||
2970 CMP #TOKEN.MINUS UNARY MINUS?
|
||||
2980 BEQ MIN YES
|
||||
2990 CMP #TOKEN.PLUS UNARY PLUS
|
||||
3000 BEQ .1 YES
|
||||
3010 CMP #'"' STRING CONSTANT?
|
||||
3020 BNE NOT. NO
|
||||
3030 *--------------------------------
|
||||
3040 * STRING CONSTANT ELEMENT
|
||||
3050 *
|
||||
3060 * SET Y,A = (TXTPTR)+CARRY
|
||||
3070 *--------------------------------
|
||||
3080 STRTXT LDA TXTPTR ADD (CARRY) TO GET ADDRESS OF 1ST CHAR
|
||||
3090 LDY TXTPTR+1 OF STRING IN Y,A
|
||||
3100 ADC #0
|
||||
3110 BCC .1
|
||||
3120 INY
|
||||
3130 .1 JSR STRLIT BUILD DESCRIPTOR TO STRING
|
||||
3140 * GET ADDRESS OF DESCRIPTOR IN FAC
|
||||
3150 JMP POINT POINT TXTPTR AFTER TRAILING QUOTE
|
||||
3160 *--------------------------------
|
||||
3170 * "NOT" FUNCTION
|
||||
3180 * IF FAC=0, RETURN FAC=1
|
||||
3190 * IF FAC<>0, RETURN FAC=0
|
||||
3200 *--------------------------------
|
||||
3210 NOT. CMP #TOKEN.NOT
|
||||
3220 BNE FN. NOT "NOT", TRY "FN"
|
||||
3230 LDY #M.EQU-MATHTBL POINT AT = COMPARISON
|
||||
3240 BNE EQUL ...ALWAYS
|
||||
3250 *--------------------------------
|
||||
3260 * COMPARISON FOR EQUALITY (= OPERATOR)
|
||||
3270 * ALSO USED TO EVALUATE "NOT" FUNCTION
|
||||
3280 *--------------------------------
|
||||
3290 EQUOP LDA FAC SET "TRUE" IF (FAC) = ZERO
|
||||
3300 BNE .1 FALSE
|
||||
3310 LDY #1 TRUE
|
||||
3320 .HS 2C TRICK TO SKIP NEXT 2 BYTES
|
||||
3330 .1 LDY #0 FALSE
|
||||
3340 JMP SNGFLT
|
||||
3350 *--------------------------------
|
||||
3360 FN. CMP #TOKEN.FN
|
||||
3370 BNE SGN.
|
||||
3380 JMP FUNCT
|
||||
3390 *--------------------------------
|
||||
3400 SGN. CMP #TOKEN.SGN
|
||||
3410 BCC PARCHK
|
||||
3420 JMP UNARY
|
||||
3430 *--------------------------------
|
||||
3440 * EVALUATE "(EXPRESSION)"
|
||||
3450 *--------------------------------
|
||||
3460 PARCHK JSR CHKOPN IS THERE A '(' AT TXTPTR?
|
||||
3470 JSR FRMEVL YES, EVALUATE EXPRESSION
|
||||
3480 *--------------------------------
|
||||
3490 CHKCLS LDA #')' CHECK FOR ')'
|
||||
3500 .HS 2C TRICK
|
||||
3510 *--------------------------------
|
||||
3520 CHKOPN LDA #'('
|
||||
3530 .HS 2C TRICK
|
||||
3540 *--------------------------------
|
||||
3550 CHKCOM LDA #',' COMMA AT TXTPTR?
|
||||
3560 *--------------------------------
|
||||
3570 * UNLESS CHAR AT TXTPTR = (A), SYNTAX ERROR
|
||||
3580 *--------------------------------
|
||||
3590 SYNCHR LDY #0
|
||||
3600 CMP (TXTPTR),Y
|
||||
3610 BNE SYNERR
|
||||
3620 JMP CHRGET MATCH, GET NEXT CHAR & RETURN
|
||||
3630 *--------------------------------
|
||||
3640 SYNERR LDX #ERR.SYNTAX
|
||||
3650 JMP ERROR
|
||||
3660 *--------------------------------
|
||||
3670 MIN LDY #M.NEG-MATHTBL POINT AT UNARY MINUS
|
||||
3680 EQUL PLA
|
||||
3690 PLA
|
||||
3700 JMP SAVOP
|
||||
3710 *--------------------------------
|
||||
3720 FRM.VARIABLE
|
||||
3730 JSR PTRGET
|
||||
3740 FRM.VARIABLE.CALL .EQ *-1 SO PTRGET CAN TELL WE CALLED
|
||||
3750 STA VPNT ADDRESS OF VARIABLE
|
||||
3760 STY VPNT+1
|
||||
3770 LDX VALTYP NUMERIC OR STRING?
|
||||
3780 BEQ .1 NUMERIC
|
||||
3790 LDX #0 STRING
|
||||
3800 STX STRNG1+1
|
||||
3810 RTS
|
||||
3820 .1 LDX VALTYP+1 NUMERIC, WHICH TYPE?
|
||||
3830 BPL .2 FLOATING POINT
|
||||
3840 LDY #0 INTEGER
|
||||
3850 LDA (VPNT),Y
|
||||
3860 TAX GET VALUE IN A,Y
|
||||
3870 INY
|
||||
3880 LDA (VPNT),Y
|
||||
3890 TAY
|
||||
3900 TXA
|
||||
3910 JMP GIVAYF CONVERT A,Y TO FLOATING POINT
|
||||
3920 .2 JMP LOAD.FAC.FROM.YA
|
||||
147
source/applesoft/S.DEF9
Normal file
147
source/applesoft/S.DEF9
Normal file
@ -0,0 +1,147 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "SCRN(" FUNCTION
|
||||
1030 *--------------------------------
|
||||
1040 SCREEN JSR CHRGET
|
||||
1050 JSR PLOTFNS GET COLUMN AND ROW
|
||||
1060 TXA ROW
|
||||
1070 LDY FIRST COLUMN
|
||||
1080 JSR MON.SCRN GET 4-BIT COLOR THERE
|
||||
1090 TAY
|
||||
1100 JSR SNGFLT CONVERT (Y) TO REAL IN FAC
|
||||
1110 JMP CHKCLS REQUIRE ")"
|
||||
1120 *--------------------------------
|
||||
1130 * PROCESS UNARY OPERATORS (FUNCTIONS)
|
||||
1140 *--------------------------------
|
||||
1150 UNARY CMP #TOKEN.SCRN NOT UNARY, DO SPECIAL
|
||||
1160 BEQ SCREEN
|
||||
1170 ASL DOUBLE TOKEN TO GET INDEX
|
||||
1180 PHA
|
||||
1190 TAX
|
||||
1200 JSR CHRGET
|
||||
1210 CPX #TOKEN.LEFTSTR*2-1 LEFT$, RIGHT$, AND MID$
|
||||
1220 BCC .1 NOT ONE OF THE STRING FUNCTIONS
|
||||
1230 JSR CHKOPN STRING FUNCTION, NEED "("
|
||||
1240 JSR FRMEVL EVALUATE EXPRESSION FOR STRING
|
||||
1250 JSR CHKCOM REQUIRE A COMMA
|
||||
1260 JSR CHKSTR MAKE SURE EXPRESSION IS A STRING
|
||||
1270 PLA
|
||||
1280 TAX RETRIEVE ROUTINE POINTER
|
||||
1290 LDA VPNT+1 STACK ADDRESS OF STRING
|
||||
1300 PHA
|
||||
1310 LDA VPNT
|
||||
1320 PHA
|
||||
1330 TXA
|
||||
1340 PHA STACK DOUBLED TOKEN
|
||||
1350 JSR GETBYT CONVERT NEXT EXPRESSION TO BYTE IN X-REG
|
||||
1360 PLA GET DOUBLED TOKEN OFF STACK
|
||||
1370 TAY USE AS INDEX TO BRANCH
|
||||
1380 TXA VALUE OF SECOND PARAMETER
|
||||
1390 PHA PUSH 2ND PARAM
|
||||
1400 JMP .2 JOIN UNARY FUNCTIONS
|
||||
1410 .1 JSR PARCHK REQUIRE "(EXPRESSION)"
|
||||
1420 PLA
|
||||
1430 TAY INDEX INTO FUNCTION ADDRESS TABLE
|
||||
1440 .2 LDA UNFNC-TOKEN.SGN-TOKEN.SGN+$100,Y
|
||||
1450 STA JMPADRS+1 PREPARE TO JSR TO ADDRESS
|
||||
1460 LDA UNFNC-TOKEN.SGN-TOKEN.SGN+$101,Y
|
||||
1470 STA JMPADRS+2
|
||||
1480 JSR JMPADRS DOES NOT RETURN FOR
|
||||
1490 * CHR$, LEFT$, RIGHT$, OR MID$
|
||||
1500 JMP CHKNUM REQUIRE NUMERIC RESULT
|
||||
1510 *--------------------------------
|
||||
1520 OR LDA ARG "OR" OPERATOR
|
||||
1530 ORA FAC IF RESULT NONZERO, IT IS TRUE
|
||||
1540 BNE TRUE
|
||||
1550 *--------------------------------
|
||||
1560 AND LDA ARG "AND" OPERATOR
|
||||
1570 BEQ FALSE IF EITHER IS ZERO, RESULT IS FALSE
|
||||
1580 LDA FAC
|
||||
1590 BNE TRUE
|
||||
1600 *--------------------------------
|
||||
1610 FALSE LDY #0 RETURN FAC=0
|
||||
1620 .HS 2C TRICK
|
||||
1630 *--------------------------------
|
||||
1640 TRUE LDY #1 RETURN FAC=1
|
||||
1650 JMP SNGFLT
|
||||
1660 *--------------------------------
|
||||
1670 * PERFORM RELATIONAL OPERATIONS
|
||||
1680 *--------------------------------
|
||||
1690 RELOPS JSR CHKVAL MAKE SURE FAC IS CORRECT TYPE
|
||||
1700 BCS STRCMP TYPE MATCHES, BRANCH IF STRINGS
|
||||
1710 LDA ARG.SIGN NUMERIC COMPARISON
|
||||
1720 ORA #$7F RE-PACK VALUE IN ARG FOR FCOMP
|
||||
1730 AND ARG+1
|
||||
1740 STA ARG+1
|
||||
1750 LDA #ARG
|
||||
1760 LDY /ARG
|
||||
1770 JSR FCOMP RETURN A-REG = -1,0,1
|
||||
1780 TAX AS ARG <,=,> FAC
|
||||
1790 JMP NUMCMP
|
||||
1800 *--------------------------------
|
||||
1810 * STRING COMPARISON
|
||||
1820 *--------------------------------
|
||||
1830 STRCMP LDA #0 SET RESULT TYPE TO NUMERIC
|
||||
1840 STA VALTYP
|
||||
1850 DEC CPRTYP MAKE CPRTYP 0000<=>0
|
||||
1860 JSR FREFAC
|
||||
1870 STA FAC STRING LENGTH
|
||||
1880 STX FAC+1
|
||||
1890 STY FAC+2
|
||||
1900 LDA ARG+3
|
||||
1910 LDY ARG+4
|
||||
1920 JSR FRETMP
|
||||
1930 STX ARG+3
|
||||
1940 STY ARG+4
|
||||
1950 TAX LEN (ARG) STRING
|
||||
1960 SEC
|
||||
1970 SBC FAC SET X TO SMALLER LEN
|
||||
1980 BEQ .1
|
||||
1990 LDA #1
|
||||
2000 BCC .1
|
||||
2010 LDX FAC
|
||||
2020 LDA #$FF
|
||||
2030 .1 STA FAC.SIGN FLAG WHICH SHORTER
|
||||
2040 LDY #$FF
|
||||
2050 INX
|
||||
2060 STRCMP.1
|
||||
2070 INY
|
||||
2080 DEX
|
||||
2090 BNE STRCMP.2 MORE CHARS IN BOTH STRINGS
|
||||
2100 LDX FAC.SIGN IF = SO FAR, DECIDE BY LENGTH
|
||||
2110 *--------------------------------
|
||||
2120 NUMCMP BMI CMPDONE
|
||||
2130 CLC
|
||||
2140 BCC CMPDONE ...ALWAYS
|
||||
2150 *--------------------------------
|
||||
2160 STRCMP.2
|
||||
2170 LDA (ARG+3),Y
|
||||
2180 CMP (FAC+1),Y
|
||||
2190 BEQ STRCMP.1 SAME, KEEP COMPARING
|
||||
2200 LDX #$FF IN CASE ARG GREATER
|
||||
2210 BCS CMPDONE IT IS
|
||||
2220 LDX #1 FAC GREATER
|
||||
2230 *--------------------------------
|
||||
2240 CMPDONE
|
||||
2250 INX CONVERT FF,0,1 TO 0,1,2
|
||||
2260 TXA
|
||||
2270 ROL AND TO 0,2,4 IF C=0, ELSE 1,2,5
|
||||
2280 AND CPRMASK 00000<=>
|
||||
2290 BEQ .1 IF NO MATCH: FALSE
|
||||
2300 LDA #1 AT LEAST ONE MATCH: TRUE
|
||||
2310 .1 JMP FLOAT
|
||||
2320 *--------------------------------
|
||||
2330 * "PDL" FUNCTION
|
||||
2340 * <<< NOTE: ARG<4 IS NOT CHECKED >>>
|
||||
2350 *--------------------------------
|
||||
2360 PDL JSR CONINT GET # IN X
|
||||
2370 JSR MON.PREAD READ PADDLE
|
||||
2380 JMP SNGFLT FLOAT RESULT
|
||||
2390 *--------------------------------
|
||||
2400 * "DIM" STATEMENT
|
||||
2410 *--------------------------------
|
||||
2420 NXDIM JSR CHKCOM SEPARATED BY COMMAS
|
||||
2430 DIM TAX NON-ZERO, FLAGS PTRGET DIM CALLED
|
||||
2440 JSR PTRGET2 ALLOCATE THE ARRAY
|
||||
2450 JSR CHRGOT NEXT CHAR
|
||||
2460 BNE NXDIM NOT END OF STATEMENT
|
||||
2470 RTS
|
||||
164
source/applesoft/S.DEFINITIONS
Normal file
164
source/applesoft/S.DEFINITIONS
Normal file
@ -0,0 +1,164 @@
|
||||
1010 *--------------------------------
|
||||
1020 * ZERO PAGE LOCATIONS:
|
||||
1030 *--------------------------------
|
||||
1040 GOWARM .EQ $00,01,02 GETS "JMP RESTART"
|
||||
1050 GOSTROUT .EQ $03,04,05 GETS "JMP STROUT"
|
||||
1060 USR .EQ $0A,0B,0C GETS "JMP <USER ADDR>"
|
||||
1070 * (INITIALLY $E199)
|
||||
1080 CHARAC .EQ $0D ALTERNATE STRING TERMINATOR
|
||||
1090 ENDCHR .EQ $0E STRING TERMINATOR
|
||||
1100 TKN.CNTR .EQ $0F USED IN PARSE
|
||||
1110 EOL.PNTR .EQ $0F USED IN NXLIN
|
||||
1120 NUMDIM .EQ $0F USED IN ARRAY ROUTINES
|
||||
1130 DIMFLG .EQ $10
|
||||
1140 VALTYP .EQ $11,12 $:VALTYP=$FF; %:VALTYP+1=$80
|
||||
1150 DATAFLG .EQ $13 USED IN PARSE
|
||||
1160 GARFLG .EQ $13 USED IN GARBAG
|
||||
1170 SUBFLG .EQ $14
|
||||
1180 INPUTFLG .EQ $15 = $40 FOR GET, $98 FOR READ
|
||||
1190 CPRMASK .EQ $16 RECEIVES CPRTYP IN FRMEVL
|
||||
1200 SIGNFLG .EQ $16 FLAGS SIGN IN TAN
|
||||
1210 HGR.SHAPE .EQ $1A,1B
|
||||
1220 HGR.BITS .EQ $1C
|
||||
1230 HGR.COUNT .EQ $1D
|
||||
1240 MON.CH .EQ $24
|
||||
1250 MON.GBASL .EQ $26
|
||||
1260 MON.GBASH .EQ $27
|
||||
1270 MON.H2 .EQ $2C
|
||||
1280 MON.V2 .EQ $2D
|
||||
1290 MON.HMASK .EQ $30
|
||||
1300 MON.INVFLG .EQ $32
|
||||
1310 MON.PROMPT .EQ $33
|
||||
1320 MON.A1L .EQ $3C USED BY TAPE I/O ROUTINES
|
||||
1330 MON.A1H .EQ $3D "
|
||||
1340 MON.A2L .EQ $3E "
|
||||
1350 MON.A2H .EQ $3F "
|
||||
1360 LINNUM .EQ $50,51 CONVERTED LINE #
|
||||
1370 TEMPPT .EQ $52 LAST USED TEMP STRING DESC
|
||||
1380 LASTPT .EQ $53,54 LAST USED TEMP STRING PNTR
|
||||
1390 TEMPST .EQ $55 - 5D HOLDS UP TO 3 DESCRIPTORS
|
||||
1400 INDEX .EQ $5E,5F
|
||||
1410 DEST .EQ $60,61
|
||||
1420 RESULT .EQ $62 - 66 RESULT OF LAST * OR /
|
||||
1430 TXTTAB .EQ $67,68 START OF PROGRAM TEXT
|
||||
1440 VARTAB .EQ $69,6A START OF VARIABLE STORAGE
|
||||
1450 ARYTAB .EQ $6B,6C START OF ARRAY STORAGE
|
||||
1460 STREND .EQ $6D,6E END OF ARRAY STORAGE
|
||||
1470 FRETOP .EQ $6F,70 START OF STRING STORAGE
|
||||
1480 FRESPC .EQ $71,72 TEMP PNTR, STRING ROUTINES
|
||||
1490 MEMSIZ .EQ $73,74 END OF STRING SPACE (HIMEM)
|
||||
1500 CURLIN .EQ $75,76 CURRENT LINE NUMBER
|
||||
1510 * ( = $FFXX IF IN DIRECT MODE)
|
||||
1520 OLDLIN .EQ $77,78 ADDR. OF LAST LINE EXECUTED
|
||||
1530 OLDTEXT .EQ $79,7A
|
||||
1540 DATLIN .EQ $7B,7C LINE # OF CURRENT DATA STT.
|
||||
1550 DATPTR .EQ $7D,7E ADDR OF CURRENT DATA STT.
|
||||
1560 INPTR .EQ $7F,80
|
||||
1570 VARNAM .EQ $81,82 NAME OF VARIABLE
|
||||
1580 VARPNT .EQ $83,84 ADDR OF VARIABLE
|
||||
1590 FORPNT .EQ $85,86
|
||||
1600 TXPSV .EQ $87,88 USED IN INPUT
|
||||
1610 LASTOP .EQ $87 SCRATCH FLAG USED IN FRMEVL
|
||||
1620 CPRTYP .EQ $89 >,=,< FLAG IN FRMEVL
|
||||
1630 TEMP3 .EQ $8A - 8E
|
||||
1640 FNCNAM .EQ $8A
|
||||
1650 DSCPTR .EQ $8C
|
||||
1660 DSCLEN .EQ $8F USED IN GARBAG
|
||||
1670 JMPADRS .EQ $90,91,92 GETS "JMP ...."
|
||||
1680 LENGTH .EQ $91 USED IN GARBAG
|
||||
1690 ARG.EXTENSION .EQ $92 FP EXTRA PRECISION
|
||||
1700 TEMP1 .EQ $93 - 97 SAVE AREAS FOR FAC
|
||||
1710 ARYPNT .EQ $94 USED IN GARBAG
|
||||
1720 HIGHDS .EQ $94,95 PNTR FOR BLTU
|
||||
1730 HIGHTR .EQ $96,97 PNTR FOR BLTU
|
||||
1740 TEMP2 .EQ $98 - 9C
|
||||
1750 TMPEXP .EQ $99 USED IN FIN (EVAL)
|
||||
1760 INDX .EQ $99 USED BY ARRAY RTNS
|
||||
1770 EXPON .EQ $9A "
|
||||
1780 DPFLG .EQ $9B FLAGS DEC PNT IN FIN
|
||||
1790 LOWTR .EQ $9B,9C
|
||||
1800 EXPSGN .EQ $9C
|
||||
1810 FAC .EQ $9D - A1 MAIN FLT PT ACCUMULATOR
|
||||
1820 DSCTMP .EQ $9D,9E,9F
|
||||
1830 VPNT .EQ $A0,A1 TEMP VAR PTR
|
||||
1840 FAC.SIGN .EQ $A2 HOLDS UNPACKED SIGN
|
||||
1850 SERLEN .EQ $A3 HOLDS LENGTH OF SERIES-1
|
||||
1860 SHIFT.SIGN.EXT .EQ $A4 SIGN EXTENSION, RIGHT SHIFTS
|
||||
1870 ARG .EQ $A5 - A9 SECONDARY FP ACC
|
||||
1880 ARG.SIGN .EQ $AA
|
||||
1890 SGNCPR .EQ $AB FLAGS OPP SIGN IN FP ROUT.
|
||||
1900 FAC.EXTENSION .EQ $AC FAC EXTENSION BYTE
|
||||
1910 SERPNT .EQ $AD PNTR TO SERIES DATA IN FP
|
||||
1920 STRNG1 .EQ $AB,AC
|
||||
1930 STRNG2 .EQ $AD,AE
|
||||
1940 PRGEND .EQ $AF,B0
|
||||
1950 CHRGET .EQ $B1 - C8
|
||||
1960 CHRGOT .EQ $B7
|
||||
1970 TXTPTR .EQ $B8,B9
|
||||
1980 RNDSEED .EQ $C9 - CD
|
||||
1990 HGR.DX .EQ $D0,D1
|
||||
2000 HGR.DY .EQ $D2
|
||||
2010 HGR.QUADRANT .EQ $D3
|
||||
2020 HGR.E .EQ $D4,D5
|
||||
2030 LOCK .EQ $D6 NO USER ACCESS IF > 127
|
||||
2040 ERRFLG .EQ $D8 $80 IF ON ERR ACTIVE
|
||||
2050 ERRLIN .EQ $DA,DB LINE # WHERE ERROR OCCURRED
|
||||
2060 ERRPOS .EQ $DC,DD TXTPTR SAVE FOR HANDLERR
|
||||
2070 ERRNUM .EQ $DE WHICH ERROR OCCURRED
|
||||
2080 ERRSTK .EQ $DF STACK PNTR BEFORE ERROR
|
||||
2090 HGR.X .EQ $E0,E1
|
||||
2100 HGR.Y .EQ $E2
|
||||
2110 HGR.COLOR .EQ $E4
|
||||
2120 HGR.HORIZ .EQ $E5 BYTE INDEX FROM GBASH,L
|
||||
2130 HGR.PAGE .EQ $E6 HGR=$20, HGR2=$40
|
||||
2140 HGR.SCALE .EQ $E7
|
||||
2150 HGR.SHAPE.PNTR .EQ $E8,E9
|
||||
2160 HGR.COLLISIONS .EQ $EA
|
||||
2170 FIRST .EQ $F0
|
||||
2180 SPEEDZ .EQ $F1 OUTPUT SPEED
|
||||
2190 TRCFLG .EQ $F2
|
||||
2200 FLASH.BIT .EQ $F3 = $40 FOR FLASH, ELSE =$00
|
||||
2210 TXTPSV .EQ $F4,F5
|
||||
2220 CURLSV .EQ $F6,F7
|
||||
2230 REMSTK .EQ $F8 STACK PNTR BEFORE EACH STT.
|
||||
2240 HGR.ROTATION .EQ $F9
|
||||
2250 * $FF IS ALSO USED BY THE STRING OUT ROUTINES
|
||||
2260 *--------------------------------
|
||||
2270 STACK .EQ $100
|
||||
2280 INPUT.BUFFER .EQ $200
|
||||
2290 AMPERSAND.VECTOR .EQ $3F5 - 3F7 GETS "JMP ...."
|
||||
2300 *--------------------------------
|
||||
2310 * I/O & SOFT SWITCHES
|
||||
2320 *--------------------------------
|
||||
2330 KEYBOARD .EQ $C000
|
||||
2340 SW.TXTCLR .EQ $C050
|
||||
2350 SW.MIXCLR .EQ $C052
|
||||
2360 SW.MIXSET .EQ $C053
|
||||
2370 SW.LOWSCR .EQ $C054
|
||||
2380 SW.HISCR .EQ $C055
|
||||
2390 SW.LORES .EQ $C056
|
||||
2400 SW.HIRES .EQ $C057
|
||||
2410 *--------------------------------
|
||||
2420 * MONITOR SUBROUTINES
|
||||
2430 *--------------------------------
|
||||
2440 MON.PLOT .EQ $F800
|
||||
2450 MON.HLINE .EQ $F819
|
||||
2460 MON.VLINE .EQ $F828
|
||||
2470 MON.SETCOL .EQ $F864
|
||||
2480 MON.SCRN .EQ $F871
|
||||
2490 MON.PREAD .EQ $FB1E
|
||||
2500 MON.SETTXT .EQ $FB39
|
||||
2510 MON.SETGR .EQ $FB40
|
||||
2520 MON.TABV .EQ $FB5B
|
||||
2530 MON.HOME .EQ $FC58
|
||||
2540 MON.WAIT .EQ $FCA8
|
||||
2550 MON.RD2BIT .EQ $FCFA
|
||||
2560 MON.RDKEY .EQ $FD0C
|
||||
2570 MON.GETLN .EQ $FD6A
|
||||
2580 MON.COUT .EQ $FDED
|
||||
2590 MON.INPORT .EQ $FE8B
|
||||
2600 MON.OUTPORT .EQ $FE95
|
||||
2610 MON.WRITE .EQ $FECD
|
||||
2620 MON.READ .EQ $FEFD
|
||||
2630 MON.READ2 .EQ $FF02
|
||||
2640 *--------------------------------
|
||||
351
source/applesoft/S.DFE3
Normal file
351
source/applesoft/S.DFE3
Normal file
@ -0,0 +1,351 @@
|
||||
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 *--------------------------------
|
||||
362
source/applesoft/S.E1B8
Normal file
362
source/applesoft/S.E1B8
Normal file
@ -0,0 +1,362 @@
|
||||
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
|
||||
323
source/applesoft/S.E3C5
Normal file
323
source/applesoft/S.E3C5
Normal file
@ -0,0 +1,323 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "STR$" FUNCTION
|
||||
1030 *--------------------------------
|
||||
1040 STR JSR CHKNUM EXPRESSION MUST BE NUMERIC
|
||||
1050 LDY #0 START STRING AT STACK-1 ($00FF)
|
||||
1060 * SO STRLIT CAN DIFFRENTIATE STR$ CALLS
|
||||
1070 JSR FOUT.1 CONVERT FAC TO STRING
|
||||
1080 PLA POP RETURN OFF STACK
|
||||
1090 PLA
|
||||
1100 LDA #STACK-1 POINT TO STACK-1
|
||||
1110 LDY /STACK-1 (WHICH=0)
|
||||
1120 BEQ STRLIT ...ALWAYS, CREATE DESC & MOVE STRING
|
||||
1130 *--------------------------------
|
||||
1140 * GET SPACE AND MAKE DESCRIPTOR FOR STRING WHOSE
|
||||
1150 * ADDRESS IS IN FAC+3,4 AND WHOSE LENGTH IS IN A-REG
|
||||
1160 *--------------------------------
|
||||
1170 STRINI LDX FAC+3 Y,X = STRING ADDRESS
|
||||
1180 LDY FAC+4
|
||||
1190 STX DSCPTR
|
||||
1200 STY DSCPTR+1
|
||||
1210 *--------------------------------
|
||||
1220 * GET SPACE AND MAKE DESCRIPTOR FOR STRING WHOSE
|
||||
1230 * ADDRESS IS IN Y,X AND WHOSE LENGTH IS IN A-REG
|
||||
1240 *--------------------------------
|
||||
1250 STRSPA JSR GETSPA A HOLDS LENGTH
|
||||
1260 STX FAC+1 SAVE DESCRIPTOR IN FAC
|
||||
1270 STY FAC+2 ---FAC--- --FAC+1-- --FAC+2--
|
||||
1280 STA FAC <LENGTH> <ADDR-LO> <ADDR-HI>
|
||||
1290 RTS
|
||||
1300 *--------------------------------
|
||||
1310 * BUILD A DESCRIPTOR FOR STRING STARTING AT Y,A
|
||||
1320 * AND TERMINATED BY $00 OR QUOTATION MARK
|
||||
1330 * RETURN WITH DESCRIPTOR IN A TEMPORARY
|
||||
1340 * AND ADDRESS OF DESCRIPTOR IN FAC+3,4
|
||||
1350 *--------------------------------
|
||||
1360 STRLIT LDX #'"' SET UP LITERAL SCAN TO STOP ON
|
||||
1370 STX CHARAC QUOTATION MARK OR $00
|
||||
1380 STX ENDCHR
|
||||
1390 *--------------------------------
|
||||
1400 * BUILD A DESCRIPTOR FOR STRING STARTING AT Y,A
|
||||
1410 * AND TERMINATED BY $00, (CHARAC), OR (ENDCHR)
|
||||
1420 *
|
||||
1430 * RETURN WITH DESCRIPTOR IN A TEMPORARY
|
||||
1440 * AND ADDRESS OF DESCRIPTOR IN FAC+3,4
|
||||
1450 *--------------------------------
|
||||
1460 STRLT2 STA STRNG1 SAVE ADDRESS OF STRING
|
||||
1470 STY STRNG1+1
|
||||
1480 STA FAC+1 ...AGAIN
|
||||
1490 STY FAC+2
|
||||
1500 LDY #$FF
|
||||
1510 .1 INY FIND END OF STRING
|
||||
1520 LDA (STRNG1),Y NEXT STRING CHAR
|
||||
1530 BEQ .3 END OF STRING
|
||||
1540 CMP CHARAC ALTERNATE TERMINATOR # 1?
|
||||
1550 BEQ .2 YES
|
||||
1560 CMP ENDCHR ALTERNATE TERMINATOR # 2?
|
||||
1570 BNE .1 NO, KEEP SCANNING
|
||||
1580 .2 CMP #'"' IS STRING ENDED WITH QUOTE MARK?
|
||||
1590 BEQ .4 YES, C=1 TO INCLUDE " IN STRING
|
||||
1600 .3 CLC
|
||||
1610 .4 STY FAC SAVE LENGTH
|
||||
1620 TYA
|
||||
1630 ADC STRNG1 COMPUTE ADDRESS OF END OF STRING
|
||||
1640 STA STRNG2 (OF 00 BYTE, OR JUST AFTER ")
|
||||
1650 LDX STRNG1+1
|
||||
1660 BCC .5
|
||||
1670 INX
|
||||
1680 .5 STX STRNG2+1
|
||||
1690 LDA STRNG1+1 WHERE DOES THE STRING START?
|
||||
1700 BEQ .6 PAGE 0, MUST BE FROM STR$ FUNCTION
|
||||
1710 CMP #2 PAGE 2?
|
||||
1720 BNE PUTNEW NO, NOT PAGE 0 OR 2
|
||||
1730 .6 TYA LENGTH OF STRING
|
||||
1740 JSR STRINI MAKE SPACE FOR STRING
|
||||
1750 LDX STRNG1
|
||||
1760 LDY STRNG1+1
|
||||
1770 JSR MOVSTR MOVE IT IN
|
||||
1780 *--------------------------------
|
||||
1790 * STORE DESCRIPTOR IN TEMPORARY DESCRIPTOR STACK
|
||||
1800 *
|
||||
1810 * THE DESCRIPTOR IS NOW IN FAC, FAC+1, FAC+2
|
||||
1820 * PUT ADDRESS OF TEMP DESCRIPTOR IN FAC+3,4
|
||||
1830 *--------------------------------
|
||||
1840 PUTNEW LDX TEMPPT POINTER TO NEXT TEMP STRING SLOT
|
||||
1850 CPX #TEMPST+9 MAX OF 3 TEMP STRINGS
|
||||
1860 BNE PUTEMP ROOM FOR ANOTHER ONE
|
||||
1870 LDX #ERR.FRMCPX TOO MANY, FORMULA TOO COMPLEX
|
||||
1880 JERR JMP ERROR
|
||||
1890 *--------------------------------
|
||||
1900 PUTEMP LDA FAC COPY TEMP DESCRIPTOR INTO TEMP STACK
|
||||
1910 STA 0,X
|
||||
1920 LDA FAC+1
|
||||
1930 STA 1,X
|
||||
1940 LDA FAC+2
|
||||
1950 STA 2,X
|
||||
1960 LDY #0
|
||||
1970 STX FAC+3 ADDRESS OF TEMP DESCRIPTOR
|
||||
1980 STY FAC+4 IN Y,X AND FAC+3,4
|
||||
1990 DEY Y=$FF
|
||||
2000 STY VALTYP FLAG (FAC ) AS STRING
|
||||
2010 STX LASTPT INDEX OF LAST POINTER
|
||||
2020 INX UPDATE FOR NEXT TEMP ENTRY
|
||||
2030 INX
|
||||
2040 INX
|
||||
2050 STX TEMPPT
|
||||
2060 RTS
|
||||
2070 *--------------------------------
|
||||
2080 * MAKE SPACE FOR STRING AT BOTTOM OF STRING SPACE
|
||||
2090 * (A)=# BYTES SPACE TO MAKE
|
||||
2100 *
|
||||
2110 * RETURN WITH (A) SAME,
|
||||
2120 * AND Y,X = ADDRESS OF SPACE ALLOCATED
|
||||
2130 *--------------------------------
|
||||
2140 GETSPA LSR GARFLG CLEAR SIGNBIT OF FLAG
|
||||
2150 .1 PHA A HOLDS LENGTH
|
||||
2160 EOR #$FF GET -LENGTH
|
||||
2170 SEC
|
||||
2180 ADC FRETOP COMPUTE STARTING ADDRESS OF SPACE
|
||||
2190 LDY FRETOP+1 FOR THE STRING
|
||||
2200 BCS .2
|
||||
2210 DEY
|
||||
2220 .2 CPY STREND+1 SEE IF FITS IN REMAINING MEMORY
|
||||
2230 BCC .4 NO, TRY GARBAGE
|
||||
2240 BNE .3 YES, IT FITS
|
||||
2250 CMP STREND HAVE TO CHECK LOWER BYTES
|
||||
2260 BCC .4 NOT ENUF ROOM YET
|
||||
2270 .3 STA FRETOP THERE IS ROOM SO SAVE NEW FRETOP
|
||||
2280 STY FRETOP+1
|
||||
2290 STA FRESPC
|
||||
2300 STY FRESPC+1
|
||||
2310 TAX ADDR IN Y,X
|
||||
2320 PLA LENGTH IN A
|
||||
2330 RTS
|
||||
2340 .4 LDX #ERR.MEMFULL
|
||||
2350 LDA GARFLG GARBAGE DONE YET?
|
||||
2360 BMI JERR YES, MEMORY IS REALLY FULL
|
||||
2370 JSR GARBAG NO, TRY COLLECTING NOW
|
||||
2380 LDA #$80 FLAG THAT COLLECTED GARBAGE ALREADY
|
||||
2390 STA GARFLG
|
||||
2400 PLA GET STRING LENGTH AGAIN
|
||||
2410 BNE .1 ...ALWAYS
|
||||
2420 *--------------------------------
|
||||
2430 * SHOVE ALL REFERENCED STRINGS AS HIGH AS POSSIBLE
|
||||
2440 * IN MEMORY (AGAINST HIMEM), FREEING UP SPACE
|
||||
2450 * BELOW STRING AREA DOWN TO STREND.
|
||||
2460 *--------------------------------
|
||||
2470 GARBAG LDX MEMSIZ COLLECT FROM TOP DOWN
|
||||
2480 LDA MEMSIZ+1
|
||||
2490 FIND.HIGHEST.STRING
|
||||
2500 STX FRETOP ONE PASS THROUGH ALL VARS
|
||||
2510 STA FRETOP+1 FOR EACH ACTIVE STRING!
|
||||
2520 LDY #0
|
||||
2530 STY FNCNAM+1 FLAG IN CASE NO STRINGS TO COLLECT
|
||||
2540 LDA STREND
|
||||
2550 LDX STREND+1
|
||||
2560 STA LOWTR
|
||||
2570 STX LOWTR+1
|
||||
2580 *--------------------------------
|
||||
2590 * START BY COLLECTING TEMPORARIES
|
||||
2600 *--------------------------------
|
||||
2610 LDA #TEMPST
|
||||
2620 LDX /TEMPST
|
||||
2630 STA INDEX
|
||||
2640 STX INDEX+1
|
||||
2650 .1 CMP TEMPPT FINISHED WITH TEMPS YET?
|
||||
2660 BEQ .2 YES, NOW DO SIMPLE VARIABLES
|
||||
2670 JSR CHECK.VARIABLE DO A TEMP
|
||||
2680 BEQ .1 ...ALWAYS
|
||||
2690 *--------------------------------
|
||||
2700 * NOW COLLECT SIMPLE VARIABLES
|
||||
2710 *--------------------------------
|
||||
2720 .2 LDA #7 LENGTH OF EACH VARIABLE IS 7 BYTES
|
||||
2730 STA DSCLEN
|
||||
2740 LDA VARTAB START AT BEGINNING OF VARTAB
|
||||
2750 LDX VARTAB+1
|
||||
2760 STA INDEX
|
||||
2770 STX INDEX+1
|
||||
2780 .3 CPX ARYTAB+1 FINISHED WITH SIMPLE VARIABLES?
|
||||
2790 BNE .4 NO
|
||||
2800 CMP ARYTAB MAYBE, CHECK LO-BYTE
|
||||
2810 BEQ .5 YES, NOW DO ARRAYS
|
||||
2820 .4 JSR CHECK.SIMPLE.VARIABLE
|
||||
2830 BEQ .3 ...ALWAYS
|
||||
2840 *--------------------------------
|
||||
2850 * NOW COLLECT ARRAY VARIABLES
|
||||
2860 *--------------------------------
|
||||
2870 .5 STA ARYPNT
|
||||
2880 STX ARYPNT+1
|
||||
2890 LDA #3 DESCRIPTORS IN ARRAYS ARE 3-BYTES EACH
|
||||
2900 STA DSCLEN
|
||||
2910 .6 LDA ARYPNT COMPARE TO END OF ARRAYS
|
||||
2920 LDX ARYPNT+1
|
||||
2930 .7 CPX STREND+1 FINISHED WITH ARRAYS YET?
|
||||
2940 BNE .8 NOT YET
|
||||
2950 CMP STREND MAYBE, CHECK LO-BYTE
|
||||
2960 BNE .8 NOT FINISHED YET
|
||||
2970 JMP MOVE.HIGHEST.STRING.TO.TOP FINISHED
|
||||
2980 .8 STA INDEX SET UP PNTR TO START OF ARRAY
|
||||
2990 STX INDEX+1
|
||||
3000 LDY #0 POINT AT NAME OF ARRAY
|
||||
3010 LDA (INDEX),Y
|
||||
3020 TAX 1ST LETTER OF NAME IN X-REG
|
||||
3030 INY
|
||||
3040 LDA (INDEX),Y
|
||||
3050 PHP STATUS FROM SECOND LETTER OF NAME
|
||||
3060 INY
|
||||
3070 LDA (INDEX),Y OFFSET TO NEXT ARRAY
|
||||
3080 ADC ARYPNT (CARRY ALWAYS CLEAR)
|
||||
3090 STA ARYPNT CALCULATE START OF NEXT ARRAY
|
||||
3100 INY
|
||||
3110 LDA (INDEX),Y HI-BYTE OF OFFSET
|
||||
3120 ADC ARYPNT+1
|
||||
3130 STA ARYPNT+1
|
||||
3140 PLP GET STATUS FROM 2ND CHAR OF NAME
|
||||
3150 BPL .6 NOT A STRING ARRAY
|
||||
3160 TXA SET STATUS WITH 1ST CHAR OF NAME
|
||||
3170 BMI .6 NOT A STRING ARRAY
|
||||
3180 INY
|
||||
3190 LDA (INDEX),Y # OF DIMENSIONS FOR THIS ARRAY
|
||||
3200 LDY #0
|
||||
3210 ASL PREAMBLE SIZE = 2*#DIMS + 5
|
||||
3220 ADC #5
|
||||
3230 ADC INDEX MAKE INDEX POINT AT FIRST ELEMENT
|
||||
3240 STA INDEX IN THE ARRAY
|
||||
3250 BCC .9
|
||||
3260 INC INDEX+1
|
||||
3270 .9
|
||||
3280 LDX INDEX+1 STEP THRU EACH STRING IN THIS ARRAY
|
||||
3290 .10 CPX ARYPNT+1 ARRAY DONE?
|
||||
3300 BNE .11 NO, PROCESS NEXT ELEMENT
|
||||
3310 CMP ARYPNT MAYBE, CHECK LO-BYTE
|
||||
3320 BEQ .7 YES, MOVE TO NEXT ARRAY
|
||||
3330 .11 JSR CHECK.VARIABLE PROCESS THE ARRAY
|
||||
3340 BEQ .10 ...ALWAYS
|
||||
3350 *--------------------------------
|
||||
3360 * PROCESS A SIMPLE VARIABLE
|
||||
3370 *--------------------------------
|
||||
3380 CHECK.SIMPLE.VARIABLE
|
||||
3390 LDA (INDEX),Y LOOK AT 1ST CHAR OF NAME
|
||||
3400 BMI CHECK.BUMP NOT A STRING VARIABLE
|
||||
3410 INY
|
||||
3420 LDA (INDEX),Y LOOK AT 2ND CHAR OF NAME
|
||||
3430 BPL CHECK.BUMP NOT A STRING VARIABLE
|
||||
3440 INY
|
||||
3450 *--------------------------------
|
||||
3460 * IF STRING IS NOT EMPTY, CHECK IF IT IS HIGHEST
|
||||
3470 *--------------------------------
|
||||
3480 CHECK.VARIABLE
|
||||
3490 LDA (INDEX),Y GET LENGTH OF STRING
|
||||
3500 BEQ CHECK.BUMP IGNORE STRING IF LENGTH IS ZERO
|
||||
3510 INY
|
||||
3520 LDA (INDEX),Y GET ADDRESS OF STRING
|
||||
3530 TAX
|
||||
3540 INY
|
||||
3550 LDA (INDEX),Y
|
||||
3560 CMP FRETOP+1 CHECK IF ALREADY COLLECTED
|
||||
3570 BCC .1 NO, BELOW FRETOP
|
||||
3580 BNE CHECK.BUMP YES, ABOVE FRETOP
|
||||
3590 CPX FRETOP MAYBE, CHECK LO-BYTE
|
||||
3600 BCS CHECK.BUMP YES, ABOVE FRETOP
|
||||
3610 .1 CMP LOWTR+1 ABOVE HIGHEST STRING FOUND?
|
||||
3620 BCC CHECK.BUMP NO, IGNORE FOR NOW
|
||||
3630 BNE .2 YES, THIS IS THE NEW HIGHEST
|
||||
3640 CPX LOWTR MAYBE, TRY LO-BYTE
|
||||
3650 BCC CHECK.BUMP NO, IGNORE FOR NOW
|
||||
3660 .2 STX LOWTR MAKE THIS THE HIGHEST STRING
|
||||
3670 STA LOWTR+1
|
||||
3680 LDA INDEX SAVE ADDRESS OF DESCRIPTOR TOO
|
||||
3690 LDX INDEX+1
|
||||
3700 STA FNCNAM
|
||||
3710 STX FNCNAM+1
|
||||
3720 LDA DSCLEN
|
||||
3730 STA LENGTH
|
||||
3740 *--------------------------------
|
||||
3750 * ADD (DSCLEN) TO PNTR IN INDEX
|
||||
3760 * RETURN WITH Y=0, PNTR ALSO IN X,A
|
||||
3770 *--------------------------------
|
||||
3780 CHECK.BUMP
|
||||
3790 LDA DSCLEN BUMP TO NEXT VARIABLE
|
||||
3800 CLC
|
||||
3810 ADC INDEX
|
||||
3820 STA INDEX
|
||||
3830 BCC CHECK.EXIT
|
||||
3840 INC INDEX+1
|
||||
3850 *--------------------------------
|
||||
3860 CHECK.EXIT
|
||||
3870 LDX INDEX+1
|
||||
3880 LDY #0
|
||||
3890 RTS
|
||||
3900 *--------------------------------
|
||||
3910 * FOUND HIGHEST NON-EMPTY STRING, SO MOVE IT
|
||||
3920 * TO TOP AND GO BACK FOR ANOTHER
|
||||
3930 *--------------------------------
|
||||
3940 MOVE.HIGHEST.STRING.TO.TOP
|
||||
3950 LDX FNCNAM+1 ANY STRING FOUND?
|
||||
3960 BEQ CHECK.EXIT NO, RETURN
|
||||
3970 LDA LENGTH GET LENGTH OF VARIABLE ELEMENT
|
||||
3980 AND #4 WAS 7 OR 3, MAKE 4 OR 0
|
||||
3990 LSR 2 0R 0; IN SIMPLE VARIABLES,
|
||||
4000 TAY NAME PRECEDES DESCRIPTOR
|
||||
4010 STA LENGTH 2 OR 0
|
||||
4020 LDA (FNCNAM),Y GET LENGTH FROM DESCRIPTOR
|
||||
4030 ADC LOWTR CARRY ALREADY CLEARED BY LSR
|
||||
4040 STA HIGHTR STRING IS BTWN (LOWTR) AND (HIGHTR)
|
||||
4050 LDA LOWTR+1
|
||||
4060 ADC #0
|
||||
4070 STA HIGHTR+1
|
||||
4080 LDA FRETOP HIGH END DESTINATION
|
||||
4090 LDX FRETOP+1
|
||||
4100 STA HIGHDS
|
||||
4110 STX HIGHDS+1
|
||||
4120 JSR BLTU2 MOVE STRING UP
|
||||
4130 LDY LENGTH FIX ITS DESCRIPTOR
|
||||
4140 INY POINT AT ADDRESS IN DESCRIPTOR
|
||||
4150 LDA HIGHDS STORE NEW ADDRESS
|
||||
4160 STA (FNCNAM),Y
|
||||
4170 TAX
|
||||
4180 INC HIGHDS+1 CORRECT BLTU'S OVERSHOOT
|
||||
4190 LDA HIGHDS+1
|
||||
4200 INY
|
||||
4210 STA (FNCNAM),Y
|
||||
4220 JMP FIND.HIGHEST.STRING
|
||||
4230 *--------------------------------
|
||||
382
source/applesoft/S.E597
Normal file
382
source/applesoft/S.E597
Normal file
@ -0,0 +1,382 @@
|
||||
1010 *--------------------------------
|
||||
1020 * CONCATENATE TWO STRINGS
|
||||
1030 *--------------------------------
|
||||
1040 CAT LDA FAC+4 SAVE ADDRESS OF FIRST DESCRIPTOR
|
||||
1050 PHA
|
||||
1060 LDA FAC+3
|
||||
1070 PHA
|
||||
1080 JSR FRM.ELEMENT GET SECOND STRING ELEMENT
|
||||
1090 JSR CHKSTR MUST BE A STRING
|
||||
1100 PLA RECOVER ADDRES OF 1ST DESCRIPTOR
|
||||
1110 STA STRNG1
|
||||
1120 PLA
|
||||
1130 STA STRNG1+1
|
||||
1140 LDY #0
|
||||
1150 LDA (STRNG1),Y ADD LENGTHS, GET CONCATENATED SIZE
|
||||
1160 CLC
|
||||
1170 ADC (FAC+3),Y
|
||||
1180 BCC .1 OK IF < $100
|
||||
1190 LDX #ERR.STRLONG
|
||||
1200 JMP ERROR
|
||||
1210 .1 JSR STRINI GET SPACE FOR CONCATENATED STRINGS
|
||||
1220 JSR MOVINS MOVE 1ST STRING
|
||||
1230 LDA DSCPTR
|
||||
1240 LDY DSCPTR+1
|
||||
1250 JSR FRETMP
|
||||
1260 JSR MOVSTR.1 MOVE 2ND STRING
|
||||
1270 LDA STRNG1
|
||||
1280 LDY STRNG1+1
|
||||
1290 JSR FRETMP
|
||||
1300 JSR PUTNEW SET UP DESCRIPTOR
|
||||
1310 JMP FRMEVL.2 FINISH EXPRESSION
|
||||
1320 *--------------------------------
|
||||
1330 * GET STRING DESCRIPTOR POINTED AT BY (STRNG1)
|
||||
1340 * AND MOVE DESCRIBED STRING TO (FRESPC)
|
||||
1350 *--------------------------------
|
||||
1360 MOVINS LDY #0
|
||||
1370 LDA (STRNG1),Y
|
||||
1380 PHA LENGTH
|
||||
1390 INY
|
||||
1400 LDA (STRNG1),Y
|
||||
1410 TAX PUT STRING POINTER IN X,Y
|
||||
1420 INY
|
||||
1430 LDA (STRNG1),Y
|
||||
1440 TAY
|
||||
1450 PLA RETRIEVE LENGTH
|
||||
1460 *--------------------------------
|
||||
1470 * MOVE STRING AT (Y,X) WITH LENGTH (A)
|
||||
1480 * TO DESTINATION WHOSE ADDRESS IS IN FRESPC,FRESPC+1
|
||||
1490 *--------------------------------
|
||||
1500 MOVSTR STX INDEX PUT POINTER IN INDEX
|
||||
1510 STY INDEX+1
|
||||
1520 MOVSTR.1
|
||||
1530 TAY LENGTH TO Y-REG
|
||||
1540 BEQ .2 IF LENGTH IS ZERO, FINISHED
|
||||
1550 PHA SAVE LENGTH ON STACK
|
||||
1560 .1 DEY MOVE BYTES FROM (INDEX) TO (FRESPC)
|
||||
1570 LDA (INDEX),Y
|
||||
1580 STA (FRESPC),Y
|
||||
1590 TYA TEST IF ANY LEFT TO MOVE
|
||||
1600 BNE .1 YES, KEEP MOVING
|
||||
1610 PLA NO, FINISHED. GET LENGTH
|
||||
1620 .2 CLC AND ADD TO FRESPC, SO
|
||||
1630 ADC FRESPC FRESPC POINTS TO NEXT HIGHER
|
||||
1640 STA FRESPC BYTE. (USED BY CONCATENATION)
|
||||
1650 BCC .3
|
||||
1660 INC FRESPC+1
|
||||
1670 .3 RTS
|
||||
1680 *--------------------------------
|
||||
1690 * IF (FAC) IS A TEMPORARY STRING, RELEASE DESCRIPTOR
|
||||
1700 *--------------------------------
|
||||
1710 FRESTR JSR CHKSTR LAST RESULT A STRING?
|
||||
1720 *--------------------------------
|
||||
1730 * IF STRING DESCRIPTOR POINTED TO BY FAC+3,4 IS
|
||||
1740 * A TEMPORARY STRING, RELEASE IT.
|
||||
1750 *--------------------------------
|
||||
1760 FREFAC LDA FAC+3 GET DESCRIPTOR POINTER
|
||||
1770 LDY FAC+4
|
||||
1780 *--------------------------------
|
||||
1790 * IF STRING DESCRIPTOR WHOSE ADDRESS IS IN Y,A IS
|
||||
1800 * A TEMPORARY STRING, RELEASE IT.
|
||||
1810 *--------------------------------
|
||||
1820 FRETMP STA INDEX SAVE THE ADDRESS OF THE DESCRIPTOR
|
||||
1830 STY INDEX+1
|
||||
1840 JSR FRETMS FREE DESCRIPTOR IF IT IS TEMPORARY
|
||||
1850 PHP REMEMBER IF TEMP
|
||||
1860 LDY #0 POINT AT LENGTH OF STRING
|
||||
1870 LDA (INDEX),Y
|
||||
1880 PHA SAVE LENGTH ON STACK
|
||||
1890 INY
|
||||
1900 LDA (INDEX),Y
|
||||
1910 TAX GET ADDRESS OF STRING IN Y,X
|
||||
1920 INY
|
||||
1930 LDA (INDEX),Y
|
||||
1940 TAY
|
||||
1950 PLA LENGTH IN A
|
||||
1960 PLP RETRIEVE STATUS, Z=1 IF TEMP
|
||||
1970 BNE .2 NOT A TEMPORARY STRING
|
||||
1980 CPY FRETOP+1 IS IT THE LOWEST STRING?
|
||||
1990 BNE .2 NO
|
||||
2000 CPX FRETOP
|
||||
2010 BNE .2 NO
|
||||
2020 PHA YES, PUSH LENGTH AGAIN
|
||||
2030 CLC RECOVER THE SPACE USED BY
|
||||
2040 ADC FRETOP THE STRING
|
||||
2050 STA FRETOP
|
||||
2060 BCC .1
|
||||
2070 INC FRETOP+1
|
||||
2080 .1 PLA RETRIEVE LENGTH AGAIN
|
||||
2090 .2 STX INDEX ADDRESS OF STRING IN Y,X
|
||||
2100 STY INDEX+1 LENGTH OF STRING IN A-REG
|
||||
2110 RTS
|
||||
2120 *--------------------------------
|
||||
2130 * RELEASE TEMPORARY DESCRIPTOR IF Y,A = LASTPT
|
||||
2140 *--------------------------------
|
||||
2150 FRETMS CPY LASTPT+1 COMPARE Y,A TO LATEST TEMP
|
||||
2160 BNE .1 NOT SAME ONE, CANNOT RELEASE
|
||||
2170 CMP LASTPT
|
||||
2180 BNE .1 NOT SAME ONE, CANNOT RELEASE
|
||||
2190 STA TEMPPT UPDATE TEMPT FOR NEXT TEMP
|
||||
2200 SBC #3 BACK OFF LASTPT
|
||||
2210 STA LASTPT
|
||||
2220 LDY #0 NOW Y,A POINTS TO TOP TEMP
|
||||
2230 .1 RTS Z=0 IF NOT TEMP, Z=1 IF TEMP
|
||||
2240 *--------------------------------
|
||||
2250 * "CHR$" FUNCTION
|
||||
2260 *--------------------------------
|
||||
2270 CHRSTR JSR CONINT CONVERT ARGUMENT TO BYTE IN X
|
||||
2280 TXA
|
||||
2290 PHA SAVE IT
|
||||
2300 LDA #1 GET SPACE FOR STRING OF LENGTH 1
|
||||
2310 JSR STRSPA
|
||||
2320 PLA RECALL THE CHARACTER
|
||||
2330 LDY #0 PUT IN STRING
|
||||
2340 STA (FAC+1),Y
|
||||
2350 PLA POP RETURN ADDRESS
|
||||
2360 PLA
|
||||
2370 JMP PUTNEW MAKE IT A TEMPORARY STRING
|
||||
2380 *--------------------------------
|
||||
2390 * "LEFT$" FUNCTION
|
||||
2400 *--------------------------------
|
||||
2410 LEFTSTR
|
||||
2420 JSR SUBSTRING.SETUP
|
||||
2430 CMP (DSCPTR),Y COMPARE 1ST PARAMETER TO LENGTH
|
||||
2440 TYA Y=A=0
|
||||
2450 SUBSTRING.1
|
||||
2460 BCC .1 1ST PARAMETER SMALLER, USE IT
|
||||
2470 LDA (DSCPTR),Y 1ST IS LONGER, USE STRING LENGTH
|
||||
2480 TAX IN X-REG
|
||||
2490 TYA Y=A=0 AGAIN
|
||||
2500 .1 PHA PUSH LEFT END OF SUBSTRING
|
||||
2510 SUBSTRING.2
|
||||
2520 TXA
|
||||
2530 SUBSTRING.3
|
||||
2540 PHA PUSH LENGTH OF SUBSTRING
|
||||
2550 JSR STRSPA MAKE ROOM FOR STRING OF (A) BYTES
|
||||
2560 LDA DSCPTR RELEASE PARAMETER STRING IF TEMP
|
||||
2570 LDY DSCPTR+1
|
||||
2580 JSR FRETMP
|
||||
2590 PLA GET LENGTH OF SUBSTRING
|
||||
2600 TAY IN Y-REG
|
||||
2610 PLA GET LEFT END OF SUBSTRING
|
||||
2620 CLC ADD TO POINTER TO STRING
|
||||
2630 ADC INDEX
|
||||
2640 STA INDEX
|
||||
2650 BCC .1
|
||||
2660 INC INDEX+1
|
||||
2670 .1 TYA LENGTH
|
||||
2680 JSR MOVSTR.1 COPY STRING INTO SPACE
|
||||
2690 JMP PUTNEW ADD TO TEMPS
|
||||
2700 *--------------------------------
|
||||
2710 * "RIGHT$" FUNCTION
|
||||
2720 *--------------------------------
|
||||
2730 RIGHTSTR
|
||||
2740 JSR SUBSTRING.SETUP
|
||||
2750 CLC COMPUTE LENGTH-WIDTH OF SUBSTRING
|
||||
2760 SBC (DSCPTR),Y TO GET STARTING POINT IN STRING
|
||||
2770 EOR #$FF
|
||||
2780 JMP SUBSTRING.1 JOIN LEFT$
|
||||
2790 *--------------------------------
|
||||
2800 * "MID$" FUNCTION
|
||||
2810 *--------------------------------
|
||||
2820 MIDSTR LDA #$FF FLAG WHETHER 2ND PARAMETER
|
||||
2830 STA FAC+4
|
||||
2840 JSR CHRGOT SEE IF ")" YET
|
||||
2850 CMP #')'
|
||||
2860 BEQ .1 YES, NO 2ND PARAMETER
|
||||
2870 JSR CHKCOM NO, MUST HAVE COMMA
|
||||
2880 JSR GETBYT GET 2ND PARAM IN X-REG
|
||||
2890 .1 JSR SUBSTRING.SETUP
|
||||
2900 DEX 1ST PARAMETER - 1
|
||||
2910 TXA
|
||||
2920 PHA
|
||||
2930 CLC
|
||||
2940 LDX #0
|
||||
2950 SBC (DSCPTR),Y
|
||||
2960 BCS SUBSTRING.2
|
||||
2970 EOR #$FF
|
||||
2980 CMP FAC+4 USE SMALLER OF TWO
|
||||
2990 BCC SUBSTRING.3
|
||||
3000 LDA FAC+4
|
||||
3010 BCS SUBSTRING.3 ...ALWAYS
|
||||
3020 *--------------------------------
|
||||
3030 * COMMON SETUP ROUTINE FOR LEFT$, RIGHT$, MID$:
|
||||
3040 * REQUIRE ")"; POP RETURN ADRS, GET DESCRIPTOR
|
||||
3050 * ADDRESS, GET 1ST PARAMETER OF COMMAND
|
||||
3060 *--------------------------------
|
||||
3070 SUBSTRING.SETUP
|
||||
3080 JSR CHKCLS REQUIRE ")"
|
||||
3090 PLA SAVE RETURN ADDRESS
|
||||
3100 TAY IN Y-REG AND LENGTH
|
||||
3110 PLA
|
||||
3120 STA LENGTH
|
||||
3130 PLA POP PREVIOUS RETURN ADDRESS
|
||||
3140 PLA (FROM GOROUT).
|
||||
3150 PLA RETRIEVE 1ST PARAMETER
|
||||
3160 TAX
|
||||
3170 PLA GET ADDRESS OF STRING DESCRIPTOR
|
||||
3180 STA DSCPTR
|
||||
3190 PLA
|
||||
3200 STA DSCPTR+1
|
||||
3210 LDA LENGTH RESTORE RETURN ADDRESS
|
||||
3220 PHA
|
||||
3230 TYA
|
||||
3240 PHA
|
||||
3250 LDY #0
|
||||
3260 TXA GET 1ST PARAMETER IN A-REG
|
||||
3270 BEQ GOIQ ERROR IF 0
|
||||
3280 RTS
|
||||
3290 *--------------------------------
|
||||
3300 * "LEN" FUNCTION
|
||||
3310 *--------------------------------
|
||||
3320 LEN JSR GETSTR GET LENTGH IN Y-REG, MAKE FAC NUMERIC
|
||||
3330 JMP SNGFLT FLOAT Y-REG INTO FAC
|
||||
3340 *--------------------------------
|
||||
3350 * IF LAST RESULT IS A TEMPORARY STRING, FREE IT
|
||||
3360 * MAKE VALTYP NUMERIC, RETURN LENGTH IN Y-REG
|
||||
3370 *--------------------------------
|
||||
3380 GETSTR JSR FRESTR IF LAST RESULT IS A STRING, FREE IT
|
||||
3390 LDX #0 MAKE VALTYP NUMERIC
|
||||
3400 STX VALTYP
|
||||
3410 TAY LENGTH OF STRING TO Y-REG
|
||||
3420 RTS
|
||||
3430 *--------------------------------
|
||||
3440 * "ASC" FUNCTION
|
||||
3450 *--------------------------------
|
||||
3460 ASC JSR GETSTR GET STRING, GET LENGTH IN Y-REG
|
||||
3470 BEQ GOIQ ERROR IF LENGTH 0
|
||||
3480 LDY #0
|
||||
3490 LDA (INDEX),Y GET 1ST CHAR OF STRING
|
||||
3500 TAY
|
||||
3510 JMP SNGFLT FLOAT Y-REG INTO FAC
|
||||
3520 *--------------------------------
|
||||
3530 GOIQ JMP IQERR ILLEGAL QUANTITY ERROR
|
||||
3540 *--------------------------------
|
||||
3550 * SCAN TO NEXT CHARACTER AND CONVERT EXPRESSION
|
||||
3560 * TO SINGLE BYTE IN X-REG
|
||||
3570 *--------------------------------
|
||||
3580 GTBYTC JSR CHRGET
|
||||
3590 *--------------------------------
|
||||
3600 * EVALUATE EXPRESSION AT TXTPTR, AND
|
||||
3610 * CONVERT IT TO SINGLE BYTE IN X-REG
|
||||
3620 *--------------------------------
|
||||
3630 GETBYT JSR FRMNUM
|
||||
3640 *--------------------------------
|
||||
3650 * CONVERT (FAC) TO SINGLE BYTE INTEGER IN X-REG
|
||||
3660 *--------------------------------
|
||||
3670 CONINT JSR MKINT CONVERT IF IN RANGE -32767 TO +32767
|
||||
3680 LDX FAC+3 HI-BYTE MUST BE ZERO
|
||||
3690 BNE GOIQ VALUE > 255, ERROR
|
||||
3700 LDX FAC+4 VALUE IN X-REG
|
||||
3710 JMP CHRGOT GET NEXT CHAR IN A-REG
|
||||
3720 *--------------------------------
|
||||
3730 * "VAL" FUNCTION
|
||||
3740 *--------------------------------
|
||||
3750 VAL JSR GETSTR GET POINTER TO STRING IN INDEX
|
||||
3760 BNE .1 LENGTH NON-ZERO
|
||||
3770 JMP ZERO.FAC RETURN 0 IF LENGTH=0
|
||||
3780 .1 LDX TXTPTR SAVE CURRENT TXTPTR
|
||||
3790 LDY TXTPTR+1
|
||||
3800 STX STRNG2
|
||||
3810 STY STRNG2+1
|
||||
3820 LDX INDEX
|
||||
3830 STX TXTPTR POINT TXTPTR TO START OF STRING
|
||||
3840 CLC
|
||||
3850 ADC INDEX ADD LENGTH
|
||||
3860 STA DEST POINT DEST TO END OF STRING + 1
|
||||
3870 LDX INDEX+1
|
||||
3880 STX TXTPTR+1
|
||||
3890 BCC .2
|
||||
3900 INX
|
||||
3910 .2 STX DEST+1
|
||||
3920 LDY #0 SAVE BYTE THAT FOLLOWS STRING
|
||||
3930 LDA (DEST),Y ON STACK
|
||||
3940 PHA
|
||||
3950 LDA #0 AND STORE $00 IN ITS PLACE
|
||||
3960 STA (DEST),Y
|
||||
3970 * <<< THAT CAUSES A BUG IF HIMEM = $BFFF, >>>
|
||||
3980 * <<< BECAUSE STORING $00 AT $C000 IS NO >>>
|
||||
3990 * <<< USE; $C000 WILL ALWAYS BE LAST CHAR >>>
|
||||
4000 * <<< TYPED, SO FIN WON'T TERMINATE UNTIL >>>
|
||||
4010 * <<< IT SEES A ZERO AT $C010! >>>
|
||||
4020 JSR CHRGOT PRIME THE PUMP
|
||||
4030 JSR FIN EVALUATE STRING
|
||||
4040 PLA GET BYTE THAT SHOULD FOLLOW STRING
|
||||
4050 LDY #0 AND PUT IT BACK
|
||||
4060 STA (DEST),Y
|
||||
4070 * RESTORE TXTPTR
|
||||
4080 *--------------------------------
|
||||
4090 * COPY STRNG2 INTO TXTPTR
|
||||
4100 *--------------------------------
|
||||
4110 POINT LDX STRNG2
|
||||
4120 LDY STRNG2+1
|
||||
4130 STX TXTPTR
|
||||
4140 STY TXTPTR+1
|
||||
4150 RTS
|
||||
4160 *--------------------------------
|
||||
4170 * EVALUATE "EXP1,EXP2"
|
||||
4180 *
|
||||
4190 * CONVERT EXP1 TO 16-BIT NUMBER IN LINNUM
|
||||
4200 * CONVERT EXP2 TO 8-BIT NUMBER IN X-REG
|
||||
4210 *--------------------------------
|
||||
4220 GTNUM JSR FRMNUM
|
||||
4230 JSR GETADR
|
||||
4240 *--------------------------------
|
||||
4250 * EVALUATE ",EXPRESSION"
|
||||
4260 * CONVERT EXPRESSION TO SINGLE BYTE IN X-REG
|
||||
4270 *--------------------------------
|
||||
4280 COMBYTE
|
||||
4290 JSR CHKCOM MUST HAVE COMMA FIRST
|
||||
4300 JMP GETBYT CONVERT EXPRESSION TO BYTE IN X-REG
|
||||
4310 *--------------------------------
|
||||
4320 * CONVERT (FAC) TO A 16-BIT VALUE IN LINNUM
|
||||
4330 *--------------------------------
|
||||
4340 GETADR LDA FAC FAC < 2^16?
|
||||
4350 CMP #$91
|
||||
4360 BCS GOIQ NO, ILLEGAL QUANTITY
|
||||
4370 JSR QINT CONVERT TO INTEGER
|
||||
4380 LDA FAC+3 COPY IT INTO LINNUM
|
||||
4390 LDY FAC+4
|
||||
4400 STY LINNUM TO LINNUM
|
||||
4410 STA LINNUM+1
|
||||
4420 RTS
|
||||
4430 *--------------------------------
|
||||
4440 * "PEEK" FUNCTION
|
||||
4450 *--------------------------------
|
||||
4460 PEEK LDA LINNUM SAVE (LINNUM) ON STACK DURING PEEK
|
||||
4470 PHA
|
||||
4480 LDA LINNUM+1
|
||||
4490 PHA
|
||||
4500 JSR GETADR GET ADDRESS PEEKING AT
|
||||
4510 LDY #0
|
||||
4520 LDA (LINNUM),Y TAKE A QUICK LOOK
|
||||
4530 TAY VALUE IN Y-REG
|
||||
4540 PLA RESTORE LINNUM FROM STACK
|
||||
4550 STA LINNUM+1
|
||||
4560 PLA
|
||||
4570 STA LINNUM
|
||||
4580 JMP SNGFLT FLOAT Y-REG INTO FAC
|
||||
4590 *--------------------------------
|
||||
4600 * "POKE" STATEMENT
|
||||
4610 *--------------------------------
|
||||
4620 POKE JSR GTNUM GET THE ADDRESS AND VALUE
|
||||
4630 TXA VALUE IN A,
|
||||
4640 LDY #0
|
||||
4650 STA (LINNUM),Y STORE IT AWAY,
|
||||
4660 RTS AND THAT'S ALL FOR TODAY
|
||||
4670 *--------------------------------
|
||||
4680 * "WAIT" STATEMENT
|
||||
4690 *--------------------------------
|
||||
4700 WAIT JSR GTNUM GET ADDRESS IN LINNUM, MASK IN X
|
||||
4710 STX FORPNT SAVE MASK
|
||||
4720 LDX #0
|
||||
4730 JSR CHRGOT ANOTHER PARAMETER?
|
||||
4740 BEQ .1 NO, USE $00 FOR EXCLUSIVE-OR
|
||||
4750 JSR COMBYTE GET XOR-MASK
|
||||
4760 .1 STX FORPNT+1 SAVE XOR-MASK HERE
|
||||
4770 LDY #0
|
||||
4780 .2 LDA (LINNUM),Y GET BYTE AT ADDRESS
|
||||
4790 EOR FORPNT+1 INVERT SPECIFIED BITS
|
||||
4800 AND FORPNT SELECT SPECIFIED BITS
|
||||
4810 BEQ .2 LOOP TILL NOT 0
|
||||
4820 RTS.10 RTS
|
||||
268
source/applesoft/S.E7A0
Normal file
268
source/applesoft/S.E7A0
Normal file
@ -0,0 +1,268 @@
|
||||
1010 *--------------------------------
|
||||
1020 * ADD 0.5 TO FAC
|
||||
1030 *--------------------------------
|
||||
1040 FADDH LDA #CON.HALF FAC+1/2 -> FAC
|
||||
1050 LDY /CON.HALF
|
||||
1060 JMP FADD
|
||||
1070 *--------------------------------
|
||||
1080 * FAC = (Y,A) - FAC
|
||||
1090 *--------------------------------
|
||||
1100 FSUB JSR LOAD.ARG.FROM.YA
|
||||
1110 *--------------------------------
|
||||
1120 * FAC = ARG - FAC
|
||||
1130 *--------------------------------
|
||||
1140 FSUBT LDA FAC.SIGN COMPLEMENT FAC AND ADD
|
||||
1150 EOR #$FF
|
||||
1160 STA FAC.SIGN
|
||||
1170 EOR ARG.SIGN FIX SGNCPR TOO
|
||||
1180 STA SGNCPR
|
||||
1190 LDA FAC MAKE STATUS SHOW FAC EXPONENT
|
||||
1200 JMP FADDT JOIN FADD
|
||||
1210 *--------------------------------
|
||||
1220 * SHIFT SMALLER ARGUMENT MORE THAN 7 BITS
|
||||
1230 *--------------------------------
|
||||
1240 FADD.1 JSR SHIFT.RIGHT ALIGN RADIX BY SHIFTING
|
||||
1250 BCC FADD.3 ...ALWAYS
|
||||
1260 *--------------------------------
|
||||
1270 * FAC = (Y,A) + FAC
|
||||
1280 *--------------------------------
|
||||
1290 FADD JSR LOAD.ARG.FROM.YA
|
||||
1300 *--------------------------------
|
||||
1310 * FAC = ARG + FAC
|
||||
1320 *--------------------------------
|
||||
1330 FADDT BNE .1 FAC IS NON-ZERO
|
||||
1340 JMP COPY.ARG.TO.FAC FAC = 0 + ARG
|
||||
1350 .1 LDX FAC.EXTENSION
|
||||
1360 STX ARG.EXTENSION
|
||||
1370 LDX #ARG SET UP TO SHIFT ARG
|
||||
1380 LDA ARG EXPONENT
|
||||
1390 *--------------------------------
|
||||
1400 FADD.2 TAY
|
||||
1410 BEQ RTS.10 IF ARG=0, WE ARE FINISHED
|
||||
1420 SEC
|
||||
1430 SBC FAC GET DIFFNCE OF EXP
|
||||
1440 BEQ FADD.3 GO ADD IF SAME EXP
|
||||
1450 BCC .1 ARG HAS SMALLER EXPONENT
|
||||
1460 STY FAC EXP HAS SMALLER EXPONENT
|
||||
1470 LDY ARG.SIGN
|
||||
1480 STY FAC.SIGN
|
||||
1490 EOR #$FF COMPLEMENT SHIFT COUNT
|
||||
1500 ADC #0 CARRY WAS SET
|
||||
1510 LDY #0
|
||||
1520 STY ARG.EXTENSION
|
||||
1530 LDX #FAC SET UP TO SHIFT FAC
|
||||
1540 BNE .2 ...ALWAYS
|
||||
1550 .1 LDY #0
|
||||
1560 STY FAC.EXTENSION
|
||||
1570 .2 CMP #$F9 SHIFT MORE THAN 7 BITS?
|
||||
1580 BMI FADD.1 YES
|
||||
1590 TAY INDEX TO # OF SHIFTS
|
||||
1600 LDA FAC.EXTENSION
|
||||
1610 LSR 1,X START SHIFTING...
|
||||
1620 JSR SHIFT.RIGHT.4 ...COMPLETE SHIFTING
|
||||
1630 FADD.3 BIT SGNCPR DO FAC AND ARG HAVE SAME SIGNS?
|
||||
1640 BPL FADD.4 YES, ADD THE MANTISSAS
|
||||
1650 LDY #FAC NO, SUBTRACT SMALLER FROM LARGER
|
||||
1660 CPX #ARG WHICH WAS ADJUSTED?
|
||||
1670 BEQ .1 IF ARG, DO FAC-ARG
|
||||
1680 LDY #ARG IF FAC, DO ARG-FAC
|
||||
1690 .1 SEC SUBTRACT SMALLER FROM LARGER (WE HOPE)
|
||||
1700 EOR #$FF (IF EXPONENTS WERE EQUAL, WE MIGHT BE
|
||||
1710 ADC ARG.EXTENSION SUBTRACTING LARGER FROM SMALLER)
|
||||
1720 STA FAC.EXTENSION
|
||||
1730 LDA 4,Y
|
||||
1740 SBC 4,X
|
||||
1750 STA FAC+4
|
||||
1760 LDA 3,Y
|
||||
1770 SBC 3,X
|
||||
1780 STA FAC+3
|
||||
1790 LDA 2,Y
|
||||
1800 SBC 2,X
|
||||
1810 STA FAC+2
|
||||
1820 LDA 1,Y
|
||||
1830 SBC 1,X
|
||||
1840 STA FAC+1
|
||||
1850 *--------------------------------
|
||||
1860 * NORMALIZE VALUE IN FAC
|
||||
1870 *--------------------------------
|
||||
1880 NORMALIZE.FAC.1
|
||||
1890 BCS NORMALIZE.FAC.2
|
||||
1900 JSR COMPLEMENT.FAC
|
||||
1910 *--------------------------------
|
||||
1920 NORMALIZE.FAC.2
|
||||
1930 LDY #0 SHIFT UP SIGNIF DIGIT
|
||||
1940 TYA START A=0, COUNT SHIFTS IN A-REG
|
||||
1950 CLC
|
||||
1960 .1 LDX FAC+1 LOOK AT MOST SIGNIFICANT BYTE
|
||||
1970 BNE NORMALIZE.FAC.4 SOME 1-BITS HERE
|
||||
1980 LDX FAC+2 HI-BYTE OF MANTISSA STILL ZERO,
|
||||
1990 STX FAC+1 SO DO A FAST 8-BIT SHUFFLE
|
||||
2000 LDX FAC+3
|
||||
2010 STX FAC+2
|
||||
2020 LDX FAC+4
|
||||
2030 STX FAC+3
|
||||
2040 LDX FAC.EXTENSION
|
||||
2050 STX FAC+4
|
||||
2060 STY FAC.EXTENSION ZERO EXTENSION BYTE
|
||||
2070 ADC #8 BUMP SHIFT COUNT
|
||||
2080 CMP #32 DONE 4 TIMES YET?
|
||||
2090 BNE .1 NO, STILL MIGHT BE SOME 1'S
|
||||
2100 * YES, VALUE OF FAC IS ZERO
|
||||
2110 *--------------------------------
|
||||
2120 * SET FAC = 0
|
||||
2130 * (ONLY NECESSARY TO ZERO EXPONENT AND SIGN CELLS)
|
||||
2140 *--------------------------------
|
||||
2150 ZERO.FAC
|
||||
2160 LDA #0
|
||||
2170 *--------------------------------
|
||||
2180 STA.IN.FAC.SIGN.AND.EXP
|
||||
2190 STA FAC
|
||||
2200 *--------------------------------
|
||||
2210 STA.IN.FAC.SIGN
|
||||
2220 STA FAC.SIGN
|
||||
2230 RTS
|
||||
2240 *--------------------------------
|
||||
2250 * ADD MANTISSAS OF FAC AND ARG INTO FAC
|
||||
2260 *--------------------------------
|
||||
2270 FADD.4 ADC ARG.EXTENSION
|
||||
2280 STA FAC.EXTENSION
|
||||
2290 LDA FAC+4
|
||||
2300 ADC ARG+4
|
||||
2310 STA FAC+4
|
||||
2320 LDA FAC+3
|
||||
2330 ADC ARG+3
|
||||
2340 STA FAC+3
|
||||
2350 LDA FAC+2
|
||||
2360 ADC ARG+2
|
||||
2370 STA FAC+2
|
||||
2380 LDA FAC+1
|
||||
2390 ADC ARG+1
|
||||
2400 STA FAC+1
|
||||
2410 JMP NORMALIZE.FAC.5
|
||||
2420 *--------------------------------
|
||||
2430 * FINISH NORMALIZING FAC
|
||||
2440 *--------------------------------
|
||||
2450 NORMALIZE.FAC.3
|
||||
2460 ADC #1 COUNT BITS SHIFTED
|
||||
2470 ASL FAC.EXTENSION
|
||||
2480 ROL FAC+4
|
||||
2490 ROL FAC+3
|
||||
2500 ROL FAC+2
|
||||
2510 ROL FAC+1
|
||||
2520 *--------------------------------
|
||||
2530 NORMALIZE.FAC.4
|
||||
2540 BPL NORMALIZE.FAC.3 UNTIL TOP BIT = 1
|
||||
2550 SEC
|
||||
2560 SBC FAC ADJUST EXPONENT BY BITS SHIFTED
|
||||
2570 BCS ZERO.FAC UNDERFLOW, RETURN ZERO
|
||||
2580 EOR #$FF
|
||||
2590 ADC #1 2'S COMPLEMENT
|
||||
2600 STA FAC CARRY=0 NOW
|
||||
2610 *--------------------------------
|
||||
2620 NORMALIZE.FAC.5
|
||||
2630 BCC RTS.11 UNLESS MANTISSA CARRIED
|
||||
2640 *--------------------------------
|
||||
2650 NORMALIZE.FAC.6
|
||||
2660 INC FAC MANTISSA CARRIED, SO SHIFT RIGHT
|
||||
2670 BEQ OVERFLOW OVERFLOW IF EXPONENT TOO BIG
|
||||
2680 ROR FAC+1
|
||||
2690 ROR FAC+2
|
||||
2700 ROR FAC+3
|
||||
2710 ROR FAC+4
|
||||
2720 ROR FAC.EXTENSION
|
||||
2730 RTS.11 RTS
|
||||
2740 *--------------------------------
|
||||
2750 * 2'S COMPLEMENT OF FAC
|
||||
2760 *--------------------------------
|
||||
2770 COMPLEMENT.FAC
|
||||
2780 LDA FAC.SIGN
|
||||
2790 EOR #$FF
|
||||
2800 STA FAC.SIGN
|
||||
2810 *--------------------------------
|
||||
2820 * 2'S COMPLEMENT OF FAC MANTISSA ONLY
|
||||
2830 *--------------------------------
|
||||
2840 COMPLEMENT.FAC.MANTISSA
|
||||
2850 LDA FAC+1
|
||||
2860 EOR #$FF
|
||||
2870 STA FAC+1
|
||||
2880 LDA FAC+2
|
||||
2890 EOR #$FF
|
||||
2900 STA FAC+2
|
||||
2910 LDA FAC+3
|
||||
2920 EOR #$FF
|
||||
2930 STA FAC+3
|
||||
2940 LDA FAC+4
|
||||
2950 EOR #$FF
|
||||
2960 STA FAC+4
|
||||
2970 LDA FAC.EXTENSION
|
||||
2980 EOR #$FF
|
||||
2990 STA FAC.EXTENSION
|
||||
3000 INC FAC.EXTENSION START INCREMENTING MANTISSA
|
||||
3010 BNE RTS.12
|
||||
3020 *--------------------------------
|
||||
3030 * INCREMENT FAC MANTISSA
|
||||
3040 *--------------------------------
|
||||
3050 INCREMENT.FAC.MANTISSA
|
||||
3060 INC FAC+4 ADD CARRY FROM EXTRA
|
||||
3070 BNE RTS.12
|
||||
3080 INC FAC+3
|
||||
3090 BNE RTS.12
|
||||
3100 INC FAC+2
|
||||
3110 BNE RTS.12
|
||||
3120 INC FAC+1
|
||||
3130 RTS.12 RTS
|
||||
3140 *--------------------------------
|
||||
3150 OVERFLOW
|
||||
3160 LDX #ERR.OVERFLOW
|
||||
3170 JMP ERROR
|
||||
3180 *--------------------------------
|
||||
3190 * SHIFT 1,X THRU 5,X RIGHT
|
||||
3200 * (A) = NEGATIVE OF SHIFT COUNT
|
||||
3210 * (X) = POINTER TO BYTES TO BE SHIFTED
|
||||
3220 *
|
||||
3230 * RETURN WITH (Y)=0, CARRY=0, EXTENSION BITS IN A-REG
|
||||
3240 *--------------------------------
|
||||
3250 SHIFT.RIGHT.1
|
||||
3260 LDX #RESULT-1 SHIFT RESULT RIGHT
|
||||
3270 SHIFT.RIGHT.2
|
||||
3280 LDY 4,X SHIFT 8 BITS RIGHT
|
||||
3290 STY FAC.EXTENSION
|
||||
3300 LDY 3,X
|
||||
3310 STY 4,X
|
||||
3320 LDY 2,X
|
||||
3330 STY 3,X
|
||||
3340 LDY 1,X
|
||||
3350 STY 2,X
|
||||
3360 LDY SHIFT.SIGN.EXT $00 IF +, $FF IF -
|
||||
3370 STY 1,X
|
||||
3380 *--------------------------------
|
||||
3390 * MAIN ENTRY TO RIGHT SHIFT SUBROUTINE
|
||||
3400 *--------------------------------
|
||||
3410 SHIFT.RIGHT
|
||||
3420 ADC #8
|
||||
3430 BMI SHIFT.RIGHT.2 STILL MORE THAN 8 BITS TO GO
|
||||
3440 BEQ SHIFT.RIGHT.2 EXACTLY 8 MORE BITS TO GO
|
||||
3450 SBC #8 UNDO ADC ABOVE
|
||||
3460 TAY REMAINING SHIFT COUNT
|
||||
3470 LDA FAC.EXTENSION
|
||||
3480 BCS SHIFT.RIGHT.5 FINISHED SHIFTING
|
||||
3490 SHIFT.RIGHT.3
|
||||
3500 L ASL 1,X SIGN -> CARRY (SIGN EXTENSION)
|
||||
3510 BCC .1 SIGN +
|
||||
3520 INC 1,X PUT SIGN IN LSB
|
||||
3530 .1 ROR 1,X RESTORE VALUE, SIGN STILL IN CARRY
|
||||
3540 ROR 1,X START RIGHT SHIFT, INSERTING SIGN
|
||||
3550 *--------------------------------
|
||||
3560 * ENTER HERE FOR SHORT SHIFTS WITH NO SIGN EXTENSION
|
||||
3570 *--------------------------------
|
||||
3580 SHIFT.RIGHT.4
|
||||
3590 ROR 2,X
|
||||
3600 ROR 3,X
|
||||
3610 ROR 4,X
|
||||
3620 ROR EXTENSION
|
||||
3630 INY COUNT THE SHIFT
|
||||
3640 BNE SHIFT.RIGHT.3
|
||||
3650 SHIFT.RIGHT.5
|
||||
3660 CLC RETURN WITH CARRY CLEAR
|
||||
3670 RTS
|
||||
3680 *--------------------------------
|
||||
396
source/applesoft/S.E913
Normal file
396
source/applesoft/S.E913
Normal file
@ -0,0 +1,396 @@
|
||||
1010 *--------------------------------
|
||||
1020 CON.ONE .HS 8100000000
|
||||
1030 *--------------------------------
|
||||
1040 POLY.LOG .DA #3 # OF COEFFICIENTS - 1
|
||||
1050 .HS 7F5E56CB79 * X^7 +
|
||||
1060 .HS 80139B0B64 * X^5 +
|
||||
1070 .HS 8076389316 * X^3 +
|
||||
1080 .HS 8238AA3B20 * X
|
||||
1090 *--------------------------------
|
||||
1100 CON.SQR.HALF .HS 803504F334
|
||||
1110 CON.SQR.TWO .HS 813504F334
|
||||
1120 CON.NEG.HALF .HS 8080000000
|
||||
1130 CON.LOG.TWO .HS 80317217F8
|
||||
1140 *--------------------------------
|
||||
1150 * "LOG" FUNCTION
|
||||
1160 *--------------------------------
|
||||
1170 LOG JSR SIGN GET -1,0,+1 IN A-REG FOR FAC
|
||||
1180 BEQ GIQ LOG (0) IS ILLEGAL
|
||||
1190 BPL LOG.2 >0 IS OK
|
||||
1200 GIQ JMP IQERR <= 0 IS NO GOOD
|
||||
1210 LOG.2 LDA FAC FIRST GET LOG BASE 2
|
||||
1220 SBC #$7F SAVE UNBIASED EXPONENT
|
||||
1230 PHA
|
||||
1240 LDA #$80 NORMALIZE BETWEEN .5 AND 1
|
||||
1250 STA FAC
|
||||
1260 LDA #CON.SQR.HALF
|
||||
1270 LDY /CON.SQR.HALF
|
||||
1280 JSR FADD COMPUTE VIA SERIES OF ODD
|
||||
1290 LDA #CON.SQR.TWO POWERS OF
|
||||
1300 LDY /CON.SQR.TWO (SQR(2)X-1)/(SQR(2)X+1)
|
||||
1310 JSR FDIV
|
||||
1320 LDA #CON.ONE
|
||||
1330 LDY /CON.ONE
|
||||
1340 JSR FSUB
|
||||
1350 LDA #POLY.LOG
|
||||
1360 LDY /POLY.LOG
|
||||
1370 JSR POLYNOMIAL.ODD
|
||||
1380 LDA #CON.NEG.HALF
|
||||
1390 LDY /CON.NEG.HALF
|
||||
1400 JSR FADD
|
||||
1410 PLA
|
||||
1420 JSR ADDACC ADD ORIGINAL EXPONENT
|
||||
1430 LDA #CON.LOG.TWO MULTIPLY BY LOG(2) TO FORM
|
||||
1440 LDY /CON.LOG.TWO NATURAL LOG OF X
|
||||
1450 *--------------------------------
|
||||
1460 * FAC = (Y,A) * FAC
|
||||
1470 *--------------------------------
|
||||
1480 FMULT JSR LOAD.ARG.FROM.YA
|
||||
1490 *--------------------------------
|
||||
1500 * FAC = ARG * FAC
|
||||
1510 *--------------------------------
|
||||
1520 FMULTT BNE .1 FAC .NE. ZERO
|
||||
1530 JMP RTS.13 FAC = 0 * ARG = 0
|
||||
1540 * <<< WHY IS LINE ABOVE JUST "RTS"? >>>
|
||||
1550 *--------------------------------
|
||||
1560 *
|
||||
1570 *--------------------------------
|
||||
1580 .1 JSR ADD.EXPONENTS
|
||||
1590 LDA #0
|
||||
1600 STA RESULT INIT PRODUCT = 0
|
||||
1610 STA RESULT+1
|
||||
1620 STA RESULT+2
|
||||
1630 STA RESULT+3
|
||||
1640 LDA FAC.EXTENSION
|
||||
1650 JSR MULTIPLY.1
|
||||
1660 LDA FAC+4
|
||||
1670 JSR MULTIPLY.1
|
||||
1680 LDA FAC+3
|
||||
1690 JSR MULTIPLY.1
|
||||
1700 LDA FAC+2
|
||||
1710 JSR MULTIPLY.1
|
||||
1720 LDA FAC+1
|
||||
1730 JSR MULTIPLY.2
|
||||
1740 JMP COPY.RESULT.INTO.FAC
|
||||
1750 *--------------------------------
|
||||
1760 * MULTIPLY ARG BY (A) INTO RESULT
|
||||
1770 *--------------------------------
|
||||
1780 MULTIPLY.1
|
||||
1790 BNE MULTIPLY.2 THIS BYTE NON-ZERO
|
||||
1800 JMP SHIFT.RIGHT.1 (A)=0, JUST SHIFT ARG RIGHT 8
|
||||
1810 *--------------------------------
|
||||
1820 MULTIPLY.2
|
||||
1830 LSR SHIFT BIT INTO CARRY
|
||||
1840 ORA #$80 SUPPLY SENTINEL BIT
|
||||
1850 .1 TAY REMAINING MULTIPLIER TO Y
|
||||
1860 BCC .2 THIS MULTIPLIER BIT = 0
|
||||
1870 CLC = 1, SO ADD ARG TO RESULT
|
||||
1880 LDA RESULT+3
|
||||
1890 ADC ARG+4
|
||||
1900 STA RESULT+3
|
||||
1910 LDA RESULT+2
|
||||
1920 ADC ARG+3
|
||||
1930 STA RESULT+2
|
||||
1940 LDA RESULT+1
|
||||
1950 ADC ARG+2
|
||||
1960 STA RESULT+1
|
||||
1970 LDA RESULT
|
||||
1980 ADC ARG+1
|
||||
1990 STA RESULT
|
||||
2000 .2 ROR RESULT SHIFT RESULT RIGHT 1
|
||||
2010 ROR RESULT+1
|
||||
2020 ROR RESULT+2
|
||||
2030 ROR RESULT+3
|
||||
2040 ROR FAC.EXTENSION
|
||||
2050 TYA REMAINING MULTIPLIER
|
||||
2060 LSR LSB INTO CARRY
|
||||
2070 BNE .1 IF SENTINEL STILL HERE, MULTIPLY
|
||||
2080 RTS.13 RTS 8 X 32 COMPLETED
|
||||
2090 *--------------------------------
|
||||
2100 * UNPACK NUMBER AT (Y,A) INTO ARG
|
||||
2110 *--------------------------------
|
||||
2120 LOAD.ARG.FROM.YA
|
||||
2130 STA INDEX USE INDEX FOR PNTR
|
||||
2140 STY INDEX+1
|
||||
2150 LDY #4 FIVE BYTES TO MOVE
|
||||
2160 LDA (INDEX),Y
|
||||
2170 STA ARG+4
|
||||
2180 DEY
|
||||
2190 LDA (INDEX),Y
|
||||
2200 STA ARG+3
|
||||
2210 DEY
|
||||
2220 LDA (INDEX),Y
|
||||
2230 STA ARG+2
|
||||
2240 DEY
|
||||
2250 LDA (INDEX),Y
|
||||
2260 STA ARG.SIGN
|
||||
2270 EOR FAC.SIGN SET COMBINED SIGN FOR MULT/DIV
|
||||
2280 STA SGNCPR
|
||||
2290 LDA ARG.SIGN TURN ON NORMALIZED INVISIBLE BIT
|
||||
2300 ORA #$80 TO COMPLETE MANTISSA
|
||||
2310 STA ARG+1
|
||||
2320 DEY
|
||||
2330 LDA (INDEX),Y
|
||||
2340 STA ARG EXPONENT
|
||||
2350 LDA FAC SET STATUS BITS ON FAC EXPONENT
|
||||
2360 RTS
|
||||
2370 *--------------------------------
|
||||
2380 * ADD EXPONENTS OF ARG AND FAC
|
||||
2390 * (CALLED BY FMULT AND FDIV)
|
||||
2400 *
|
||||
2410 * ALSO CHECK FOR OVERFLOW, AND SET RESULT SIGN
|
||||
2420 *--------------------------------
|
||||
2430 ADD.EXPONENTS
|
||||
2440 LDA ARG
|
||||
2450 *--------------------------------
|
||||
2460 ADD.EXPONENTS.1
|
||||
2470 BEQ ZERO IF ARG=0, RESULT IS ZERO
|
||||
2480 CLC
|
||||
2490 ADC FAC
|
||||
2500 BCC .1 IN RANGE
|
||||
2510 BMI JOV OVERFLOW
|
||||
2520 CLC
|
||||
2530 .HS 2C TRICK TO SKIP
|
||||
2540 .1 BPL ZERO OVERFLOW
|
||||
2550 ADC #$80 RE-BIAS
|
||||
2560 STA FAC RESULT
|
||||
2570 BNE .2
|
||||
2580 JMP STA.IN.FAC.SIGN RESULT IS ZERO
|
||||
2590 * <<< CRAZY TO JUMP WAY BACK THERE! >>>
|
||||
2600 * <<< SAME IDENTICAL CODE IS BELOW! >>>
|
||||
2610 * <<< INSTEAD OF BNE .2, JMP STA.IN.FAC.SIGN >>>
|
||||
2620 * <<< ONLY NEEDED BEQ .3 >>>
|
||||
2630 .2 LDA SGNCPR SET SIGN OF RESULT
|
||||
2640 .3 STA FAC.SIGN
|
||||
2650 RTS
|
||||
2660 *--------------------------------
|
||||
2670 * IF (FAC) IS POSITIVE, GIVE "OVERFLOW" ERROR
|
||||
2680 * IF (FAC) IS NEGATIVE, SET FAC=0, POP ONE RETURN, AND RTS
|
||||
2690 * CALLED FROM "EXP" FUNCTION
|
||||
2700 *--------------------------------
|
||||
2710 OUTOFRNG
|
||||
2720 LDA FAC.SIGN
|
||||
2730 EOR #$FF
|
||||
2740 BMI JOV ERROR IF POSITIVE #
|
||||
2750 *--------------------------------
|
||||
2760 * POP RETURN ADDRESS AND SET FAC=0
|
||||
2770 *--------------------------------
|
||||
2780 ZERO PLA
|
||||
2790 PLA
|
||||
2800 JMP ZERO.FAC
|
||||
2810 *--------------------------------
|
||||
2820 JOV JMP OVERFLOW
|
||||
2830 *--------------------------------
|
||||
2840 * MULTIPLY FAC BY 10
|
||||
2850 *--------------------------------
|
||||
2860 MUL10 JSR COPY.FAC.TO.ARG.ROUNDED
|
||||
2870 TAX TEXT FAC EXPONENT
|
||||
2880 BEQ .1 FINISHED IF FAC=0
|
||||
2890 CLC
|
||||
2900 ADC #2 ADD 2 TO EXPONENT GIVES (FAC)*4
|
||||
2910 BCS JOV OVERFLOW
|
||||
2920 LDX #0
|
||||
2930 STX SGNCPR
|
||||
2940 JSR FADD.2 MAKES (FAC)*5
|
||||
2950 INC FAC *2, MAKES (FAC)*10
|
||||
2960 BEQ JOV OVERFLOW
|
||||
2970 .1 RTS
|
||||
2980 *--------------------------------
|
||||
2990 CON.TEN .HS 8420000000
|
||||
3000 *--------------------------------
|
||||
3010 * DIVIDE FAC BY 10
|
||||
3020 *--------------------------------
|
||||
3030 DIV10 JSR COPY.FAC.TO.ARG.ROUNDED
|
||||
3040 LDA #CON.TEN SET UP TO PUT
|
||||
3050 LDY /CON.TEN 10 IN FAC
|
||||
3060 LDX #0
|
||||
3070 *--------------------------------
|
||||
3080 * FAC = ARG / (Y,A)
|
||||
3090 *--------------------------------
|
||||
3100 DIV STX SGNCPR
|
||||
3110 JSR LOAD.FAC.FROM.YA
|
||||
3120 JMP FDIVT DIVIDE ARG BY FAC
|
||||
3130 *--------------------------------
|
||||
3140 * FAC = (Y,A) / FAC
|
||||
3150 *--------------------------------
|
||||
3160 FDIV JSR LOAD.ARG.FROM.YA
|
||||
3170 *--------------------------------
|
||||
3180 * FAC = ARG / FAC
|
||||
3190 *--------------------------------
|
||||
3200 FDIVT BEQ .8 FAC = 0, DIVIDE BY ZERO ERROR
|
||||
3210 JSR ROUND.FAC
|
||||
3220 LDA #0 NEGATE FAC EXPONENT, SO
|
||||
3230 SEC ADD.EXPONENTS FORMS DIFFERENCE
|
||||
3240 SBC FAC
|
||||
3250 STA FAC
|
||||
3260 JSR ADD.EXPONENTS
|
||||
3270 INC FAC
|
||||
3280 BEQ JOV OVERFLOW
|
||||
3290 LDX #-4 INDEX FOR RESULT
|
||||
3300 LDA #1 SENTINEL
|
||||
3310 .1 LDY ARG+1 SEE IF FAC CAN BE SUBTRACTED
|
||||
3320 CPY FAC+1
|
||||
3330 BNE .2
|
||||
3340 LDY ARG+2
|
||||
3350 CPY FAC+2
|
||||
3360 BNE .2
|
||||
3370 LDY ARG+3
|
||||
3380 CPY FAC+3
|
||||
3390 BNE .2
|
||||
3400 LDY ARG+4
|
||||
3410 CPY FAC+4
|
||||
3420 .2 PHP SAVE THE ANSWER, AND ALSO ROLL THE
|
||||
3430 ROL BIT INTO THE QUOTIENT, SENTINEL OUT
|
||||
3440 BCC .3 NO SENTINEL, STILL NOT 8 TRIPS
|
||||
3450 INX 8 TRIPS, STORE BYTE OF QUOTIENT
|
||||
3460 STA RESULT+3,X
|
||||
3470 BEQ .6 32-BITS COMPLETED
|
||||
3480 BPL .7 FINAL EXIT WHEN X=1
|
||||
3490 LDA #1 RE-START SENTINEL
|
||||
3500 .3 PLP GET ANSWER, CAN FAC BE SUBTRACTED?
|
||||
3510 BCS .5 YES, DO IT
|
||||
3520 .4 ASL ARG+4 NO, SHIFT ARG LEFT
|
||||
3530 ROL ARG+3
|
||||
3540 ROL ARG+2
|
||||
3550 ROL ARG+1
|
||||
3560 BCS .2 ANOTHER TRIP
|
||||
3570 BMI .1 HAVE TO COMPARE FIRST
|
||||
3580 BPL .2 ...ALWAYS
|
||||
3590 .5 TAY SAVE QUOTIENT/SENTINEL BYTE
|
||||
3600 LDA ARG+4 SUBTRACT FAC FROM ARG ONCE
|
||||
3610 SBC FAC+4
|
||||
3620 STA ARG+4
|
||||
3630 LDA ARG+3
|
||||
3640 SBC FAC+3
|
||||
3650 STA ARG+3
|
||||
3660 LDA ARG+2
|
||||
3670 SBC FAC+2
|
||||
3680 STA ARG+2
|
||||
3690 LDA ARG+1
|
||||
3700 SBC FAC+1
|
||||
3710 STA ARG+1
|
||||
3720 TYA RESTORE QUOTIENT/SENTINEL BYTE
|
||||
3730 JMP .4 GO TO SHIFT ARG AND CONTINUE
|
||||
3740 *--------------------------------
|
||||
3750 .6 LDA #$40 DO A FEW EXTENSION BITS
|
||||
3760 BNE .3 ...ALWAYS
|
||||
3770 *--------------------------------
|
||||
3780 .7 ASL LEFT JUSTIFY THE EXTENSION BITS WE DID
|
||||
3790 ASL
|
||||
3800 ASL
|
||||
3810 ASL
|
||||
3820 ASL
|
||||
3830 ASL
|
||||
3840 STA FAC.EXTENSION
|
||||
3850 PLP
|
||||
3860 JMP COPY.RESULT.INTO.FAC
|
||||
3870 *--------------------------------
|
||||
3880 .8 LDX #ERR.ZERODIV
|
||||
3890 JMP ERROR
|
||||
3900 *--------------------------------
|
||||
3910 * COPY RESULT INTO FAC MANTISSA, AND NORMALIZE
|
||||
3920 *--------------------------------
|
||||
3930 COPY.RESULT.INTO.FAC
|
||||
3940 LDA RESULT
|
||||
3950 STA FAC+1
|
||||
3960 LDA RESULT+1
|
||||
3970 STA FAC+2
|
||||
3980 LDA RESULT+2
|
||||
3990 STA FAC+3
|
||||
4000 LDA RESULT+3
|
||||
4010 STA FAC+4
|
||||
4020 JMP NORMALIZE.FAC.2
|
||||
4030 *--------------------------------
|
||||
4040 * UNPACK (Y,A) INTO FAC
|
||||
4050 *--------------------------------
|
||||
4060 LOAD.FAC.FROM.YA
|
||||
4070 STA INDEX USE INDEX FOR PNTR
|
||||
4080 STY INDEX+1
|
||||
4090 LDY #4 PICK UP 5 BYTES
|
||||
4100 LDA (INDEX),Y
|
||||
4110 STA FAC+4
|
||||
4120 DEY
|
||||
4130 LDA (INDEX),Y
|
||||
4140 STA FAC+3
|
||||
4150 DEY
|
||||
4160 LDA (INDEX),Y
|
||||
4170 STA FAC+2
|
||||
4180 DEY
|
||||
4190 LDA (INDEX),Y
|
||||
4200 STA FAC.SIGN FIRST BIT IS SIGN
|
||||
4210 ORA #$80 SET NORMALIZED INVISIBLE BIT
|
||||
4220 STA FAC+1
|
||||
4230 DEY
|
||||
4240 LDA (INDEX),Y
|
||||
4250 STA FAC EXPONENT
|
||||
4260 STY FAC.EXTENSION Y=0
|
||||
4270 RTS
|
||||
4280 *--------------------------------
|
||||
4290 * ROUND FAC, STORE IN TEMP2
|
||||
4300 *--------------------------------
|
||||
4310 STORE.FAC.IN.TEMP2.ROUNDED
|
||||
4320 LDX #TEMP2 PACK FAC INTO TEMP2
|
||||
4330 .HS 2C TRICK TO BRANCH
|
||||
4340 *--------------------------------
|
||||
4350 * ROUND FAC, STORE IN TEMP1
|
||||
4360 *--------------------------------
|
||||
4370 STORE.FAC.IN.TEMP1.ROUNDED
|
||||
4380 LDX #TEMP1 PACK FAC INTO TEMP1
|
||||
4390 LDY /TEMP1 HI-BYTE OF TEMP1 SAME AS TEMP2
|
||||
4400 BEQ STORE.FAC.AT.YX.ROUNDED ...ALWAYS
|
||||
4410 *--------------------------------
|
||||
4420 * ROUND FAC, AND STORE WHERE FORPNT POINTS
|
||||
4430 *--------------------------------
|
||||
4440 SETFOR LDX FORPNT
|
||||
4450 LDY FORPNT+1
|
||||
4460 *--------------------------------
|
||||
4470 * ROUND FAC, AND STORE AT (Y,X)
|
||||
4480 *--------------------------------
|
||||
4490 STORE.FAC.AT.YX.ROUNDED
|
||||
4500 JSR ROUND.FAC ROUND VALUE IN FAC USING EXTENSION
|
||||
4510 STX INDEX USE INDEX FOR PNTR
|
||||
4520 STY INDEX+1
|
||||
4530 LDY #4 STORING 5 PACKED BYTES
|
||||
4540 LDA FAC+4
|
||||
4550 STA (INDEX),Y
|
||||
4560 DEY
|
||||
4570 LDA FAC+3
|
||||
4580 STA (INDEX),Y
|
||||
4590 DEY
|
||||
4600 LDA FAC+2
|
||||
4610 STA (INDEX),Y
|
||||
4620 DEY
|
||||
4630 LDA FAC.SIGN PACK SIGN IN TOP BIT OF MANTISSA
|
||||
4640 ORA #$7F
|
||||
4650 AND FAC+1
|
||||
4660 STA (INDEX),Y
|
||||
4670 DEY
|
||||
4680 LDA FAC EXPONENT
|
||||
4690 STA (INDEX),Y
|
||||
4700 STY FAC.EXTENSION ZERO THE EXTENSION
|
||||
4710 RTS
|
||||
4720 *--------------------------------
|
||||
4730 * COPY ARG INTO FAC
|
||||
4740 *--------------------------------
|
||||
4750 COPY.ARG.TO.FAC
|
||||
4760 LDA ARG.SIGN COPY SIGN
|
||||
4770 MFA STA FAC.SIGN
|
||||
4780 LDX #5 MOVE 5 BYTES
|
||||
4790 .1 LDA ARG-1,X
|
||||
4800 STA FAC-1,X
|
||||
4810 DEX
|
||||
4820 BNE .1
|
||||
4830 STX FAC.EXTENSION ZERO EXTENSION
|
||||
4840 RTS
|
||||
4850 *--------------------------------
|
||||
4860 * ROUND FAC AND COPY TO ARG
|
||||
4870 *--------------------------------
|
||||
4880 COPY.FAC.TO.ARG.ROUNDED
|
||||
4890 JSR ROUND.FAC ROUND FAC USING EXTENSION
|
||||
4900 MAF LDX #6 COPY 6 BYTES, INCLUDES SIGN
|
||||
4910 .1 LDA FAC-1,X
|
||||
4920 STA ARG-1,X
|
||||
4930 DEX
|
||||
4940 BNE .1
|
||||
4950 STX FAC.EXTENSION ZERO FAC EXTENSION
|
||||
4960 RTS.14 RTS
|
||||
180
source/applesoft/S.EB72
Normal file
180
source/applesoft/S.EB72
Normal file
@ -0,0 +1,180 @@
|
||||
1010 *--------------------------------
|
||||
1020 * ROUND FAC USING EXTENSION BYTE
|
||||
1030 *--------------------------------
|
||||
1040 ROUND.FAC
|
||||
1050 LDA FAC
|
||||
1060 BEQ RTS.14 FAC = 0, RETURN
|
||||
1070 ASL FAC.EXTENSION IS FAC.EXTENSION >= 128?
|
||||
1080 BCC RTS.14 NO, FINISHED
|
||||
1090 *--------------------------------
|
||||
1100 * INCREMENT MANTISSA AND RE-NORMALIZE IF CARRY
|
||||
1110 *--------------------------------
|
||||
1120 INCREMENT.MANTISSA
|
||||
1130 JSR INCREMENT.FAC.MANTISSA YES, INCREMENT FAC
|
||||
1140 BNE RTS.14 HIGH BYTE HAS BITS, FINISHED
|
||||
1150 JMP NORMALIZE.FAC.6 HI-BYTE=0, SO SHIFT LEFT
|
||||
1160 *--------------------------------
|
||||
1170 * TEST FAC FOR ZERO AND SIGN
|
||||
1180 *
|
||||
1190 * FAC > 0, RETURN +1
|
||||
1200 * FAC = 0, RETURN 0
|
||||
1210 * FAC < 0, RETURN -1
|
||||
1220 *--------------------------------
|
||||
1230 SIGN LDA FAC CHECK SIGN OF FAC AND
|
||||
1240 BEQ RTS.15 RETURN -1,0,1 IN A-REG
|
||||
1250 *--------------------------------
|
||||
1260 SIGN1 LDA FAC.SIGN
|
||||
1270 *--------------------------------
|
||||
1280 SIGN2 ROL MSBIT TO CARRY
|
||||
1290 LDA #$FF -1
|
||||
1300 BCS RTS.15 MSBIT = 1
|
||||
1310 LDA #1 +1
|
||||
1320 RTS.15 RTS
|
||||
1330 *--------------------------------
|
||||
1340 * "SGN" FUNCTION
|
||||
1350 *--------------------------------
|
||||
1360 SGN JSR SIGN CONVERT FAC TO -1,0,1
|
||||
1370 *--------------------------------
|
||||
1380 * CONVERT (A) INTO FAC, AS SIGNED VALUE -128 TO +127
|
||||
1390 *--------------------------------
|
||||
1400 FLOAT STA FAC+1 PUT IN HIGH BYTE OF MANTISSA
|
||||
1410 LDA #0 CLEAR 2ND BYTE OF MANTISSA
|
||||
1420 STA FAC+2
|
||||
1430 LDX #$88 USE EXPONENT 2^9
|
||||
1440 *--------------------------------
|
||||
1450 * FLOAT UNSIGNED VALUE IN FAC+1,2
|
||||
1460 * (X) = EXPONENT
|
||||
1470 *--------------------------------
|
||||
1480 FLOAT.1
|
||||
1490 LDA FAC+1 MSBIT=0, SET CARRY; =1, CLEAR CARRY
|
||||
1500 EOR #$FF
|
||||
1510 ROL
|
||||
1520 *--------------------------------
|
||||
1530 * FLOAT UNSIGNED VALUE IN FAC+1,2
|
||||
1540 * (X) = EXPONENT
|
||||
1550 * C=0 TO MAKE VALUE NEGATIVE
|
||||
1560 * C=1 TO MAKE VALUE POSITIVE
|
||||
1570 *--------------------------------
|
||||
1580 FLOAT.2
|
||||
1590 LDA #0 CLEAR LOWER 16-BITS OF MANTISSA
|
||||
1600 STA FAC+4
|
||||
1610 STA FAC+3
|
||||
1620 STX FAC STORE EXPONENT
|
||||
1630 STA FAC.EXTENSION CLEAR EXTENSION
|
||||
1640 STA FAC.SIGN MAKE SIGN POSITIVE
|
||||
1650 JMP NORMALIZE.FAC.1 IF C=0, WILL NEGATE FAC
|
||||
1660 *--------------------------------
|
||||
1670 * "ABS" FUNCTION
|
||||
1680 *--------------------------------
|
||||
1690 ABS LSR FAC.SIGN CHANGE SIGN TO +
|
||||
1700 RTS
|
||||
1710 *--------------------------------
|
||||
1720 * COMPARE FAC WITH PACKED # AT (Y,A)
|
||||
1730 * RETURN A=1,0,-1 AS (Y,A) IS <,=,> FAC
|
||||
1740 *--------------------------------
|
||||
1750 FCOMP STA DEST USE DEST FOR PNTR
|
||||
1760 *--------------------------------
|
||||
1770 * SPECIAL ENTRY FROM "NEXT" PROCESSOR
|
||||
1780 * "DEST" ALREADY SET UP
|
||||
1790 *--------------------------------
|
||||
1800 FCOMP2 STY DEST+1
|
||||
1810 LDY #0 GET EXPONENT OF COMPARAND
|
||||
1820 LDA (DEST),Y
|
||||
1830 INY POINT AT NEXT BYTE
|
||||
1840 TAX EXPONENT TO X-REG
|
||||
1850 BEQ SIGN IF COMPARAND=0, "SIGN" COMPARES FAC
|
||||
1860 LDA (DEST),Y GET HI-BYTE OF MANTISSA
|
||||
1870 EOR FAC.SIGN COMPARE WITH FAC SIGN
|
||||
1880 BMI SIGN1 DIFFERENT SIGNS, "SIGN" GIVES ANSWER
|
||||
1890 CPX FAC SAME SIGN, SO COMPARE EXPONENTS
|
||||
1900 BNE .1 DIFFERENT, SO SUFFICIENT TEST
|
||||
1910 LDA (DEST),Y SAME EXPONENT, COMPARE MANTISSA
|
||||
1920 ORA #$80 SET INVISIBLE NORMALIZED BIT
|
||||
1930 CMP FAC+1
|
||||
1940 BNE .1 NOT SAME, SO SUFFICIENT
|
||||
1950 INY SAME, COMPARE MORE MANTISSA
|
||||
1960 LDA (DEST),Y
|
||||
1970 CMP FAC+2
|
||||
1980 BNE .1 NOT SAME, SO SUFFICIENT
|
||||
1990 INY SAME, COMPARE MORE MANTISSA
|
||||
2000 LDA (DEST),Y
|
||||
2010 CMP FAC+3
|
||||
2020 BNE .1 NOT SAME, SO SUFFICIENT
|
||||
2030 INY SAME, COMPARE REST OF MANTISSA
|
||||
2040 LDA #$7F ARTIFICIAL EXTENSION BYTE FOR COMPARAND
|
||||
2050 CMP FAC.EXTENSION
|
||||
2060 LDA (DEST),Y
|
||||
2070 SBC FAC+4
|
||||
2080 BEQ RTS.16 NUMBERS ARE EQUAL, RETURN (A)=0
|
||||
2090 .1 LDA FAC.SIGN NUMBERS ARE DIFFERENT
|
||||
2100 BCC .2 FAC IS LARGER MAGNITUDE
|
||||
2110 EOR #$FF FAC IS SMALLER MAGNITUDE
|
||||
2120 * <<< NOTE THAT ABOVE THREE LINES CAN BE SHORTENED: >>>
|
||||
2130 * <<< .1 ROR PUT CARRY INTO SIGN BIT >>>
|
||||
2140 * <<< EOR FAC.SIGN TOGGLE WITH SIGN OF FAC >>>
|
||||
2150 .2 JMP SIGN2 CONVERT +1 OR -1
|
||||
2160 *--------------------------------
|
||||
2170 * QUICK INTEGER FUNCTION
|
||||
2180 *
|
||||
2190 * CONVERTS FP VALUE IN FAC TO INTEGER VALUE
|
||||
2200 * IN FAC+1...FAC+4, BY SHIFTING RIGHT WITH SIGN
|
||||
2210 * EXTENSION UNTIL FRACTIONAL BITS ARE OUT.
|
||||
2220 *
|
||||
2230 * THIS SUBROUTINE ASSUMES THE EXPONENT < 32.
|
||||
2240 *--------------------------------
|
||||
2250 QINT LDA FAC LOOK AT FAC EXPONENT
|
||||
2260 BEQ QINT.3 FAC=0, SO FINISHED
|
||||
2270 SEC GET -(NUMBER OF FRACTIONAL BITS)
|
||||
2280 SBC #$A0 IN A-REG FOR SHIFT COUNT
|
||||
2290 BIT FAC.SIGN CHECK SIGN OF FAC
|
||||
2300 BPL .1 POSITIVE, CONTINUE
|
||||
2310 TAX NEGATIVE, SO COMPLEMENT MANTISSA
|
||||
2320 LDA #$FF AND SET SIGN EXTENSION FOR SHIFT
|
||||
2330 STA SHIFT.SIGN.EXT
|
||||
2340 JSR COMPLEMENT.FAC.MANTISSA
|
||||
2350 TXA RESTORE BIT COUNT TO A-REG
|
||||
2360 .1 LDX #FAC POINT SHIFT SUBROUTINE AT FAC
|
||||
2370 CMP #$F9 MORE THAN 7 BITS TO SHIFT?
|
||||
2380 BPL QINT.2 NO, SHORT SHIFT
|
||||
2390 JSR SHIFT.RIGHT YES, USE GENERAL ROUTINE
|
||||
2400 STY SHIFT.SIGN.EXT Y=0, CLEAR SIGN EXTENSION
|
||||
2410 RTS.16 RTS
|
||||
2420 *--------------------------------
|
||||
2430 QINT.2 TAY SAVE SHIFT COUNT
|
||||
2440 LDA FAC.SIGN GET SIGN BIT
|
||||
2450 AND #$80
|
||||
2460 LSR FAC+1 START RIGHT SHIFT
|
||||
2470 ORA FAC+1 AND MERGE WITH SIGN
|
||||
2480 STA FAC+1
|
||||
2490 JSR SHIFT.RIGHT.4 JUMP INTO MIDDLE OF SHIFTER
|
||||
2500 STY SHIFT.SIGN.EXT Y=0, CLEAR SIGN EXTENSION
|
||||
2510 RTS
|
||||
2520 *--------------------------------
|
||||
2530 * "INT" FUNCTION
|
||||
2540 *
|
||||
2550 * USES QINT TO CONVERT (FAC) TO INTEGER FORM,
|
||||
2560 * AND THEN REFLOATS THE INTEGER.
|
||||
2570 * <<< A FASTER APPROACH WOULD SIMPLY CLEAR >>>
|
||||
2580 * <<< THE FRACTIONAL BITS BY ZEROING THEM >>>
|
||||
2590 *--------------------------------
|
||||
2600 INT LDA FAC CHECK IF EXPONENT < 32
|
||||
2610 CMP #$A0 BECAUSE IF > 31 THERE IS NO FRACTION
|
||||
2620 BCS RTS.17 NO FRACTION, WE ARE FINISHED
|
||||
2630 JSR QINT USE GENERAL INTEGER CONVERSION
|
||||
2640 STY FAC.EXTENSION Y=0, CLEAR EXTENSION
|
||||
2650 LDA FAC.SIGN GET SIGN OF VALUE
|
||||
2660 STY FAC.SIGN Y=0, CLEAR SIGN
|
||||
2670 EOR #$80 TOGGLE ACTUAL SIGN
|
||||
2680 ROL AND SAVE IN CARRY
|
||||
2690 LDA #$A0 SET EXPONENT TO 32
|
||||
2700 STA FAC BECAUSE 4-BYTE INTEGER NOW
|
||||
2710 LDA FAC+4 SAVE LOW 8-BITS OF INTEGER FORM
|
||||
2720 STA CHARAC FOR EXP AND POWER
|
||||
2730 JMP NORMALIZE.FAC.1 NORMALIZE TO FINISH CONVERSION
|
||||
2740 *--------------------------------
|
||||
2750 QINT.3 STA FAC+1 FAC=0, SO CLEAR ALL 4 BYTES FOR
|
||||
2760 STA FAC+2 INTEGER VERSION
|
||||
2770 STA FAC+3
|
||||
2780 STA FAC+4
|
||||
2790 TAY Y=0 TOO
|
||||
2800 RTS.17 RTS
|
||||
132
source/applesoft/S.EC4A
Normal file
132
source/applesoft/S.EC4A
Normal file
@ -0,0 +1,132 @@
|
||||
1010 *--------------------------------
|
||||
1020 * CONVERT STRING TO FP VALUE IN FAC
|
||||
1030 *
|
||||
1040 * STRING POINTED TO BY TXTPTR
|
||||
1050 * FIRST CHAR ALREADY SCANNED BY CHRGET
|
||||
1060 * (A) = FIRST CHAR, C=0 IF DIGIT.
|
||||
1070 *--------------------------------
|
||||
1080 FIN LDY #0 CLEAR WORKING AREA ($99...$A3)
|
||||
1090 LDX #10 TMPEXP, EXPON, DPFLG, EXPSGN, FAC, SERLEN
|
||||
1100 .1 STY TMPEXP,X
|
||||
1110 DEX
|
||||
1120 BPL .1
|
||||
1130 *--------------------------------
|
||||
1140 BCC FIN.2 FIRST CHAR IS A DIGIT
|
||||
1150 CMP #'-' CHECK FOR LEADING SIGN
|
||||
1160 BNE .2 NOT MINUS
|
||||
1170 STX SERLEN MINUS, SET SERLEN = $FF FOR FLAG
|
||||
1180 BEQ FIN.1 ...ALWAYS
|
||||
1190 .2 CMP #'+' MIGHT BE PLUS
|
||||
1200 BNE FIN.3 NOT PLUS EITHER, CHECK DECIMAL POINT
|
||||
1210 *--------------------------------
|
||||
1220 FIN.1 JSR CHRGET GET NEXT CHAR OF STRING
|
||||
1230 *--------------------------------
|
||||
1240 FIN.2 BCC FIN.9 INSERT THIS DIGIT
|
||||
1250 *--------------------------------
|
||||
1260 FIN.3 CMP #'.' CHECK FOR DECIMAL POINT
|
||||
1270 BEQ FIN.10 YES
|
||||
1280 CMP #'E' CHECK FOR EXPONENT PART
|
||||
1290 BNE FIN.7 NO, END OF NUMBER
|
||||
1300 JSR CHRGET YES, START CONVERTING EXPONENT
|
||||
1310 BCC FIN.5 EXPONENT DIGIT
|
||||
1320 CMP #TOKEN.MINUS NEGATIVE EXPONENT?
|
||||
1330 BEQ .1 YES
|
||||
1340 CMP #'-' MIGHT NOT BE TOKENIZED YET
|
||||
1350 BEQ .1 YES, IT IS NEGATIVE
|
||||
1360 CMP #TOKEN.PLUS OPTIONAL "+"
|
||||
1370 BEQ FIN.4 YES
|
||||
1380 CMP #'+' MIGHT NOT BE TOKENIZED YET
|
||||
1390 BEQ FIN.4 YES, FOUND "+"
|
||||
1400 BNE FIN.6 ...ALWAYS, NUMBER COMPLETED
|
||||
1410 .1 ROR EXPSGN C=1, SET FLAG NEGATIVE
|
||||
1420 *--------------------------------
|
||||
1430 FIN.4 JSR CHRGET GET NEXT DIGIT OF EXPONENT
|
||||
1440 *--------------------------------
|
||||
1450 FIN.5 BCC GETEXP CHAR IS A DIGIT OF EXPONENT
|
||||
1460 *--------------------------------
|
||||
1470 FIN.6 BIT EXPSGN END OF NUMBER, CHECK EXP SIGN
|
||||
1480 BPL FIN.7 POSITIVE EXPONENT
|
||||
1490 LDA #0 NEGATIVE EXPONENT
|
||||
1500 SEC MAKE 2'S COMPLEMENT OF EXPONENT
|
||||
1510 SBC EXPON
|
||||
1520 JMP FIN.8
|
||||
1530 *--------------------------------
|
||||
1540 * FOUND A DECIMAL POINT
|
||||
1550 *--------------------------------
|
||||
1560 FIN.10 ROR DPFLG C=1, SET DPFLG FOR DECIMAL POINT
|
||||
1570 BIT DPFLG CHECK IF PREVIOUS DEC. PT.
|
||||
1580 BVC FIN.1 NO PREVIOUS DECIMAL POINT
|
||||
1590 * A SECOND DECIMAL POINT IS TAKEN AS A TERMINATOR
|
||||
1600 * TO THE NUMERIC STRING.
|
||||
1610 * "A=11..22" WILL GIVE A SYNTAX ERROR, BECAUSE
|
||||
1620 * IT IS TWO NUMBERS WITH NO OPERATOR BETWEEN.
|
||||
1630 * "PRINT 11..22" GIVES NO ERROR, BECAUSE IT IS
|
||||
1640 * JUST THE CONCATENATION OF TWO NUMBERS.
|
||||
1650 *--------------------------------
|
||||
1660 * NUMBER TERMINATED, ADJUST EXPONENT NOW
|
||||
1670 *--------------------------------
|
||||
1680 FIN.7 LDA EXPON E-VALUE
|
||||
1690 FIN.8 SEC MODIFY WITH COUNT OF DIGITS
|
||||
1700 SBC TMPEXP AFTER THE DECIMAL POINT
|
||||
1710 STA EXPON COMPLETE CURRENT EXPONENT
|
||||
1720 BEQ .15 NO ADJUST NEEDED IF EXP=0
|
||||
1730 BPL .14 EXP>0, MULTIPLY BY TEN
|
||||
1740 .13 JSR DIV10 EXP<0, DIVIDE BY TEN
|
||||
1750 INC EXPON UNTIL EXP=0
|
||||
1760 BNE .13
|
||||
1770 BEQ .15 ...ALWAYS, WE ARE FINISHED
|
||||
1780 .14 JSR MUL10 EXP>0, MULTIPLY BKY TEN
|
||||
1790 DEC EXPON UNTIL EXP=0
|
||||
1800 BNE .14
|
||||
1810 .15 LDA SERLEN IS WHOLE NUMBER NEGATIVE?
|
||||
1820 BMI .16 YES
|
||||
1830 RTS NO, RETURN, WHOLE JOB DONE!
|
||||
1840 .16 JMP NEGOP NEGATIVE NUMBER, SO NEGATE FAC
|
||||
1850 *--------------------------------
|
||||
1860 * ACCUMULATE A DIGIT INTO FAC
|
||||
1870 *--------------------------------
|
||||
1880 FIN.9 PHA SAVE DIGIT
|
||||
1890 BIT DPFLG SEEN A DECIMAL POINT YET?
|
||||
1900 BPL .1 NO, STILL IN INTEGER PART
|
||||
1910 INC TMPEXP YES, COUNT THE FRACTIONAL DIGIT
|
||||
1920 .1 JSR MUL10 FAC = FAC * 10
|
||||
1930 PLA CURRENT DIGIT
|
||||
1940 SEC <<<SHORTER HERE TO JUST "AND #$0F">>>
|
||||
1950 SBC #'0' <<<TO CONVERT ASCII TO BINARY FORM>>>
|
||||
1960 JSR ADDACC ADD THE DIGIT
|
||||
1970 JMP FIN.1 GO BACK FOR MORE
|
||||
1980 *--------------------------------
|
||||
1990 * ADD (A) TO FAC
|
||||
2000 *--------------------------------
|
||||
2010 ADDACC PHA SAVE ADDEND
|
||||
2020 JSR COPY.FAC.TO.ARG.ROUNDED
|
||||
2030 PLA GET ADDEND AGAIN
|
||||
2040 JSR FLOAT CONVERT TO FP VALUE IN FAC
|
||||
2050 LDA ARG.SIGN
|
||||
2060 EOR FAC.SIGN
|
||||
2070 STA SGNCPR
|
||||
2080 LDX FAC TO SIGNAL IF FAC=0
|
||||
2090 JMP FADDT PERFORM THE ADDITION
|
||||
2100 *--------------------------------
|
||||
2110 * ACCUMULATE DIGIT OF EXPONENT
|
||||
2120 *--------------------------------
|
||||
2130 GETEXP LDA EXPON CHECK CURRENT VALUE
|
||||
2140 CMP #10 FOR MORE THAN 2 DIGITS
|
||||
2150 BCC .1 NO, THIS IS 1ST OR 2ND DIGIT
|
||||
2160 LDA #100 EXPONENT TOO BIG
|
||||
2170 BIT EXPSGN UNLESS IT IS NEGATIVE
|
||||
2180 BMI .2 LARGE NEGATIVE EXPONENT MAKES FAC=0
|
||||
2190 JMP OVERFLOW LARGE POSITIVE EXPONENT IS ERROR
|
||||
2200 .1 ASL EXPONENT TIMES 10
|
||||
2210 ASL
|
||||
2220 CLC
|
||||
2230 ADC EXPON
|
||||
2240 ASL
|
||||
2250 CLC <<< ASL ALREADY DID THIS! >>>
|
||||
2260 LDY #0 ADD THE NEW DIGIT
|
||||
2270 ADC (TXTPTR),Y BUT THIS IS IN ASCII,
|
||||
2280 SEC SO ADJUST BACK TO BINARY
|
||||
2290 SBC #'0'
|
||||
2300 .2 STA EXPON NEW VALUE
|
||||
2310 JMP FIN.4 BACK FOR MORE
|
||||
2320 *--------------------------------
|
||||
232
source/applesoft/S.ED0A
Normal file
232
source/applesoft/S.ED0A
Normal file
@ -0,0 +1,232 @@
|
||||
1010 *--------------------------------
|
||||
1020 CON.99999999.9 .HS 9B3EBC1FFD 99,999,999.9
|
||||
1030 CON.999999999 .HS 9E6E6B27FD 999,999,999
|
||||
1040 CON.BILLION .HS 9E6E6B2800 1,000,000,000
|
||||
1050 *--------------------------------
|
||||
1060 * PRINT "IN <LINE #>"
|
||||
1070 *--------------------------------
|
||||
1080 INPRT LDA #QT.IN PRINT " IN "
|
||||
1090 LDY /QT.IN
|
||||
1100 JSR GO.STROUT
|
||||
1110 LDA CURLIN+1
|
||||
1120 LDX CURLIN
|
||||
1130 *--------------------------------
|
||||
1140 * PRINT A,X AS DECIMAL INTEGER
|
||||
1150 *--------------------------------
|
||||
1160 LINPRT STA FAC+1 PRINT A,X IN DECIMAL
|
||||
1170 STX FAC+2
|
||||
1180 LDX #$90 EXPONENT = 2^16
|
||||
1190 SEC CONVERT UNSIGNED
|
||||
1200 JSR FLOAT.2 CONVERT LINE # TO FP
|
||||
1210 *--------------------------------
|
||||
1220 * CONVERT (FAC) TO STRING, AND PRINT IT
|
||||
1230 *--------------------------------
|
||||
1240 PRINT.FAC
|
||||
1250 JSR FOUT CONVERT (FAC) TO STRING AT STACK
|
||||
1260 *--------------------------------
|
||||
1270 * PRINT STRING STARTING AT Y,A
|
||||
1280 *--------------------------------
|
||||
1290 GO.STROUT
|
||||
1300 JMP STROUT PRINT STRING AT A,Y
|
||||
1310 *--------------------------------
|
||||
1320 * CONVERT (FAC) TO STRING STARTING AT STACK
|
||||
1330 * RETURN WITH (Y,A) POINTING AT STRING
|
||||
1340 *--------------------------------
|
||||
1350 FOUT LDY #1 NORMAL ENTRY PUTS STRING AT STACK...
|
||||
1360 *--------------------------------
|
||||
1370 * "STR$" FUNCTION ENTERS HERE, WITH (Y)=0
|
||||
1380 * SO THAT RESULT STRING STARTS AT STACK-1
|
||||
1390 * (THIS IS USED AS A FLAG)
|
||||
1400 *--------------------------------
|
||||
1410 FOUT.1 LDA #'-' IN CASE VALUE NEGATIVE
|
||||
1420 DEY BACK UP PNTR
|
||||
1430 BIT FAC.SIGN
|
||||
1440 BPL .1 VALUE IS +
|
||||
1450 INY VALUE IS -
|
||||
1460 STA STACK-1,Y EMIT "-"
|
||||
1470 .1 STA FAC.SIGN MAKE FAC.SIGN POSITIVE ($2D)
|
||||
1480 STY STRNG2 SAVE STRING PNTR
|
||||
1490 INY
|
||||
1500 LDA #'0' IN CASE (FAC)=0
|
||||
1510 LDX FAC NUMBER=0?
|
||||
1520 BNE .2 NO, (FAC) NOT ZERO
|
||||
1530 JMP FOUT.4 YES, FINISHED
|
||||
1540 *--------------------------------
|
||||
1550 .2 LDA #0 STARTING VALUE FOR TMPEXP
|
||||
1560 CPX #$80 ANY INTEGER PART?
|
||||
1570 BEQ .3 NO, BTWN .5 AND .999999999
|
||||
1580 BCS .4 YES
|
||||
1590 *--------------------------------
|
||||
1600 .3 LDA #CON.BILLION MULTIPLY BY 1E9
|
||||
1610 LDY /CON.BILLION TO GIVE ADJUSTMENT A HEAD START
|
||||
1620 JSR FMULT
|
||||
1630 LDA #-9 EXPONENT ADJUSTMENT
|
||||
1640 .4 STA TMPEXP 0 OR -9
|
||||
1650 *--------------------------------
|
||||
1660 * ADJUST UNTIL 1E8 <= (FAC) <1E9
|
||||
1670 *--------------------------------
|
||||
1680 .5 LDA #CON.999999999
|
||||
1690 LDY /CON.999999999
|
||||
1700 JSR FCOMP COMPARE TO 1E9-1
|
||||
1710 BEQ .10 (FAC) = 1E9-1
|
||||
1720 BPL .8 TOO LARGE, DIVIDE BY TEN
|
||||
1730 .6 LDA #CON.99999999.9 COMPARE TO 1E8-.1
|
||||
1740 LDY /CON.99999999.9
|
||||
1750 JSR FCOMP COMPARE TO 1E8-.1
|
||||
1760 BEQ .7 (FAC) = 1E8-.1
|
||||
1770 BPL .9 IN RANGE, ADJUSTMENT FINISHED
|
||||
1780 .7 JSR MUL10 TOO SMALL, MULTIPLY BY TEN
|
||||
1790 DEC TMPEXP KEEP TRACK OF MULTIPLIES
|
||||
1800 BNE .6 ...ALWAYS
|
||||
1810 .8 JSR DIV10 TOO LARGE, DIVIDE BY TEN
|
||||
1820 INC TMPEXP KEEP TRACK OF DIVISIONS
|
||||
1830 BNE .5 ...ALWAYS
|
||||
1840 *--------------------------------
|
||||
1850 .9 JSR FADDH ROUND ADJUSTED RESULT
|
||||
1860 .10 JSR QINT CONVERT ADJUSTED VALUE TO 32-BIT INTEGER
|
||||
1870 *--------------------------------
|
||||
1880 * FAC+1...FAC+4 IS NOW IN INTEGER FORM
|
||||
1890 * WITH POWER OF TEN ADJUSTMENT IN TMPEXP
|
||||
1900 *
|
||||
1910 * IF -10 < TMPEXP > 1, PRINT IN DECIMAL FORM
|
||||
1920 * OTHERWISE, PRINT IN EXPONENTIAL FORM
|
||||
1930 *--------------------------------
|
||||
1940 FOUT.2 LDX #1 ASSUME 1 DIGIT BEFORE "."
|
||||
1950 LDA TMPEXP CHECK RANGE
|
||||
1960 CLC
|
||||
1970 ADC #10
|
||||
1980 BMI .1 < .01, USE EXPONENTIAL FORM
|
||||
1990 CMP #11
|
||||
2000 BCS .2 >= 1E10, USE EXPONENTIAL FORM
|
||||
2010 ADC #$FF LESS 1 GIVES INDEX FOR "."
|
||||
2020 TAX
|
||||
2030 LDA #2 SET REMAINING EXPONENT = 0
|
||||
2040 .1 SEC COMPUTE REMAINING EXPONENT
|
||||
2050 .2 SBC #2
|
||||
2060 STA EXPON VALUE FOR "E+XX" OR "E-XX"
|
||||
2070 STX TMPEXP INDEX FOR DECIMAL POINT
|
||||
2080 TXA SEE IF "." COMES FIRST
|
||||
2090 BEQ .3 YES
|
||||
2100 BPL .5 NO, LATER
|
||||
2110 .3 LDY STRNG2 GET INDEX INTO STRING BEING BUILT
|
||||
2120 LDA #'.' STORE A DECIMAL POINT
|
||||
2130 INY
|
||||
2140 STA STACK-1,Y
|
||||
2150 TXA SEE IF NEED ".0"
|
||||
2160 BEQ .4 NO
|
||||
2170 LDA #'0' YES, STORE "0"
|
||||
2180 INY
|
||||
2190 STA STACK-1,Y
|
||||
2200 .4 STY STRNG2 SAVE OUTPUT INDEX AGAIN
|
||||
2210 *--------------------------------
|
||||
2220 * NOW DIVIDE BY POWERS OF TEN TO GET SUCCESSIVE DIGITS
|
||||
2230 *--------------------------------
|
||||
2240 .5 LDY #0 INDEX TO TABLE OF POWERS OF TEN
|
||||
2250 LDX #$80 STARTING VALUE FOR DIGIT WITH DIRECTION
|
||||
2260 .6 LDA FAC+4 START BY ADDING -100000000 UNTIL
|
||||
2270 CLC OVERSHOOT. THEN ADD +10000000,
|
||||
2280 ADC DECTBL+3,Y THEN ADD -1000000, THEN ADD
|
||||
2290 STA FAC+4 +100000, AND SO ON.
|
||||
2300 LDA FAC+3 THE # OF TIMES EACH POWER IS ADDED
|
||||
2310 ADC DECTBL+2,Y IS 1 MORE THAN CORRESPONDING DIGIT
|
||||
2320 STA FAC+3
|
||||
2330 LDA FAC+2
|
||||
2340 ADC DECTBL+1,Y
|
||||
2350 STA FAC+2
|
||||
2360 LDA FAC+1
|
||||
2370 ADC DECTBL,Y
|
||||
2380 STA FAC+1
|
||||
2390 INX COUNT THE ADD
|
||||
2400 BCS .7 IF C=1 AND X NEGATIVE, KEEP ADDING
|
||||
2410 BPL .6 IF C=0 AND X POSITIVE, KEEP ADDING
|
||||
2420 BMI .8 IF C=0 AND X NEGATIVE, WE OVERSHOT
|
||||
2430 .7 BMI .6 IF C=1 AND X POSITIVE, WE OVERSHOT
|
||||
2440 .8 TXA OVERSHOT, SO MAKE X INTO A DIGIT
|
||||
2450 BCC .9 HOW DEPENDS ON DIRECTION WE WERE GOING
|
||||
2460 EOR #$FF DIGIT = 9-X
|
||||
2470 ADC #10
|
||||
2480 .9 ADC #'0'-1 MAKE DIGIT INTO ASCII
|
||||
2490 INY ADVANCE TO NEXT SMALLER POWER OF TEN
|
||||
2500 INY
|
||||
2510 INY
|
||||
2520 INY
|
||||
2530 STY VARPNT SAVE PNTR TO POWERS
|
||||
2540 LDY STRNG2 GET OUTPUT PNTR
|
||||
2550 INY STORE THE DIGIT
|
||||
2560 TAX SAVE DIGIT, HI-BIT IS DIRECTION
|
||||
2570 AND #$7F MAKE SURE $30...$39 FOR STRING
|
||||
2580 STA STACK-1,Y
|
||||
2590 DEC TMPEXP COUNT THE DIGIT
|
||||
2600 BNE .10 NOT TIME FOR "." YET
|
||||
2610 LDA #'.' TIME, SO STORE THE DECIMAL POINT
|
||||
2620 INY
|
||||
2630 STA STACK-1,Y
|
||||
2640 .10 STY STRNG2 SAVE OUTPUT PNTR AGAIN
|
||||
2650 LDY VARPNT GET PNTR TO POWERS
|
||||
2660 TXA GET DIGIT WITH HI-BIT = DIRECTION
|
||||
2670 EOR #$FF CHANGE DIRECTION
|
||||
2680 AND #$80 $00 IF ADDING, $80 IF SUBTRACTING
|
||||
2690 TAX
|
||||
2700 CPY #DECTBL.END-DECTBL
|
||||
2710 BNE .6 NOT FINISHED YET
|
||||
2720 *--------------------------------
|
||||
2730 * NINE DIGITS HAVE BEEN STORED IN STRING. NOW LOOK
|
||||
2740 * BACK AND LOP OFF TRAILING ZEROES AND A TRAILING
|
||||
2750 * DECIMAL POINT.
|
||||
2760 *--------------------------------
|
||||
2770 FOUT.3 LDY STRNG2 POINTS AT LAST STORED CHAR
|
||||
2780 .1 LDA STACK-1,Y SEE IF LOPPABLE
|
||||
2790 DEY
|
||||
2800 CMP #'0' SUPPRESS TRAILING ZEROES
|
||||
2810 BEQ .1 YES, KEEP LOOPING
|
||||
2820 CMP #'.' SUPPRESS TRAILING DECIMAL POINT
|
||||
2830 BEQ .2 ".", SO WRITE OVER IT
|
||||
2840 INY NOT ".", SO INCLUDE IN STRING AGAIN
|
||||
2850 .2 LDA #'+' PREPARE FOR POSITIVE EXPONENT "E+XX"
|
||||
2860 LDX EXPON SEE IF ANY E-VALUE
|
||||
2870 BEQ FOUT.5 NO, JUST MARK END OF STRING
|
||||
2880 BPL .3 YES, AND IT IS POSITIVE
|
||||
2890 LDA #0 YES, AND IT IS NEGATIVE
|
||||
2900 SEC COMPLEMENT THE VALUE
|
||||
2910 SBC EXPON
|
||||
2920 TAX GET MAGNITUDE IN X
|
||||
2930 LDA #'-' E SIGN
|
||||
2940 .3 STA STACK+1,Y STORE SIGN IN STRING
|
||||
2950 LDA #'E' STORE "E" IN STRING BEFORE SIGN
|
||||
2960 STA STACK,Y
|
||||
2970 TXA EXPONENT MAGNITUDE IN A-REG
|
||||
2980 LDX #'0'-1 SEED FOR EXPONENT DIGIT
|
||||
2990 SEC CONVERT TO DECIMAL
|
||||
3000 .4 INX COUNT THE SUBTRACTION
|
||||
3010 SBC #10 TEN'S DIGIT
|
||||
3020 BCS .4 MORE TENS TO SUBTRACT
|
||||
3030 ADC #'0'+10 CONVERT REMAINDER TO ONE'S DIGIT
|
||||
3040 STA STACK+3,Y STORE ONE'S DIGIT
|
||||
3050 TXA
|
||||
3060 STA STACK+2,Y STORE TEN'S DIGIT
|
||||
3070 LDA #0 MARK END OF STRING WITH $00
|
||||
3080 STA STACK+4,Y
|
||||
3090 BEQ FOUT.6 ...ALWAYS
|
||||
3100 FOUT.4 STA STACK-1,Y STORE "0" IN ASCII
|
||||
3110 FOUT.5 LDA #0 STORE $00 ON END OF STRING
|
||||
3120 STA STACK,Y
|
||||
3130 FOUT.6 LDA #STACK POINT Y,A AT BEGINNING OF STRING
|
||||
3140 LDY /STACK (STR$ STARTED STRING AT STACK-1, BUT
|
||||
3150 RTS STR$ DOESN'T USE Y,A ANYWAY.)
|
||||
3160 *--------------------------------
|
||||
3170 CON.HALF .HS 8000000000 FP CONSTANT 0.5
|
||||
3180 *--------------------------------
|
||||
3190 * POWERS OF 10 FROM 1E8 DOWN TO 1,
|
||||
3200 * AS 32-BIT INTEGERS, WITH ALTERNATING SIGNS
|
||||
3210 *--------------------------------
|
||||
3220 DECTBL .HS FA0A1F00 -100000000
|
||||
3230 .HS 00989680 10000000
|
||||
3240 .HS FFF0BDC0 -1000000
|
||||
3250 .HS 000186A0 100000
|
||||
3260 .HS FFFFD8F0 -10000
|
||||
3270 .HS 000003E8 1000
|
||||
3280 .HS FFFFFF9C -100
|
||||
3290 .HS 0000000A 10
|
||||
3300 .HS FFFFFFFF -1
|
||||
3310 DECTBL.END
|
||||
3320 *--------------------------------
|
||||
212
source/applesoft/S.EE8D
Normal file
212
source/applesoft/S.EE8D
Normal file
@ -0,0 +1,212 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "SQR" FUNCTION
|
||||
1030 *
|
||||
1040 * <<< UNFORTUNATELY, RATHER THAN A NEWTON-RAPHSON >>>
|
||||
1050 * <<< ITERATION, APPLESOFT USES EXPONENTIATION >>>
|
||||
1060 * <<< SQR(X) = X^.5 >>>
|
||||
1070 *--------------------------------
|
||||
1080 SQR JSR COPY.FAC.TO.ARG.ROUNDED
|
||||
1090 LDA #CON.HALF SET UP POWER OF 0.5
|
||||
1100 LDY /CON.HALF
|
||||
1110 JSR LOAD.FAC.FROM.YA
|
||||
1120 *--------------------------------
|
||||
1130 * EXPONENTIATION OPERATION
|
||||
1140 *
|
||||
1150 * ARG ^ FAC = EXP( LOG(ARG) * FAC )
|
||||
1160 *--------------------------------
|
||||
1170 FPWRT BEQ EXP IF FAC=0, ARG^FAC=EXP(0)
|
||||
1180 LDA ARG IF ARG=0, ARG^FAC=0
|
||||
1190 BNE .1 NEITHER IS ZERO
|
||||
1200 JMP STA.IN.FAC.SIGN.AND.EXP SET FAC = 0
|
||||
1210 .1 LDX #TEMP3 SAVE FAC IN TEMP3
|
||||
1220 LDY #0
|
||||
1230 JSR STORE.FAC.AT.YX.ROUNDED
|
||||
1240 LDA ARG.SIGN NORMALLY, ARG MUST BE POSITIVE
|
||||
1250 BPL .2 IT IS POSITIVE, SO ALL IS WELL
|
||||
1260 JSR INT NEGATIVE, BUT OK IF INTEGRAL POWER
|
||||
1270 LDA #TEMP3 SEE IF INT(FAC)=FAC
|
||||
1280 LDY #0
|
||||
1290 JSR FCOMP IS IT AN INTEGER POWER?
|
||||
1300 BNE .2 NOT INTEGRAL, WILL CAUSE ERROR LATER
|
||||
1310 TYA MAKE ARG SIGN + AS IT IS MOVED TO FAC
|
||||
1320 LDY CHARAC INTEGRAL, SO ALLOW NEGATIVE ARG
|
||||
1330 .2 JSR MFA MOVE ARGUMENT TO FAC
|
||||
1340 TYA SAVE FLAG FOR NEGATIVE ARG (0=+)
|
||||
1350 PHA
|
||||
1360 JSR LOG GET LOG(ARG)
|
||||
1370 LDA #TEMP3 MULTIPLY BY POWER
|
||||
1380 LDY #0
|
||||
1390 JSR FMULT
|
||||
1400 JSR EXP E ^ LOG(FAC)
|
||||
1410 PLA GET FLAG FOR NEGATIVE ARG
|
||||
1420 LSR <<<LSR,BCC COULD BE MERELY BPL>>>
|
||||
1430 BCC RTS.18 NOT NEGATIVE, FINISHED
|
||||
1440 * NEGATIVE ARG, SO NEGATE RESULT
|
||||
1450 *--------------------------------
|
||||
1460 * NEGATE VALUE IN FAC
|
||||
1470 *--------------------------------
|
||||
1480 NEGOP LDA FAC IF FAC=0, NO NEED TO COMPLEMENT
|
||||
1490 BEQ RTS.18 YES, FAC=0
|
||||
1500 LDA FAC.SIGN NO, SO TOGGLE SIGN
|
||||
1510 EOR #$FF
|
||||
1520 STA FAC.SIGN
|
||||
1530 RTS.18 RTS
|
||||
1540 *--------------------------------
|
||||
1550 CON.LOG.E .HS 8138AA3B29 LOG(E) TO BASE 2
|
||||
1560 *--------------------------------
|
||||
1570 POLY.EXP .DA #7 ( # OF TERMS IN POLYNOMIAL) - 1
|
||||
1580 .HS 7134583E56 (LOG(2)^7)/8!
|
||||
1590 .HS 74167EB31B (LOG(2)^6)/7!
|
||||
1600 .HS 772FEEE385 (LOG(2)^5)/6!
|
||||
1610 .HS 7A1D841C2A (LOG(2)^4)/5!
|
||||
1620 .HS 7C6359580A (LOG(2)^3)/4!
|
||||
1630 .HS 7E75FDE7C6 (LOG(2)^2)/3!
|
||||
1640 .HS 8031721810 LOG(2)/2!
|
||||
1650 .HS 8100000000 1
|
||||
1660 *--------------------------------
|
||||
1670 * "EXP" FUNCTION
|
||||
1680 *
|
||||
1690 * FAC = E ^ FAC
|
||||
1700 *--------------------------------
|
||||
1710 EXP LDA #CON.LOG.E CONVERT TO POWER OF TWO PROBLEM
|
||||
1720 LDY /CON.LOG.E E^X = 2^(LOG2(E)*X)
|
||||
1730 JSR FMULT
|
||||
1740 LDA FAC.EXTENSION NON-STANDARD ROUNDING HERE
|
||||
1750 ADC #$50 ROUND UP IF EXTENSION > $AF
|
||||
1760 BCC .1 NO, DON'T ROUND UP
|
||||
1770 JSR INCREMENT.MANTISSA
|
||||
1780 .1 STA ARG.EXTENSION STRANGE VALUE
|
||||
1790 JSR MAF COPY FAC INTO ARG
|
||||
1800 LDA FAC MAXIMUM EXPONENT IS < 128
|
||||
1810 CMP #$88 WITHIN RANGE?
|
||||
1820 BCC .3 YES
|
||||
1830 .2 JSR OUTOFRNG OVERFLOW IF +, RETURN 0.0 IF -
|
||||
1840 .3 JSR INT GET INT(FAC)
|
||||
1850 LDA CHARAC THIS IS THE INETGRAL PART OF THE POWER
|
||||
1860 CLC ADD TO EXPONENT BIAS + 1
|
||||
1870 ADC #$81
|
||||
1880 BEQ .2 OVERFLOW
|
||||
1890 SEC BACK OFF TO NORMAL BIAS
|
||||
1900 SBC #1
|
||||
1910 PHA SAVE EXPONENT
|
||||
1920 *--------------------------------
|
||||
1930 LDX #5 SWAP ARG AND FAC
|
||||
1940 .4 LDA ARG,X <<< WHY SWAP? IT IS DOING >>>
|
||||
1950 LDY FAC,X <<< -(A-B) WHEN (B-A) IS THE >>>
|
||||
1960 STA FAC,X <<< SAME THING! >>>
|
||||
1970 STY ARG,X
|
||||
1980 DEX
|
||||
1990 BPL .4
|
||||
2000 LDA ARG.EXTENSION
|
||||
2010 STA FAC.EXTENSION
|
||||
2020 JSR FSUBT POWER-INT(POWER) --> FRACTIONAL PART
|
||||
2030 JSR NEGOP
|
||||
2040 LDA #POLY.EXP
|
||||
2050 LDY /POLY.EXP
|
||||
2060 JSR POLYNOMIAL COMPUTE F(X) ON FRACTIONAL PART
|
||||
2070 LDA #0
|
||||
2080 STA SGNCPR
|
||||
2090 PLA GET EXPONENT
|
||||
2100 JSR ADD.EXPONENTS.1
|
||||
2110 RTS <<< WASTED BYTE HERE, COULD HAVE >>>
|
||||
2120 * <<< JUST USED "JMP ADD.EXPO..." >>>
|
||||
2130 *--------------------------------
|
||||
2140 * ODD POLYNOMIAL SUBROUTINE
|
||||
2150 *
|
||||
2160 * F(X) = X * P(X^2)
|
||||
2170 *
|
||||
2180 * WHERE: X IS VALUE IN FAC
|
||||
2190 * Y,A POINTS AT COEFFICIENT TABLE
|
||||
2200 * FIRST BYTE OF COEFF. TABLE IS N
|
||||
2210 * COEFFICIENTS FOLLOW, HIGHEST POWER FIRST
|
||||
2220 *
|
||||
2230 * P(X^2) COMPUTED USING NORMAL POLYNOMIAL SUBROUTINE
|
||||
2240 *
|
||||
2250 *--------------------------------
|
||||
2260 POLYNOMIAL.ODD
|
||||
2270 STA SERPNT SAVE ADDRESS OF COEFFICIENT TABLE
|
||||
2280 STY SERPNT+1
|
||||
2290 JSR STORE.FAC.IN.TEMP1.ROUNDED
|
||||
2300 LDA #TEMP1 Y=0 ALREADY, SO Y,A POINTS AT TEMP1
|
||||
2310 JSR FMULT FORM X^2
|
||||
2320 JSR SERMAIN DO SERIES IN X^2
|
||||
2330 LDA #TEMP1 GET X AGAIN
|
||||
2340 LDY /TEMP1
|
||||
2350 JMP FMULT MULTIPLY X BY P(X^2) AND EXIT
|
||||
2360 *--------------------------------
|
||||
2370 * NORMAL POLYNOMIAL SUBROUTINE
|
||||
2380 *
|
||||
2390 * P(X) = C(0)*X^N + C(1)*X^(N-1) + ... + C(N)
|
||||
2400 *
|
||||
2410 * WHERE: X IS VALUE IN FAC
|
||||
2420 * Y,A POINTS AT COEFFICIENT TABLE
|
||||
2430 * FIRST BYTE OF COEFF. TABLE IS N
|
||||
2440 * COEFFICIENTS FOLLOW, HIGHEST POWER FIRST
|
||||
2450 *
|
||||
2460 *--------------------------------
|
||||
2470 POLYNOMIAL
|
||||
2480 STA SERPNT POINTER TO COEFFICIENT TABLE
|
||||
2490 STY SERPNT+1
|
||||
2500 *--------------------------------
|
||||
2510 SERMAIN
|
||||
2520 JSR STORE.FAC.IN.TEMP2.ROUNDED
|
||||
2530 LDA (SERPNT),Y GET N
|
||||
2540 STA SERLEN SAVE N
|
||||
2550 LDY SERPNT BUMP PNTR TO HIGHEST COEFFICIENT
|
||||
2560 INY AND GET PNTR INTO Y,A
|
||||
2570 TYA
|
||||
2580 BNE .1
|
||||
2590 INC SERPNT+1
|
||||
2600 .1 STA SERPNT
|
||||
2610 LDY SERPNT+1
|
||||
2620 .2 JSR FMULT ACCUMULATE SERIES TERMS
|
||||
2630 LDA SERPNT BUMP PNTR TO NEXT COEFFICIENT
|
||||
2640 LDY SERPNT+1
|
||||
2650 CLC
|
||||
2660 ADC #5
|
||||
2670 BCC .3
|
||||
2680 INY
|
||||
2690 .3 STA SERPNT
|
||||
2700 STY SERPNT+1
|
||||
2710 JSR FADD ADD NEXT COEFFICIENT
|
||||
2720 LDA #TEMP2 POINT AT X AGAIN
|
||||
2730 LDY #0
|
||||
2740 DEC SERLEN IF SERIES NOT FINISHED,
|
||||
2750 BNE .2 THEN ADD ANOTHER TERM
|
||||
2760 RTS.19 RTS FINISHED
|
||||
2770 *--------------------------------
|
||||
2780 CON.RND.1 .HS 9835447A <<< THESE ARE MISSING ONE BYTE >>>
|
||||
2790 CON.RND.2 .HS 6828B146 <<< FOR FP VALUES >>>
|
||||
2800 *--------------------------------
|
||||
2810 * "RND" FUNCTION
|
||||
2820 *--------------------------------
|
||||
2830 RND JSR SIGN REDUCE ARGUMENT TO -1, 0, OR +1
|
||||
2840 TAX SAVE ARGUMENT
|
||||
2850 BMI .1 = -1, USE CURRENT ARGUMENT FOR SEED
|
||||
2860 LDA #RNDSEED USE CURRENT SEED
|
||||
2870 LDY /RNDSEED
|
||||
2880 JSR LOAD.FAC.FROM.YA
|
||||
2890 TXA RECALL SIGN OF ARGUMENT
|
||||
2900 BEQ RTS.19 =0, RETURN SEED UNCHANGED
|
||||
2910 LDA #CON.RND.1 VERY POOR RND ALGORITHM
|
||||
2920 LDY /CON.RND.1
|
||||
2930 JSR FMULT
|
||||
2940 LDA #CON.RND.2 ALSO, CONSTANTS ARE TRUNCATED
|
||||
2950 LDY /CON.RND.2 <<<THIS DOES NOTHING, DUE TO >>>
|
||||
2960 * <<<SMALL EXPONENT >>>
|
||||
2970 JSR FADD
|
||||
2980 .1 LDX FAC+4 SHUFFLE HI AND LO BYTES
|
||||
2990 LDA FAC+1 TO SUPPOSEDLY MAKE IT MORE RANDOM
|
||||
3000 STA FAC+4
|
||||
3010 STX FAC+1
|
||||
3020 LDA #0 MAKE IT POSITIVE
|
||||
3030 STA FAC.SIGN
|
||||
3040 LDA FAC A SOMEWHAT RANDOM EXTENSION
|
||||
3050 STA FAC.EXTENSION
|
||||
3060 LDA #$80 EXPONENT TO MAKE VALUE < 1.0
|
||||
3070 STA FAC
|
||||
3080 JSR NORMALIZE.FAC.2
|
||||
3090 LDX #RNDSEED MOVE FAC TO RND SEED
|
||||
3100 LDY /RNDSEED
|
||||
3110 GO.MOVMF JMP STORE.FAC.AT.YX.ROUNDED
|
||||
3120 *--------------------------------
|
||||
273
source/applesoft/S.EFEA
Normal file
273
source/applesoft/S.EFEA
Normal file
@ -0,0 +1,273 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "COS" FUNCTION
|
||||
1030 *--------------------------------
|
||||
1040 COS LDA #CON.PI.HALF COS(X)=SIN(X + PI/2)
|
||||
1050 LDY /CON.PI.HALF
|
||||
1060 JSR FADD
|
||||
1070 *--------------------------------
|
||||
1080 * "SIN" FUNCTION
|
||||
1090 *--------------------------------
|
||||
1100 SIN JSR COPY.FAC.TO.ARG.ROUNDED
|
||||
1110 LDA #CON.PI.DOUB REMOVE MULTIPLES OF 2*PI
|
||||
1120 LDY /CON.PI.DOUB BY DIVIDING AND SAVING
|
||||
1130 LDX ARG.SIGN THE FRACTIONAL PART
|
||||
1140 JSR DIV USE SIGN OF ARGUMENT
|
||||
1150 JSR COPY.FAC.TO.ARG.ROUNDED
|
||||
1160 JSR INT TAKE INTEGER PART
|
||||
1170 LDA #0 <<< WASTED LINES, BECAUSE FSUBT >>>
|
||||
1180 STA SGNCPR <<< CHANGES SGNCPR AGAIN >>>
|
||||
1190 JSR FSUBT SUBTRACT TO GET FRACTIONAL PART
|
||||
1200 *--------------------------------
|
||||
1210 * (FAC) = ANGLE AS A FRACTION OF A FULL CIRCLE
|
||||
1220 *
|
||||
1230 * NOW FOLD THE RANGE INTO A QUARTER CIRCLE
|
||||
1240 *
|
||||
1250 * <<< THERE ARE MUCH SIMPLER WAYS TO DO THIS >>>
|
||||
1260 *--------------------------------
|
||||
1270 LDA #QUARTER 1/4 - FRACTION MAKES
|
||||
1280 LDY /QUARTER -3/4 <= FRACTION < 1/4
|
||||
1290 JSR FSUB
|
||||
1300 LDA FAC.SIGN TEST SIGN OF RESULT
|
||||
1310 PHA SAVE SIGN FOR LATER UNFOLDING
|
||||
1320 BPL SIN.1 ALREADY 0...1/4
|
||||
1330 JSR FADDH ADD 1/2 TO SHIFT TO -1/4...1/2
|
||||
1340 LDA FAC.SIGN TEST SIGN
|
||||
1350 BMI SIN.2 -1/4...0
|
||||
1360 * 0...1/2
|
||||
1370 LDA SIGNFLG SIGNFLG INITIALIZED = 0 IN "TAN"
|
||||
1380 EOR #$FF FUNCTION
|
||||
1390 STA SIGNFLG "TAN" IS ONLY USER OF SIGNFLG TOO
|
||||
1400 *--------------------------------
|
||||
1410 * IF FALL THRU, RANGE IS 0...1/2
|
||||
1420 * IF BRANCH HERE, RANGE IS 0...1/4
|
||||
1430 *--------------------------------
|
||||
1440 SIN.1 JSR NEGOP
|
||||
1450 *--------------------------------
|
||||
1460 * IF FALL THRU, RANGE IS -1/2...0
|
||||
1470 * IF BRANCH HERE, RANGE IS -1/4...0
|
||||
1480 *--------------------------------
|
||||
1490 SIN.2 LDA #QUARTER ADD 1/4 TO SHIFT RANGE
|
||||
1500 LDY /QUARTER TO -1/4...1/4
|
||||
1510 JSR FADD
|
||||
1520 PLA GET SAVED SIGN FROM ABOVE
|
||||
1530 BPL .1
|
||||
1540 JSR NEGOP MAKE RANGE 0...1/4
|
||||
1550 .1 LDA #POLY.SIN DO STANDARD SIN SERIES
|
||||
1560 LDY /POLY.SIN
|
||||
1570 JMP POLYNOMIAL.ODD
|
||||
1580 *--------------------------------
|
||||
1590 * "TAN" FUNCTION
|
||||
1600 *
|
||||
1610 * COMPUTE TAN(X) = SIN(X) / COS(X)
|
||||
1620 *--------------------------------
|
||||
1630 TAN JSR STORE.FAC.IN.TEMP1.ROUNDED
|
||||
1640 LDA #0 SIGNFLG WILL BE TOGGLED IF 2ND OR 3RD
|
||||
1650 STA SIGNFLG QUADRANT
|
||||
1660 JSR SIN GET SIN(X)
|
||||
1670 LDX #TEMP3 SAVE SIN(X) IN TEMP3
|
||||
1680 LDY /TEMP3
|
||||
1690 JSR GO.MOVMF <<<FUNNY WAY TO CALL MOVMF! >>>
|
||||
1700 LDA #TEMP1 RETRIEVE X
|
||||
1710 LDY /TEMP1
|
||||
1720 JSR LOAD.FAC.FROM.YA
|
||||
1730 LDA #0 AND COMPUTE COS(X)
|
||||
1740 STA FAC.SIGN
|
||||
1750 LDA SIGNFLG
|
||||
1760 JSR TAN.1 WEIRD & DANGEROUS WAY TO GET INTO SIN
|
||||
1770 LDA #TEMP3 NOW FORM SIN/COS
|
||||
1780 LDY /TEMP3
|
||||
1790 JMP FDIV
|
||||
1800 *--------------------------------
|
||||
1810 TAN.1 PHA SHAME, SHAME!
|
||||
1820 JMP SIN.1
|
||||
1830 *--------------------------------
|
||||
1840 CON.PI.HALF .HS 81490FDAA2
|
||||
1850 CON.PI.DOUB .HS 83490FDAA2
|
||||
1860 QUARTER .HS 7F00000000
|
||||
1870 *--------------------------------
|
||||
1880 POLY.SIN .DA #5 POWER OF POLYNOMIAL
|
||||
1890 .HS 84E61A2D1B (2PI)^11/11!
|
||||
1900 .HS 862807FBF8 (2PI)^9/9!
|
||||
1910 .HS 8799688901 (2PI)^7/7!
|
||||
1920 .HS 872335DFE1 (2PI)^5/5!
|
||||
1930 .HS 86A55DE728 (2PI)^3/3!
|
||||
1940 .HS 83490FDAA2 2PI
|
||||
1950 *--------------------------------
|
||||
1960 * <<< NEXT TEN BYTES ARE NEVER REFERENCED >>>
|
||||
1970 *--------------------------------
|
||||
1980 .HS A6D3C1C8D4 OR "&SAHT" IN ASCII [exclusive-or each byte with $87 ]
|
||||
[to get the string "!TFOSORCIM" ]
|
||||
1990 .HS C8D5C4CECA OR "HUDNJ" IN ASCII [which is "MICROSOFT!" backwards.]
|
||||
2000 *--------------------------------
|
||||
2010 * "ATN" FUNCTION
|
||||
2020 *--------------------------------
|
||||
2030 ATN LDA FAC.SIGN FOLD THE ARGUMENT RANGE FIRST
|
||||
2040 PHA SAVE SIGN FOR LATER UNFOLDING
|
||||
2050 BPL .1 .GE. 0
|
||||
2060 JSR NEGOP .LT. 0, SO COMPLEMENT
|
||||
2070 .1 LDA FAC IF .GE. 1, FORM RECIPROCAL
|
||||
2080 PHA SAVE FOR LATER UNFOLDING
|
||||
2090 CMP #$81 (EXPONENT FOR .GE. 1
|
||||
2100 BCC .2 X < 1
|
||||
2110 LDA #CON.ONE FORM 1/X
|
||||
2120 LDY /CON.ONE
|
||||
2130 JSR FDIV
|
||||
2140 *--------------------------------
|
||||
2150 * 0 <= X <= 1
|
||||
2160 * 0 <= ATN(X) <= PI/8
|
||||
2170 *--------------------------------
|
||||
2180 .2 LDA #POLY.ATN COMPUTE POLYNOMIAL APPROXIMATION
|
||||
2190 LDY /POLY.ATN
|
||||
2200 JSR POLYNOMIAL.ODD
|
||||
2210 PLA START TO UNFOLD
|
||||
2220 CMP #$81 WAS IT .GE. 1?
|
||||
2230 BCC .3 NO
|
||||
2240 LDA #CON.PI.HALF YES, SUBTRACT FROM PI/2
|
||||
2250 LDY /CON.PI.HALF
|
||||
2260 JSR FSUB
|
||||
2270 .3 PLA WAS IT NEGATIVE?
|
||||
2280 BPL RTS.20 NO
|
||||
2290 JMP NEGOP YES, COMPLEMENT
|
||||
2300 RTS.20 RTS
|
||||
2310 *--------------------------------
|
||||
2320 POLY.ATN .DA #11 POWER OF POLYNOMIAL
|
||||
2330 .HS 76B383BDD3
|
||||
2340 .HS 791EF4A6F5
|
||||
2350 .HS 7B83FCB010
|
||||
2360 .HS 7C0C1F67CA
|
||||
2370 .HS 7CDE53CBC1
|
||||
2380 .HS 7D1464704C
|
||||
2390 .HS 7DB7EA517A
|
||||
2400 .HS 7D6330887E
|
||||
2410 .HS 7E9244993A
|
||||
2420 .HS 7E4CCC91C7
|
||||
2430 .HS 7FAAAAAA13
|
||||
2440 .HS 8100000000
|
||||
2450 *--------------------------------
|
||||
2460 * GENERIC COPY OF CHRGET SUBROUTINE, WHICH
|
||||
2470 * IS COPIED INTO $00B1...$00C8 DURING INITIALIZATION
|
||||
2480 *
|
||||
2490 * CORNELIS BONGERS DESCRIBED SEVERAL IMPROVEMENTS
|
||||
2500 * TO CHRGET IN MICRO MAGAZINE OR CALL A.P.P.L.E.
|
||||
2510 * (I DON'T REMEMBER WHICH OR EXACTLY WHEN)
|
||||
2520 *--------------------------------
|
||||
2530 GENERIC.CHRGET
|
||||
2540 INC TXTPTR
|
||||
2550 BNE .1
|
||||
2560 INC TXTPTR+1
|
||||
2570 .1 LDA $EA60 <<< ACTUAL ADDRESS FILLED IN LATER >>>
|
||||
2580 CMP #':' EOS, ALSO TOP OF NUMERIC RANGE
|
||||
2590 BCS .2 NOT NUMBER, MIGHT BE EOS
|
||||
2600 CMP #' ' IGNORE BLANKS
|
||||
2610 BEQ GENERIC.CHRGET
|
||||
2620 SEC TEST FOR NUMERIC RANGE IN WAY THAT
|
||||
2630 SBC #'0' CLEARS CARRY IF CHAR IS DIGIT
|
||||
2640 SEC AND LEAVES CHAR IN A-REG
|
||||
2650 SBC #-'0'
|
||||
2660 .2 RTS
|
||||
2670 *--------------------------------
|
||||
2680 * INITIAL VALUE FOR RANDOM NUMBER, ALSO COPIED
|
||||
2690 * IN ALONG WITH CHRGET, BUT ERRONEOUSLY:
|
||||
2700 * <<< THE LAST BYTE IS NOT COPIED >>>
|
||||
2710 *--------------------------------
|
||||
2720 .HS 804FC75258 APPROX. = .811635157
|
||||
2730 GENERIC.END
|
||||
2740 *--------------------------------
|
||||
2750 COLD.START
|
||||
2760 LDX #$FF SET DIRECT MODE FLAG
|
||||
2770 STX CURLIN+1
|
||||
2780 LDX #$FB SET STACK POINTER, LEAVING ROOM FOR
|
||||
2790 TXS LINE BUFFER DURING PARSING
|
||||
2800 LDA #COLD.START SET RESTART TO COLD.START
|
||||
2810 LDY /COLD.START UNTIL COLDSTART IS COMPLETED
|
||||
2820 STA GOWARM+1
|
||||
2830 STY GOWARM+2
|
||||
2840 STA GOSTROUT+1 ALSO SECOND USER VECTOR...
|
||||
2850 STY GOSTROUT+2 ..WE SIMPLY MUST FINISH COLD.START!
|
||||
2860 JSR NORMAL SET NORMAL DISPLAY MODE
|
||||
2870 LDA #$4C "JMP" OPCODE FOR 4 VECTORS
|
||||
2880 STA GOWARM WARM START
|
||||
2890 STA GOSTROUT ANYONE EVER USE THIS ONE?
|
||||
2900 STA JMPADRS USED BY FUNCTIONS (JSR JMPADRS)
|
||||
2910 STA USR "USR" FUNCTION VECTOR
|
||||
2920 LDA #IQERR POINT "USR" TO ILLEGAL QUANTITY
|
||||
2930 LDY /IQERR ERROR, UNTIL USER SETS IT UP
|
||||
2940 STA USR+1
|
||||
2950 STY USR+2
|
||||
2960 *--------------------------------
|
||||
2970 * MOVE GENERIC CHRGET AND RANDOM SEED INTO PLACE
|
||||
2980 *
|
||||
2990 * <<< NOTE THAT LOOP VALUE IS WRONG! >>>
|
||||
3000 * <<< THE LAST BYTE OF THE RANDOM SEED IS NOT >>>
|
||||
3010 * <<< COPIED INTO PAGE ZERO! >>>
|
||||
3020 *--------------------------------
|
||||
3030 LDX #GENERIC.END-GENERIC.CHRGET-1
|
||||
3040 .1 LDA GENERIC.CHRGET-1,X
|
||||
3050 STA CHRGET-1,X
|
||||
3060 STX SPEEDZ ON LAST PASS STORES $01)
|
||||
3070 DEX
|
||||
3080 BNE .1
|
||||
3090 *--------------------------------
|
||||
3100 STX TRCFLG X=0, TURN OFF TRACING
|
||||
3110 TXA A=0
|
||||
3120 STA SHIFT.SIGN.EXT
|
||||
3130 STA LASTPT+1
|
||||
3140 PHA PUT $00 ON STACK (WHAT FOR?)
|
||||
3150 LDA #3 SET LENGTH OF TEMP. STRING DESCRIPTORS
|
||||
3160 STA DSCLEN FOR GARBAGE COLLECTION SUBROUTINE
|
||||
3170 JSR CRDO PRINT <RETURN>
|
||||
3180 LDA #1 SET UP FAKE FORWARD LINK
|
||||
3190 STA INPUT.BUFFER-3
|
||||
3200 STA INPUT.BUFFER-4
|
||||
3210 LDX #TEMPST INIT INDEX TO TEMP STRING DESCRIPTORS
|
||||
3220 STX TEMPPT
|
||||
3230 *--------------------------------
|
||||
3240 * FIND HIGH END OF RAM
|
||||
3250 *--------------------------------
|
||||
3260 LDA #$0800 SET UP POINTER TO LOW END OF RAM
|
||||
3270 LDY /$0800
|
||||
3280 STA LINNUM
|
||||
3290 STY LINNUM+1
|
||||
3300 LDY #0
|
||||
3310 .2 INC LINNUM+1 TEST FIRST BYTE OF EACH PAGE
|
||||
3320 LDA (LINNUM),Y BY COMPLEMENTING IT AND WATCHING
|
||||
3330 EOR #$FF IT CHANGE THE SAME WAY
|
||||
3340 STA (LINNUM),Y
|
||||
3350 CMP (LINNUM),Y ROM OR EMPTY SOCKETS WON'T TRACK
|
||||
3360 BNE .3 NOT RAM HERE
|
||||
3370 EOR #$FF RESTORE ORIGINAL VALUE
|
||||
3380 STA (LINNUM),Y
|
||||
3390 CMP (LINNUM),Y DID IT TRACK AGAIN?
|
||||
3400 BEQ .2 YES, STILL IN RAM
|
||||
3410 .3 LDY LINNUM NO, END OF RAM
|
||||
3420 LDA LINNUM+1
|
||||
3430 AND #$F0 FORCE A MULTIPLE OF 4096 BYTES
|
||||
3440 STY MEMSIZ (BAD RAM MAY HAVE YIELDED NON-MULTIPLE)
|
||||
3450 STA MEMSIZ+1
|
||||
3460 STY FRETOP SET HIMEM AND BOTTOM OF STRINGS
|
||||
3470 STA FRETOP+1
|
||||
3480 LDX #$0800 SET PROGRAM POINTER TO $0800
|
||||
3490 LDY /$0800
|
||||
3500 STX TXTTAB
|
||||
3510 STY TXTTAB+1
|
||||
3520 LDY #0 TURN OFF SEMI-SECRET LOCK FLAG
|
||||
3530 STY LOCK
|
||||
3540 TYA A=0 TOO
|
||||
3550 STA (TXTTAB),Y FIRST BYTE IN PROGRAM SPACE = 0
|
||||
3560 INC TXTTAB ADVANCE PAST THE $00
|
||||
3570 BNE .4
|
||||
3580 INC TXTTAB+1
|
||||
3590 .4 LDA TXTTAB
|
||||
3600 LDY TXTTAB+1
|
||||
3610 JSR REASON SET REST OF POINTERS UP
|
||||
3620 JSR SCRTCH MORE POINTERS
|
||||
3630 LDA #STROUT PUT CORRECT ADDRESSES IN TWO
|
||||
3640 LDY /STROUT USER VECTORS
|
||||
3650 STA GOSTROUT+1
|
||||
3660 STY GOSTROUT+2
|
||||
3670 LDA #RESTART
|
||||
3680 LDY /RESTART
|
||||
3690 STA GOWARM+1
|
||||
3700 STY GOWARM+2
|
||||
3710 JMP (GOWARM+1) SILLY, WHY NOT JUST "JMP RESTART"
|
||||
3720 *--------------------------------
|
||||
368
source/applesoft/S.F1D5
Normal file
368
source/applesoft/S.F1D5
Normal file
@ -0,0 +1,368 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "CALL" STATEMENT
|
||||
1030 *
|
||||
1040 * EFFECTIVELY PERFORMS A "JSR" TO THE SPECIFIED
|
||||
1050 * ADDRESS, WITH THE FOLLOWING REGISTER CONTENTS:
|
||||
1060 * (A,Y) = CALL ADDRESS
|
||||
1070 * (X) = $9D
|
||||
1080 *
|
||||
1090 * THE CALLED ROUTINE CAN RETURN WITH "RTS",
|
||||
1100 * AND APPLESOFT WILL CONTINUE WITH THE NEXT
|
||||
1110 * STATEMENT.
|
||||
1120 *--------------------------------
|
||||
1130 CALL JSR FRMNUM EVALUATE EXPRESSION FOR CALL ADDRESS
|
||||
1140 JSR GETADR CONVERT EXPRESSION TO 16-BIT INTEGER
|
||||
1150 JMP (LINNUM) IN LINNUM, AND JUMP THERE.
|
||||
1160 *--------------------------------
|
||||
1170 * "IN#" STATEMENT
|
||||
1180 *
|
||||
1190 * NOTE: NO CHECK FOR VALID SLOT #, AS LONG
|
||||
1200 * AS VALUE IS < 256 IT IS ACCEPTED.
|
||||
1210 * MONITOR MASKS VALUE TO 4 BITS (0-15).
|
||||
1220 *--------------------------------
|
||||
1230 IN.NUMBER
|
||||
1240 JSR GETBYT GET SLOT NUMBER IN X-REG
|
||||
1250 TXA MONITOR WILL INSTALL IN VECTOR
|
||||
1260 JMP MON.INPORT AT $38,39.
|
||||
1270 *--------------------------------
|
||||
1280 * "PR#" STATEMENT
|
||||
1290 *
|
||||
1300 * NOTE: NO CHECK FOR VALID SLOT #, AS LONG
|
||||
1310 * AS VALUE IS < 256 IT IS ACCEPTED.
|
||||
1320 * MONITOR MASKS VALUE TO 4 BITS (0-15).
|
||||
1330 *--------------------------------
|
||||
1340 PR.NUMBER
|
||||
1350 JSR GETBYT GET SLOT NUMBER IN X-REG
|
||||
1360 TXA MONITOR WILL INSTALL IN VECTOR
|
||||
1370 JMP MON.OUTPORT AT $36,37
|
||||
1380 *--------------------------------
|
||||
1390 * GET TWO VALUES < 48, WITH COMMA SEPARATOR
|
||||
1400 *
|
||||
1410 * CALLED FOR "PLOT X,Y"
|
||||
1420 * AND "HLIN A,B AT Y"
|
||||
1430 * AND "VLIN A,B AT X"
|
||||
1440 *
|
||||
1450 *--------------------------------
|
||||
1460 PLOTFNS
|
||||
1470 JSR GETBYT GET FIRST VALUE IN X-REG
|
||||
1480 CPX #48 MUST BE < 48
|
||||
1490 BCS GOERR TOO LARGE
|
||||
1500 STX FIRST SAVE FIRST VALUE
|
||||
1510 LDA #',' MUST HAVE A COMMA
|
||||
1520 JSR SYNCHR
|
||||
1530 JSR GETBYT GET SECOND VALUE IN X-REG
|
||||
1540 CPX #48 MUST BE < 48
|
||||
1550 BCS GOERR TOO LARGE
|
||||
1560 STX MON.H2 SAVE SECOND VALUE
|
||||
1570 STX MON.V2
|
||||
1580 RTS SECOND VALUE STILL IN X-REG
|
||||
1590 *--------------------------------
|
||||
1600 GOERR JMP IQERR ILLEGAL QUANTITY ERROR
|
||||
1610 *--------------------------------
|
||||
1620 * GET "A,B AT C" VALUES FOR "HLIN" AND "VLIN"
|
||||
1630 *
|
||||
1640 * PUT SMALLER OF (A,B) IN FIRST,
|
||||
1650 * AND LARGER OF (A,B) IN H2 AND V2.
|
||||
1660 * RETURN WITH (X) = C-VALUE.
|
||||
1670 *--------------------------------
|
||||
1680 LINCOOR
|
||||
1690 JSR PLOTFNS GET A,B VALUES
|
||||
1700 CPX FIRST IS A < B?
|
||||
1710 BCS .1 YES, IN RIGHT ORDER
|
||||
1720 LDA FIRST NO, INTERCHANGE THEM
|
||||
1730 STA MON.H2
|
||||
1740 STA MON.V2
|
||||
1750 STX FIRST
|
||||
1760 .1 LDA #TOKEN.AT MUST HAVE "AT" NEXT
|
||||
1770 JSR SYNCHR
|
||||
1780 JSR GETBYT GET C-VALUE IN X-REG
|
||||
1790 CPX #48 MUST BE < 48
|
||||
1800 BCS GOERR TOO LARGE
|
||||
1810 RTS C-VALUE IN X-REG
|
||||
1820 *--------------------------------
|
||||
1830 * "PLOT" STATEMENT
|
||||
1840 *--------------------------------
|
||||
1850 PLOT JSR PLOTFNS GET X,Y VALUES
|
||||
1860 TXA Y-COORD TO A-REG FOR MONITOR
|
||||
1870 LDY FIRST X-COORD TO Y-YEG FOR MONITOR
|
||||
1880 CPY #40 X-COORD MUST BE < 40
|
||||
1890 BCS GOERR X-COORD IS TOO LARGE
|
||||
1900 JMP MON.PLOT PLOT!
|
||||
1910 *--------------------------------
|
||||
1920 * "HLIN" STATEMENT
|
||||
1930 *--------------------------------
|
||||
1940 HLIN JSR LINCOOR GET "A,B AT C"
|
||||
1950 TXA Y-COORD IN A-REG
|
||||
1960 LDY MON.H2 RIGHT END OF LINE
|
||||
1970 CPY #40 MUST BE < 40
|
||||
1980 BCS GOERR TOO LARGE
|
||||
1990 LDY FIRST LEFT END OF LINE IN Y-REG
|
||||
2000 JMP MON.HLINE LET MONITOR DRAW LINE
|
||||
2010 *--------------------------------
|
||||
2020 * "VLIN" STATEMENT
|
||||
2030 *--------------------------------
|
||||
2040 VLIN JSR LINCOOR GET "A,B AT C"
|
||||
2050 TXA X-COORD IN Y-REG
|
||||
2060 TAY
|
||||
2070 CPY #40 X-COORD MUST BE < 40
|
||||
2080 BCS GOERR TOO LARGE
|
||||
2090 LDA FIRST TOP END OF LINE IN A-REG
|
||||
2100 JMP MON.VLINE LET MONITOR DRAW LINE
|
||||
2110 *--------------------------------
|
||||
2120 * "COLOR=" STATEMENT
|
||||
2130 *--------------------------------
|
||||
2140 COLOR JSR GETBYT GET COLOR VALUE IN X-REG
|
||||
2150 TXA
|
||||
2160 JMP MON.SETCOL LET MONITOR STORE COLOR
|
||||
2170 *--------------------------------
|
||||
2180 * "VTAB" STATEMENT
|
||||
2190 *--------------------------------
|
||||
2200 VTAB JSR GETBYT GET LINE # IN X-REG
|
||||
2210 DEX CONVERT TO ZERO BASE
|
||||
2220 TXA
|
||||
2230 CMP #24 MUST BE 0-23
|
||||
2240 BCS GOERR TOO LARGE, OR WAS "VTAB 0"
|
||||
2250 JMP MON.TABV LET MONITOR COMPUTE BASE
|
||||
2260 *--------------------------------
|
||||
2270 * "SPEED=" STATEMENT
|
||||
2280 *--------------------------------
|
||||
2290 SPEED JSR GETBYT GET SPEED SETTING IN X-REG
|
||||
2300 TXA SPEEDZ = $100-SPEED
|
||||
2310 EOR #$FF SO "SPEED=255" IS FASTEST
|
||||
2320 TAX
|
||||
2330 INX
|
||||
2340 STX SPEEDZ
|
||||
2350 RTS
|
||||
2360 *--------------------------------
|
||||
2370 * "TRACE" STATEMENT
|
||||
2380 * SET SIGN BIT IN TRCFLG
|
||||
2390 *--------------------------------
|
||||
2400 TRACE SEC
|
||||
2410 .HS 90 FAKE BCC TO SKIP NEXT OPCODE
|
||||
2420 *--------------------------------
|
||||
2430 * "NOTRACE" STATEMENT
|
||||
2440 * CLEAR SIGN BIT IN TRCFLG
|
||||
2450 *--------------------------------
|
||||
2460 NOTRACE
|
||||
2470 CLC
|
||||
2480 ROR TRCFLG SHIFT CARRY INTO TRCFLG
|
||||
2490 RTS
|
||||
2500 *--------------------------------
|
||||
2510 * "NORMAL" STATEMENT
|
||||
2520 *--------------------------------
|
||||
2530 NORMAL LDA #$FF SET INVFLG = $FF
|
||||
2540 BNE N.I. AND FLASH.BIT = $00
|
||||
2550 *--------------------------------
|
||||
2560 * "INVERSE" STATEMENT
|
||||
2570 *--------------------------------
|
||||
2580 INVERSE
|
||||
2590 LDA #$3F SET INVFLG = $3F
|
||||
2600 N.I. LDX #0 AND FLASH.BIT = $00
|
||||
2610 N.I.F. STA MON.INVFLG
|
||||
2620 STX FLASH.BIT
|
||||
2630 RTS
|
||||
2640 *--------------------------------
|
||||
2650 * "FLASH" STATEMENT
|
||||
2660 *--------------------------------
|
||||
2670 FLASH LDA #$7F SET INVFLG = $7F
|
||||
2680 LDX #$40 AND FLASH.BIT = $40
|
||||
2690 BNE N.I.F. ...ALWAYS
|
||||
2700 *--------------------------------
|
||||
2710 * "HIMEM:" STATEMENT
|
||||
2720 *--------------------------------
|
||||
2730 HIMEM JSR FRMNUM GET VALUE SPECIFIED FOR HIMEM
|
||||
2740 JSR GETADR AS 16-BIT INTEGER
|
||||
2750 LDA LINNUM MUST BE ABOVE VARIABLES AND ARRAYS
|
||||
2760 CMP STREND
|
||||
2770 LDA LINNUM+1
|
||||
2780 SBC STREND+1
|
||||
2790 BCS SETHI IT IS ABOVE THEM
|
||||
2800 JMM JMP MEMERR NOT ENOUGH MEMORY
|
||||
2810 SETHI LDA LINNUM STORE NEW HIMEM: VALUE
|
||||
2820 STA MEMSIZ
|
||||
2830 STA FRETOP <<<NOTE THAT "HIMEM:" DOES NOT>>>
|
||||
2840 LDA LINNUM+1 <<<CLEAR STRING VARIABLES. >>>
|
||||
2850 STA MEMSIZ+1 <<<THIS COULD BE DISASTROUS. >>>
|
||||
2860 STA FRETOP+1
|
||||
2870 RTS
|
||||
2880 *--------------------------------
|
||||
2890 * "LOMEM:" STATEMENT
|
||||
2900 *--------------------------------
|
||||
2910 LOMEM JSR FRMNUM GET VALUE SPECIFIED FOR LOMEM
|
||||
2920 JSR GETADR AS 16-BIT INTEGER IN LINNUM
|
||||
2930 LDA LINNUM MUST BE BELOW HIMEM
|
||||
2940 CMP MEMSIZ
|
||||
2950 LDA LINNUM+1
|
||||
2960 SBC MEMSIZ+1
|
||||
2970 BCS JMM ABOVE HIMEM, MEMORY ERROR
|
||||
2980 LDA LINNUM MUST BE ABOVE PROGRAM
|
||||
2990 CMP VARTAB
|
||||
3000 LDA LINNUM+1
|
||||
3010 SBC VARTAB+1
|
||||
3020 BCC JMM NOT ABOVE PROGRAM, ERROR
|
||||
3030 LDA LINNUM STORE NEW LOMEM VALUE
|
||||
3040 STA VARTAB
|
||||
3050 LDA LINNUM+1
|
||||
3060 STA VARTAB+1
|
||||
3070 JMP CLEARC LOMEM CLEARS VARIABLES AND ARRAYS
|
||||
3080 *--------------------------------
|
||||
3090 * "ON ERR GO TO" STATEMENT
|
||||
3100 *--------------------------------
|
||||
3110 ONERR LDA #TOKEN.GOTO MUST BE "GOTO" NEXT
|
||||
3120 JSR SYNCHR
|
||||
3130 LDA TXTPTR SAVE TXTPTR FOR HANDLERR
|
||||
3140 STA TXTPSV
|
||||
3150 LDA TXTPTR+1
|
||||
3160 STA TXTPSV+1
|
||||
3170 SEC SET SIGN BIT OF ERRFLG
|
||||
3180 ROR ERRFLG
|
||||
3190 LDA CURLIN SAVE LINE # OF CURRENT LINE
|
||||
3200 STA CURLSV
|
||||
3210 LDA CURLIN+1
|
||||
3220 STA CURLSV+1
|
||||
3230 JSR REMN IGNORE REST OF LINE <<<WHY?>>>
|
||||
3240 JMP ADDON CONTINUE PROGRAM
|
||||
3250 *--------------------------------
|
||||
3260 * ROUTINE TO HANDLE ERRORS IF ONERR GOTO ACTIVE
|
||||
3270 *--------------------------------
|
||||
3280 HANDLERR
|
||||
3290 STX ERRNUM SAVE ERROR CODE NUMBER
|
||||
3300 LDX REMSTK GET STACK PNTR SAVED AT NEWSTT
|
||||
3310 STX ERRSTK REMEMBER IT
|
||||
3320 * <<<COULD ALSO HAVE DONE TXS >>>
|
||||
3330 * <<<HERE; SEE ONERR CORRECTION>>>
|
||||
3340 * <<<IN APPLESOFT MANUAL. >>>
|
||||
3350 LDA CURLIN GET LINE # OF OFFENDING STATEMENT
|
||||
3360 STA ERRLIN SO USER CAN SEE IT IF DESIRED
|
||||
3370 LDA CURLIN+1
|
||||
3380 STA ERRLIN+1
|
||||
3390 LDA OLDTEXT ALSO THE POSITION IN THE LINE
|
||||
3400 STA ERRPOS IN CASE USER WANTS TO "RESUME"
|
||||
3410 LDA OLDTEXT+1
|
||||
3420 STA ERRPOS+1
|
||||
3430 LDA TXTPSV SET UP TXTPTR TO READ TARGET LINE #
|
||||
3440 STA TXTPTR IN "ON ERR GO TO XXXX"
|
||||
3450 LDA TXTPSV+1
|
||||
3460 STA TXTPTR+1
|
||||
3470 LDA CURLSV
|
||||
3480 STA CURLIN LINE # OF "ON ERR" STATEMENT
|
||||
3490 LDA CURLSV+1
|
||||
3500 STA CURLIN+1
|
||||
3510 JSR CHRGOT START CONVERSION
|
||||
3520 JSR GOTO GOTO SPECIFIED ONERR LINE
|
||||
3530 JMP NEWSTT
|
||||
3540 *--------------------------------
|
||||
3550 * "RESUME" STATEMENT
|
||||
3560 *--------------------------------
|
||||
3570 RESUME LDA ERRLIN RESTORE LINE # AND TXTPTR
|
||||
3580 STA CURLIN TO RE-TRY OFFENDING LINE
|
||||
3590 LDA ERRLIN+1
|
||||
3600 STA CURLIN+1
|
||||
3610 LDA ERRPOS
|
||||
3620 STA TXTPTR
|
||||
3630 LDA ERRPOS+1
|
||||
3640 STA TXTPTR+1
|
||||
3650 * <<< ONERR CORRECTION IN MANUAL IS EASILY >>>
|
||||
3660 * <<< BY "CALL -3288", WHICH IS $F328 HERE >>>
|
||||
3670 LDX ERRSTK RETRIEVE STACK PNTR AS IT WAS
|
||||
3680 TXS BEFORE STATEMENT SCANNED
|
||||
3690 JMP NEWSTT DO STATEMENT AGAIN
|
||||
3700 *--------------------------------
|
||||
3710 JSYN JMP SYNERR
|
||||
3720 *--------------------------------
|
||||
3730 * "DEL" STATEMENT
|
||||
3740 *--------------------------------
|
||||
3750 DEL BCS JSYN ERROR IF # NOT SPECIFIED
|
||||
3760 LDX PRGEND
|
||||
3770 STX VARTAB
|
||||
3780 LDX PRGEND+1
|
||||
3790 STX VARTAB+1
|
||||
3800 JSR LINGET GET BEGINNING OF RANGE
|
||||
3810 JSR FNDLIN FIND THIS LINE OR NEXT
|
||||
3820 LDA LOWTR UPPER PORTION OF PROGRAM WILL
|
||||
3830 STA DEST BE MOVED DOWN TO HERE
|
||||
3840 LDA LOWTR+1
|
||||
3850 STA DEST+1
|
||||
3860 LDA #',' MUST HAVE A COMMA NEXT
|
||||
3870 JSR SYNCHR
|
||||
3880 JSR LINGET GET END RANGE
|
||||
3890 * (DOES NOTHING IF END RANGE
|
||||
3900 * IS NOT SPECIFIED)
|
||||
3910 INC LINNUM POINT ONE PAST IT
|
||||
3920 BNE .1
|
||||
3930 INC LINNUM+1
|
||||
3940 .1 JSR FNDLIN FIND START LINE AFTER SPECIFIED LINE
|
||||
3950 LDA LOWTR WHICH IS BEGINNING OF PORTION
|
||||
3960 CMP DEST TO BE MOVED DOWN
|
||||
3970 LDA LOWTR+1 IT MUST BE ABOVE THE TARGET
|
||||
3980 SBC DEST+1
|
||||
3990 BCS .2 IT IS OKAY
|
||||
4000 RTS NOTHING TO DELETE
|
||||
4010 .2 LDY #0 MOVE UPPER PORTION DOWN NOW
|
||||
4020 .3 LDA (LOWTR),Y SOURCE . . .
|
||||
4030 STA (DEST),Y ...TO DESTINATION
|
||||
4040 INC LOWTR BUMP SOURCE PNTR
|
||||
4050 BNE .4
|
||||
4060 INC LOWTR+1
|
||||
4070 .4 INC DEST BUMP DESTINATION PNTR
|
||||
4080 BNE .5
|
||||
4090 INC DEST+1
|
||||
4100 .5 LDA VARTAB REACHED END OF PROGRAM YET?
|
||||
4110 CMP LOWTR
|
||||
4120 LDA VARTAB+1
|
||||
4130 SBC LOWTR+1
|
||||
4140 BCS .3 NO, KEEP MOVING
|
||||
4150 LDX DEST+1 STORE NEW END OF PROGRAM
|
||||
4160 LDY DEST MUST SUBTRACT 1 FIRST
|
||||
4170 BNE .6
|
||||
4180 DEX
|
||||
4190 .6 DEY
|
||||
4200 STX VARTAB+1
|
||||
4210 STY VARTAB
|
||||
4220 JMP FIX.LINKS RESET LINKS AFTER A DELETE
|
||||
4230 *--------------------------------
|
||||
4240 * "GR" STATEMENT
|
||||
4250 *--------------------------------
|
||||
4260 GR LDA SW.LORES
|
||||
4270 LDA SW.MIXSET
|
||||
4280 JMP MON.SETGR
|
||||
4290 *--------------------------------
|
||||
4300 * "TEXT" STATEMENT
|
||||
4310 *--------------------------------
|
||||
4320 TEXT LDA SW.LOWSCR JMP $FB36 WOULD HAVE
|
||||
4330 JMP MON.SETTXT DONE BOTH OF THESE
|
||||
4340 * <<< BETTER CODE WOULD BE: >>>
|
||||
4350 * <<< LDA SW.MIXSET >>>
|
||||
4360 * <<< JMP $FB33 >>>
|
||||
4370 *--------------------------------
|
||||
4380 * "STORE" STATEMENT
|
||||
4390 *--------------------------------
|
||||
4400 STORE JSR GETARYPT GET ADDRESS OF ARRAY TO BE SAVED
|
||||
4410 LDY #3 FORWARD OFFSET - 1 IS SIZE OF
|
||||
4420 LDA (LOWTR),Y THIS ARRAY
|
||||
4430 TAX
|
||||
4440 DEY
|
||||
4450 LDA (LOWTR),Y
|
||||
4460 SBC #1
|
||||
4470 BCS .1
|
||||
4480 DEX
|
||||
4490 .1 STA LINNUM
|
||||
4500 STX LINNUM+1
|
||||
4510 JSR MON.WRITE
|
||||
4520 JSR TAPEPNT
|
||||
4530 JMP MON.WRITE
|
||||
4540 *--------------------------------
|
||||
4550 * "RECALL" STATEMENT
|
||||
4560 *--------------------------------
|
||||
4570 RECALL JSR GETARYPT FIND ARRAY IN MEMORY
|
||||
4580 JSR MON.READ READ HEADER
|
||||
4590 LDY #2 MAKE SURE THE NEW DATA FITS
|
||||
4600 LDA (LOWTR),Y
|
||||
4610 CMP LINNUM
|
||||
4620 INY
|
||||
4630 LDA (LOWTR),Y
|
||||
4640 SBC LINNUM+1
|
||||
4650 BCS .1 IT FITS
|
||||
4660 JMP MEMERR DOESN'T FIT
|
||||
4670 .1 JSR TAPEPNT READ THE DATA
|
||||
4680 JMP MON.READ
|
||||
153
source/applesoft/S.F3D8
Normal file
153
source/applesoft/S.F3D8
Normal file
@ -0,0 +1,153 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "HGR" AND "HGR2" STATEMENTS
|
||||
1030 *--------------------------------
|
||||
1040 HGR2 BIT SW.HISCR SELECT PAGE 2 ($4000-5FFF)
|
||||
1050 BIT SW.MIXCLR DEFAULT TO FULL SCREEN
|
||||
1060 LDA /$4000 SET STARTING PAGE FOR HIRES
|
||||
1070 BNE SETHPG ...ALWAYS
|
||||
1080 HGR LDA /$2000 SET STARTING PAGE FOR HIRES
|
||||
1090 BIT SW.LOWSCR SELECT PAGE 1 ($2000-3FFF)
|
||||
1100 BIT SW.MIXSET DEFAULT TO MIXED SCREEN
|
||||
1110 SETHPG STA HGR.PAGE BASE PAGE OF HIRES BUFFER
|
||||
1120 LDA SW.HIRES TURN ON HIRES
|
||||
1130 LDA SW.TXTCLR TURN ON GRAPHICS
|
||||
1140 *--------------------------------
|
||||
1150 * CLEAR SCREEN
|
||||
1160 *--------------------------------
|
||||
1170 HCLR LDA #0 SET FOR BLACK BACKGROUND
|
||||
1180 STA HGR.BITS
|
||||
1190 *--------------------------------
|
||||
1200 * FILL SCREEN WITH (HGR.BITS)
|
||||
1210 *--------------------------------
|
||||
1220 BKGND LDA HGR.PAGE PUT BUFFER ADDRESS IN HGR.SHAPE
|
||||
1230 STA HGR.SHAPE+1
|
||||
1240 LDY #0
|
||||
1250 STY HGR.SHAPE
|
||||
1260 .1 LDA HGR.BITS COLOR BYTE
|
||||
1270 STA (HGR.SHAPE),Y CLEAR HIRES TO HGR.BITS
|
||||
1280 JSR COLOR.SHIFT CORRECT FOR COLOR SHIFT
|
||||
1290 INY (SLOWS CLEAR BY FACTOR OF 2)
|
||||
1300 BNE .1
|
||||
1310 INC HGR.SHAPE+1
|
||||
1320 LDA HGR.SHAPE+1
|
||||
1330 AND #$1F DONE? ($40 OR$60)
|
||||
1340 BNE .1 NO
|
||||
1350 RTS YES, RETURN
|
||||
1360 *--------------------------------
|
||||
1370 * SET THE HIRES CURSOR POSITION
|
||||
1380 *
|
||||
1390 * (Y,X) = HORIZONTAL COORDINATE (0-279)
|
||||
1400 * (A) = VERTICAL COORDINATE (0-191)
|
||||
1410 *--------------------------------
|
||||
1420 HPOSN STA HGR.Y SAVE Y- AND X-POSITIONS
|
||||
1430 STX HGR.X
|
||||
1440 STY HGR.X+1
|
||||
1450 PHA Y-POS ALSO ON STACK
|
||||
1460 AND #$C0 CALCULATE BASE ADDRESS FOR Y-POS
|
||||
1470 STA MON.GBASL FOR Y=ABCDEFGH
|
||||
1480 LSR GBASL=ABAB0000
|
||||
1490 LSR
|
||||
1500 ORA MON.GBASL
|
||||
1510 STA MON.GBASL
|
||||
1520 PLA (A) (GBASH) (GBASL)
|
||||
1530 STA MON.GBASH ?-ABCDEFGH ABCDEFGH ABAB0000
|
||||
1540 ASL A-BCDEFGH0 ABCDEFGH ABAB0000
|
||||
1550 ASL B-CDEFGH00 ABCDEFGH ABAB0000
|
||||
1560 ASL C-DEFGH000 ABCDEFGH ABAB0000
|
||||
1570 ROL MON.GBASH A-DEFGH000 BCDEFGHC ABAB0000
|
||||
1580 ASL D-EFGH0000 BCDEFGHC ABAB0000
|
||||
1590 ROL MON.GBASH B-EFGH0000 CDEFGHCD ABAB0000
|
||||
1600 ASL E-FGH00000 CDEFGHCD ABAB0000
|
||||
1610 ROR MON.GBASL 0-FGH00000 CDEFGHCD EABAB000
|
||||
1620 LDA MON.GBASH 0-CDEFGHCD CDEFGHCD EABAB000
|
||||
1630 AND #$1F 0-000FGHCD CDEFGHCD EABAB000
|
||||
1640 ORA HGR.PAGE 0-PPPFGHCD CDEFGHCD EABAB000
|
||||
1650 STA MON.GBASH 0-PPPFGHCD PPPFGHCD EABAB000
|
||||
1660 TXA DIVIDE X-POS BY 7 FOR INDEX FROM BASE
|
||||
1670 CPY #0 IS X-POS < 256?
|
||||
1680 BEQ .2 YES
|
||||
1690 LDY #35 NO: 256/7 = 36 REM 4
|
||||
1700 * CARRY=1, SO ADC #4 IS TOO LARGE;
|
||||
1710 * HOWEVER, ADC #4 CLEARS CARRY
|
||||
1720 * WHICH MAKES SBC #7 ONLY -6
|
||||
1730 * BALANCING IT OUT.
|
||||
1740 ADC #4 FOLLOWING INY MAKES Y=36
|
||||
1750 .1 INY
|
||||
1760 .2 SBC #7
|
||||
1770 BCS .1
|
||||
1780 STY HGR.HORIZ HORIZONTAL INDEX
|
||||
1790 TAX USE REMAINDER-7 TO LOOK UP THE
|
||||
1800 LDA MSKTBL-$100+7,X BIT MASK
|
||||
1810 STA MON.HMASK
|
||||
1820 TYA QUOTIENT GIVES BYTE INDEX
|
||||
1830 LSR ODD OR EVEN COLUMN?
|
||||
1840 LDA HGR.COLOR IF ON ODD BYTE (CARRY SET)
|
||||
1850 STA HGR.BITS THEN ROTATE BITS
|
||||
1860 BCS COLOR.SHIFT ODD COLUMN
|
||||
1870 RTS EVEN COLUMN
|
||||
1880 *--------------------------------
|
||||
1890 * PLOT A DOT
|
||||
1900 *
|
||||
1910 * (Y,X) = HORIZONTAL POSITION
|
||||
1920 * (A) = VERTICAL POSITION
|
||||
1930 *--------------------------------
|
||||
1940 HPLOT0 JSR HPOSN
|
||||
1950 LDA HGR.BITS CALCULATE BIT POSN IN GBAS,
|
||||
1960 EOR (MON.GBASL),Y HGR.HORIZ, AND HMASK FROM
|
||||
1970 AND MON.HMASK Y-COOR IN A-REG,
|
||||
1980 EOR (MON.GBASL),Y X-COOR IN X,Y REGS.
|
||||
1990 STA (MON.GBASL),Y FOR ANY 1-BITS, SUBSTITUTE
|
||||
2000 RTS CORRESPONDING BIT OF HGR.BITS
|
||||
2010 *--------------------------------
|
||||
2020 * MOVE LEFT OR RIGHT ONE PIXEL
|
||||
2030 *
|
||||
2040 * IF STATUS IS +, MOVE RIGHT; IF -, MOVE LEFT
|
||||
2050 * IF ALREADY AT LEFT OR RIGHT EDGE, WRAP AROUND
|
||||
2060 *
|
||||
2070 * REMEMBER BITS IN HI-RES BYTE ARE BACKWARDS ORDER:
|
||||
2080 * BYTE N BYTE N+1
|
||||
2090 * S7654321 SEDCBA98
|
||||
2100 *--------------------------------
|
||||
2110 MOVE.LEFT.OR.RIGHT
|
||||
2120 BPL MOVE.RIGHT + MOVE RIGHT, - MOVE LEFT
|
||||
2130 LDA MON.HMASK MOVE LEFT ONE PIXEL
|
||||
2140 LSR SHIFT MASK RIGHT, MOVES DOT LEFT
|
||||
2150 BCS LR.2 ...DOT MOVED TO NEXT BYTE
|
||||
2160 EOR #$C0 MOVE SIGN BIT BACK WHERE IT WAS
|
||||
2170 LR.1 STA MON.HMASK NEW MASK VALUE
|
||||
2180 RTS
|
||||
2190 LR.2 DEY MOVED TO NEXT BYTE, SO DECR INDEX
|
||||
2200 BPL LR.3 STILL NOT PAST EDGE
|
||||
2210 LDY #39 OFF LEFT EDGE, SO WRAP AROUND SCREEN
|
||||
2220 LR.3 LDA #$C0 NEW HMASK, RIGHTMOST BIT ON SCREEN
|
||||
2230 LR.4 STA MON.HMASK NEW MASK AND INDEX
|
||||
2240 STY HGR.HORIZ
|
||||
2250 LDA HGR.BITS ALSO NEED TO ROTATE COLOR
|
||||
2260 *--------------------------------
|
||||
2270 COLOR.SHIFT
|
||||
2280 ASL ROTATE LOW-ORDER 7 BITS
|
||||
2290 CMP #$C0 OF HGR.BITS ONE BIT POSN.
|
||||
2300 BPL .1
|
||||
2310 LDA HGR.BITS
|
||||
2320 EOR #$7F
|
||||
2330 STA HGR.BITS
|
||||
2340 .1 RTS
|
||||
2350 *--------------------------------
|
||||
2360 * MOVE RIGHT ONE PIXEL
|
||||
2370 * IF ALREADY AT RIGHT EDGE, WRAP AROUND
|
||||
2380 *--------------------------------
|
||||
2390 MOVE.RIGHT
|
||||
2400 LDA MON.HMASK
|
||||
2410 ASL SHIFTING BYTE LEFT MOVES PIXEL RIGHT
|
||||
2420 EOR #$80
|
||||
2430 * ORIGINAL: C0 A0 90 88 84 82 81
|
||||
2440 * SHIFTED: 80 40 20 10 08 02 01
|
||||
2450 * EOR #$80: 00 C0 A0 90 88 84 82
|
||||
2460 BMI LR.1 FINISHED
|
||||
2470 LDA #$81 NEW MASK VALUE
|
||||
2480 INY MOVE TO NEXT BYTE RIGHT
|
||||
2490 CPY #40 UNLESS THAT IS TOO FAR
|
||||
2500 BCC LR.4 NOT TOO FAR
|
||||
2510 LDY #0 TOO FAR, SO WRAP AROUND
|
||||
2520 BCS LR.4 ...ALWAYS
|
||||
2530 *--------------------------------
|
||||
223
source/applesoft/S.F49C
Normal file
223
source/applesoft/S.F49C
Normal file
@ -0,0 +1,223 @@
|
||||
1010 *--------------------------------
|
||||
1020 * "XDRAW" ONE BIT
|
||||
1030 *--------------------------------
|
||||
1040 LRUDX1 CLC C=0 MEANS NO 90 DEGREE ROTATION
|
||||
1050 LRUDX2 LDA HGR.DX+1 C=1 MEANS ROTATE 90 DEGREES
|
||||
1060 AND #4 IF BIT2=0 THEN DON'T PLOT
|
||||
1070 BEQ LRUD4 YES, DO NOT PLOT
|
||||
1080 LDA #$7F NO, LOOK AT WHAT IS ALREADY THERE
|
||||
1090 AND MON.HMASK
|
||||
1100 AND (MON.GBASL),Y SCREEN BIT = 1?
|
||||
1110 BNE LRUD3 YES, GO CLEAR IT
|
||||
1120 INC HGR.COLLISIONS NO, COUNT THE COLLISION
|
||||
1130 LDA #$7F AND TURN THE BIT ON
|
||||
1140 AND MON.HMASK
|
||||
1150 BPL LRUD3 ...ALWAYS
|
||||
1160 *--------------------------------
|
||||
1170 * "DRAW" ONE BIT
|
||||
1180 *--------------------------------
|
||||
1190 LRUD1 CLC C=0 MEANS NO 90 DEGREE ROTATION
|
||||
1200 LRUD2 LDA HGR.DX+1 C=1 MEANS ROTATE
|
||||
1210 AND #4 IF BIT2=0 THEN DO NOT PLOT
|
||||
1220 BEQ LRUD4 DO NOT PLOT
|
||||
1230 LDA (MON.GBASL),Y
|
||||
1240 EOR HGR.BITS 1'S WHERE ANY BITS NOT IN COLOR
|
||||
1250 AND MON.HMASK LOOK AT JUST THIS BIT POSITION
|
||||
1260 BNE LRUD3 THE BIT WAS ZERO, SO PLOT IT
|
||||
1270 INC HGR.COLLISIONS BIT IS ALREADY 1; COUNT COLLSN
|
||||
1280 *--------------------------------
|
||||
1290 * TOGGLE BIT ON SCREEN WITH (A)
|
||||
1300 *--------------------------------
|
||||
1310 LRUD3 EOR (MON.GBASL),Y
|
||||
1320 STA (MON.GBASL),Y
|
||||
1330 *--------------------------------
|
||||
1340 * DETERMINE WHERE NEXT POINT WILL BE, AND MOVE THERE
|
||||
1350 * C=0 IF NO 90 DEGREE ROTATION
|
||||
1360 * C=1 ROTATES 90 DEGREES
|
||||
1370 *--------------------------------
|
||||
1380 LRUD4 LDA HGR.DX+1 CALCULATE THE DIRECTION TO MOVE
|
||||
1390 ADC HGR.QUADRANT
|
||||
1400 AND #3 WRAP AROUND THE CIRCLE
|
||||
1410 CON.03 .EQ *-1 (( A CONSTANT ))
|
||||
1420 *
|
||||
1430 * 00 -- UP
|
||||
1440 * 01 -- DOWN
|
||||
1450 * 10 -- RIGHT
|
||||
1460 * 11 -- LEFT
|
||||
1470 *
|
||||
1480 CMP #2 C=0 IF 0 OR 1, C=1 IF 2 OR 3
|
||||
1490 ROR PUT C INTO SIGN, ODD/EVEN INTO C
|
||||
1500 BCS MOVE.LEFT.OR.RIGHT
|
||||
1510 *--------------------------------
|
||||
1520 MOVE.UP.OR.DOWN
|
||||
1530 BMI MOVE.DOWN SIGN FOR UP/DOWN SELECT.
|
||||
1540 *--------------------------------
|
||||
1550 * MOVE UP ONE PIXEL
|
||||
1560 * IF ALREADY AT TOP, GO TO BOTTOM
|
||||
1570 *
|
||||
1580 * REMEMBER: Y-COORD GBASH GBASL
|
||||
1590 * ABCDEFGH PPPFGHCD EABAB000
|
||||
1600 *--------------------------------
|
||||
1610 CLC MOVE UP
|
||||
1620 LDA MON.GBASH CALC. BASE ADDRESS OF PREV. LINE
|
||||
1630 BIT CON.1C LOOK AT BITS 000FGH00 IN GBASH
|
||||
1640 BNE .5 SIMPLE, JUST FGH=FGH-1
|
||||
1650 * GBASH=PPP000CD, GBASL=EABAB000
|
||||
1660 ASL MON.GBASL WHAT IS "E"?
|
||||
1670 BCS .3 E=1, THEN EFGH=EFGH-1
|
||||
1680 BIT CON.03 LOOK AT 000000CD IN GBASH
|
||||
1690 BEQ .1 Y-POS IS AB000000 FORM
|
||||
1700 ADC #$1F CD <> 0, SO CDEFGH=CDEFGH-1
|
||||
1710 SEC
|
||||
1720 BCS .4 ...ALWAYS
|
||||
1730 .1 ADC #$23 ENOUGH TO MAKE GBASH=PPP11111 LATER
|
||||
1740 PHA SAVE FOR LATER
|
||||
1750 LDA MON.GBASL GBASL IS NOW ABAB0000 (AB=00,01,10)
|
||||
1760 ADC #$B0 0000+1011=1011 AND CARRY CLEAR
|
||||
1770 * OR 0101+1011=0000 AND CARRY SET
|
||||
1780 * OR 1010+1011=0101 AND CARRY SET
|
||||
1790 BCS .2 NO WRAP-AROUND NEEDED
|
||||
1800 ADC #$F0 CHANGE 1011 TO 1010 (WRAP-AROUND)
|
||||
1810 .2 STA MON.GBASL FORM IS NOW STILL ABAB0000
|
||||
1820 PLA PARTIALLY MODIFIED GBASH
|
||||
1830 BCS .4 ...ALWAYS
|
||||
1840 .3 ADC #$1F
|
||||
1850 .4 ROR MON.GBASL SHIFT IN E, TO GET EABAB000 FORM
|
||||
1860 .5 ADC #$FC FINISH GBASH MODS
|
||||
1870 UD.1 STA MON.GBASH
|
||||
1880 RTS
|
||||
1890 *--------------------------------
|
||||
1900 CLC <<<NEVER USED>>>
|
||||
1910 *--------------------------------
|
||||
1920 * MOVE DOWN ONE PIXEL
|
||||
1930 * IF ALREADY AT BOTTOM, GO TO TOP
|
||||
1940 *
|
||||
1950 * REMEMBER: Y-COORD GBASH GBASL
|
||||
1960 * ABCDEFGH PPPFGHCD EABAB000
|
||||
1970 *--------------------------------
|
||||
1980 MOVE.DOWN
|
||||
1990 LDA MON.GBASH TRY IT FIRST, BY FGH=FGH+1
|
||||
2000 ADC #4 GBASH = PPPFGHCD
|
||||
2010 CON.04 .EQ *-1 (( CONSTANT ))
|
||||
2020 BIT CON.1C IS FGH FIELD NOW ZERO?
|
||||
2030 BNE UD.1 NO, SO WE ARE FINISHED
|
||||
2040 * YES, RIPPLE THE CARRY AS HIGH
|
||||
2050 * AS NECESSARY
|
||||
2060 ASL MON.GBASL LOOK AT "E" BIT
|
||||
2070 BCC .2 NOW ZERO; MAKE IT 1 AND LEAVE
|
||||
2080 ADC #$E0 CARRY = 1, SO ADDS $E1
|
||||
2090 CLC IS "CD" NOT ZERO?
|
||||
2100 BIT CON.04 TESTS BIT 2 FOR CARRY OUT OF "CD"
|
||||
2110 BEQ .3 NO CARRY, FINISHED
|
||||
2120 * INCREMENT "AB" THEN
|
||||
2130 * 0000 --> 0101
|
||||
2140 * 0101 --> 1010
|
||||
2150 * 1010 --> WRAP AROUND TO LINE 0
|
||||
2160 LDA MON.GBASL 0000 0101 1010
|
||||
2170 ADC #$50 0101 1010 1111
|
||||
2180 EOR #$F0 1010 0101 0000
|
||||
2190 BEQ .1
|
||||
2200 EOR #$F0 0101 1010
|
||||
2210 .1 STA MON.GBASL NEW ABAB0000
|
||||
2220 LDA HGR.PAGE WRAP AROUND TO LINE ZERO OF GROUP
|
||||
2230 BCC .3 ...ALWAYS
|
||||
2240 .2 ADC #$E0
|
||||
2250 .3 ROR MON.GBASL
|
||||
2260 BCC UD.1 ...ALWAYS
|
||||
2270 *--------------------------------
|
||||
2280 * HLINRL IS NEVER CALLED BY APPLESOFT
|
||||
2290 *
|
||||
2300 * ENTER WITH: (A,X) = DX FROM CURRENT POINT
|
||||
2310 * (Y) = DY FROM CURRENT POINT
|
||||
2320 *--------------------------------
|
||||
2330 HLINRL PHA SAVE (A)
|
||||
2340 LDA #0 CLEAR CURRENT POINT SO HGLIN WILL
|
||||
2350 STA HGR.X ACT RELATIVELY
|
||||
2360 STA HGR.X+1
|
||||
2370 STA HGR.Y
|
||||
2380 PLA RESTORE (A)
|
||||
2390 *--------------------------------
|
||||
2400 * DRAW LINE FROM LAST PLOTTED POINT TO (A,X),(Y)
|
||||
2410 *
|
||||
2420 * ENTER WITH: (A,X) = X OF TARGET POINT
|
||||
2430 * (Y) = Y OF TARGET POINT
|
||||
2440 *--------------------------------
|
||||
2450 HGLIN PHA COMPUTE DX = X- X0
|
||||
2460 SEC
|
||||
2470 SBC HGR.X
|
||||
2480 PHA
|
||||
2490 TXA
|
||||
2500 SBC HGR.X+1
|
||||
2510 STA HGR.QUADRANT SAVE DX SIGN (+ = RIGHT, - = LEFT)
|
||||
2520 BCS .1 NOW FIND ABS (DX)
|
||||
2530 PLA FORMS 2'S COMPLEMENT
|
||||
2540 EOR #$FF
|
||||
2550 ADC #1
|
||||
2560 PHA
|
||||
2570 LDA #0
|
||||
2580 SBC HGR.QUADRANT
|
||||
2590 .1 STA HGR.DX+1
|
||||
2600 STA HGR.E+1 INIT HGR.E TO ABS(X-X0)
|
||||
2610 PLA
|
||||
2620 STA HGR.DX
|
||||
2630 STA HGR.E
|
||||
2640 PLA
|
||||
2650 STA HGR.X TARGET X POINT
|
||||
2660 STX HGR.X+1
|
||||
2670 TYA TARGET Y POINT
|
||||
2680 CLC COMPUTE DY = Y-HGR.Y
|
||||
2690 SBC HGR.Y AND SAVE -ABS(Y-HGR.Y)-1 IN HGR.DY
|
||||
2700 BCC .2 (SO + MEANS UP, - MEANS DOWN)
|
||||
2710 EOR #$FF 2'S COMPLEMENT OF DY
|
||||
2720 ADC #$FE
|
||||
2730 .2 STA HGR.DY
|
||||
2740 STY HGR.Y TARGET Y POINT
|
||||
2750 ROR HGR.QUADRANT SHIFT Y-DIRECTION INTO QUADRANT
|
||||
2760 SEC COUNT = DX -(-DY) = # OF DOTS NEEDED
|
||||
2770 SBC HGR.DX
|
||||
2780 TAX COUNTL IS IN X-REG
|
||||
2790 LDA #$FF
|
||||
2800 SBC HGR.DX+1
|
||||
2810 STA HGR.COUNT
|
||||
2820 LDY HGR.HORIZ HORIZONTAL INDEX
|
||||
2830 BCS MOVEX2 ...ALWAYS
|
||||
2840 *--------------------------------
|
||||
2850 * MOVE LEFT OR RIGHT ONE PIXEL
|
||||
2860 * (A) BIT 6 HAS DIRECTION
|
||||
2870 *--------------------------------
|
||||
2880 MOVEX ASL PUT BIT 6 INTO SIGN POSITION
|
||||
2890 JSR MOVE.LEFT.OR.RIGHT
|
||||
2900 SEC
|
||||
2910 *--------------------------------
|
||||
2920 * DRAW LINE NOW
|
||||
2930 *--------------------------------
|
||||
2940 MOVEX2 LDA HGR.E CARRY IS SET
|
||||
2950 ADC HGR.DY E = E-DELTY
|
||||
2960 STA HGR.E NOTE: DY IS (-DELTA Y)-1
|
||||
2970 LDA HGR.E+1 CARRY CLR IF HGR.E GOES NEGATIVE
|
||||
2980 SBC #0
|
||||
2990 .1 STA HGR.E+1
|
||||
3000 LDA (MON.GBASL),Y
|
||||
3010 EOR HGR.BITS PLOT A DOT
|
||||
3020 AND MON.HMASK
|
||||
3030 EOR (MON.GBASL),Y
|
||||
3040 STA (MON.GBASL),Y
|
||||
3050 INX FINISHED ALL THE DOTS?
|
||||
3060 BNE .2 NO
|
||||
3070 INC HGR.COUNT TEST REST OF COUNT
|
||||
3080 BEQ RTS.22 YES, FINISHED.
|
||||
3090 .2 LDA HGR.QUADRANT TEST DIRECTION
|
||||
3100 BCS MOVEX NEXT MOVE IS IN THE X DIRECTION
|
||||
3110 JSR MOVE.UP.OR.DOWN IF CLR, NEG, MOVE
|
||||
3120 CLC E = E+DX
|
||||
3130 LDA HGR.E
|
||||
3140 ADC HGR.DX
|
||||
3150 STA HGR.E
|
||||
3160 LDA HGR.E+1
|
||||
3170 ADC HGR.DX+1
|
||||
3180 BVC .1 ...ALWAYS
|
||||
3190 *--------------------------------
|
||||
3200 MSKTBL .HS 8182848890A0C0
|
||||
3210 *--------------------------------
|
||||
3220 CON.1C .HS 1C MASK FOR "FGH" BITS
|
||||
3230 *--------------------------------
|
||||
394
source/applesoft/S.F5BA
Normal file
394
source/applesoft/S.F5BA
Normal file
@ -0,0 +1,394 @@
|
||||
1010 *--------------------------------
|
||||
1020 * TABLE OF COS(90*X/16 DEGREES)*$100 - 1
|
||||
1030 * WITH ONE BYTE PRECISION, X=0 TO 16:
|
||||
1040 *--------------------------------
|
||||
1050 COSINE.TABLE
|
||||
1060 .HS FFFEFAF4ECE1D4C5
|
||||
1070 .HS B4A18D7861493118
|
||||
1080 .HS FF
|
||||
1090 *--------------------------------
|
||||
1100 * HFIND -- CALCULATES CURRENT POSITION OF HI-RES CURSOR
|
||||
1110 * (NOT CALLED BY ANY APPLESOFT ROUTINE)
|
||||
1120 *
|
||||
1130 * CALCULATE Y-COORD FROM GBASL,H
|
||||
1140 * AND X-COORD FROM HORIZ AND HMASK
|
||||
1150 *--------------------------------
|
||||
1160 HFIND LDA MON.GBASL GBASL = EABAB000
|
||||
1170 ASL E INTO CARRY
|
||||
1180 LDA MON.GBASH GBASH = PPPFGHCD
|
||||
1190 AND #3 000000CD
|
||||
1200 ROL 00000CDE
|
||||
1210 ORA MON.GBASL EABABCDE
|
||||
1220 ASL ABABCDE0
|
||||
1230 ASL BABCDE00
|
||||
1240 ASL ABCDE000
|
||||
1250 STA HGR.Y ALL BUT FGH
|
||||
1260 LDA MON.GBASH PPPFGHCD
|
||||
1270 LSR 0PPPFGHC
|
||||
1280 LSR 00PPPFGH
|
||||
1290 AND #7 00000FGH
|
||||
1300 ORA HGR.Y ABCDEFGH
|
||||
1310 STA HGR.Y THAT TAKES CARE OF Y-COORDINATE!
|
||||
1320 LDA HGR.HORIZ X = 7*HORIZ + BIT POS. IN HMASK
|
||||
1330 ASL MULTIPLY BY 7
|
||||
1340 ADC HGR.HORIZ 3* SO FAR
|
||||
1350 ASL 6*
|
||||
1360 TAX SINCE 7* MIGHT NOT FIT IN 1 BYTE,
|
||||
1370 * WAIT TILL LATER FOR LAST ADD
|
||||
1380 DEX
|
||||
1390 LDA MON.HMASK NOW FIND BIT POSITION IN HMASK
|
||||
1400 AND #$7F ONLY LOOK AT LOW SEVEN
|
||||
1410 .1 INX COUNT A SHIFT
|
||||
1420 LSR
|
||||
1430 BNE .1 STILL IN THERE
|
||||
1440 STA HGR.X+1 ZERO TO HI-BYTE
|
||||
1450 TXA 6*HORIZ+LOG2(HMASK)
|
||||
1460 CLC ADD HORIZ ONE MORE TIME
|
||||
1470 ADC HGR.HORIZ 7*HORIZ+LOG2(HMASK)
|
||||
1480 BCC .2 UPPER BYTE = 0
|
||||
1490 INC HGR.X+1 UPPER BYTE = 1
|
||||
1500 .2 STA HGR.X STORE LOWER BYTE
|
||||
1510 RTS.22 RTS
|
||||
1520 *--------------------------------
|
||||
1530 * DRAW A SHAPE
|
||||
1540 *
|
||||
1550 * (Y,X) = SHAPE STARTING ADDRESS
|
||||
1560 * (A) = ROTATION (0-3F)
|
||||
1570 *--------------------------------
|
||||
1580 * APPLESOFT DOES NOT CALL DRAW0
|
||||
1590 *--------------------------------
|
||||
1600 DRAW0 STX HGR.SHAPE SAVE SHAPE ADDRESS
|
||||
1610 STY HGR.SHAPE+1
|
||||
1620 *--------------------------------
|
||||
1630 * APPLESOFT ENTERS HERE
|
||||
1640 *--------------------------------
|
||||
1650 DRAW1 TAX SAVE ROTATION (0-$3F)
|
||||
1660 LSR DIVIDE ROTATION BY 16 TO GET
|
||||
1670 LSR QUADRANT (0=UP, 1=RT, 2=DWN, 3=LFT)
|
||||
1680 LSR
|
||||
1690 LSR
|
||||
1700 STA HGR.QUADRANT
|
||||
1710 TXA USE LOW 4 BITS OF ROTATION TO INDEX
|
||||
1720 AND #$0F THE TRIG TABLE
|
||||
1730 TAX
|
||||
1740 LDY COSINE.TABLE,X SAVE COSINE IN HGR.DX
|
||||
1750 STY HGR.DX
|
||||
1760 EOR #$F AND SINE IN DY
|
||||
1770 TAX
|
||||
1780 LDY COSINE.TABLE+1,X
|
||||
1790 INY
|
||||
1800 STY HGR.DY
|
||||
1810 LDY HGR.HORIZ INDEX FROM GBASL,H TO BYTE WE'RE IN
|
||||
1820 LDX #0
|
||||
1830 STX HGR.COLLISIONS CLEAR COLLISION COUNTER
|
||||
1840 LDA (HGR.SHAPE,X) GET FIRST BYTE OF SHAPE DEFN
|
||||
1850 .1 STA HGR.DX+1 KEEP SHAPE BYTE IN HGR.DX+1
|
||||
1860 LDX #$80 INITIAL VALUES FOR FRACTIONAL VECTORS
|
||||
1870 STX HGR.E .5 IN COSINE COMPONENT
|
||||
1880 STX HGR.E+1 .5 IN SINE COMPONENT
|
||||
1890 LDX HGR.SCALE SCALE FACTOR
|
||||
1900 .2 LDA HGR.E ADD COSINE VALUE TO X-VALUE
|
||||
1910 SEC IF >= 1, THEN DRAW
|
||||
1920 ADC HGR.DX
|
||||
1930 STA HGR.E ONLY SAVE FRACTIONAL PART
|
||||
1940 BCC .3 NO INTEGRAL PART
|
||||
1950 JSR LRUD1 TIME TO PLOT COSINE COMPONENT
|
||||
1960 CLC
|
||||
1970 .3 LDA HGR.E+1 ADD SINE VALUE TO Y-VALUE
|
||||
1980 ADC HGR.DY IF >= 1, THEN DRAW
|
||||
1990 STA HGR.E+1 ONLY SAVE FRACTIONAL PART
|
||||
2000 BCC .4 NO INTEGRAL PART
|
||||
2010 JSR LRUD2 TIME TO PLOT SINE COMPONENT
|
||||
2020 .4 DEX LOOP ON SCALE FACTOR.
|
||||
2030 BNE .2 STILL ON SAME SHAPE ITEM
|
||||
2040 LDA HGR.DX+1 GET NEXT SHAPE ITEM
|
||||
2050 LSR NEXT 3 BIT VECTOR
|
||||
2060 LSR
|
||||
2070 LSR
|
||||
2080 BNE .1 MORE IN THIS SHAPE BYTE
|
||||
2090 INC HGR.SHAPE GO TO NEXT SHAPE BYTE
|
||||
2100 BNE .5
|
||||
2110 INC HGR.SHAPE+1
|
||||
2120 .5 LDA (HGR.SHAPE,X) NEXT BYTE OF SHAPE DEFINITION
|
||||
2130 BNE .1 PROCESS IF NOT ZERO
|
||||
2140 RTS FINISHED
|
||||
2150 *--------------------------------
|
||||
2160 * XDRAW A SHAPE (SAME AS DRAW, EXCEPT TOGGLES SCREEN)
|
||||
2170 *
|
||||
2180 * (Y,X) = SHAPE STARTING ADDRESS
|
||||
2190 * (A) = ROTATION (0-3F)
|
||||
2200 *--------------------------------
|
||||
2210 * APPLESOFT DOES NOT CALL XDRAW0
|
||||
2220 *--------------------------------
|
||||
2230 XDRAW0 STX HGR.SHAPE SAVE SHAPE ADDRESS
|
||||
2240 STY HGR.SHAPE+1
|
||||
2250 *--------------------------------
|
||||
2260 * APPLESOFT ENTERS HERE
|
||||
2270 *--------------------------------
|
||||
2280 XDRAW1 TAX SAVE ROTATION (0-$3F)
|
||||
2290 LSR DIVIDE ROTATION BY 16 TO GET
|
||||
2300 LSR QUADRANT (0=UP, 1=RT, 2=DWN, 3=LFT)
|
||||
2310 LSR
|
||||
2320 LSR
|
||||
2330 STA HGR.QUADRANT
|
||||
2340 TXA USE LOW 4 BITS OF ROTATION TO INDEX
|
||||
2350 AND #$0F THE TRIG TABLE
|
||||
2360 TAX
|
||||
2370 LDY COSINE.TABLE,X SAVE COSINE IN HGR.DX
|
||||
2380 STY HGR.DX
|
||||
2390 EOR #$F AND SINE IN DY
|
||||
2400 TAX
|
||||
2410 LDY COSINE.TABLE+1,X
|
||||
2420 INY
|
||||
2430 STY HGR.DY
|
||||
2440 LDY HGR.HORIZ INDEX FROM GBASL,H TO BYTE WE'RE IN
|
||||
2450 LDX #0
|
||||
2460 STX HGR.COLLISIONS CLEAR COLLISION COUNTER
|
||||
2470 LDA (HGR.SHAPE,X) GET FIRST BYTE OF SHAPE DEFN
|
||||
2480 .1 STA HGR.DX+1 KEEP SHAPE BYTE IN HGR.DX+1
|
||||
2490 LDX #$80 INITIAL VALUES FOR FRACTIONAL VECTORS
|
||||
2500 STX HGR.E .5 IN COSINE COMPONENT
|
||||
2510 STX HGR.E+1 .5 IN SINE COMPONENT
|
||||
2520 LDX HGR.SCALE SCALE FACTOR
|
||||
2530 .2 LDA HGR.E ADD COSINE VALUE TO X-VALUE
|
||||
2540 SEC IF >= 1, THEN DRAW
|
||||
2550 ADC HGR.DX
|
||||
2560 STA HGR.E ONLY SAVE FRACTIONAL PART
|
||||
2570 BCC .3 NO INTEGRAL PART
|
||||
2580 JSR LRUDX1 TIME TO PLOT COSINE COMPONENT
|
||||
2590 CLC
|
||||
2600 .3 LDA HGR.E+1 ADD SINE VALUE TO Y-VALUE
|
||||
2610 ADC HGR.DY IF >= 1, THEN DRAW
|
||||
2620 STA HGR.E+1 ONLY SAVE FRACTIONAL PART
|
||||
2630 BCC .4 NO INTEGRAL PART
|
||||
2640 JSR LRUDX2 TIME TO PLOT SINE COMPONENT
|
||||
2650 .4 DEX LOOP ON SCALE FACTOR.
|
||||
2660 BNE .2 STILL ON SAME SHAPE ITEM
|
||||
2670 LDA HGR.DX+1 GET NEXT SHAPE ITEM
|
||||
2680 LSR NEXT 3 BIT VECTOR
|
||||
2690 LSR
|
||||
2700 LSR
|
||||
2710 BNE .1 MORE IN THIS SHAPE BYTE
|
||||
2720 INC HGR.SHAPE GO TO NEXT SHAPE BYTE
|
||||
2730 BNE .5
|
||||
2740 INC HGR.SHAPE+1
|
||||
2750 .5 LDA (HGR.SHAPE,X) NEXT BYTE OF SHAPE DEFINITION
|
||||
2760 BNE .1 PROCESS IF NOT ZERO
|
||||
2770 RTS FINISHED
|
||||
2780 *--------------------------------
|
||||
2790 * GET HI-RES PLOTTING COORDINATES (0-279,0-191) FROM
|
||||
2800 * TXTPTR. LEAVE REGISTERS SET UP FOR HPOSN:
|
||||
2810 * (Y,X)=X-COORD
|
||||
2820 * (A) =Y-COORD
|
||||
2830 *--------------------------------
|
||||
2840 HFNS JSR FRMNUM EVALUATE EXPRESSION, MUST BE NUMERIC
|
||||
2850 JSR GETADR CONVERT TO 2-BYTE INTEGER IN LINNUM
|
||||
2860 LDY LINNUM+1 GET HORIZ COOR IN X,Y
|
||||
2870 LDX LINNUM
|
||||
2880 CPY /280 MAKE SURE IT IS < 280
|
||||
2890 BCC .1 IN RANGE
|
||||
2900 BNE GGERR
|
||||
2910 CPX #280
|
||||
2920 BCS GGERR
|
||||
2930 .1 TXA SAVE HORIZ COOR ON STACK
|
||||
2940 PHA
|
||||
2950 TYA
|
||||
2960 PHA
|
||||
2970 LDA #',' REQUIRE A COMMA
|
||||
2980 JSR SYNCHR
|
||||
2990 JSR GETBYT EVAL EXP TO SINGLE BYTE IN X-REG
|
||||
3000 CPX #192 CHECK FOR RANGE
|
||||
3010 BCS GGERR TOO BIG
|
||||
3020 STX FAC SAVE Y-COORD
|
||||
3030 PLA RETRIEVE HORIZONTAL COORDINATE
|
||||
3040 TAY
|
||||
3050 PLA
|
||||
3060 TAX
|
||||
3070 LDA FAC AND VERTICAL COORDINATE
|
||||
3080 RTS
|
||||
3090 *--------------------------------
|
||||
3100 GGERR JMP GOERR ILLEGAL QUANTITY ERROR
|
||||
3110 *--------------------------------
|
||||
3120 * "HCOLOR=" STATEMENT
|
||||
3130 *--------------------------------
|
||||
3140 HCOLOR JSR GETBYT EVAL EXP TO SINGLE BYTE IN X
|
||||
3150 CPX #8 VALUE MUST BE 0-7
|
||||
3160 BCS GGERR TOO BIG
|
||||
3170 LDA COLORTBL,X GET COLOR PATTERN
|
||||
3180 STA HGR.COLOR
|
||||
3190 RTS.23 RTS
|
||||
3200 *--------------------------------
|
||||
3210 COLORTBL .HS 002A557F80AAD5FF
|
||||
3220 *--------------------------------
|
||||
3230 * "HPLOT" STATEMENT
|
||||
3240 *
|
||||
3250 * HPLOT X,Y
|
||||
3260 * HPLOT TO X,Y
|
||||
3270 * HPLOT X1,Y1 TO X2,Y2
|
||||
3280 *--------------------------------
|
||||
3290 HPLOT CMP #TOKEN.TO "PLOT TO" FORM?
|
||||
3300 BEQ .2 YES, START FROM CURRENT LOCATION
|
||||
3310 JSR HFNS NO, GET STARTING POINT OF LINE
|
||||
3320 JSR HPLOT0 PLOT THE POINT, AND SET UP FOR
|
||||
3330 * DRAWING A LINE FROM THAT POINT
|
||||
3340 .1 JSR CHRGOT CHARACTER AT END OF EXPRESSION
|
||||
3350 CMP #TOKEN.TO IS A LINE SPECIFIED?
|
||||
3360 BNE RTS.23 NO, EXIT
|
||||
3370 .2 JSR SYNCHR YES. ADV. TXTPTR (WHY NOT CHRGET)
|
||||
3380 JSR HFNS GET COORDINATES OF LINE END
|
||||
3390 STY DSCTMP SET UP FOR LINE
|
||||
3400 TAY
|
||||
3410 TXA
|
||||
3420 LDX DSCTMP
|
||||
3430 JSR HGLIN PLOT LINE
|
||||
3440 JMP .1 LOOP TILL NO MORE "TO" PHRASES
|
||||
3450 *--------------------------------
|
||||
3460 * "ROT=" STATEMENT
|
||||
3470 *--------------------------------
|
||||
3480 ROT JSR GETBYT EVAL EXP TO A BYTE IN X-REG
|
||||
3490 STX HGR.ROTATION
|
||||
3500 RTS
|
||||
3510 *--------------------------------
|
||||
3520 * "SCALE=" STATEMENT
|
||||
3530 *--------------------------------
|
||||
3540 SCALE JSR GETBYT EVAL EXP TO A BYTE IN X-REG
|
||||
3550 STX HGR.SCALE
|
||||
3560 RTS
|
||||
3570 *--------------------------------
|
||||
3580 * SET UP FOR DRAW AND XDRAW
|
||||
3590 *--------------------------------
|
||||
3600 DRWPNT JSR GETBYT GET SHAPE NUMBER IN X-REG
|
||||
3610 LDA HGR.SHAPE.PNTR SEARCH FOR THAT SHAPE
|
||||
3620 STA HGR.SHAPE SET UP PNTR TO BEGINNING OF TABLE
|
||||
3630 LDA HGR.SHAPE.PNTR+1
|
||||
3640 STA HGR.SHAPE+1
|
||||
3650 TXA
|
||||
3660 LDX #0
|
||||
3670 CMP (HGR.SHAPE,X) COMPARE TO # OF SHAPES IN TABLE
|
||||
3680 BEQ .1 LAST SHAPE IN TABLE
|
||||
3690 BCS GGERR SHAPE # TOO LARGE
|
||||
3700 .1 ASL DOUBLE SHAPE# TO MAKE AN INDEX
|
||||
3710 BCC .2 ADD 256 IF SHAPE # > 127
|
||||
3720 INC HGR.SHAPE+1
|
||||
3730 CLC
|
||||
3740 .2 TAY USE INDEX TO LOOK UP OFFSET FOR SHAPE
|
||||
3750 LDA (HGR.SHAPE),Y IN OFFSET TABLE
|
||||
3760 ADC HGR.SHAPE
|
||||
3770 TAX
|
||||
3780 INY
|
||||
3790 LDA (HGR.SHAPE),Y
|
||||
3800 ADC HGR.SHAPE.PNTR+1
|
||||
3810 STA HGR.SHAPE+1 SAVE ADDRESS OF SHAPE
|
||||
3820 STX HGR.SHAPE
|
||||
3830 JSR CHRGOT IS THERE ANY "AT" PHRASE?
|
||||
3840 CMP #TOKEN.AT
|
||||
3850 BNE .3 NO, DRAW RIGHT WHERE WE ARE
|
||||
3860 JSR SYNCHR SCAN OVER "AT"
|
||||
3870 JSR HFNS GET X- AND Y-COORDS TO START DRAWING AT
|
||||
3880 JSR HPOSN SET UP CURSOR THERE
|
||||
3890 .3 LDA HGR.ROTATION ROTATION VALUE
|
||||
3900 RTS
|
||||
3910 *--------------------------------
|
||||
3920 * "DRAW" STATEMENT
|
||||
3930 *--------------------------------
|
||||
3940 DRAW JSR DRWPNT
|
||||
3950 JMP DRAW1
|
||||
3960 *--------------------------------
|
||||
3970 * "XDRAW" STATEMENT
|
||||
3980 *--------------------------------
|
||||
3990 XDRAW JSR DRWPNT
|
||||
4000 JMP XDRAW1
|
||||
4010 *--------------------------------
|
||||
4020 * "SHLOAD" STATEMENT
|
||||
4030 *
|
||||
4040 * READS A SHAPE TABLE FROM CASSETTE TAPE
|
||||
4050 * TO A POSITION JUST BELOW HIMEM.
|
||||
4060 * HIMEM IS THEN MOVED TO JUST BELOW THE TABLE
|
||||
4070 *--------------------------------
|
||||
4080 SHLOAD LDA /LINNUM SET UP TO READ TWO BYTES
|
||||
4090 STA MON.A1H INTO LINNUM,LINNUM+1
|
||||
4100 STA MON.A2H
|
||||
4110 LDY #LINNUM
|
||||
4120 STY MON.A1L
|
||||
4130 INY LINNUM+1
|
||||
4140 STY MON.A2L
|
||||
4150 JSR MON.READ READ TAPE
|
||||
4160 CLC SETUP TO READ (LINNUM) BYTES
|
||||
4170 LDA MEMSIZ ENDING AT HIMEM-1
|
||||
4180 TAX
|
||||
4190 DEX FORMING HIMEM-1
|
||||
4200 STX MON.A2L
|
||||
4210 SBC LINNUM FORMING HIMEM-(LINNUM)
|
||||
4220 PHA
|
||||
4230 LDA MEMSIZ+1
|
||||
4240 TAY
|
||||
4250 INX SEE IF HIMEM LOW-BYTE WAS ZERO
|
||||
4260 BNE .1 NO
|
||||
4270 DEY YES, HAVE TO DECREMENT HIGH BYTE
|
||||
4280 .1 STY MON.A2H
|
||||
4290 SBC LINNUM+1
|
||||
4300 CMP STREND+1 RUNNING INTO VARIABLES?
|
||||
4310 BCC .2 YES, OUT OF MEMORY
|
||||
4320 BNE .3 NO, STILL ROOM
|
||||
4330 .2 JMP MEMERR MEM FULL ERR
|
||||
4340 .3 STA MEMSIZ+1
|
||||
4350 STA FRETOP+1 CLEAR STRING SPACE
|
||||
4360 STA MON.A1H (BUT NAMES ARE STILL IN VARTBL!)
|
||||
4370 STA HGR.SHAPE.PNTR+1
|
||||
4380 PLA
|
||||
4390 STA HGR.SHAPE.PNTR
|
||||
4400 STA MEMSIZ
|
||||
4410 STA FRETOP
|
||||
4420 STA MON.A1L
|
||||
4430 JSR MON.RD2BIT READ TO TAPE TRANSITIONS
|
||||
4440 LDA #3 SHORT DELAY FOR INTERMEDIATE HEADER
|
||||
4450 JMP MON.READ2 READ SHAPES
|
||||
4460 *--------------------------------
|
||||
4470 * CALLED FROM STORE AND RECALL
|
||||
4480 *--------------------------------
|
||||
4490 TAPEPNT
|
||||
4500 CLC
|
||||
4510 LDA LOWTR
|
||||
4520 ADC LINNUM
|
||||
4530 STA MON.A2L
|
||||
4540 LDA LOWTR+1
|
||||
4550 ADC LINNUM+1
|
||||
4560 STA MON.A2H
|
||||
4570 LDY #4
|
||||
4580 LDA (LOWTR),Y
|
||||
4590 JSR GETARY2
|
||||
4600 LDA HIGHDS
|
||||
4610 STA MON.A1L
|
||||
4620 LDA HIGHDS+1
|
||||
4630 STA MON.A1H
|
||||
4640 RTS
|
||||
4650 *--------------------------------
|
||||
4660 * CALLED FROM STORE AND RECALL
|
||||
4670 *--------------------------------
|
||||
4680 GETARYPT
|
||||
4681 LDA #$40
|
||||
4690 STA SUBFLG
|
||||
4700 JSR PTRGET
|
||||
4710 LDA #0
|
||||
4720 STA SUBFLG
|
||||
4730 JMP VARTIO
|
||||
4740 *--------------------------------
|
||||
4750 * "HTAB" STATEMENT
|
||||
4760 *
|
||||
4770 * NOTE THAT IF WNDLEFT IS NOT 0, HTAB CAN PRINT
|
||||
4780 * OUTSIDE THE SCREEN (EG., IN THE PROGRAM)
|
||||
4790 *--------------------------------
|
||||
4800 HTAB JSR GETBYT
|
||||
4810 DEX
|
||||
4820 TXA
|
||||
4830 .1 CMP #40
|
||||
4840 BCC .2
|
||||
4850 SBC #40
|
||||
4860 PHA
|
||||
4870 JSR CRDO
|
||||
4880 PLA
|
||||
4890 JMP .1
|
||||
4900 .2 STA MON.CH
|
||||
4910 RTS
|
||||
4920 *--------------------------------
|
||||
4930 .AS -/KRW/ SOMEONE'S INITIALS?
|
||||
5322
source/applesoft/check.txt
Normal file
5322
source/applesoft/check.txt
Normal file
File diff suppressed because it is too large
Load Diff
Loading…
x
Reference in New Issue
Block a user