commit 6a1e34ba6f06d67c13a902da87a550c1fc97acb5 Author: Tom Greene Date: Thu May 11 16:42:22 2017 -0400 initial diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..9de2564 --- /dev/null +++ b/Makefile @@ -0,0 +1,23 @@ +AFLAGS = +LFLAGS = -C replica1.cfg +BINFILE = applesoft-lite.bin +OBJS = applesoft-lite.o io.o cffa1.o wozmon.o + +$(BINFILE): $(OBJS) + ld65 $(LFLAGS) $(OBJS) -o $(BINFILE) + +applesoft-lite.o: applesoft-lite.s + ca65 $(AFLAGS) $< + +wozmon.o: wozmon.s + ca65 $(AFLAGS) $< + +cffa1.o: cffa1.s + ca65 $(AFLAGS) $< + +io.o: io.s + ca65 $(AFLAGS) $< + +clean: + rm $(OBJS) $(BINFILE) + diff --git a/README.md b/README.md new file mode 100644 index 0000000..2a56ee3 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# applesoft-lite + +This is a stripped-down version of Applesoft BASIC (Microsoft 6502 BASIC) for the Apple-1. + +See https://cowgod.org/replica1/applesoft/ diff --git a/applesoft-lite.s b/applesoft-lite.s new file mode 100644 index 0000000..0bd5820 --- /dev/null +++ b/applesoft-lite.s @@ -0,0 +1,5501 @@ +; Applesoft Lite +; +; Disassembled from the Apple II+ ROMs with da65 V2.12.0 +; +; Most comments and label names from the S-C DocuMentor +; by Bob Sander-Cederlof +; +; Adapted for the Replica-1 by Tom Greene +; 7-May-2008 +; +; v0.4 + + + +.setcpu "6502" +.segment "BASIC" + +.export FIX_LINKS, ERROR, INPUTBUFFER +.exportzp ERR_SYNTAX, ERR_NOCFFA + +.import CLS, OUTDO, CRDO, OUTSP, OUTQUES ; Imports from io.s +.import KEYBOARD, GETLN, RDKEY + +.import CFFALoad, CFFASave, CFFAMenu ; Imports from cffa1.s + +.include "macros.s" +.include "zeropage.s" + + +; ---------------------------------------------------------------------------- +STACK := $0100 +INPUTBUFFER := $0200 + +; ---------------------------------------------------------------------------- +; Applesoft Tokens +; ---------------------------------------------------------------------------- +TOKEN_FOR = $81 +TOKEN_DATA = $83 +TOKEN_POP = $88 +TOKEN_GOTO = $8E +TOKEN_GOSUB = $92 +TOKEN_REM = $94 +TOKEN_PRINT = $98 +TOKEN_TO = $A2 +TOKEN_SPC = $A3 +TOKEN_THEN = $A4 +TOKEN_NOT = $A5 +TOKEN_STEP = $A6 +TOKEN_PLUS = $A7 +TOKEN_MINUS = $A8 +TOKEN_GREATER = $AE +TOKEN_EQUAL = $AF +TOKEN_SGN = $B1 +TOKEN_LEFTSTR = $BF + + +; ---------------------------------------------------------------------------- +; Cold and warm entry points at $E000 and E003 +; ---------------------------------------------------------------------------- + jmp COLDSTART + jmp RESTART + + +; ---------------------------------------------------------------------------- +; Branch Table for Tokens +; ---------------------------------------------------------------------------- +TOKEN_ADDRESS_TABLE: + .addr END - 1 ; $80... 128... END + .addr FOR - 1 ; $81... 129... FOR + .addr NEXT - 1 ; $82... 130... NEXT + .addr DATA - 1 ; $83... 131... DATA + .addr INPUT - 1 ; $84... 132... INPUT + .addr DIM - 1 ; $85... 133... DIM + .addr READ - 1 ; $86... 134... READ + .addr CALL - 1 ; $87... 135... CALL + .addr POP - 1 ; $88... 136... POP + .addr HIMEM - 1 ; $89... 136... HIMEM: + .addr LOMEM - 1 ; $8A... 137... LOMEM: + .addr ONERR - 1 ; $8B... 138... ONERR + .addr RESUME - 1 ; $8C... 139... RESUME + .addr LET - 1 ; $8D... 140... LET + .addr GOTO - 1 ; $8E... 141... GOTO + .addr RUN - 1 ; $8F... 142... RUN + .addr IF - 1 ; $90... 143... IF + .addr RESTORE - 1 ; $91... 144... RESTORE + .addr GOSUB - 1 ; $92... 145... GOSUB + .addr POP - 1 ; $93... 146... RETURN + .addr REM - 1 ; $94... 147... REM + .addr STOP - 1 ; $95... 148... STOP + .addr ONGOTO - 1 ; $96... 149... ON + .addr POKE - 1 ; $97... 150... POKE + .addr PRINT - 1 ; $98... 151... PRINT + .addr CONT - 1 ; $99... 152... CONT + .addr LIST - 1 ; $9A... 153... LIST + .addr CLEAR - 1 ; $9B... 154... CLEAR + .addr GET - 1 ; $9C... 155... GET + .addr NEW - 1 ; $9D... 156... NEW + .addr CFFAMenu - 1 ; $9E... 157... MENU + .addr CFFASave - 1 ; $9F... 158... SAVE + .addr CFFALoad - 1 ; $A0... 160... LOAD + .addr CLS - 1 ; $A1... 161... CLS +; ---------------------------------------------------------------------------- +UNFNC: .addr SGN ; $B1... 177... SGN + .addr INT ; $B2... 178... INT + .addr ABS ; $B3... 179... ABS + .addr FRE ; $B4... 180... FRE + .addr SQR ; $B5... 181... SQR + .addr RND ; $B6... 182... RND + .addr LOG ; $B7... 183... LOG + .addr EXP ; $B8... 184... EXP + .addr PEEK ; $B9... 185... PEEK + .addr LEN ; $BA... 186... LEN + .addr STR ; $BB... 187... STR$ + .addr VAL ; $BC... 188... VAL + .addr ASC ; $BD... 189... ASC + .addr CHRSTR ; $BE... 190... CHR$ + .addr LEFTSTR ; $BF... 191... LEFT$ + .addr RIGHTSTR ; $C0... 192... RIGHT$ + .addr MIDSTR ; $C1... 193... MID$ + + +; ---------------------------------------------------------------------------- +; Math Operator Branch Table +; +; one-byte precedence code +; two-byte address +; ---------------------------------------------------------------------------- +POR = $46 ; "OR" is lowest precedence +PAND = $50 +PREL = $64 ; Relational operators +PADD = $79 ; binary + and - +PMUL = $7B ; * and / +PPWR = $7D ; exponentiation +PNEQ = $7F ; unary - and comparison = +; ---------------------------------------------------------------------------- +MATHTBL:.byte PADD + .addr FADDT - 1 ; $A7... 167... + + .byte PADD + .addr FSUBT - 1 ; $A8... 168... - + .byte PMUL + .addr FMULTT - 1 ; $A9... 169... * + .byte PMUL + .addr FDIVT - 1 ; $AA... 170... / + .byte PPWR + .addr FPWRT - 1 ; $AB... 171... ^ + .byte PAND + .addr TAND - 1 ; $AC... 172... AND + .byte POR + .addr OR - 1 ; $AD... 173... OR +M_NEG: .byte PNEQ + .addr NEGOP - 1 ; $AE... 174... > +M_EQU: .byte PNEQ + .addr EQUOP - 1 ; $AF... 175... = +M_REL: .byte PREL + .addr RELOPS - 1 ; $B0... 176... < + + +; ---------------------------------------------------------------------------- +; Token Name Table +; ---------------------------------------------------------------------------- +TOKEN_NAME_TABLE: + htasc "END" ; $80... 128 + htasc "FOR" ; $81... 129 + htasc "NEXT" ; $82... 130 + htasc "DATA" ; $83... 131 + htasc "INPUT" ; $84... 132 + htasc "DIM" ; $85... 133 + htasc "READ" ; $86... 134 + htasc "CALL" ; $87... 135 + htasc "POP" ; $88... 136 + htasc "HIMEM:" ; $89... 137 + htasc "LOMEM:" ; $8A... 138 + htasc "ONERR" ; $8B... 139 + htasc "RESUME" ; $8C... 140 + htasc "LET" ; $8D... 141 + htasc "GOTO" ; $8E... 142 + htasc "RUN" ; $8F... 143 + htasc "IF" ; $90... 144 + htasc "RESTORE" ; $91... 145 + htasc "GOSUB" ; $92... 146 + htasc "RETURN" ; $93... 147 + htasc "REM" ; $94... 148 + htasc "STOP" ; $95... 149 + htasc "ON" ; $96... 150 + htasc "POKE" ; $97... 151 + htasc "PRINT" ; $98... 152 + htasc "CONT" ; $99... 153 + htasc "LIST" ; $9A... 154 + htasc "CLEAR" ; $9B... 155 + htasc "GET" ; $9C... 156 + htasc "NEW" ; $9D... 157 + htasc "MENU" ; $9E... 158 New tokens + htasc "SAVE" ; $9F... 159 for + htasc "LOAD" ; $A0... 160 CFFA I/O + htasc "CLS" ; $A1... 161 New token to clear screen + htasc "TO" ; $A2... 162 + htasc "SPC(" ; $A3... 163 + htasc "THEN" ; $A4... 164 + htasc "NOT" ; $A5... 165 + htasc "STEP" ; $A6... 166 + htasc "+" ; $A7... 167 + htasc "-" ; $A8... 168 + htasc "*" ; $A9... 169 + htasc "/" ; $AA... 170 + htasc "^" ; $AB... 171 + htasc "AND" ; $AC... 172 + htasc "OR" ; $AD... 173 + htasc ">" ; $AE... 174 + htasc "=" ; $AF... 175 + htasc "<" ; $B0... 176 + htasc "SGN" ; $B1... 177 + htasc "INT" ; $B2... 178 + htasc "ABS" ; $B3... 179 + htasc "FRE" ; $B4... 180 + htasc "SQR" ; $B5... 181 + htasc "RND" ; $B6... 182 + htasc "LOG" ; $B7... 183 + htasc "EXP" ; $B8... 184 + htasc "PEEK" ; $B9... 185 + htasc "LEN" ; $BA... 186 + htasc "STR$" ; $BB... 187 + htasc "VAL" ; $BC... 188 + htasc "ASC" ; $BD... 189 + htasc "CHR$" ; $BE... 190 + htasc "LEFT$" ; $BF... 191 + htasc "RIGHT$" ; $C0... 192 + htasc "MID$" ; $C1... 193 + .byte $00 ; END OF TOKEN NAME TABLE + + +; ---------------------------------------------------------------------------- +; Error Messages +; ---------------------------------------------------------------------------- +ERROR_MESSAGES: + +ERR_NOFOR := <(*-ERROR_MESSAGES) + htasc "NO FOR" + +ERR_SYNTAX := <(*-ERROR_MESSAGES) + htasc "SYNTAX" + +ERR_NOGOSUB := <(*-ERROR_MESSAGES) + htasc "NO GOSUB" + +ERR_NODATA := <(*-ERROR_MESSAGES) + htasc "OUT OF DATA" + +ERR_ILLQTY := <(*-ERROR_MESSAGES) + htasc "ILLEG QTY" + +ERR_OVERFLOW := <(*-ERROR_MESSAGES) + htasc "OVERFLOW" + +ERR_MEMFULL := <(*-ERROR_MESSAGES) + htasc "OUT OF MEM" + +ERR_UNDEFSTAT := <(*-ERROR_MESSAGES) + htasc "UNDEF LINE" + +ERR_BADSUBS := <(*-ERROR_MESSAGES) + htasc "BAD SUBSCR" + +ERR_REDIMD := <(*-ERROR_MESSAGES) + htasc "REDIM" + +ERR_ZERODIV := <(*-ERROR_MESSAGES) + htasc "DIV BY 0" + +ERR_ILLDIR := <(*-ERROR_MESSAGES) + htasc "NOT DIRECT" + +ERR_BADTYPE := <(*-ERROR_MESSAGES) + htasc "WRONG TYP" + +ERR_STRLONG := <(*-ERROR_MESSAGES) + htasc "LONG STR" + +ERR_FRMCPX := <(*-ERROR_MESSAGES) + htasc "LONG FORMULA" + +ERR_CANTCONT := <(*-ERROR_MESSAGES) + htasc "CAN'T CONT" + +ERR_NOCFFA := <(*-ERROR_MESSAGES) ; New error message for CFFA1 I/O + htasc "NO CFFA" +; ---------------------------------------------------------------------------- +QT_ERROR: + .byte " ERR" + .byte $00 +QT_IN: .byte " IN " + .byte $00 +QT_BREAK: + .byte $0D + .byte "BREAK" + .byte $00 + +; ---------------------------------------------------------------------------- +; CALLED BY "NEXT" AND "FOR" TO SCAN THROUGH +; THE STACK FOR A FRAME WITH THE SAME VARIABLE. +; +; (FORPNT) = ADDRESS OF VARIABLE IF "FOR" OR "NEXT" +; = $XXFF IF CALLED FROM "RETURN" +; <<< BUG: SHOULD BE $FFXX >>> +; +; RETURNS .NE. IF VARIABLE NOT FOUND, +; (X) = STACK PNTR AFTER SKIPPING ALL FRAMES +; +; .EQ. IF FOUND +; (X) = STACK PNTR OF FRAME FOUND +; ---------------------------------------------------------------------------- +GTFORPNT: + tsx + inx + inx + inx + inx +@1: lda STACK+1,x ; "FOR" FRAME HERE? + cmp #TOKEN_FOR + bne @4 ; NO + lda FORPNT+1 ; YES -- "NEXT" WITH NO VARIABLE? + bne @2 ; NO, VARIABLE SPECIFIED + lda STACK+2,x ; YES, SO USE THIS FRAME + sta FORPNT + lda STACK+3,x + sta FORPNT+1 +@2: cmp STACK+3,x ; IS VARIABLE IN THIS FRAME? + bne @3 ; NO + lda FORPNT ; LOOK AT 2ND BYTE TOO + cmp STACK+2,x ; SAME VARIABLE? + beq @4 ; YES +@3: txa ; NO, SO TRY NEXT FRAME (IF ANY) + clc ; 18 BYTES PER FRAME + adc #18 + tax + bne @1 ; ...ALWAYS? +@4: rts + + +; ---------------------------------------------------------------------------- +; MOVE BLOCK OF MEMORY UP +; +; ON ENTRY: +; (Y,A) = (HIGHDS) = DESTINATION END+1 +; (LOWTR) = LOWEST ADDRESS OF SOURCE +; (HIGHTR) = HIGHEST SOURCE ADDRESS+1 +; ---------------------------------------------------------------------------- +BLTU: jsr REASON ; BE SURE (Y,A) < FRETOP + sta STREND ; NEW TOP OF ARRAY STORAGE + sty STREND+1 +BLTU2: sec + lda HIGHTR ; COMPUTE # OF BYTES TO BE MOVED + sbc LOWTR ; (FROM LOWTR THRU HIGHTR-1) + sta INDEX ; PARTIAL PAGE AMOUNT + tay + lda HIGHTR+1 + sbc LOWTR+1 + tax ; # OF WHOLE PAGES IN X-REG + inx + tya ; # BYTES IN PARTIAL PAGE + beq @4 ; NO PARTIAL PAGE + lda HIGHTR ; BACK UP HIGHTR # BYTES IN PARTIAL PAGE + sec + sbc INDEX + sta HIGHTR + bcs @1 + dec HIGHTR+1 + sec +@1: lda HIGHDS ; BACK UP HIGHDS # BYTES IN PARTIAL PAGE + sbc INDEX + sta HIGHDS + bcs @3 + dec HIGHDS+1 + bcc @3 ; ...ALWAYS +@2: lda (HIGHTR),y ; MOVE THE BYTES + sta (HIGHDS),y +@3: dey + bne @2 ; LOOP TO END OF THIS 256 BYTES + lda (HIGHTR),y ; MOVE ONE MORE BYTE + sta (HIGHDS),y +@4: dec HIGHTR+1 ; DOWN TO NEXT BLOCK OF 256 + dec HIGHDS+1 + dex ; ANOTHER BLOCK OF 256 TO MOVE? + bne @3 ; YES + rts ; NO, FINISHED + + +; ---------------------------------------------------------------------------- +; CHECK IF ENOUGH ROOM LEFT ON STACK +; FOR "FOR", "GOSUB", OR EXPRESSION EVALUATION +; ---------------------------------------------------------------------------- +CHKMEM: asl a + adc #54 + bcs MEMERR ; ...MEM FULL ERR + sta INDEX + tsx + cpx INDEX + bcc MEMERR ; ...MEM FULL ERR + rts + + +; ---------------------------------------------------------------------------- +; CHECK IF ENOUGH ROOM BETWEEN ARRAYS AND STRINGS +; (Y,A) = ADDR ARRAYS NEED TO GROW TO +; ---------------------------------------------------------------------------- +REASON: cpy FRETOP+1 ; HIGH BYTE + bcc @4 ; PLENTY OF ROOM + bne @1 ; NOT ENOUGH, TRY GARBAGE COLLECTION + cmp FRETOP ; LOW BYTE + bcc @4 ; ENOUGH ROOM +@1: pha ; SAVE (Y,A), TEMP1, AND TEMP2 + ldx #FAC-TEMP1-1 + tya +@2: pha + lda TEMP1,x + dex + bpl @2 + jsr GARBAG ; MAKE AS MUCH ROOM AS POSSIBLE + ldx #TEMP1-FAC+1 ; RESTORE TEMP1 AND TEMP2 +@3: pla ; AND (Y,A) + sta FAC,x + inx + bmi @3 + pla + tay + pla ; DID WE FIND ENOUGH ROOM? + cpy FRETOP+1 ; HIGH BYTE + bcc @4 ; YES, AT LEAST A PAGE + bne MEMERR ; NO, MEM FULL ERR + cmp FRETOP ; LOW BYTE + bcs MEMERR ; NO, MEM FULL ERR +@4: rts ; YES, RETURN + +; ---------------------------------------------------------------------------- +MEMERR: ldx #ERR_MEMFULL + + +; ---------------------------------------------------------------------------- +; HANDLE AN ERROR +; +; (X)=OFFSET IN ERROR MESSAGE TABLE +; (ERRFLG) > 128 IF "ON ERR" TURNED ON +; (CURLIN+1) = $FF IF IN DIRECT MODE +; ---------------------------------------------------------------------------- +ERROR: bit ERRFLG ; "ON ERR" TURNED ON? + bpl @1 ; NO + jmp HANDLERR ; YES +@1: jsr CRDO ; PRINT + jsr OUTQUES ; PRINT "?" +@2: lda ERROR_MESSAGES,x + pha ; PRINT MESSAGE + jsr OUTDO + inx + pla + bpl @2 + jsr STKINI ; FIX STACK, ET AL + lda #QT_ERROR + + +; ---------------------------------------------------------------------------- +; PRINT STRING AT (Y,A) +; PRINT CURRENT LINE # UNLESS IN DIRECT MODE +; FALL INTO WARM RESTART +; ---------------------------------------------------------------------------- +PRINT_ERROR_LINNUM: + jsr STROUT ; PRINT STRING AT (Y,A) + ldy CURLIN+1 ; RUNNING, OR DIRECT? + iny + beq RESTART ; WAS $FF, SO DIRECT MODE + jsr INPRT ; RUNNING, SO PRINT LINE NUMBER + + +; ---------------------------------------------------------------------------- +; WARM RESTART ENTRY +; +; COME HERE FROM MONITOR BY CTL-C, 0G, 3D0G, OR E003G +; ---------------------------------------------------------------------------- +RESTART: + jsr CRDO ; PRINT + ldx #']' + $80 ; PROMPT CHARACTER + jsr INLIN2 ; READ A LINE + stx TXTPTR ; SET UP CHRGET TO SCAN THE LINE + sty TXTPTR+1 + lsr ERRFLG ; CLEAR FLAG + jsr CHRGET + tax + beq RESTART ; EMPTY LINE + ldx #$FF ; $FF IN HI-BYTE OF CURLIN MEANS + stx CURLIN+1 ; WE ARE IN DIRECT MODE + bcc NUMBERED_LINE ; CHRGET SAW DIGIT, NUMBERED LINE + jsr PARSE_INPUT_LINE ; NO NUMBER, SO PARSE IT + jmp NEWSTT2 ; AND TRY EXECUTING IT + + +; ---------------------------------------------------------------------------- +; HANDLE NUMBERED LINE +; ---------------------------------------------------------------------------- +NUMBERED_LINE: + ldx PRGEND ; SQUASH VARIABLE TABLE + stx VARTAB + ldx PRGEND+1 + stx VARTAB+1 + jsr LINGET ; GET LINE # + jsr PARSE_INPUT_LINE ; AND PARSE THE INPUT LINE + sty EOLPNTR ; SAVE INDEX TO INPUT BUFFER + jsr FNDLIN ; IS THIS LINE # ALREADY IN PROGRAM? + bcc PUT_NEW_LINE ; NO + ldy #1 ; YES, SO DELETE IT + lda (LOWTR),y ; LOWTR POINTS AT LINE + sta INDEX+1 ; GET HIGH BYTE OF FORWARD PNTR + lda VARTAB + sta INDEX + lda LOWTR+1 + sta DEST+1 + lda LOWTR + dey + sbc (LOWTR),y + clc + adc VARTAB + sta VARTAB + sta DEST + lda VARTAB+1 + adc #$FF + sta VARTAB+1 + sbc LOWTR+1 + tax + sec + lda LOWTR + sbc VARTAB + tay + bcs @1 + inx + dec DEST+1 +@1: clc + adc INDEX + bcc @2 + dec INDEX+1 + clc +; ---------------------------------------------------------------------------- +@2: lda (INDEX),y ; MOVE HIGHER LINES OF PROGRAM + sta (DEST),y ; DOWN OVER THE DELETED LINE. + iny + bne @2 + inc INDEX+1 + inc DEST+1 + dex + bne @2 + + +; ---------------------------------------------------------------------------- +PUT_NEW_LINE: + lda INPUTBUFFER ; ANY CHARACTERS AFTER LINE #? + beq FIX_LINKS ; NO, SO NOTHING TO INSERT. + lda MEMSIZ ; YES, SO MAKE ROOM AND INSERT LINE + ldy MEMSIZ+1 ; WIPE STRING AREA CLEAN + sta FRETOP + sty FRETOP+1 + lda VARTAB ; SET UP BLTU SUBROUTINE + sta HIGHTR ; INSERT NEW LINE. + adc EOLPNTR + sta HIGHDS + ldy VARTAB+1 + sty HIGHTR+1 + bcc @1 + iny +@1: sty HIGHDS+1 + jsr BLTU ; MAKE ROOM FOR THE LINE + lda LINNUM ; PUT LINE NUMBER IN LINE IMAGE + ldy LINNUM+1 + sta INPUTBUFFER-2 + sty INPUTBUFFER-1 + lda STREND + ldy STREND+1 + sta VARTAB + sty VARTAB+1 + ldy EOLPNTR +; ---COPY LINE INTO PROGRAM------- +@2: lda INPUTBUFFER-5,y + dey + sta (LOWTR),y + bne @2 + + +; ---------------------------------------------------------------------------- +; CLEAR ALL VARIABLES +; RE-ESTABLISH ALL FORWARD LINKS +; ---------------------------------------------------------------------------- +FIX_LINKS: + jsr SETPTRS ; CLEAR ALL VARIABLES + lda TXTTAB ; POINT INDEX AT START OF PROGRAM + ldy TXTTAB+1 + sta INDEX + sty INDEX+1 + clc +@1: ldy #1 ; HI-BYTE OF NEXT FORWARD PNTR + lda (INDEX),y ; END OF PROGRAM YET? + bne @2 ; NO, KEEP GOING + lda VARTAB ; YES + sta PRGEND + lda VARTAB+1 + sta PRGEND+1 + jmp RESTART +@2: ldy #4 ; FIND END OF THIS LINE +@3: iny ; (NOTE MAXIMUM LENGTH < 256) + lda (INDEX),y + bne @3 + iny ; COMPUTE ADDRESS OF NEXT LINE + tya + adc INDEX + tax + ldy #0 ; STORE FORWARD PNTR IN THIS LINE + sta (INDEX),y + lda INDEX+1 + adc #0 ; (NOTE: THIS CLEARS CARRY) + iny + sta (INDEX),y + stx INDEX + sta INDEX+1 + bcc @1 ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; READ A LINE, AND STRIP OFF SIGN BITS +; ---------------------------------------------------------------------------- +INLIN: ldx #$80 ; NULL PROMPT +INLIN2: stx PROMPT + jsr GETLN + cpx #239 ; MAXIMUM LINE LENGTH + bcc @1 + ldx #239 ; TRUNCATE AT 239 CHARS +@1: lda #0 ; MARK END OF LINE WITH $00 BYTE + sta INPUTBUFFER,x +; txa +; beq @3 ; NULL INPUT LINE +;@2: lda INPUTBUFFER-1,x ; DROP SIGN BITS +; and #$7F ; already cleared by GETLN +; sta INPUTBUFFER-1,x +; dex +; bne @2 +;@3: lda #0 ; (Y,X) POINTS AT BUFFER-1 + ldx #INPUTBUFFER-1 + rts + +; ---------------------------------------------------------------------------- +; TOKENIZE THE INPUT LINE +; ---------------------------------------------------------------------------- +PARSE_INPUT_LINE: + ldx TXTPTR ; INDEX INTO UNPARSED LINE + dex ; PREPARE FOR INX AT "PARSE" + ldy #4 ; INDEX TO PARSED OUTPUT LINE + sty DATAFLG ; CLEAR SIGN-BIT OF DATAFLG + bit LOCK ; IS THIS PROGRAM LOCKED? + bpl PARSE ; NO, GO AHEAD AND PARSE THE LINE + pla ; YES, IGNORE INPUT AND "RUN" + pla ; THE PROGRAM + jsr SETPTRS ; CLEAR ALL VARIABLES + jmp NEWSTT ; START RUNNING +; ---------------------------------------------------------------------------- +PARSE: inx ; NEXT INPUT CHARACTER +@1: lda INPUTBUFFER,x + bit DATAFLG ; IN A "DATA" STATEMENT? + bvs @2 ; YES (DATAFLG = $49) + cmp #' ' ; IGNORE BLANKS + beq PARSE +@2: sta ENDCHR + cmp #'"' ; START OF QUOTATION? + beq @13 + bvs @9 ; BRANCH IF IN "DATA" STATEMENT + cmp #'?' ; SHORTHAND FOR "PRINT"? + bne @3 ; NO + lda #TOKEN_PRINT ; YES, REPLACE WITH "PRINT" TOKEN + bne @9 ; ...ALWAYS +@3: cmp #'0' ; IS IT A DIGIT, COLON, OR SEMI-COLON? + bcc @4 ; NO, PUNCTUATION !"#$%&'()*+,-./ + cmp #';'+1 + bcc @9 ; YES, NOT A TOKEN +; ---------------------------------------------------------------------------- +; SEARCH TOKEN NAME TABLE FOR MATCH STARTING +; WITH CURRENT CHAR FROM INPUT LINE +; ---------------------------------------------------------------------------- +@4: sty STRNG2 ; SAVE INDEX TO OUTPUT LINE + lda #<(TOKEN_NAME_TABLE-$100) + sta FAC ; MAKE PNTR FOR SEARCH + lda #>(TOKEN_NAME_TABLE-$100) + sta FAC+1 + ldy #0 ; USE Y-REG WITH (FAC) TO ADDRESS TABLE + sty TKNCNTR ; HOLDS CURRENT TOKEN-$80 + dey ; PREPARE FOR "INY" A FEW LINES DOWN + stx TXTPTR ; SAVE POSITION IN INPUT LINE + dex ; PREPARE FOR "INX" A FEW LINES DOWN +@5: iny ; ADVANCE POINTER TO TOKEN TABLE + bne @6 ; Y=Y+1 IS ENOUGH + inc FAC+1 ; ALSO NEED TO BUMP THE PAGE +@6: inx ; ADVANCE POINTER TO INPUT LINE +@7: lda INPUTBUFFER,x ; NEXT CHAR FROM INPUT LINE + cmp #' ' ; THIS CHAR A BLANK? + beq @6 ; YES, IGNORE ALL BLANKS + sec ; NO, COMPARE TO CHAR IN TABLE + sbc (FAC),y ; SAME AS NEXT CHAR OF TOKEN NAME? + beq @5 ; YES, CONTINUE MATCHING + cmp #$80 ; MAYBE; WAS IT SAME EXCEPT FOR BIT 7? + bne @14 ; NO, SKIP TO NEXT TOKEN + ora TKNCNTR ; YES, END OF TOKEN; GET TOKEN # +; ---------------------------------------------------------------------------- +; STORE CHARACTER OR TOKEN IN OUTPUT LINE +; ---------------------------------------------------------------------------- +@8: ldy STRNG2 ; GET INDEX TO OUTPUT LINE IN Y-REG +@9: inx ; ADVANCE INPUT INDEX + iny ; ADVANCE OUTPUT INDEX + sta INPUTBUFFER-5,y ; STORE CHAR OR TOKEN + lda INPUTBUFFER-5,y ; TEST FOR EOL OR EOS + beq @17 ; END OF LINE + sec + sbc #':' ; END OF STATEMENT? + beq @10 ; YES, CLEAR DATAFLG + cmp #TOKEN_DATA-':' ; "DATA" TOKEN? + bne @11 ; NO, LEAVE DATAFLG ALONE +@10: sta DATAFLG ; DATAFLG = 0 OR $83-$3A = $49 +@11: sec ; IS IT A "REM" TOKEN? + sbc #TOKEN_REM-':' + bne @1 ; NO, CONTINUE PARSING LINE + sta ENDCHR ; YES, CLEAR LITERAL FLAG +; ---------------------------------------------------------------------------- +; HANDLE LITERAL (BETWEEN QUOTES) OR REMARK, +; BY COPYING CHARS UP TO ENDCHR. +; ---------------------------------------------------------------------------- +@12: lda INPUTBUFFER,x + beq @9 ; END OF LINE + cmp ENDCHR + beq @9 ; FOUND ENDCHR +@13: iny ; NEXT OUTPUT CHAR + sta INPUTBUFFER-5,y + inx ; NEXT INPUT CHAR + bne @12 ; ...ALWAYS +; ---------------------------------------------------------------------------- +; ADVANCE POINTER TO NEXT TOKEN NAME +; ---------------------------------------------------------------------------- +@14: ldx TXTPTR ; GET POINTER TO INPUT LINE IN X-REG + inc TKNCNTR ; BUMP (TOKEN # - $80) +@15: lda (FAC),y ; SCAN THROUGH TABLE FOR BIT7 = 1 + iny ; NEXT TOKEN ONE BEYOND THAT + bne @16 ; ...USUALLY ENOUGH TO BUMP Y-REG + inc FAC+1 ; NEXT SET OF 256 TOKEN CHARS +@16: asl a ; SEE IF SIGN BIT SET ON CHAR + bcc @15 ; NO, MORE IN THIS NAME + lda (FAC),y ; YES, AT NEXT NAME. END OF TABLE? + bne @7 ; NO, NOT END OF TABLE + lda INPUTBUFFER,x ; YES, SO NOT A KEYWORD + bpl @8 ; ...ALWAYS, COPY CHAR AS IS +; ---END OF LINE------------------ +@17: sta INPUTBUFFER-3,y ; STORE ANOTHER 00 ON END + dec TXTPTR+1 ; SET TXTPTR = INPUTBUFFER-1 + lda # + iny + lda (LOWTR),y ; GET LINE #, COMPARE WITH END RANGE + tax + iny + lda (LOWTR),y + cmp LINNUM+1 + bne @5 + cpx LINNUM + beq @6 ; ON LAST LINE OF RANGE +@5: bcs LIST3 ; FINISHED THE RANGE +; ---LIST ONE LINE---------------- +@6: sty FORPNT + jsr LINPRT ; PRINT LINE # FROM X,A + lda #' ' ; PRINT SPACE AFTER LINE # +LIST1: ldy FORPNT + and #$7F +LIST2: jsr OUTDO +@1: iny + lda (LOWTR),y + bne LIST4 ; NOT END OF LINE YET + tay ; END OF LINE + lda (LOWTR),y ; GET LINK TO NEXT LINE + tax + iny + lda (LOWTR),y + stx LOWTR ; POINT TO NEXT LINE + sta LOWTR+1 + bne LIST0 ; BRANCH IF NOT END OF PROGRAM +LIST3: jsr CRDO ; PRINT + jmp NEWSTT ; TO NEXT STATEMENT +; ---------------------------------------------------------------------------- +GETCHR: iny ; PICK UP CHAR FROM TABLE + bne @1 + inc FAC+1 +@1: lda (FAC),y + rts +; ---------------------------------------------------------------------------- +LIST4: bpl LIST2 ; BRANCH IF NOT A TOKEN + sec + sbc #$7F ; CONVERT TOKEN TO INDEX + tax + sty FORPNT ; SAVE LINE POINTER + ldy #<(TOKEN_NAME_TABLE-$100) + sty FAC ; POINT FAC TO TABLE + ldy #>(TOKEN_NAME_TABLE-$100) + sty FAC+1 + ldy #-1 +@1: dex ; SKIP KEYWORDS UNTIL REACH THIS ONE + beq @3 +@2: jsr GETCHR ; BUMP Y, GET CHAR FROM TABLE + bpl @2 ; NOT AT END OF KEYWORD YET + bmi @1 ; END OF KEYWORD, ALWAYS BRANCHES +@3: jsr OUTSP ; FOUND THE RIGHT KEYWORD, PRINT LEADING SPACE +@4: jsr GETCHR ; PRINT THE KEYWORD + bmi @5 ; LAST CHAR OF KEYWORD + jsr OUTDO + bne @4 ; ...ALWAYS +@5: jsr OUTDO ; PRINT LAST CHAR OF KEYWORD + lda #' ' ; PRINT TRAILING SPACE + bne LIST1 ; ...ALWAYS, BACK TO ACTUAL LINE + + +; ---------------------------------------------------------------------------- +; "FOR" STATEMENT +; +; FOR PUSHES 18 BYTES ON THE STACK: +; 2 -- TXTPTR +; 2 -- LINE NUMBER +; 5 -- INITIAL (CURRENT) FOR VARIABLE VALUE +; 1 -- STEP SIGN +; 5 -- STEP VALUE +; 2 -- ADDRESS OF FOR VARIABLE IN VARTAB +; 1 -- FOR TOKEN ($81) +; ---------------------------------------------------------------------------- +FOR: lda #$80 + sta SUBFLG ; SUBSCRIPTS NOT ALLOWED + jsr LET ; DO = , STORE ADDR IN FORPNT + jsr GTFORPNT ; IS THIS FOR VARIABLE ACTIVE? + bne @1 ; NO + txa ; YES, CANCEL IT AND ENCLOSED LOOPS + adc #15 ; CARRY=1, THIS ADDS 16 + tax ; X WAS ALREADY S+2 + txs +@1: pla ; POP RETURN ADDRESS TOO + pla + lda #9 ; BE CERTAIN ENOUGH ROOM IN STACK + jsr CHKMEM + jsr DATAN ; SCAN AHEAD TO NEXT STATEMENT + clc ; PUSH STATEMENT ADDRESS ON STACK + tya + adc TXTPTR + pha + lda TXTPTR+1 + adc #0 + pha + lda CURLIN+1 ; PUSH LINE NUMBER ON STACK + pha + lda CURLIN + pha + lda #TOKEN_TO + jsr SYNCHR ; REQUIRE "TO" + jsr CHKNUM ; = MUST BE NUMERIC + jsr FRMNUM ; GET FINAL VALUE, MUST BE NUMERIC + lda FACSIGN ; PUT SIGN INTO VALUE IN FAC + ora #$7F + and FAC+1 + sta FAC+1 + lda #STEP ; TO STEP + sta INDEX + sty INDEX+1 + jmp FRM_STACK3 ; RETURNS BY "JMP (INDEX)" + + +; ---------------------------------------------------------------------------- +; "STEP" PHRASE OF "FOR" STATEMENT +; ---------------------------------------------------------------------------- +STEP: lda #CON_ONE + jsr LOAD_FAC_FROM_YA + jsr CHRGOT + cmp #TOKEN_STEP + bne @1 ; USE DEFAULT VALUE OF 1.0 + jsr CHRGET ; STEP SPECIFIED, GET IT + jsr FRMNUM +@1: jsr SIGN + jsr FRM_STACK2 + lda FORPNT+1 + pha + lda FORPNT + pha + lda #TOKEN_FOR + pha + + +; ---------------------------------------------------------------------------- +; PERFORM NEXT STATEMENT +; ---------------------------------------------------------------------------- +NEWSTT: tsx ; REMEMBER THE STACK POSITION + stx REMSTK + jsr ISCNTC ; SEE IF CONTROL-C HAS BEEN TYPED + lda TXTPTR ; NO, KEEP EXECUTING + ldy TXTPTR+1 + ldx CURLIN+1 ; =$FF IF IN DIRECT MODE + inx ; $FF TURNS INTO $00 + beq @1 ; IN DIRECT MODE + sta OLDTEXT ; IN RUNNING MODE + sty OLDTEXT+1 +@1: ldy #0 + lda (TXTPTR),y ; END OF LINE YET? + bne COLON ; NO + ldy #2 ; YES, SEE IF END OF PROGRAM + lda (TXTPTR),y + clc + beq GOEND ; YES, END OF PROGRAM + iny + lda (TXTPTR),y ; GET LINE # OF NEXT LINE + sta CURLIN + iny + lda (TXTPTR),y + sta CURLIN+1 + tya ; ADJUST TXTPTR TO START + adc TXTPTR ; OF NEW LINE + sta TXTPTR + bcc @2 + inc TXTPTR+1 +@2: +NEWSTT2: + jsr CHRGET ; GET FIRST CHR OF STATEMENT + jsr EXECUTE_STATEMENT ; AND START PROCESSING + jmp NEWSTT ; BACK FOR MORE +; ---------------------------------------------------------------------------- +GOEND: beq END4 + + +; ---------------------------------------------------------------------------- +; EXECUTE A STATEMENT +; +; (A) IS FIRST CHAR OF STATEMENT +; CARRY IS SET +; ---------------------------------------------------------------------------- +EXECUTE_STATEMENT: + beq RTS3 ; END OF LINE, NULL STATEMENT +EXECUTE_STATEMENT1: + sbc #$80 ; FIRST CHAR A TOKEN? + bcc @1 ; NOT TOKEN, MUST BE "LET" + cmp #$40 ; STATEMENT-TYPE TOKEN? + bcs SYNERR1 ; NO, SYNTAX ERROR + asl a ; DOUBLE TO GET INDEX + tay ; INTO ADDRESS TABLE + lda TOKEN_ADDRESS_TABLE+1,y + pha ; PUT ADDRESS ON STACK + lda TOKEN_ADDRESS_TABLE,y + pha + jmp CHRGET ; GET NEXT CHR & RTS TO ROUTINE +; ---------------------------------------------------------------------------- +@1: jmp LET ; MUST BE = +; ---------------------------------------------------------------------------- +COLON: cmp #':' + beq NEWSTT2 +SYNERR1: + jmp SYNERR + + +; ---------------------------------------------------------------------------- +; "RESTORE" STATEMENT +; ---------------------------------------------------------------------------- +RESTORE: + sec ; SET DATPTR TO BEGINNING OF PROGRAM + lda TXTTAB + sbc #1 + ldy TXTTAB+1 + bcs SETDA + dey +; ---SET DATPTR TO Y,A------------ +SETDA: sta DATPTR + sty DATPTR+1 +RTS3: rts + + +; ---------------------------------------------------------------------------- +; SEE IF CONTROL-C TYPED +; ---------------------------------------------------------------------------- +ISCNTC: lda KEYBOARD + cmp #$83 + beq @1 + rts +@1: jsr RDKEY +CONTROL_C_TYPED: + ldx #$FF ; CONTROL C ATTEMPTED + bit ERRFLG ; "ON ERR" ENABLED? + bpl @2 ; NO + jmp HANDLERR ; YES, RETURN ERR CODE = 255 +@2: cmp #3 ; SINCE IT IS CTRL-C, SET Z AND C BITS + + +; ---------------------------------------------------------------------------- +; "STOP" STATEMENT +; ---------------------------------------------------------------------------- +STOP: bcs END2 ; CARRY=1 TO FORCE PRINTING "BREAK AT.." + + +; ---------------------------------------------------------------------------- +; "END" STATEMENT +; ---------------------------------------------------------------------------- +END: clc ; CARRY=0 TO AVOID PRINTING MESSAGE +END2: bne RTS4 ; IF NOT END OF STATEMENT, DO NOTHING + lda TXTPTR + ldy TXTPTR+1 + ldx CURLIN+1 + inx ; RUNNING? + beq @1 ; NO, DIRECT MODE + sta OLDTEXT + sty OLDTEXT+1 + lda CURLIN + ldy CURLIN+1 + sta OLDLIN + sty OLDLIN+1 +@1: pla + pla +END4: lda #QT_BREAK + bcc @1 + jmp PRINT_ERROR_LINNUM +@1: jmp RESTART + + +; ---------------------------------------------------------------------------- +; "CONT" COMMAND +; ---------------------------------------------------------------------------- +CONT: bne RTS4 ; IF NOT END OF STATEMENT, DO NOTHING + ldx #ERR_CANTCONT + ldy OLDTEXT+1 ; MEANINGFUL RE-ENTRY? + bne @1 ; YES + jmp ERROR ; NO +@1: lda OLDTEXT ; RESTORE TXTPTR + sta TXTPTR + sty TXTPTR+1 + lda OLDLIN ; RESTORE LINE NUMBER + ldy OLDLIN+1 + sta CURLIN + sty CURLIN+1 +RTS4: rts + + +; ---------------------------------------------------------------------------- +; "RUN" COMMAND +; ---------------------------------------------------------------------------- +RUN: php ; SAVE STATUS WHILE SUBTRACTING + dec CURLIN+1 ; IF WAS $FF (MEANING DIRECT MODE) MAKE IT "RUNNING MODE" + plp ; GET STATUS AGAIN (FROM CHRGET) + bne @1 ; PROBABLY A LINE NUMBER + jmp SETPTRS ; START AT BEGINNING OF PROGRAM +@1: jsr CLEARC ; CLEAR VARIABLES + jmp GO_TO_LINE ; JOIN GOSUB STATEMENT + + +; ---------------------------------------------------------------------------- +; "GOSUB" STATEMENT +; +; LEAVES 7 BYTES ON STACK: +; 2 -- RETURN ADDRESS (NEWSTT) +; 2 -- TXTPTR +; 2 -- LINE # +; 1 -- GOSUB TOKEN +; ---------------------------------------------------------------------------- +GOSUB: lda #3 ; BE SURE ENOUGH ROOM ON STACK + jsr CHKMEM + lda TXTPTR+1 + pha + lda TXTPTR + pha + lda CURLIN+1 + pha + lda CURLIN + pha + lda #TOKEN_GOSUB + pha +GO_TO_LINE: + jsr CHRGOT + jsr GOTO + jmp NEWSTT + + +; ---------------------------------------------------------------------------- +; "GOTO" STATEMENT +; ALSO USED BY "RUN" AND "GOSUB" +; ---------------------------------------------------------------------------- +GOTO: jsr LINGET ; GET GOTO LINE + jsr REMN ; POINT Y TO EOL + lda CURLIN+1 ; IS CURRENT PAGE < GOTO PAGE? + cmp LINNUM+1 + bcs @1 ; SEARCH FROM PROG START IF NOT + tya ; OTHERWISE SEARCH FROM NEXT LINE + sec + adc TXTPTR + ldx TXTPTR+1 + bcc @2 + inx + bcs @2 +@1: lda TXTTAB ; GET PROGRAM BEGINNING + ldx TXTTAB+1 +@2: jsr FL1 ; SEARCH FOR GOTO LINE + bcc UNDERR ; ERROR IF NOT THERE + lda LOWTR ; TXTPTR = START OF THE DESTINATION LINE + sbc #1 + sta TXTPTR + lda LOWTR+1 + sbc #0 + sta TXTPTR+1 +RTS5: rts ; RETURN TO NEWSTT OR GOSUB + + +; ---------------------------------------------------------------------------- +; "POP" AND "RETURN" STATEMENTS +; ---------------------------------------------------------------------------- +POP: bne RTS5 + lda #$FF + sta FORPNT ; <<< BUG: SHOULD BE FORPNT+1 SEE "ALL ABOUT APPLESOFT", PAGES 100,101>>> + jsr GTFORPNT ; TO CANCEL FOR/NEXT IN SUB + txs + cmp #TOKEN_GOSUB ; LAST GOSUB FOUND? + beq RETURN + ldx #ERR_NOGOSUB + .byte $2C ; FAKE +UNDERR: ldx #ERR_UNDEFSTAT + jmp ERROR +; ---------------------------------------------------------------------------- +SYNERR2: + jmp SYNERR +; ---------------------------------------------------------------------------- +RETURN: pla ; DISCARD GOSUB TOKEN + pla + cpy #<(TOKEN_POP*2) ; BRANCH IF A POP + beq PULL3 ; PULL LINE # + sta CURLIN + pla + sta CURLIN+1 + pla + sta TXTPTR ; PULL TXTPTR + pla + sta TXTPTR+1 + + +; ---------------------------------------------------------------------------- +; "DATA" STATEMENT +; EXECUTED BY SKIPPING TO NEXT COLON OR EOL +; ---------------------------------------------------------------------------- +DATA: jsr DATAN ; MOVE TO NEXT STATEMENT + + +; ---------------------------------------------------------------------------- +; ADD (Y) TO TXTPTR +; ---------------------------------------------------------------------------- +ADDON: tya + clc + adc TXTPTR + sta TXTPTR + bcc @1 + inc TXTPTR+1 +@1: +RTS6: rts + + +; ---------------------------------------------------------------------------- +; SCAN AHEAD TO NEXT ":" OR EOL +; ---------------------------------------------------------------------------- +DATAN: ldx #':' ; GET OFFSET IN Y TO EOL OR ":" + .byte $2C ; FAKE +; ---------------------------------------------------------------------------- +REMN: ldx #0 ; TO EOL ONLY + stx CHARAC + ldy #0 + sty ENDCHR +@1: lda ENDCHR ; TRICK TO COUNT QUOTE PARITY + ldx CHARAC + sta CHARAC + stx ENDCHR +@2: lda (TXTPTR),y + beq RTS6 ; END OF LINE + cmp ENDCHR + beq RTS6 ; COLON IF LOOKING FOR COLONS + iny + cmp #'"' + bne @2 + beq @1 ; ...ALWAYS +; ---------------------------------------------------------------------------- +PULL3: pla + pla + pla + rts + + +; ---------------------------------------------------------------------------- +; "IF" STATEMENT +; ---------------------------------------------------------------------------- +IF: jsr FRMEVL + jsr CHRGOT + cmp #TOKEN_GOTO + beq @1 + lda #TOKEN_THEN + jsr SYNCHR +@1: lda FAC ; CONDITION TRUE OR FALSE? + bne IF_TRUE ; BRANCH IF TRUE + + +; ---------------------------------------------------------------------------- +; "REM" STATEMENT, OR FALSE "IF" STATEMENT +; ---------------------------------------------------------------------------- +REM: jsr REMN ; SKIP REST OF LINE + beq ADDON ; ...ALWAYS +; ---------------------------------------------------------------------------- +IF_TRUE: + jsr CHRGOT ; COMMAND OR NUMBER? + bcs @1 ; COMMAND + jmp GOTO ; NUMBER +@1: jmp EXECUTE_STATEMENT + + +; ---------------------------------------------------------------------------- +; "ON" STATEMENT +; +; ON GOTO +; ON GOSUB +; ---------------------------------------------------------------------------- +ONGOTO: jsr GETBYT ; EVALUATE , AS BYTE IN FAC+4 + pha ; SAVE NEXT CHAR ON STACK + cmp #TOKEN_GOSUB + beq ON2 +ON1: cmp #TOKEN_GOTO + bne SYNERR2 +ON2: dec FAC+4 ; COUNTED TO RIGHT ONE YET? + bne @3 ; NO, KEEP LOOKING + pla ; YES, RETRIEVE CMD + jmp EXECUTE_STATEMENT1 ; AND GO. +@3: jsr CHRGET ; PRIME CONVERT SUBROUTINE + jsr LINGET ; CONVERT LINE # + cmp #',' ; TERMINATE WITH COMMA? + beq ON2 ; YES + pla ; NO, END OF LIST, SO IGNORE +RTS7: rts + + +; ---------------------------------------------------------------------------- +; CONVERT LINE NUMBER +; ---------------------------------------------------------------------------- +LINGET: ldx #0 ; ASC # TO HEX ADDRESS + stx LINNUM ; IN LINNUM. + stx LINNUM+1 +@1: bcs RTS7 ; NOT A DIGIT + sbc #'0'-1 ; CONVERT DIGIT TO BINARY + sta CHARAC ; SAVE THE DIGIT + lda LINNUM+1 ; CHECK RANGE + sta INDEX + cmp #>6400 ; LINE # TOO LARGE? + bcs ON1 ; YES, > 63999, GO INDIRECTLY TO "SYNTAX ERROR". + lda LINNUM ; MULTIPLY BY TEN + asl a + rol INDEX + asl a + rol INDEX + adc LINNUM + sta LINNUM + lda INDEX + adc LINNUM+1 + sta LINNUM+1 + asl LINNUM + rol LINNUM+1 + lda LINNUM + adc CHARAC ; ADD DIGIT + sta LINNUM + bcc @2 + inc LINNUM+1 +@2: jsr CHRGET ; GET NEXT CHAR + jmp @1 ; MORE CONVERTING + + +; ---------------------------------------------------------------------------- +; "LET" STATEMENT +; +; LET = +; = +; ---------------------------------------------------------------------------- +LET: jsr PTRGET ; GET + sta FORPNT + sty FORPNT+1 + lda #TOKEN_EQUAL + jsr SYNCHR + lda VALTYP+1 ; SAVE VARIABLE TYPE + pha + lda VALTYP + pha + jsr FRMEVL ; EVALUATE + pla + rol a + jsr CHKVAL + bne LETSTRING + pla +; ---------------------------------------------------------------------------- +LET2: bpl @1 ; REAL VARIABLE + jsr ROUND_FAC ; INTEGER VAR: ROUND TO 32 BITS + jsr AYINT ; TRUNCATE TO 16-BITS + ldy #0 + lda FAC+3 + sta (FORPNT),y + iny + lda FAC+4 + sta (FORPNT),y + rts + + +; ---------------------------------------------------------------------------- +; REAL VARIABLE = EXPRESSION +; ---------------------------------------------------------------------------- +@1: jmp SETFOR +; ---------------------------------------------------------------------------- +LETSTRING: + pla + + +; ---------------------------------------------------------------------------- +; INSTALL STRING, DESCRIPTOR ADDRESS IS AT FAC+3,4 +; ---------------------------------------------------------------------------- +PUTSTR: ldy #2 ; STRING DATA ALREADY IN STRING AREA? + lda (FAC+3),y ; (STRING AREA IS BTWN FRETOP + cmp FRETOP+1 ; HIMEM) + bcc @2 ; YES, DATA ALREADY UP THERE + bne @1 ; NO + dey ; MAYBE, TEST LOW BYTE OF POINTER + lda (FAC+3),y + cmp FRETOP + bcc @2 ; YES, ALREADY THERE +@1: ldy FAC+4 ; NO. DESCRIPTOR ALREADY AMONG VARIABLES? + cpy VARTAB+1 + bcc @2 ; NO + bne @3 ; YES + lda FAC+3 ; MAYBE, COMPARE LO-BYTE + cmp VARTAB + bcs @3 ; YES, DESCRIPTOR IS AMONG VARIABLES +@2: lda FAC+3 ; EITHER STRING ALREADY ON TOP, OR + ldy FAC+4 ; DESCRIPTOR IS NOT A VARIABLE + jmp @4 ; SO JUST STORE THE DESCRIPTOR +; ---------------------------------------------------------------------------- +; STRING NOT YET IN STRING AREA, +; AND DESCRIPTOR IS A VARIABLE +; ---------------------------------------------------------------------------- +@3: ldy #0 ; POINT AT LENGTH IN DESCRIPTOR + lda (FAC+3),y ; GET LENGTH + jsr STRINI ; MAKE A STRING THAT LONG UP ABOVE + lda DSCPTR ; SET UP SOURCE PNTR FOR MONINS + ldy DSCPTR+1 + sta STRNG1 + sty STRNG1+1 + jsr MOVINS ; MOVE STRING DATA TO NEW AREA + lda #FAC +@4: sta DSCPTR + sty DSCPTR+1 + jsr FRETMS ; DISCARD DESCRIPTOR IF 'TWAS TEMPORARY + ldy #0 ; COPY STRING DESCRIPTOR + lda (DSCPTR),y + sta (FORPNT),y + iny + lda (DSCPTR),y + sta (FORPNT),y + iny + lda (DSCPTR),y + sta (FORPNT),y +RTS8: rts + + +; ---------------------------------------------------------------------------- +PRSTRING: + jsr STRPRT + jsr CHRGOT + + +; ---------------------------------------------------------------------------- +; "PRINT" STATEMENT +; ---------------------------------------------------------------------------- +PRINT: beq GOCR ; NO MORE LIST, PRINT +; ---------------------------------------------------------------------------- +PRINT2: beq RTS8 ; NO MORE LIST, DON'T PRINT + cmp #TOKEN_SPC + clc + beq PR_TAB_OR_SPC ; C=0 FOR SPC( + cmp #',' + beq PR_NEXT_CHAR + cmp #';' + beq PR_NEXT_CHAR + jsr FRMEVL ; EVALUATE EXPRESSION + bit VALTYP ; STRING OR FP VALUE? + bmi PRSTRING ; STRING + jsr FOUT ; FP: CONVERT INTO BUFFER + jsr STRLIT ; MAKE BUFFER INTO STRING + jmp PRSTRING ; PRINT THE STRING +; ---------------------------------------------------------------------------- +GOCR: jmp CRDO + +; ---------------------------------------------------------------------------- +PR_TAB_OR_SPC: + jsr GTBYTC ; GET VALUE + cmp #')' ; TRAILING PARENTHESIS + beq @2 ; GOOD + jmp SYNERR ; NO, SYNTAX ERROR +@2: inx +NXSPC: dex + bne DOSPC ; MORE SPACES TO PRINT +; ---------------------------------------------------------------------------- +PR_NEXT_CHAR: + jsr CHRGET + jmp PRINT2 ; CONTINUE PARSING PRINT LIST +; ---------------------------------------------------------------------------- +DOSPC: jsr OUTSP + bne NXSPC ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; PRINT STRING AT (Y,A) +; ---------------------------------------------------------------------------- +STROUT: jsr STRLIT ; MAKE (Y,A) PRINTABLE + + +; ---------------------------------------------------------------------------- +; PRINT STRING AT (FACMO,FACLO) +; ---------------------------------------------------------------------------- +STRPRT: jsr FREFAC ; GET ADDRESS INTO INDEX, (A)=LENGTH + tax ; USE X-REG FOR COUNTER + ldy #0 ; USE Y-REG FOR SCANNER + inx +@1: dex + beq RTS8 ; FINISHED + lda (INDEX),y ; NEXT CHAR FROM STRING + jsr OUTDO ; PRINT THE CHAR + iny + jmp @1 + + +; ---------------------------------------------------------------------------- +; INPUT CONVERSION ERROR: ILLEGAL CHARACTER +; IN NUMERIC FIELD. MUST DISTINGUISH +; BETWEEN INPUT, READ, AND GET +; ---------------------------------------------------------------------------- +INPUTERR: + lda INPUTFLG + beq RESPERR ; TAKEN IF INPUT + bmi READERR ; TAKEN IF READ + ldy #$FF ; FROM A GET + bne ERLIN ; ...ALWAYS +; ---------------------------------------------------------------------------- +READERR: + lda DATLIN ; TELL WHERE THE "DATA" IS, RATHER + ldy DATLIN+1 ; THAN THE "READ" +; ---------------------------------------------------------------------------- +ERLIN: sta CURLIN + sty CURLIN+1 + jmp SYNERR +; ---------------------------------------------------------------------------- +INPERR: pla +; ---------------------------------------------------------------------------- +RESPERR: + bit ERRFLG ; "ON ERR" TURNED ON? + bpl @1 ; NO, GIVE REENTRY A TRY + ldx #254 ; ERROR CODE = 254 + jmp HANDLERR +@1: lda #ERRREENTRY + jsr STROUT + lda OLDTEXT ; RE-EXECUTE THE WHOLE INPUT STATEMENT + ldy OLDTEXT+1 + sta TXTPTR + sty TXTPTR+1 + rts + + +; ---------------------------------------------------------------------------- +; "GET" STATEMENT +; ---------------------------------------------------------------------------- +GET: jsr ERRDIR ; ILLEGAL IF IN DIRECT MODE + ldx #<(INPUTBUFFER+1) ; SIMULATE INPUT + ldy #>(INPUTBUFFER+1) + lda #0 + sta INPUTBUFFER+1 + lda #$40 ; SET UP INPUTFLG + jmp PROCESS_INPUT_LIST + + +; ---------------------------------------------------------------------------- +; "INPUT" STATEMENT +; ---------------------------------------------------------------------------- +INPUT: cmp #'"' ; CHECK FOR OPTIONAL PROMPT STRING + bne @1 ; NO, PRINT "?" PROMPT + jsr STRTXT ; MAKE A PRINTABLE STRING OUT OF IT + lda #';' ; MUST HAVE ; NOW + jsr SYNCHR + jsr STRPRT ; PRINT THE STRING + jmp @2 +@1: jsr OUTQUES ; NO STRING, PRINT "?" +@2: jsr ERRDIR ; ILLEGAL IF IN DIRECT MODE + lda #',' ; PRIME THE BUFFER + sta INPUTBUFFER-1 + jsr INLIN + lda INPUTBUFFER + cmp #$03 ; CONTROL C? + bne INPUTFLAGZERO ; NO + jmp CONTROL_C_TYPED +; ---------------------------------------------------------------------------- +NXIN: jsr OUTQUES ; PRINT "?" + jmp INLIN + + +; ---------------------------------------------------------------------------- +; "READ" STATEMENT +; ---------------------------------------------------------------------------- +READ: ldx DATPTR ; Y,X POINTS AT NEXT DATA STATEMENT + ldy DATPTR+1 + lda #$98 ; SET INPUTFLG = $98 + .byte $2C ; TRICK TO PROCESS_INPUT_LIST +; ---------------------------------------------------------------------------- +INPUTFLAGZERO: + lda #0 ; SET INPUTFLG = $00 + + +; ---------------------------------------------------------------------------- +; PROCESS INPUT LIST +; +; (Y,X) IS ADDRESS OF INPUT DATA STRING +; (A) = VALUE FOR INPUTFLG: $00 FOR INPUT +; $40 FOR GET +; $98 FOR READ +; ---------------------------------------------------------------------------- +PROCESS_INPUT_LIST: + sta INPUTFLG + stx INPTR ; ADDRESS OF INPUT STRING + sty INPTR+1 + +; ---------------------------------------------------------------------------- +PROCESS_INPUT_ITEM: + jsr PTRGET ; GET ADDRESS OF VARIABLE + sta FORPNT + sty FORPNT+1 + lda TXTPTR ; SAVE CURRENT TXTPTR, + ldy TXTPTR+1 ; WHICH POINTS INTO PROGRAM + sta TXPSV + sty TXPSV+1 + ldx INPTR ; SET TXTPTR TO POINT AT INPUT BUFFER + ldy INPTR+1 ; OR "DATA" LINE + stx TXTPTR + sty TXTPTR+1 + jsr CHRGOT ; GET CHAR AT PNTR + bne INSTART ; NOT END OF LINE OR COLON + bit INPUTFLG ; DOING A "GET"? + bvc @1 ; NO + jsr RDKEY ; YES, GET CHAR + sta INPUTBUFFER + ldx #<(INPUTBUFFER-1) + ldy #>(INPUTBUFFER-1) + bne @2 ; ...ALWAYS +; ---------------------------------------------------------------------------- +@1: bmi FINDATA ; DOING A "READ" + jsr OUTQUES ; DOING AN "INPUT", PRINT "?" + jsr NXIN ; PRINT ANOTHER "?", AND INPUT A LINE +@2: stx TXTPTR + sty TXTPTR+1 + +; ---------------------------------------------------------------------------- +INSTART: + jsr CHRGET ; GET NEXT INPUT CHAR + bit VALTYP ; STRING OR NUMERIC? + bpl @5 ; NUMERIC + bit INPUTFLG ; STRING -- NOW WHAT INPUT TYPE? + bvc @1 ; NOT A "GET" + inx ; "GET" + stx TXTPTR + lda #0 + sta CHARAC ; NO OTHER TERMINATORS THAN $00 + beq @2 ; ...ALWAYS +; ---------------------------------------------------------------------------- +@1: sta CHARAC + cmp #'"' ; TERMINATE ON $00 OR QUOTE + beq @3 + lda #':' ; TERMINATE ON $00, COLON, OR COMMA + sta CHARAC + lda #',' +@2: clc +@3: sta ENDCHR + lda TXTPTR + ldy TXTPTR+1 + adc #0 ; SKIP OVER QUOTATION MARK, IF + bcc @4 ; THERE WAS ONE + iny +@4: jsr STRLT2 ; BUILD STRING STARTING AT (Y,A) TERMINATED BY $00, (CHARAC), OR (ENDCHR) + jsr POINT ; SET TXTPTR TO POINT AT STRING + jsr PUTSTR ; STORE STRING IN VARIABLE + jmp INPUT_MORE +; ---------------------------------------------------------------------------- +@5: pha + lda INPUTBUFFER ; ANYTHING IN BUFFER? + beq INPFIN ; NO, SEE IF READ OR INPUT + +; ---------------------------------------------------------------------------- +INPUT_DATA: + pla ; "READ" + jsr FIN ; GET FP NUMBER AT TXTPTR + lda VALTYP+1 + jsr LET2 ; STORE RESULT IN VARIABLE + +; ---------------------------------------------------------------------------- +INPUT_MORE: + jsr CHRGOT + beq @1 ; END OF LINE OR COLON + cmp #',' ; COMMA IN INPUT? + beq @1 ; YES + jmp INPUTERR ; NOTHING ELSE WILL DO +@1: lda TXTPTR ; SAVE POSITION IN INPUT BUFFER + ldy TXTPTR+1 + sta INPTR + sty INPTR+1 + lda TXPSV ; RESTORE PROGRAM POINTER + ldy TXPSV+1 + sta TXTPTR + sty TXTPTR+1 + jsr CHRGOT ; NEXT CHAR FROM PROGRAM + beq INPDONE ; END OF STATEMENT + jsr CHKCOM ; BETTER BE A COMMA THEN + jmp PROCESS_INPUT_ITEM + +; ---------------------------------------------------------------------------- +INPFIN: lda INPUTFLG ; "INPUT" OR "READ" + bne INPUT_DATA ; "READ" + jmp INPERR + +; ---------------------------------------------------------------------------- +FINDATA: + jsr DATAN ; GET OFFSET TO NEXT COLON OR EOL + iny ; TO FIRST CHAR OF NEXT LINE + tax ; WHICH: EOL OR COLON? + bne @1 ; COLON + ldx #ERR_NODATA ; EOL: MIGHT BE OUT OF DATA + iny ; CHECK HI-BYTE OF FORWARD PNTR + lda (TXTPTR),y ; END OF PROGRAM? + beq GERR ; YES, WE ARE OUT OF DATA + iny ; PICK UP THE LINE # + lda (TXTPTR),y + sta DATLIN + iny + lda (TXTPTR),y + iny ; POINT AT FIRST TEXT CHAR IN LINE + sta DATLIN+1 +@1: lda (TXTPTR),y ; GET 1ST TOKEN OF STATEMENT + tax ; SAVE TOKEN IN X-REG + jsr ADDON ; ADD (Y) TO TXTPTR + cpx #TOKEN_DATA ; DID WE FIND A "DATA" STATEMENT? + bne FINDATA ; NOT YET + jmp INSTART ; YES, READ IT +; ---NO MORE INPUT REQUESTED------ +INPDONE: + lda INPTR ; GET POINTER IN CASE IT WAS "READ" + ldy INPTR+1 + ldx INPUTFLG ; "READ" OR "INPUT"? + bpl @1 ; "INPUT" + jmp SETDA ; "DATA", SO STORE (Y,X) AT DATPTR +@1: ldy #0 ; "INPUT": ANY MORE CHARS ON LINE? + lda (INPTR),y + beq @2 ; NO, ALL IS WELL + lda #ERREXTRA ; "EXTRA IGNORED" + jmp STROUT +@2: rts + +; ---------------------------------------------------------------------------- +ERREXTRA: + .byte "?EXTRA IGNORED",$0D,$00 +ERRREENTRY: + .byte "?REENTER",$0D,$00 + + +; ---------------------------------------------------------------------------- +; "NEXT" STATEMENT +; ---------------------------------------------------------------------------- +NEXT: bne NEXT1 ; VARIABLE AFTER "NEXT" + ldy #0 ; FLAG BY SETTING FORPNT+1 = 0 + beq NEXT2 ; ...ALWAYS +; ---------------------------------------------------------------------------- +NEXT1: jsr PTRGET ; GET PNTR TO VARIABLE IN (Y,A) +NEXT2: sta FORPNT + sty FORPNT+1 + jsr GTFORPNT ; FIND FOR-FRAME FOR THIS VARIABLE + beq NEXT3 ; FOUND IT + ldx #ERR_NOFOR ; NOT THERE, ABORT +GERR: beq JERROR ; ...ALWAYS +NEXT3: txs ; SET STACK PTR TO POINT TO THIS FRAME, + inx ; WHICH TRIMS OFF ANY INNER LOOPS + inx + inx + inx + txa ; LOW BYTE OF ADRS OF STEP VALUE + inx + inx + inx + inx + inx + inx + stx DEST ; LOW BYTE ADRS OF FOR VAR VALUE + ldy #>STACK ; (Y,A) IS ADDRESS OF STEP VALUE + jsr LOAD_FAC_FROM_YA ; STEP TO FAC + tsx + lda STACK+9,x + sta FACSIGN + lda FORPNT + ldy FORPNT+1 + jsr FADD ; ADD TO FOR VALUE + jsr SETFOR ; PUT NEW VALUE BACK + ldy #>STACK ; (Y,A) IS ADDRESS OF END VALUE + jsr FCOMP2 ; COMPARE TO END VALUE + tsx + sec + sbc STACK+9,x ; SIGN OF STEP + beq @2 ; BRANCH IF FOR COMPLETE + lda STACK+15,x ; OTHERWISE SET UP + sta CURLIN ; FOR LINE # + lda STACK+16,x + sta CURLIN+1 + lda STACK+18,x ; AND SET TXTPTR TO JUST + sta TXTPTR ; AFTER FOR STATEMENT + lda STACK+17,x + sta TXTPTR+1 +@1: jmp NEWSTT +@2: txa ; POP OFF FOR-FRAME, LOOP IS DONE + adc #17 ; CARRY IS SET, SO ADDS 18 + tax + txs + jsr CHRGOT ; CHAR AFTER VARIABLE + cmp #',' ; ANOTHER VARIABLE IN NEXT? + bne @1 ; NO, GO TO NEXT STATEMENT + jsr CHRGET ; YES, PRIME FOR NEXT VARIABLE + jsr NEXT1 ; (DOES NOT RETURN) + + +; ---------------------------------------------------------------------------- +; EVALUATE EXPRESSION, MAKE SURE IT IS NUMERIC +; ---------------------------------------------------------------------------- +FRMNUM: jsr FRMEVL + + +; ---------------------------------------------------------------------------- +; MAKE SURE (FAC) IS NUMERIC +; ---------------------------------------------------------------------------- +CHKNUM: clc + .byte $24 ; DUMMY FOR SKIP + + +; ---------------------------------------------------------------------------- +; MAKE SURE (FAC) IS STRING +; ---------------------------------------------------------------------------- +CHKSTR: sec + + +; ---------------------------------------------------------------------------- +; MAKE SURE (FAC) IS CORRECT TYPE +; IF C=0, TYPE MUST BE NUMERIC +; IF C=1, TYPE MUST BE STRING +; ---------------------------------------------------------------------------- +CHKVAL: bit VALTYP ; $00 IF NUMERIC, $FF IF STRING + bmi @2 ; TYPE IS STRING + bcs @3 ; NOT STRING, BUT WE NEED STRING +@1: rts ; TYPE IS CORRECT +@2: bcs @1 ; IS STRING AND WE WANTED STRING +@3: ldx #ERR_BADTYPE ; TYPE MISMATCH +JERROR: jmp ERROR + + +; ---------------------------------------------------------------------------- +; EVALUATE THE EXPRESSION AT TXTPTR, LEAVING THE +; RESULT IN FAC. WORKS FOR BOTH STRING AND NUMERIC +; EXPRESSIONS. +; ---------------------------------------------------------------------------- +FRMEVL: ldx TXTPTR ; DECREMENT TXTPTR + bne @1 + dec TXTPTR+1 +@1: dec TXTPTR + ldx #0 ; START WITH PRECEDENCE = 0 + .byte $24 ; TRICK TO SKIP FOLLOWING "PHA" +; ---------------------------------------------------------------------------- +FRMEVL1: + pha ; PUSH RELOPS FLAGS + txa + pha ; SAVE LAST PRECEDENCE + lda #1 + jsr CHKMEM ; CHECK IF ENOUGH ROOM ON STACK + jsr FRM_ELEMENT ; GET AN ELEMENT + lda #0 + sta CPRTYP ; CLEAR COMPARISON OPERATOR FLAGS +; ---------------------------------------------------------------------------- +FRMEVL2: + jsr CHRGOT ; CHECK FOR RELATIONAL OPERATORS +@1: sec ; > IS $AE, = IS $AF, < IS $B0 + sbc #TOKEN_GREATER ; > IS 0, = IS 1, < IS 2 + bcc @2 ; NOT RELATIONAL OPERATOR + cmp #3 + bcs @2 ; NOT RELATIONAL OPERATOR + cmp #1 ; SET CARRY IF "=" OR "<" + rol a ; NOW > IS 0, = IS 3, < IS 5 + eor #1 ; NOW > IS 1, = IS 2, < IS 4 + eor CPRTYP ; SET BITS OF CPRTYP: 00000<=> + cmp CPRTYP ; CHECK FOR ILLEGAL COMBINATIONS + bcc SNTXERR ; IF LESS THAN, A RELOP WAS REPEATED + sta CPRTYP + jsr CHRGET ; ANOTHER OPERATOR? + jmp @1 ; CHECK FOR <,=,> AGAIN +; ---------------------------------------------------------------------------- +@2: ldx CPRTYP ; DID WE FIND A RELATIONAL OPERATOR? + bne FRM_RELATIONAL ; YES + bcs NOTMATH ; NO, AND NEXT TOKEN IS > $D1 + adc #TOKEN_GREATER-TOKEN_PLUS ; NO, AND NEXT TOKEN < $CF + bcc NOTMATH ; IF NEXT TOKEN < "+" + adc VALTYP ; + AND LAST RESULT A STRING? + bne @3 ; BRANCH IF NOT + jmp CAT ; CONCATENATE IF SO. +; ---------------------------------------------------------------------------- +@3: adc #$FF ; +-*/ IS 0123 + sta INDEX + asl a ; MULTIPLY BY 3 + adc INDEX ; +-*/ IS 0,3,6,9 + tay + +; ---------------------------------------------------------------------------- +FRM_PRECEDENCE_TEST: + pla ; GET LAST PRECEDENCE + cmp MATHTBL,y + bcs FRM_PERFORM1 ; DO NOW IF HIGHER PRECEDENCE + jsr CHKNUM ; WAS LAST RESULT A #? +NXOP: pha ; YES, SAVE PRECEDENCE ON STACK +SAVOP: jsr FRM_RECURSE ; SAVE REST, CALL FRMEVL RECURSIVELY + pla + ldy LASTOP + bpl PREFNC + tax + beq GOEX ; EXIT IF NO MATH IN EXPRESSION + bne FRM_PERFORM2 ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; FOUND ONE OR MORE RELATIONAL OPERATORS <,=,> +; ---------------------------------------------------------------------------- +FRM_RELATIONAL: + lsr VALTYP ; (VALTYP) = 0 (NUMERIC), = $FF (STRING) + txa ; SET CPRTYP TO 0000<=>C + rol a ; WHERE C=0 IF #, C=1 IF STRING + ldx TXTPTR ; BACK UP TXTPTR + bne @1 + dec TXTPTR+1 +@1: dec TXTPTR + ldy #M_REL-MATHTBL ; POINT AT RELOPS ENTRY + sta CPRTYP + bne FRM_PRECEDENCE_TEST ; ...ALWAYS +; ---------------------------------------------------------------------------- +PREFNC: cmp MATHTBL,y + bcs FRM_PERFORM2 ; DO NOW IF HIGHER PRECEDENCE + bcc NXOP ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; STACK THIS OPERATION AND CALL FRMEVL FOR +; ANOTHER ONE +; ---------------------------------------------------------------------------- +FRM_RECURSE: + lda MATHTBL+2,y + pha ; PUSH ADDRESS OF OPERATION PERFORMER + lda MATHTBL+1,y + pha + jsr FRM_STACK1 ; STACK FAC.SIGN AND FAC + lda CPRTYP ; A=RELOP FLAGS, X=PRECEDENCE BYTE + jmp FRMEVL1 ; RECURSIVELY CALL FRMEVL +; ---------------------------------------------------------------------------- +SNTXERR: + jmp SYNERR + + +; ---------------------------------------------------------------------------- +; STACK (FAC) +; THREE ENTRY POINTS: +; 1, FROM FRMEVL +; 2, FROM "STEP" +; 3, FROM "FOR" +; ---------------------------------------------------------------------------- +FRM_STACK1: + lda FACSIGN ; GET FAC.SIGN TO PUSH IT + ldx MATHTBL,y ; PRECEDENCE BYTE FROM MATHTBL + + +; ---------------------------------------------------------------------------- +; ENTER HERE FROM "STEP", TO PUSH STEP SIGN AND VALUE +; ---------------------------------------------------------------------------- +FRM_STACK2: + tay ; FAC.SIGN OR SGN(STEP VALUE) + pla ; PULL RETURN ADDRESS AND ADD 1 + sta INDEX ; <<< ASSUMES NOT ON PAGE BOUNDARY! >>> + inc INDEX ; PLACE BUMPED RETURN ADDRESS IN + pla ; INDEX,INDEX+1 + sta INDEX+1 + tya ; FAC.SIGN OR SGN(STEP VALUE) + pha ; PUSH FAC.SIGN OR SGN(STEP VALUE) + + +; ---------------------------------------------------------------------------- +; ENTER HERE FROM "FOR", WITH (INDEX) = STEP, +; TO PUSH INITIAL VALUE OF "FOR" VARIABLE +; ---------------------------------------------------------------------------- +FRM_STACK3: + jsr ROUND_FAC ; ROUND TO 32 BITS + lda FAC+4 ; PUSH (FAC) + pha + lda FAC+3 + pha + lda FAC+2 + pha + lda FAC+1 + pha + lda FAC + pha + jmp (INDEX) ; DO RTS FUNNY WAY + + +; ---------------------------------------------------------------------------- +NOTMATH: + ldy #$FF ; SET UP TO EXIT ROUTINE + pla +GOEX: beq EXIT ; EXIT IF NO MATH TO DO + + +; ---------------------------------------------------------------------------- +; PERFORM STACKED OPERATION +; +; (A) = PRECEDENCE BYTE +; STACK: 1 -- CPRMASK +; 5 -- (ARG) +; 2 -- ADDR OF PERFORMER +; ---------------------------------------------------------------------------- +FRM_PERFORM1: + cmp #PREL ; WAS IT RELATIONAL OPERATOR? + beq @1 ; YES, ALLOW STRING COMPARE + jsr CHKNUM ; MUST BE NUMERIC VALUE +@1: sty LASTOP +FRM_PERFORM2: + pla ; GET 0000<=>C FROM STACK + lsr a ; SHIFT TO 00000<=> FORM + sta CPRMASK ; 00000<=> + pla + sta ARG ; GET FLOATING POINT VALUE OFF STACK, + pla ; AND PUT IT IN ARG + sta ARG+1 + pla + sta ARG+2 + pla + sta ARG+3 + pla + sta ARG+4 + pla + sta ARG+5 + eor FACSIGN ; SAVE EOR OF SIGNS OF THE OPERANDS, + sta SGNCPR ; IN CASE OF MULTIPLY OR DIVIDE +EXIT: lda FAC ; FAC EXPONENT IN A-REG / STATUS .EQ. IF (FAC)=0 + rts ; RTS GOES TO PERFORM OPERATION + + +; ---------------------------------------------------------------------------- +; GET ELEMENT IN EXPRESSION +; +; GET VALUE OF VARIABLE OR NUMBER AT TXTPNT, OR POINT +; TO STRING DESCRIPTOR IF A STRING, AND PUT IN FAC. +; ---------------------------------------------------------------------------- +FRM_ELEMENT: + lda #0 ; ASSUME NUMERIC + sta VALTYP +@1: jsr CHRGET + bcs @3 ; NOT A DIGIT +@2: jmp FIN ; NUMERIC CONSTANT +@3: jsr ISLETC ; VARIABLE NAME? + bcs FRM_VARIABLE ; YES + cmp #'.' ; DECIMAL POINT + beq @2 ; YES, NUMERIC CONSTANT + cmp #TOKEN_MINUS ; UNARY MINUS? + beq MIN ; YES + cmp #TOKEN_PLUS ; UNARY PLUS + beq @1 ; YES + cmp #'"' ; STRING CONSTANT? + bne NOT_ ; NO + + +; ---------------------------------------------------------------------------- +; STRING CONSTANT ELEMENT +; +; SET Y,A = (TXTPTR)+CARRY +; ---------------------------------------------------------------------------- +STRTXT: lda TXTPTR ; ADD (CARRY) TO GET ADDRESS OF 1ST CHAR + ldy TXTPTR+1 ; OF STRING IN Y,A + adc #0 + bcc @1 + iny +@1: jsr STRLIT ; BUILD DESCRIPTOR TO STRING / GET ADDRESS OF DESCRIPTOR IN FAC + jmp POINT ; POINT TXTPTR AFTER TRAILING QUOTE + + +; ---------------------------------------------------------------------------- +; "NOT" FUNCTION +; IF FAC=0, RETURN FAC=1 +; IF FAC<>0, RETURN FAC=0 +; ---------------------------------------------------------------------------- +NOT_: cmp #TOKEN_NOT + bne SGN_ ; NOT "NOT", TRY "SGN" + ldy #M_EQU-MATHTBL ; POINT AT = COMPARISON + bne EQUL ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; COMPARISON FOR EQUALITY (= OPERATOR) +; ALSO USED TO EVALUATE "NOT" FUNCTION +; ---------------------------------------------------------------------------- +EQUOP: lda FAC ; SET "TRUE" IF (FAC) = ZERO + bne @1 ; FALSE + ldy #1 ; TRUE + .byte $2C ; TRICK TO SKIP NEXT 2 BYTES +@1: ldy #0 ; FALSE + jmp SNGFLT +; ---------------------------------------------------------------------------- +SGN_: cmp #TOKEN_SGN + bcc PARCHK + jmp UNARY + + +; ---------------------------------------------------------------------------- +; EVALUATE "(EXPRESSION)" +; ---------------------------------------------------------------------------- +PARCHK: jsr CHKOPN ; IS THERE A '(' AT TXTPTR? + jsr FRMEVL ; YES, EVALUATE EXPRESSION +; ---------------------------------------------------------------------------- +CHKCLS: lda #')' ; CHECK FOR ')' + .byte $2C ; TRICK +; ---------------------------------------------------------------------------- +CHKOPN: lda #'(' + .byte $2C ; TRICK +; ---------------------------------------------------------------------------- +CHKCOM: lda #',' ; COMMA AT TXTPTR? + + +; ---------------------------------------------------------------------------- +; UNLESS CHAR AT TXTPTR = (A), SYNTAX ERROR +; ---------------------------------------------------------------------------- +SYNCHR: ldy #0 + cmp (TXTPTR),y + bne SYNERR + jmp CHRGET ; MATCH, GET NEXT CHAR & RETURN +; ---------------------------------------------------------------------------- +SYNERR: ldx #ERR_SYNTAX + jmp ERROR +; ---------------------------------------------------------------------------- +MIN: ldy #M_NEG-MATHTBL ; POINT AT UNARY MINUS +EQUL: pla + pla + jmp SAVOP +; ---------------------------------------------------------------------------- +FRM_VARIABLE: + jsr PTRGET +FRM_VARIABLE_CALL = *-1 ; SO PTRGET CAN TELL WE CALLED + sta VPNT ; ADDRESS OF VARIABLE + sty VPNT+1 + ldx VALTYP ; NUMERIC OR STRING? + beq @1 ; NUMERIC + ldx #0 ; STRING + stx STRNG1+1 + rts +@1: ldx VALTYP+1 ; NUMERIC, WHICH TYPE? + bpl @2 ; FLOATING POINT + ldy #0 ; INTEGER + lda (VPNT),y + tax ; GET VALUE IN A,Y + iny + lda (VPNT),y + tay + txa + jmp GIVAYF ; CONVERT A,Y TO FLOATING POINT +@2: jmp LOAD_FAC_FROM_YA + + +; ---------------------------------------------------------------------------- +UNARY: asl a ; DOUBLE TOKEN TO GET INDEX + pha + tax + jsr CHRGET + cpx #<(TOKEN_LEFTSTR*2-1) ; LEFT$, RIGHT$, AND MID$ + bcc @1 ; NOT ONE OF THE STRING FUNCTIONS + jsr CHKOPN ; STRING FUNCTION, NEED "(" + jsr FRMEVL ; EVALUATE EXPRESSION FOR STRING + jsr CHKCOM ; REQUIRE A COMMA + jsr CHKSTR ; MAKE SURE EXPRESSION IS A STRING + pla + tax ; RETRIEVE ROUTINE POINTER + lda VPNT+1 ; STACK ADDRESS OF STRING + pha + lda VPNT + pha + txa + pha ; STACK DOUBLED TOKEN + jsr GETBYT ; CONVERT NEXT EXPRESSION TO BYTE IN X-REG + pla ; GET DOUBLED TOKEN OFF STACK + tay ; USE AS INDEX TO BRANCH + txa ; VALUE OF SECOND PARAMETER + pha ; PUSH 2ND PARAM + jmp @2 ; JOIN UNARY FUNCTIONS +@1: jsr PARCHK ; REQUIRE "(EXPRESSION)" + pla + tay ; INDEX INTO FUNCTION ADDRESS TABLE +@2: lda UNFNC-TOKEN_SGN-TOKEN_SGN+$100,y + sta JMPADRS+1 ; PREPARE TO JSR TO ADDRESS + lda UNFNC-TOKEN_SGN-TOKEN_SGN+$101,y + sta JMPADRS+2 + jsr JMPADRS ; DOES NOT RETURN FOR CHR$, LEFT$, RIGHT$, OR MID$ + jmp CHKNUM ; REQUIRE NUMERIC RESULT +; ---------------------------------------------------------------------------- +OR: lda ARG ; "OR" OPERATOR + ora FAC ; IF RESULT NONZERO, IT IS TRUE + bne TRUE +; ---------------------------------------------------------------------------- +TAND: lda ARG ; "AND" OPERATOR + beq FALSE ; IF EITHER IS ZERO, RESULT IS FALSE + lda FAC + bne TRUE +; ---------------------------------------------------------------------------- +FALSE: ldy #0 ; RETURN FAC=0 + .byte $2C ; TRICK +; ---------------------------------------------------------------------------- +TRUE: ldy #1 ; RETURN FAC=1 + jmp SNGFLT + + +; ---------------------------------------------------------------------------- +; PERFORM RELATIONAL OPERATIONS +; ---------------------------------------------------------------------------- +RELOPS: jsr CHKVAL ; MAKE SURE FAC IS CORRECT TYPE + bcs STRCMP ; TYPE MATCHES, BRANCH IF STRINGS + lda ARGSIGN ; NUMERIC COMPARISON + ora #$7F ; RE-PACK VALUE IN ARG FOR FCOMP + and ARG+1 + sta ARG+1 + lda #ARG + jsr FCOMP ; RETURN A-REG = -1,0,1 + tax ; AS ARG <,=,> FAC + jmp NUMCMP + + +; ---------------------------------------------------------------------------- +; STRING COMPARISON +; ---------------------------------------------------------------------------- +STRCMP: lda #0 ; SET RESULT TYPE TO NUMERIC + sta VALTYP + dec CPRTYP ; MAKE CPRTYP 0000<=>0 + jsr FREFAC + sta FAC ; STRING LENGTH + stx FAC+1 + sty FAC+2 + lda ARG+3 + ldy ARG+4 + jsr FRETMP + stx ARG+3 + sty ARG+4 + tax ; LEN (ARG) STRING + sec + sbc FAC ; SET X TO SMALLER LEN + beq @1 + lda #1 + bcc @1 + ldx FAC + lda #$FF +@1: sta FACSIGN ; FLAG WHICH SHORTER + ldy #$FF + inx +STRCMP1: + iny + dex + bne STRCMP2 ; MORE CHARS IN BOTH STRINGS + ldx FACSIGN ; IF = SO FAR, DECIDE BY LENGTH +; ---------------------------------------------------------------------------- +NUMCMP: bmi CMPDONE + clc + bcc CMPDONE ; ...ALWAYS +; ---------------------------------------------------------------------------- +STRCMP2: + lda (ARG+3),y + cmp (FAC+1),y + beq STRCMP1 ; SAME, KEEP COMPARING + ldx #$FF ; IN CASE ARG GREATER + bcs CMPDONE ; IT IS + ldx #1 ; FAC GREATER +; ---------------------------------------------------------------------------- +CMPDONE: + inx ; CONVERT FF,0,1 TO 0,1,2 + txa + rol a ; AND TO 0,2,4 IF C=0, ELSE 1,2,5 + and CPRMASK ; 00000<=> + beq @1 ; IF NO MATCH: FALSE + lda #1 ; AT LEAST ONE MATCH: TRUE +@1: jmp FLOAT + + +; ---------------------------------------------------------------------------- +; "DIM" STATEMENT +; ---------------------------------------------------------------------------- +NXDIM: jsr CHKCOM ; SEPARATED BY COMMAS +DIM: tax ; NON-ZERO, FLAGS PTRGET DIM CALLED + jsr PTRGET2 ; ALLOCATE THE ARRAY + jsr CHRGOT ; NEXT CHAR + bne NXDIM ; NOT END OF STATEMENT + rts + + +; ---------------------------------------------------------------------------- +; PTRGET -- GENERAL VARIABLE SCAN +; +; SCANS VARIABLE NAME AT TXTPTR, AND SEARCHES THE +; VARTAB AND ARYTAB FOR THE NAME. +; IF NOT FOUND, CREATE VARIABLE OF APPROPRIATE TYPE. +; RETURN WITH ADDRESS IN VARPNT AND Y,A +; +; ACTUAL ACTIVITY CONTROLLED SOMEWHAT BY TWO FLAGS: +; DIMFLG -- NONZERO IF CALLED FROM "DIM" +; ELSE = 0 +; +; SUBFLG -- = $00 +; = $40 IF CALLED FROM "GETARYPT" +; ---------------------------------------------------------------------------- +PTRGET: ldx #0 + jsr CHRGOT ; GET FIRST CHAR OF VARIABLE NAME +; ---------------------------------------------------------------------------- +PTRGET2: + stx DIMFLG ; X IS NONZERO IF FROM DIM +; ---------------------------------------------------------------------------- +PTRGET3: + sta VARNAM + jsr CHRGOT + jsr ISLETC ; IS IT A LETTER? + bcs NAMOK ; YES, OKAY SO FAR +BADNAM: jmp SYNERR ; NO, SYNTAX ERROR +NAMOK: ldx #0 + stx VALTYP + stx VALTYP+1 +; ---------------------------------------------------------------------------- +PTRGET4: + jsr CHRGET ; SECOND CHAR OF VARIABLE NAME + bcc @1 ; NUMERIC + jsr ISLETC ; LETTER? + bcc @3 ; NO, END OF NAME +@1: tax ; SAVE SECOND CHAR OF NAME IN X +@2: jsr CHRGET ; SCAN TO END OF VARIABLE NAME + bcc @2 ; NUMERIC + jsr ISLETC + bcs @2 ; ALPHA +@3: cmp #'$' ; STRING? + bne @4 ; NO + lda #$FF + sta VALTYP + bne @5 ; ...ALWAYS +@4: cmp #'%' ; INTEGER? + bne @6 ; NO + lda SUBFLG ; YES; INTEGER VARIABLE ALLOWED? + bmi BADNAM ; NO, SYNTAX ERROR + lda #$80 ; YES + sta VALTYP+1 ; FLAG INTEGER MODE + ora VARNAM + sta VARNAM ; SET SIGN BIT ON VARNAME +@5: txa ; SECOND CHAR OF NAME + ora #$80 ; SET SIGN + tax + jsr CHRGET ; GET TERMINATING CHAR +@6: stx VARNAM+1 ; STORE SECOND CHAR OF NAME + sec + ora SUBFLG ; $00 OR $40 IF SUBSCRIPTS OK, ELSE $80 + sbc #'(' ; IF SUBFLG=$00 AND CHAR="("... + bne @8 ; NOPE +@7: jmp ARRAY ; YES +@8: bit SUBFLG ; CHECK TOP TWO BITS OF SUBFLG + bmi @9 ; $80 + bvs @7 ; $40, CALLED FROM GETARYPT +@9: lda #0 ; CLEAR SUBFLG + sta SUBFLG + lda VARTAB ; START LOWTR AT SIMPLE VARIABLE TABLE + ldx VARTAB+1 + ldy #0 +@10: stx LOWTR+1 +@11: sta LOWTR + cpx ARYTAB+1 ; END OF SIMPLE VARIABLES? + bne @12 ; NO, GO ON + cmp ARYTAB ; YES; END OF ARRAYS? + beq NAMENOTFOUND ; YES, MAKE ONE +@12: lda VARNAM ; SAME FIRST LETTER? + cmp (LOWTR),y + bne @13 ; NOT SAME FIRST LETTER + lda VARNAM+1 ; SAME SECOND LETTER? + iny + cmp (LOWTR),y + beq SET_VARPNT_AND_YA ; YES, SAME VARIABLE NAME + dey ; NO, BUMP TO NEXT NAME +@13: clc + lda LOWTR + adc #7 + bcc @11 + inx + bne @10 ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; CHECK IF (A) IS ASCII LETTER A-Z +; +; RETURN CARRY = 1 IF A-Z +; = 0 IF NOT +; ---------------------------------------------------------------------------- +ISLETC: cmp #'Z'+1 ; COMPARE HI END + bcs @1 ; ABOVE A-Z + cmp #'A' ; COMPARE LO END + rts ; C=0 IF LO, C=1 IF A-Z +@1: clc ; C=0 IF HI + rts + + +; ---------------------------------------------------------------------------- +; VARIABLE NOT FOUND, SO MAKE ONE +; ---------------------------------------------------------------------------- +NAMENOTFOUND: + pla ; LOOK AT RETURN ADDRESS ON STACK TO + pha ; SEE IF CALLED FROM FRM.VARIABLE + cmp #FRM_VARIABLE_CALL + bne MAKENEWVARIABLE ; NO + lda #C_ZERO ; POINT TO A CONSTANT ZERO + rts ; NEW VARIABLE USED IN EXPRESSION = 0 + +; ---------------------------------------------------------------------------- +C_ZERO: .word $0000 ; INTEGER OR REAL ZERO, OR NULL STRING + + +; ---------------------------------------------------------------------------- +; MAKE A NEW SIMPLE VARIABLE +; +; MOVE ARRAYS UP 7 BYTES TO MAKE ROOM FOR NEW VARIABLE +; ENTER 7-BYTE VARIABLE DATA IN THE HOLE +; ---------------------------------------------------------------------------- +MAKENEWVARIABLE: + lda ARYTAB ; SET UP CALL TO BLTU TO + ldy ARYTAB+1 ; TO MOVE FROM ARYTAB THRU STREND-1 + sta LOWTR ; 7 BYTES HIGHER + sty LOWTR+1 + lda STREND + ldy STREND+1 + sta HIGHTR + sty HIGHTR+1 + clc + adc #7 + bcc @1 + iny +@1: sta ARYPNT + sty ARYPNT+1 + jsr BLTU ; MOVE ARRAY BLOCK UP + lda ARYPNT ; STORE NEW START OF ARRAYS + ldy ARYPNT+1 + iny + sta ARYTAB + sty ARYTAB+1 + ldy #0 + lda VARNAM ; FIRST CHAR OF NAME + sta (LOWTR),y + iny + lda VARNAM+1 ; SECOND CHAR OF NAME + sta (LOWTR),y + lda #0 ; SET FIVE-BYTE VALUE TO 0 + iny + sta (LOWTR),y + iny + sta (LOWTR),y + iny + sta (LOWTR),y + iny + sta (LOWTR),y + iny + sta (LOWTR),y + + +; ---------------------------------------------------------------------------- +; PUT ADDRESS OF VALUE OF VARIABLE IN VARPNT AND Y,A +; ---------------------------------------------------------------------------- +SET_VARPNT_AND_YA: + lda LOWTR ; LOWTR POINTS AT NAME OF VARIABLE, + clc ; SO ADD 2 TO GET TO VALUE + adc #2 + ldy LOWTR+1 + bcc @1 + iny +@1: sta VARPNT ; ADDRESS IN VARPNT AND Y,A + sty VARPNT+1 + rts + + +; ---------------------------------------------------------------------------- +; COMPUTE ADDRESS OF FIRST VALUE IN ARRAY +; ARYPNT = (LOWTR) + #DIMS*2 + 5 +; ---------------------------------------------------------------------------- +GETARY: lda NUMDIM ; GET # OF DIMENSIONS + asl a ; #DIMS*2 (SIZE OF EACH DIM IN 2 BYTES) + adc #5 ; + 5 (2 FOR NAME, 2 FOR OFFSET TO NEXT ARRAY, AND 1 FOR #DIMS + adc LOWTR ; ADDRESS OF TH IS ARRAY IN ARYTAB + ldy LOWTR+1 + bcc @1 + iny +@1: sta ARYPNT ; ADDRESS OF FIRST VALUE IN ARRAY + sty ARYPNT+1 + rts + + +; ---------------------------------------------------------------------------- +NEG32768: + .byte $90,$80,$00,$00,$00 ; -32768 IN FLOATING POINT +; ---------------------------------------------------------------------------- + + +; ---------------------------------------------------------------------------- +; EVALUATE NUMERIC FORMULA AT TXTPTR +; CONVERTING RESULT TO INTEGER 0 <= X <= 32767 +; IN FAC+3,4 +; ---------------------------------------------------------------------------- +MAKINT: jsr CHRGET + jsr FRMNUM + + +; ---------------------------------------------------------------------------- +; CONVERT FAC TO INTEGER +; MUST BE POSITIVE AND LESS THAN 32768 +; ---------------------------------------------------------------------------- +MKINT: lda FACSIGN ; ERROR IF - + bmi MI1 + + +; ---------------------------------------------------------------------------- +; CONVERT FAC TO INTEGER +; MUST BE -32767 <= FAC <= 32767 +; ---------------------------------------------------------------------------- +AYINT: lda FAC ; EXPONENT OF VALUE IN FAC + cmp #$90 ; ABS(VALUE) < 32768? + bcc MI2 ; YES, OK FOR INTEGER + lda #NEG32768 + jsr FCOMP +; ---------------------------------------------------------------------------- +MI1: bne IQERR ; ILLEGAL QUANTITY +MI2: jmp QINT ; CONVERT TO INTEGER + + +; ---------------------------------------------------------------------------- +; LOCATE ARRAY ELEMENT OR CREATE AN ARRAY +; ---------------------------------------------------------------------------- +ARRAY: lda SUBFLG ; SUBSCRIPTS GIVEN? + bne @2 ; NO +; ---------------------------------------------------------------------------- +; PARSE THE SUBSCRIPT LIST +; ---------------------------------------------------------------------------- + lda DIMFLG ; YES + ora VALTYP+1 ; SET HIGH BIT IF % + pha ; SAVE VALTYP AND DIMFLG ON STACK + lda VALTYP + pha + ldy #0 ; COUNT # DIMENSIONS IN Y-REG +@1: tya ; SAVE #DIMS ON STACK + pha + lda VARNAM+1 ; SAVE VARIABLE NAME ON STACK + pha + lda VARNAM + pha + jsr MAKINT ; EVALUATE SUBSCRIPT AS INTEGER + pla ; RESTORE VARIABLE NAME + sta VARNAM + pla + sta VARNAM+1 + pla ; RESTORE # DIMS TO Y-REG + tay + tsx ; COPY VALTYP AND DIMFLG ON STACK + lda STACK+2,x ; TO LEAVE ROOM FOR THE SUBSCRIPT + pha + lda STACK+1,x + pha + lda FAC+3 ; GET SUBSCRIPT VALUE AND PLACE IN THE + sta STACK+2,x ; STACK WHERE VALTYP & DIMFLG WERE + lda FAC+4 + sta STACK+1,x + iny ; COUNT THE SUBSCRIPT + jsr CHRGOT ; NEXT CHAR + cmp #',' + beq @1 ; COMMA, PARSE ANOTHER SUBSCRIPT + sty NUMDIM ; NO MORE SUBSCRIPTS, SAVE # + jsr CHKCLS ; NOW NEED ")" + pla ; RESTORE VALTYPE AND DIMFLG + sta VALTYP + pla + sta VALTYP+1 + and #$7F ; ISOLATE DIMFLG + sta DIMFLG +; ---------------------------------------------------------------------------- +; SEARCH ARRAY TABLE FOR THIS ARRAY NAME +; ---------------------------------------------------------------------------- +@2: ldx ARYTAB ; (A,X) = START OF ARRAY TABLE + lda ARYTAB+1 +@3: stx LOWTR ; USE LOWTR FOR RUNNING POINTER + sta LOWTR+1 + cmp STREND+1 ; DID WE REACH THE END OF ARRAYS YET? + bne @4 ; NO, KEEP SEARCHING + cpx STREND + beq MAKE_NEW_ARRAY ; YES, THIS IS A NEW ARRAY NAME +@4: ldy #0 ; POINT AT 1ST CHAR OF ARRAY NAME + lda (LOWTR),y ; GET 1ST CHAR OF NAME + iny ; POINT AT 2ND CHAR + cmp VARNAM ; 1ST CHAR SAME? + bne @5 ; NO, MOVE TO NEXT ARRAY + lda VARNAM+1 ; YES, TRY 2ND CHAR + cmp (LOWTR),y ; SAME? + beq USE_OLD_ARRAY ; YES, ARRAY FOUND +@5: iny ; POINT AT OFFSET TO NEXT ARRAY + lda (LOWTR),y ; ADD OFFSET TO RUNNING POINTER + clc + adc LOWTR + tax + iny + lda (LOWTR),y + adc LOWTR+1 + bcc @3 ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; ERROR: BAD SUBSCRIPTS +; ---------------------------------------------------------------------------- +SUBERR: ldx #ERR_BADSUBS + .byte $2C ; TRICK TO SKIP NEXT LINE + + +; ---------------------------------------------------------------------------- +; ERROR: ILLEGAL QUANTITY +; ---------------------------------------------------------------------------- +IQERR: ldx #ERR_ILLQTY +JER: jmp ERROR + + +; ---------------------------------------------------------------------------- +; FOUND THE ARRAY +; ---------------------------------------------------------------------------- +USE_OLD_ARRAY: + ldx #ERR_REDIMD ; SET UP FOR REDIM'D ARRAY ERROR + lda DIMFLG ; CALLED FROM "DIM" STATEMENT? + bne JER ; YES, ERROR + lda SUBFLG ; NO, CHECK IF ANY SUBSCRIPTS + beq @1 ; YES, NEED TO CHECK THE NUMBER + sec ; NO, SIGNAL ARRAY FOUND + rts +; ---------------------------------------------------------------------------- +@1: jsr GETARY ; SET (ARYPNT) = ADDR OF FIRST ELEMENT + lda TKNCNTR ; COMPARE NUMBER OF DIMENSIONS + ldy #4 + cmp (LOWTR),y + bne SUBERR ; NOT SAME, SUBSCRIPT ERROR + jmp FIND_ARRAY_ELEMENT + + +; ---------------------------------------------------------------------------- +; CREATE A NEW ARRAY, UNLESS CALLED FROM GETARYPT +; ---------------------------------------------------------------------------- +MAKE_NEW_ARRAY: + lda SUBFLG ; CALLED FROM GETARYPT? + beq @1 ; NO + ldx #ERR_NODATA ; YES, GIVE "OUT OF DATA" ERROR + jmp ERROR +@1: jsr GETARY ; PUT ADDR OF 1ST ELEMENT IN ARYPNT + jsr REASON ; MAKE SURE ENOUGH MEMORY LEFT + ldy #0 ; POINT Y-REG AT VARIABLE NAME SLOT + sty STRNG2+1 ; START SIZE COMPUTATION + ldx #5 ; ASSUME 5-BYTES PER ELEMENT + lda VARNAM ; STUFF VARIABLE NAME IN ARRAY + sta (LOWTR),y + bpl @2 ; NOT INTEGER ARRAY + dex ; INTEGER ARRAY, DECR. SIZE TO 4-BYTES +@2: iny ; POINT Y-REG AT NEXT CHAR OF NAME + lda VARNAM+1 ; REST OF ARRAY NAME + sta (LOWTR),y + bpl @3 ; REAL ARRAY, STICK WITH SIZE = 5 BYTES + dex ; INTEGER OR STRING ARRAY, ADJUST SIZE + dex ; TO INTEGER=3, STRING=2 BYTES +@3: stx STRNG2 ; STORE LOW-BYTE OF ARRAY ELEMENT SIZE + lda NUMDIM ; STORE NUMBER OF DIMENSIONS + iny ; IN 5TH BYTE OF ARRAY + iny + iny + sta (LOWTR),y +@4: ldx #11 ; DEFAULT DIMENSION = 11 ELEMENTS + lda #0 ; FOR HI-BYTE OF DIMENSION IF DEFAULT + bit DIMFLG ; DIMENSIONED ARRAY? + bvc @5 ; NO, USE DEFAULT VALUE + pla ; GET SPECIFIED DIM IN A,X + clc ; # ELEMENTS IS 1 LARGER THAN + adc #1 ; DIMENSION VALUE + tax + pla + adc #0 +@5: iny ; ADD THIS DIMENSION TO ARRAY DESCRIPTOR + sta (LOWTR),y + iny + txa + sta (LOWTR),y + jsr MULTIPLY_SUBSCRIPT ; MULTIPLY THIS DIMENSION BY RUNNING SIZE ((LOWTR)) * (STRNG2) --> A,X + stx STRNG2 ; STORE RUNNING SIZE IN STRNG2 + sta STRNG2+1 + ldy INDEX ; RETRIEVE Y SAVED BY MULTIPLY.SUBSCRIPT + dec NUMDIM ; COUNT DOWN # DIMS + bne @4 ; LOOP TILL DONE +; ---------------------------------------------------------------------------- +; NOW A,X HAS TOTAL # BYTES OF ARRAY ELEMENTS +; ---------------------------------------------------------------------------- + adc ARYPNT+1 ; COMPUTE ADDRESS OF END OF THIS ARRAY + bcs GME ; ...TOO LARGE, ERROR + sta ARYPNT+1 + tay + txa + adc ARYPNT + bcc @6 + iny + beq GME ; ...TOO LARGE, ERROR +@6: jsr REASON ; MAKE SURE THERE IS ROOM UP TO Y,A + sta STREND ; THERE IS ROOM SO SAVE NEW END OF TABLE + sty STREND+1 ; AND ZERO THE ARRAY + lda #0 + inc STRNG2+1 ; PREPARE FOR FAST ZEROING LOOP + ldy STRNG2 ; # BYTES MOD 256 + beq @8 ; FULL PAGE +@7: dey ; CLEAR PAGE FULL + sta (ARYPNT),y + bne @7 +@8: dec ARYPNT+1 ; POINT TO NEXT PAGE + dec STRNG2+1 ; COUNT THE PAGES + bne @7 ; STILL MORE TO CLEAR + inc ARYPNT+1 ; RECOVER LAST DEC, POINT AT 1ST ELEMENT + sec + lda STREND ; COMPUTE OFFSET TO END OF ARRAYS + sbc LOWTR ; AND STORE IN ARRAY DESCRIPTOR + ldy #2 + sta (LOWTR),y + lda STREND+1 + iny + sbc LOWTR+1 + sta (LOWTR),y + lda DIMFLG ; WAS THIS CALLED FROM "DIM" STATEMENT? + bne RTS9 ; YES, WE ARE FINISHED + iny ; NO, NOW NEED TO FIND THE ELEMENT + + +; ---------------------------------------------------------------------------- +; FIND SPECIFIED ARRAY ELEMENT +; +; (LOWTR),Y POINTS AT # OF DIMS IN ARRAY DESCRIPTOR +; THE SUBSCRIPTS ARE ALL ON THE STACK AS INTEGERS +; ---------------------------------------------------------------------------- +FIND_ARRAY_ELEMENT: + lda (LOWTR),y ; GET # OF DIMENSIONS + sta NUMDIM + lda #0 ; ZERO SUBSCRIPT ACCUMULATOR + sta STRNG2 +FAE1: sta STRNG2+1 + iny + pla ; PULL NEXT SUBSCRIPT FROM STACK + tax ; SAVE IN FAC+3,4 + sta FAC+3 ; AND COMPARE WITH DIMENSIONED SIZE + pla + sta FAC+4 + cmp (LOWTR),y + bcc FAE2 ; SUBSCRIPT NOT TOO LARGE + bne GSE ; SUBSCRIPT IS TOO LARGE + iny ; CHECK LOW-BYTE OF SUBSCRIPT + txa + cmp (LOWTR),y + bcc FAE3 ; NOT TOO LARGE +; ---------------------------------------------------------------------------- +GSE: jmp SUBERR ; BAD SUBSCRIPTS ERROR +GME: jmp MEMERR ; MEM FULL ERROR +; ---------------------------------------------------------------------------- +FAE2: iny ; BUMP POINTER INTO DESCRIPTOR +FAE3: lda STRNG2+1 ; BYPASS MULTIPLICATION IF VALUE SO + ora STRNG2 ; FAR = 0 + clc + beq @1 ; IT IS ZERO SO FAR + jsr MULTIPLY_SUBSCRIPT ; NOT ZERO, SO MULTIPLY + txa ; ADD CURRENT SUBSCRIPT + adc FAC+3 + tax + tya + ldy INDEX ; RETRIEVE Y SAVED BY MULTIPLY.SUBSCRIPT +@1: adc FAC+4 ; FINISH ADDING CURRENT SUBSCRIPT + stx STRNG2 ; STORE ACCUMULATED OFFSET + dec NUMDIM ; LAST SUBSCRIPT YET? + bne FAE1 ; NO, LOOP TILL DONE + sta STRNG2+1 ; YES, NOW MULTIPLY BE ELEMENT SIZE + ldx #5 ; START WITH SIZE = 5 + lda VARNAM ; DETERMINE VARIABLE TYPE + bpl @2 ; NOT INTEGER + dex ; INTEGER, BACK DOWN SIZE TO 4 BYTES +@2: lda VARNAM+1 ; DISCRIMINATE BETWEEN REAL AND STR + bpl @3 ; IT IS REAL + dex ; SIZE = 3 IF STRING, =2 IF INTEGER + dex +@3: stx RESULT+2 ; SET UP MULTIPLIER + lda #0 ; HI-BYTE OF MULTIPLIER + jsr MULTIPLY_SUBS1 ; (STRNG2) BY ELEMENT SIZE + txa ; ADD ACCUMULATED OFFSET + adc ARYPNT ; TO ADDRESS OF 1ST ELEMENT + sta VARPNT ; TO GET ADDRESS OF SPECIFIED ELEMENT + tya + adc ARYPNT+1 + sta VARPNT+1 + tay ; RETURN WITH ADDR IN VARPNT + lda VARPNT ; AND IN Y,A +RTS9: rts + + +; ---------------------------------------------------------------------------- +; MULTIPLY (STRNG2) BY ((LOWTR),Y) +; LEAVING PRODUCT IN A,X. (HI-BYTE ALSO IN Y.) +; USED ONLY BY ARRAY SUBSCRIPT ROUTINES +; ---------------------------------------------------------------------------- +MULTIPLY_SUBSCRIPT: + sty INDEX ; SAVE Y-REG + lda (LOWTR),y ; GET MULTIPLIER + sta RESULT+2 ; SAVE IN RESULT+2,3 + dey + lda (LOWTR),y +; ---------------------------------------------------------------------------- +MULTIPLY_SUBS1: + sta RESULT+3 ; LOW BYTE OF MULTIPLIER + lda #16 ; MULTIPLY 16 BITS + sta INDX + ldx #0 ; PRODUCT = 0 INITIALLY + ldy #0 +@1: txa ; DOUBLE PRODUCT + asl a ; LOW BYTE + tax + tya ; HIGH BYTE + rol a ; IF TOO LARGE, SET CARRY + tay + bcs GME ; TOO LARGE, "MEM FULL ERROR" + asl STRNG2 ; NEXT BIT OF MUTLPLICAND + rol STRNG2+1 ; INTO CARRY + bcc @2 ; BIT=0, DON'T NEED TO ADD + clc ; BIT=1, ADD INTO PARTIAL PRODUCT + txa + adc RESULT+2 + tax + tya + adc RESULT+3 + tay + bcs GME ; TOO LARGE, "MEM FULL ERROR" +@2: dec INDX ; 16-BITS YET? + bne @1 ; NO, KEEP SHUFFLING + rts ; YES, PRODUCT IN Y,X AND A,X + + +; ---------------------------------------------------------------------------- +; "FRE" FUNCTION +; +; COLLECTS GARBAGE AND RETURNS # BYTES OF MEMORY LEFT +; ---------------------------------------------------------------------------- +FRE: lda VALTYP ; LOOK AT VALUE OF ARGUMENT + beq @1 ; =0 MEANS REAL, =$FF MEANS STRING + jsr FREFAC ; STRING, SO SET IT FREE IS TEMP +@1: jsr GARBAG ; COLLECT ALL THE GARBAGE IN SIGHT + sec ; COMPUTE SPACE BETWEEN ARRAYS AND + lda FRETOP ; STRING TEMP AREA + sbc STREND + tay + lda FRETOP+1 + sbc STREND+1 ; FREE SPACE IN Y,A +; FALL INTO GIVAYF TO FLOAT THE VALUE +; NOTE THAT VALUES OVER 32767 WILL RETURN AS NEGATIVE + + +; ---------------------------------------------------------------------------- +; FLOAT THE SIGNED INTEGER IN A,Y +; ---------------------------------------------------------------------------- +GIVAYF: ldx #0 ; MARK FAC VALUE TYPE REAL + stx VALTYP + sta FAC+1 ; SAVE VALUE FROM A,Y IN MANTISSA + sty FAC+2 + ldx #$90 ; SET EXPONENT TO 2^16 + jmp FLOAT1 ; CONVERT TO SIGNED FP + + +; ---------------------------------------------------------------------------- +; FLOAT (Y) INTO FAC, GIVING VALUE 0-255 +; ---------------------------------------------------------------------------- +SNGFLT: lda #0 ; MSB = 0 + beq GIVAYF ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; CHECK FOR DIRECT OR RUNNING MODE +; GIVING ERROR IF DIRECT MODE +; ---------------------------------------------------------------------------- +ERRDIR: ldx CURLIN+1 ; =$FF IF DIRECT MODE + inx ; MAKES $FF INTO ZERO + bne RTS9 ; RETURN IF RUNNING MODE + ldx #ERR_ILLDIR ; DIRECT MODE, GIVE ERROR + jmp ERROR + + +; ---------------------------------------------------------------------------- +; "STR$" FUNCTION +; ---------------------------------------------------------------------------- +STR: jsr CHKNUM ; EXPRESSION MUST BE NUMERIC + ldy #0 ; START STRING AT STACK-1 ($00FF) SO STRLIT CAN DIFFRENTIATE STR$ CALLS + jsr FOUT1 ; CONVERT FAC TO STRING + pla ; POP RETURN OFF STACK + pla + lda #STACK-1 ; (WHICH=0) + beq STRLIT ; ...ALWAYS, CREATE DESC & MOVE STRING + + +; ---------------------------------------------------------------------------- +; GET SPACE AND MAKE DESCRIPTOR FOR STRING WHOSE +; ADDRESS IS IN FAC+3,4 AND WHOSE LENGTH IS IN A-REG +; ---------------------------------------------------------------------------- +STRINI: ldx FAC+3 ; Y,X = STRING ADDRESS + ldy FAC+4 + stx DSCPTR + sty DSCPTR+1 + + +; ---------------------------------------------------------------------------- +; GET SPACE AND MAKE DESCRIPTOR FOR STRING WHOSE +; ADDRESS IS IN Y,X AND WHOSE LENGTH IS IN A-REG +; ---------------------------------------------------------------------------- +STRSPA: jsr GETSPA ; A HOLDS LENGTH + stx FAC+1 ; SAVE DESCRIPTOR IN FAC + sty FAC+2 ; ---FAC--- --FAC+1-- --FAC+2-- + sta FAC ; + rts + + +; ---------------------------------------------------------------------------- +; BUILD A DESCRIPTOR FOR STRING STARTING AT Y,A +; AND TERMINATED BY $00 OR QUOTATION MARK +; RETURN WITH DESCRIPTOR IN A TEMPORARY +; AND ADDRESS OF DESCRIPTOR IN FAC+3,4 +; ---------------------------------------------------------------------------- +STRLIT: ldx #'"' ; SET UP LITERAL SCAN TO STOP ON + stx CHARAC ; QUOTATION MARK OR $00 + stx ENDCHR + + +; ---------------------------------------------------------------------------- +; BUILD A DESCRIPTOR FOR STRING STARTING AT Y,A +; AND TERMINATED BY $00, (CHARAC), OR (ENDCHR) +; +; RETURN WITH DESCRIPTOR IN A TEMPORARY +; AND ADDRESS OF DESCRIPTOR IN FAC+3,4 +; ---------------------------------------------------------------------------- +STRLT2: sta STRNG1 ; SAVE ADDRESS OF STRING + sty STRNG1+1 + sta FAC+1 ; ...AGAIN + sty FAC+2 + ldy #$FF +@1: iny ; FIND END OF STRING + lda (STRNG1),y ; NEXT STRING CHAR + beq @3 ; END OF STRING + cmp CHARAC ; ALTERNATE TERMINATOR # 1? + beq @2 ; YES + cmp ENDCHR ; ALTERNATE TERMINATOR # 2? + bne @1 ; NO, KEEP SCANNING +@2: cmp #'"' ; IS STRING ENDED WITH QUOTE MARK? + beq @4 ; YES, C=1 TO INCLUDE " IN STRING +@3: clc +@4: sty FAC ; SAVE LENGTH + tya + adc STRNG1 ; COMPUTE ADDRESS OF END OF STRING + sta STRNG2 ; (OF 00 BYTE, OR JUST AFTER ") + ldx STRNG1+1 + bcc @5 + inx +@5: stx STRNG2+1 + lda STRNG1+1 ; WHERE DOES THE STRING START? + beq @6 ; PAGE 0, MUST BE FROM STR$ FUNCTION + cmp #2 ; PAGE 2? + bne PUTNEW ; NO, NOT PAGE 0 OR 2 +@6: tya ; LENGTH OF STRING + jsr STRINI ; MAKE SPACE FOR STRING + ldx STRNG1 + ldy STRNG1+1 + jsr MOVSTR ; MOVE IT IN + + +; ---------------------------------------------------------------------------- +; STORE DESCRIPTOR IN TEMPORARY DESCRIPTOR STACK +; +; THE DESCRIPTOR IS NOW IN FAC, FAC+1, FAC+2 +; PUT ADDRESS OF TEMP DESCRIPTOR IN FAC+3,4 +; ---------------------------------------------------------------------------- +PUTNEW: ldx TEMPPT ; POINTER TO NEXT TEMP STRING SLOT + cpx #TEMPST+9 ; MAX OF 3 TEMP STRINGS + bne PUTEMP ; ROOM FOR ANOTHER ONE + ldx #ERR_FRMCPX ; TOO MANY, FORMULA TOO COMPLEX +JERR: jmp ERROR +; ---------------------------------------------------------------------------- +PUTEMP: lda FAC ; COPY TEMP DESCRIPTOR INTO TEMP STACK + sta 0,x + lda FAC+1 + sta 1,x + lda FAC+2 + sta 2,x + ldy #0 + stx FAC+3 ; ADDRESS OF TEMP DESCRIPTOR + sty FAC+4 ; IN Y,X AND FAC+3,4 + dey ; Y=$FF + sty VALTYP ; FLAG (FAC ) AS STRING + stx LASTPT ; INDEX OF LAST POINTER + inx ; UPDATE FOR NEXT TEMP ENTRY + inx + inx + stx TEMPPT + rts + + +; ---------------------------------------------------------------------------- +; MAKE SPACE FOR STRING AT BOTTOM OF STRING SPACE +; (A)=# BYTES SPACE TO MAKE +; +; RETURN WITH (A) SAME, +; AND Y,X = ADDRESS OF SPACE ALLOCATED +; ---------------------------------------------------------------------------- +GETSPA: lsr GARFLG ; CLEAR SIGNBIT OF FLAG +@1: pha ; A HOLDS LENGTH + eor #$FF ; GET -LENGTH + sec + adc FRETOP ; COMPUTE STARTING ADDRESS OF SPACE + ldy FRETOP+1 ; FOR THE STRING + bcs @2 + dey +@2: cpy STREND+1 ; SEE IF FITS IN REMAINING MEMORY + bcc @4 ; NO, TRY GARBAGE + bne @3 ; YES, IT FITS + cmp STREND ; HAVE TO CHECK LOWER BYTES + bcc @4 ; NOT ENUF ROOM YET +@3: sta FRETOP ; THERE IS ROOM SO SAVE NEW FRETOP + sty FRETOP+1 + sta FRESPC + sty FRESPC+1 + tax ; ADDR IN Y,X + pla ; LENGTH IN A + rts +@4: ldx #ERR_MEMFULL + lda GARFLG ; GARBAGE DONE YET? + bmi JERR ; YES, MEMORY IS REALLY FULL + jsr GARBAG ; NO, TRY COLLECTING NOW + lda #$80 ; FLAG THAT COLLECTED GARBAGE ALREADY + sta GARFLG + pla ; GET STRING LENGTH AGAIN + bne @1 ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; SHOVE ALL REFERENCED STRINGS AS HIGH AS POSSIBLE +; IN MEMORY (AGAINST HIMEM), FREEING UP SPACE +; BELOW STRING AREA DOWN TO STREND. +; ---------------------------------------------------------------------------- +GARBAG: ldx MEMSIZ ; COLLECT FROM TOP DOWN + lda MEMSIZ+1 +FINDHIGHESTSTRING: + stx FRETOP ; ONE PASS THROUGH ALL VARS + sta FRETOP+1 ; FOR EACH ACTIVE STRING! + ldy #0 + sty FNCNAM+1 ; FLAG IN CASE NO STRINGS TO COLLECT + lda STREND + ldx STREND+1 + sta LOWTR + stx LOWTR+1 +; ---------------------------------------------------------------------------- +; START BY COLLECTING TEMPORARIES +; ---------------------------------------------------------------------------- + lda #TEMPST + sta INDEX + stx INDEX+1 +@1: cmp TEMPPT ; FINISHED WITH TEMPS YET? + beq @2 ; YES, NOW DO SIMPLE VARIABLES + jsr CHECK_VARIABLE ; DO A TEMP + beq @1 ; ...ALWAYS +; ---------------------------------------------------------------------------- +; NOW COLLECT SIMPLE VARIABLES +; ---------------------------------------------------------------------------- +@2: lda #7 ; LENGTH OF EACH VARIABLE IS 7 BYTES + sta DSCLEN + lda VARTAB ; START AT BEGINNING OF VARTAB + ldx VARTAB+1 + sta INDEX + stx INDEX+1 +@3: cpx ARYTAB+1 ; FINISHED WITH SIMPLE VARIABLES? + bne @4 ; NO + cmp ARYTAB ; MAYBE, CHECK LO-BYTE + beq @5 ; YES, NOW DO ARRAYS +@4: jsr CHECK_SIMPLE_VARIABLE + beq @3 ; ...ALWAYS +; ---------------------------------------------------------------------------- +; NOW COLLECT ARRAY VARIABLES +; ---------------------------------------------------------------------------- +@5: sta ARYPNT + stx ARYPNT+1 + lda #3 ; DESCRIPTORS IN ARRAYS ARE 3-BYTES EACH + sta DSCLEN +@6: lda ARYPNT ; COMPARE TO END OF ARRAYS + ldx ARYPNT+1 +@7: cpx STREND+1 ; FINISHED WITH ARRAYS YET? + bne @8 ; NOT YET + cmp STREND ; MAYBE, CHECK LO-BYTE + bne @8 ; NOT FINISHED YET + jmp MOVE_HIGHEST_STRING_TO_TOP ; FINISHED +@8: sta INDEX ; SET UP PNTR TO START OF ARRAY + stx INDEX+1 + ldy #0 ; POINT AT NAME OF ARRAY + lda (INDEX),y + tax ; 1ST LETTER OF NAME IN X-REG + iny + lda (INDEX),y + php ; STATUS FROM SECOND LETTER OF NAME + iny + lda (INDEX),y ; OFFSET TO NEXT ARRAY + adc ARYPNT ; (CARRY ALWAYS CLEAR) + sta ARYPNT ; CALCULATE START OF NEXT ARRAY + iny + lda (INDEX),y ; HI-BYTE OF OFFSET + adc ARYPNT+1 + sta ARYPNT+1 + plp ; GET STATUS FROM 2ND CHAR OF NAME + bpl @6 ; NOT A STRING ARRAY + txa ; SET STATUS WITH 1ST CHAR OF NAME + bmi @6 ; NOT A STRING ARRAY + iny + lda (INDEX),y ; # OF DIMENSIONS FOR THIS ARRAY + ldy #0 + asl a ; PREAMBLE SIZE = 2*#DIMS + 5 + adc #5 + adc INDEX ; MAKE INDEX POINT AT FIRST ELEMENT + sta INDEX ; IN THE ARRAY + bcc @9 + inc INDEX+1 +@9: ldx INDEX+1 ; STEP THRU EACH STRING IN THIS ARRAY +@10: cpx ARYPNT+1 ; ARRAY DONE? + bne @11 ; NO, PROCESS NEXT ELEMENT + cmp ARYPNT ; MAYBE, CHECK LO-BYTE + beq @7 ; YES, MOVE TO NEXT ARRAY +@11: jsr CHECK_VARIABLE ; PROCESS THE ARRAY + beq @10 ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; PROCESS A SIMPLE VARIABLE +; ---------------------------------------------------------------------------- +CHECK_SIMPLE_VARIABLE: + lda (INDEX),y ; LOOK AT 1ST CHAR OF NAME + bmi CHECK_BUMP ; NOT A STRING VARIABLE + iny + lda (INDEX),y ; LOOK AT 2ND CHAR OF NAME + bpl CHECK_BUMP ; NOT A STRING VARIABLE + iny + + +; ---------------------------------------------------------------------------- +; IF STRING IS NOT EMPTY, CHECK IF IT IS HIGHEST +; ---------------------------------------------------------------------------- +CHECK_VARIABLE: + lda (INDEX),y ; GET LENGTH OF STRING + beq CHECK_BUMP ; IGNORE STRING IF LENGTH IS ZERO + iny + lda (INDEX),y ; GET ADDRESS OF STRING + tax + iny + lda (INDEX),y + cmp FRETOP+1 ; CHECK IF ALREADY COLLECTED + bcc @1 ; NO, BELOW FRETOP + bne CHECK_BUMP ; YES, ABOVE FRETOP + cpx FRETOP ; MAYBE, CHECK LO-BYTE + bcs CHECK_BUMP ; YES, ABOVE FRETOP +@1: cmp LOWTR+1 ; ABOVE HIGHEST STRING FOUND? + bcc CHECK_BUMP ; NO, IGNORE FOR NOW + bne @2 ; YES, THIS IS THE NEW HIGHEST + cpx LOWTR ; MAYBE, TRY LO-BYTE + bcc CHECK_BUMP ; NO, IGNORE FOR NOW +@2: stx LOWTR ; MAKE THIS THE HIGHEST STRING + sta LOWTR+1 + lda INDEX ; SAVE ADDRESS OF DESCRIPTOR TOO + ldx INDEX+1 + sta FNCNAM + stx FNCNAM+1 + lda DSCLEN + sta LENGTH + + +; ---------------------------------------------------------------------------- +; ADD (DSCLEN) TO PNTR IN INDEX +; RETURN WITH Y=0, PNTR ALSO IN X,A +; ---------------------------------------------------------------------------- +CHECK_BUMP: + lda DSCLEN ; BUMP TO NEXT VARIABLE + clc + adc INDEX + sta INDEX + bcc CHECK_EXIT + inc INDEX+1 +; ---------------------------------------------------------------------------- +CHECK_EXIT: + ldx INDEX+1 + ldy #0 + rts + + +; ---------------------------------------------------------------------------- +; FOUND HIGHEST NON-EMPTY STRING, SO MOVE IT +; TO TOP AND GO BACK FOR ANOTHER +; ---------------------------------------------------------------------------- +MOVE_HIGHEST_STRING_TO_TOP: + ldx FNCNAM+1 ; ANY STRING FOUND? + beq CHECK_EXIT ; NO, RETURN + lda LENGTH ; GET LENGTH OF VARIABLE ELEMENT + and #4 ; WAS 7 OR 3, MAKE 4 OR 0 + lsr a ; 2 0R 0; IN SIMPLE VARIABLES, + tay ; NAME PRECEDES DESCRIPTOR + sta LENGTH ; 2 OR 0 + lda (FNCNAM),y ; GET LENGTH FROM DESCRIPTOR + adc LOWTR ; CARRY ALREADY CLEARED BY LSR + sta HIGHTR ; STRING IS BTWN (LOWTR) AND (HIGHTR) + lda LOWTR+1 + adc #0 + sta HIGHTR+1 + lda FRETOP ; HIGH END DESTINATION + ldx FRETOP+1 + sta HIGHDS + stx HIGHDS+1 + jsr BLTU2 ; MOVE STRING UP + ldy LENGTH ; FIX ITS DESCRIPTOR + iny ; POINT AT ADDRESS IN DESCRIPTOR + lda HIGHDS ; STORE NEW ADDRESS + sta (FNCNAM),y + tax + inc HIGHDS+1 ; CORRECT BLTU'S OVERSHOOT + lda HIGHDS+1 + iny + sta (FNCNAM),y + jmp FINDHIGHESTSTRING + + +; ---------------------------------------------------------------------------- +; CONCATENATE TWO STRINGS +; ---------------------------------------------------------------------------- +CAT: lda FAC+4 ; SAVE ADDRESS OF FIRST DESCRIPTOR + pha + lda FAC+3 + pha + jsr FRM_ELEMENT ; GET SECOND STRING ELEMENT + jsr CHKSTR ; MUST BE A STRING + pla ; RECOVER ADDRES OF 1ST DESCRIPTOR + sta STRNG1 + pla + sta STRNG1+1 + ldy #0 + lda (STRNG1),y ; ADD LENGTHS, GET CONCATENATED SIZE + clc + adc (FAC+3),y + bcc @1 ; OK IF < $100 + ldx #ERR_STRLONG + jmp ERROR +@1: jsr STRINI ; GET SPACE FOR CONCATENATED STRINGS + jsr MOVINS ; MOVE 1ST STRING + lda DSCPTR + ldy DSCPTR+1 + jsr FRETMP + jsr MOVSTR1 ; MOVE 2ND STRING + lda STRNG1 + ldy STRNG1+1 + jsr FRETMP + jsr PUTNEW ; SET UP DESCRIPTOR + jmp FRMEVL2 ; FINISH EXPRESSION + + +; ---------------------------------------------------------------------------- +; GET STRING DESCRIPTOR POINTED AT BY (STRNG1) +; AND MOVE DESCRIBED STRING TO (FRESPC) +; ---------------------------------------------------------------------------- +MOVINS: ldy #0 + lda (STRNG1),y + pha ; LENGTH + iny + lda (STRNG1),y + tax ; PUT STRING POINTER IN X,Y + iny + lda (STRNG1),y + tay + pla ; RETRIEVE LENGTH + + +; ---------------------------------------------------------------------------- +; MOVE STRING AT (Y,X) WITH LENGTH (A) +; TO DESTINATION WHOSE ADDRESS IS IN FRESPC,FRESPC+1 +; ---------------------------------------------------------------------------- +MOVSTR: stx INDEX ; PUT POINTER IN INDEX + sty INDEX+1 +MOVSTR1: + tay ; LENGTH TO Y-REG + beq @2 ; IF LENGTH IS ZERO, FINISHED + pha ; SAVE LENGTH ON STACK +@1: dey ; MOVE BYTES FROM (INDEX) TO (FRESPC) + lda (INDEX),y + sta (FRESPC),y + tya ; TEST IF ANY LEFT TO MOVE + bne @1 ; YES, KEEP MOVING + pla ; NO, FINISHED. GET LENGTH +@2: clc ; AND ADD TO FRESPC, SO + adc FRESPC ; FRESPC POINTS TO NEXT HIGHER + sta FRESPC ; BYTE. (USED BY CONCATENATION) + bcc @4 + inc FRESPC+1 +@4: rts + + +; ---------------------------------------------------------------------------- +; IF (FAC) IS A TEMPORARY STRING, RELEASE DESCRIPTOR +; ---------------------------------------------------------------------------- +FRESTR: jsr CHKSTR ; LAST RESULT A STRING? + + +; ---------------------------------------------------------------------------- +; IF STRING DESCRIPTOR POINTED TO BY FAC+3,4 IS +; A TEMPORARY STRING, RELEASE IT. +; ---------------------------------------------------------------------------- +FREFAC: lda FAC+3 ; GET DESCRIPTOR POINTER + ldy FAC+4 + + +; ---------------------------------------------------------------------------- +; IF STRING DESCRIPTOR WHOSE ADDRESS IS IN Y,A IS +; A TEMPORARY STRING, RELEASE IT. +; ---------------------------------------------------------------------------- +FRETMP: sta INDEX ; SAVE THE ADDRESS OF THE DESCRIPTOR + sty INDEX+1 + jsr FRETMS ; FREE DESCRIPTOR IF IT IS TEMPORARY + php ; REMEMBER IF TEMP + ldy #0 ; POINT AT LENGTH OF STRING + lda (INDEX),y + pha ; SAVE LENGTH ON STACK + iny + lda (INDEX),y + tax ; GET ADDRESS OF STRING IN Y,X + iny + lda (INDEX),y + tay + pla ; LENGTH IN A + plp ; RETRIEVE STATUS, Z=1 IF TEMP + bne @2 ; NOT A TEMPORARY STRING + cpy FRETOP+1 ; IS IT THE LOWEST STRING? + bne @2 ; NO + cpx FRETOP + bne @2 ; NO + pha ; YES, PUSH LENGTH AGAIN + clc ; RECOVER THE SPACE USED BY + adc FRETOP ; THE STRING + sta FRETOP + bcc @1 + inc FRETOP+1 +@1: pla ; RETRIEVE LENGTH AGAIN +@2: stx INDEX ; ADDRESS OF STRING IN Y,X + sty INDEX+1 ; LENGTH OF STRING IN A-REG + rts + + +; ---------------------------------------------------------------------------- +; RELEASE TEMPORARY DESCRIPTOR IF Y,A = LASTPT +; ---------------------------------------------------------------------------- +FRETMS: cpy LASTPT+1 ; COMPARE Y,A TO LATEST TEMP + bne @1 ; NOT SAME ONE, CANNOT RELEASE + cmp LASTPT + bne @1 ; NOT SAME ONE, CANNOT RELEASE + sta TEMPPT ; UPDATE TEMPT FOR NEXT TEMP + sbc #3 ; BACK OFF LASTPT + sta LASTPT + ldy #0 ; NOW Y,A POINTS TO TOP TEMP +@1: rts ; Z=0 IF NOT TEMP, Z=1 IF TEMP + + +; ---------------------------------------------------------------------------- +; "CHR$" FUNCTION +; ---------------------------------------------------------------------------- +CHRSTR: jsr CONINT ; CONVERT ARGUMENT TO BYTE IN X + txa + pha ; SAVE IT + lda #1 ; GET SPACE FOR STRING OF LENGTH 1 + jsr STRSPA + pla ; RECALL THE CHARACTER + ldy #0 ; PUT IN STRING + sta (FAC+1),y + pla ; POP RETURN ADDRESS + pla + jmp PUTNEW ; MAKE IT A TEMPORARY STRING + + +; ---------------------------------------------------------------------------- +; "LEFT$" FUNCTION +; ---------------------------------------------------------------------------- +LEFTSTR: + jsr SUBSTRING_SETUP + cmp (DSCPTR),y ; COMPARE 1ST PARAMETER TO LENGTH + tya ; Y=A=0 +SUBSTRING1: + bcc @1 ; 1ST PARAMETER SMALLER, USE IT + lda (DSCPTR),y ; 1ST IS LONGER, USE STRING LENGTH + tax ; IN X-REG + tya ; Y=A=0 AGAIN +@1: pha ; PUSH LEFT END OF SUBSTRING +SUBSTRING2: + txa +SUBSTRING3: + pha ; PUSH LENGTH OF SUBSTRING + jsr STRSPA ; MAKE ROOM FOR STRING OF (A) BYTES + lda DSCPTR ; RELEASE PARAMETER STRING IF TEMP + ldy DSCPTR+1 + jsr FRETMP + pla ; GET LENGTH OF SUBSTRING + tay ; IN Y-REG + pla ; GET LEFT END OF SUBSTRING + clc ; ADD TO POINTER TO STRING + adc INDEX + sta INDEX + bcc @1 + inc INDEX+1 +@1: tya ; LENGTH + jsr MOVSTR1 ; COPY STRING INTO SPACE + jmp PUTNEW ; ADD TO TEMPS + + +; ---------------------------------------------------------------------------- +; "RIGHT$" FUNCTION +; ---------------------------------------------------------------------------- +RIGHTSTR: + jsr SUBSTRING_SETUP + clc ; COMPUTE LENGTH-WIDTH OF SUBSTRING + sbc (DSCPTR),y ; TO GET STARTING POINT IN STRING + eor #$FF + jmp SUBSTRING1 ; JOIN LEFT$ + + +; ---------------------------------------------------------------------------- +; "MID$" FUNCTION +; ---------------------------------------------------------------------------- +MIDSTR: lda #$FF ; FLAG WHETHER 2ND PARAMETER + sta FAC+4 + jsr CHRGOT ; SEE IF ")" YET + cmp #')' + beq @1 ; YES, NO 2ND PARAMETER + jsr CHKCOM ; NO, MUST HAVE COMMA + jsr GETBYT ; GET 2ND PARAM IN X-REG +@1: jsr SUBSTRING_SETUP + dex ; 1ST PARAMETER - 1 + txa + pha + clc + ldx #0 + sbc (DSCPTR),y + bcs SUBSTRING2 + eor #$FF + cmp FAC+4 ; USE SMALLER OF TWO + bcc SUBSTRING3 + lda FAC+4 + bcs SUBSTRING3 ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; COMMON SETUP ROUTINE FOR LEFT$, RIGHT$, MID$: +; REQUIRE ")"; POP RETURN ADRS, GET DESCRIPTOR +; ADDRESS, GET 1ST PARAMETER OF COMMAND +; ---------------------------------------------------------------------------- +SUBSTRING_SETUP: + jsr CHKCLS ; REQUIRE ")" + pla ; SAVE RETURN ADDRESS + tay ; IN Y-REG AND LENGTH + pla + sta LENGTH + pla ; POP PREVIOUS RETURN ADDRESS + pla ; (FROM GOROUT). + pla ; RETRIEVE 1ST PARAMETER + tax + pla ; GET ADDRESS OF STRING DESCRIPTOR + sta DSCPTR + pla + sta DSCPTR+1 + lda LENGTH ; RESTORE RETURN ADDRESS + pha + tya + pha + ldy #0 + txa ; GET 1ST PARAMETER IN A-REG + beq GOIQ ; ERROR IF 0 + rts + + +; ---------------------------------------------------------------------------- +; "LEN" FUNCTION +; ---------------------------------------------------------------------------- +LEN: jsr GETSTR ; GET LENTGH IN Y-REG, MAKE FAC NUMERIC + jmp SNGFLT ; FLOAT Y-REG INTO FAC + + +; ---------------------------------------------------------------------------- +; IF LAST RESULT IS A TEMPORARY STRING, FREE IT +; MAKE VALTYP NUMERIC, RETURN LENGTH IN Y-REG +; ---------------------------------------------------------------------------- +GETSTR: jsr FRESTR ; IF LAST RESULT IS A STRING, FREE IT + ldx #0 ; MAKE VALTYP NUMERIC + stx VALTYP + tay ; LENGTH OF STRING TO Y-REG + rts + + +; ---------------------------------------------------------------------------- +; "ASC" FUNCTION +; ---------------------------------------------------------------------------- +ASC: jsr GETSTR ; GET STRING, GET LENGTH IN Y-REG + beq GOIQ ; ERROR IF LENGTH 0 + ldy #0 + lda (INDEX),y ; GET 1ST CHAR OF STRING + tay + jmp SNGFLT ; FLOAT Y-REG INTO FAC +; ---------------------------------------------------------------------------- +GOIQ: jmp IQERR ; ILLEGAL QUANTITY ERROR + + +; ---------------------------------------------------------------------------- +; SCAN TO NEXT CHARACTER AND CONVERT EXPRESSION +; TO SINGLE BYTE IN X-REG +; ---------------------------------------------------------------------------- +GTBYTC: jsr CHRGET + + +; ---------------------------------------------------------------------------- +; EVALUATE EXPRESSION AT TXTPTR, AND +; CONVERT IT TO SINGLE BYTE IN X-REG +; ---------------------------------------------------------------------------- +GETBYT: jsr FRMNUM + + +; ---------------------------------------------------------------------------- +; CONVERT (FAC) TO SINGLE BYTE INTEGER IN X-REG +; ---------------------------------------------------------------------------- +CONINT: jsr MKINT ; CONVERT IF IN RANGE -32767 TO +32767 + ldx FAC+3 ; HI-BYTE MUST BE ZERO + bne GOIQ ; VALUE > 255, ERROR + ldx FAC+4 ; VALUE IN X-REG + jmp CHRGOT ; GET NEXT CHAR IN A-REG + + +; ---------------------------------------------------------------------------- +; "VAL" FUNCTION +; ---------------------------------------------------------------------------- +VAL: jsr GETSTR ; GET POINTER TO STRING IN INDEX + bne @1 ; LENGTH NON-ZERO + jmp ZERO_FAC ; RETURN 0 IF LENGTH=0 +@1: ldx TXTPTR ; SAVE CURRENT TXTPTR + ldy TXTPTR+1 + stx STRNG2 + sty STRNG2+1 + ldx INDEX + stx TXTPTR ; POINT TXTPTR TO START OF STRING + clc + adc INDEX ; ADD LENGTH + sta DEST ; POINT DEST TO END OF STRING + 1 + ldx INDEX+1 + stx TXTPTR+1 + bcc @2 + inx +@2: stx DEST+1 + ldy #0 ; SAVE BYTE THAT FOLLOWS STRING + lda (DEST),y ; ON STACK + pha + lda #0 ; AND STORE $00 IN ITS PLACE + sta (DEST),y + jsr CHRGOT ; PRIME THE PUMP + jsr FIN ; EVALUATE STRING + pla ; GET BYTE THAT SHOULD FOLLOW STRING + ldy #0 ; AND PUT IT BACK + sta (DEST),y + + +; ---------------------------------------------------------------------------- +; COPY STRNG2 INTO TXTPTR +; ---------------------------------------------------------------------------- +POINT: ldx STRNG2 + ldy STRNG2+1 + stx TXTPTR + sty TXTPTR+1 + rts + + +; ---------------------------------------------------------------------------- +; EVALUATE "EXP1,EXP2" +; +; CONVERT EXP1 TO 16-BIT NUMBER IN LINNUM +; CONVERT EXP2 TO 8-BIT NUMBER IN X-REG +; ---------------------------------------------------------------------------- +GTNUM: jsr FRMNUM + jsr GETADR + + +; ---------------------------------------------------------------------------- +; EVALUATE ",EXPRESSION" +; CONVERT EXPRESSION TO SINGLE BYTE IN X-REG +; ---------------------------------------------------------------------------- +COMBYTE: + jsr CHKCOM ; MUST HAVE COMMA FIRST + jmp GETBYT ; CONVERT EXPRESSION TO BYTE IN X-REG + + +; ---------------------------------------------------------------------------- +; CONVERT (FAC) TO A 16-BIT VALUE IN LINNUM +; ---------------------------------------------------------------------------- +GETADR: lda FAC ; FAC < 2^16? + cmp #$91 + bcs GOIQ ; NO, ILLEGAL QUANTITY + jsr QINT ; CONVERT TO INTEGER + lda FAC+3 ; COPY IT INTO LINNUM + ldy FAC+4 + sty LINNUM ; TO LINNUM + sta LINNUM+1 + rts + + +; ---------------------------------------------------------------------------- +; "PEEK" FUNCTION +; ---------------------------------------------------------------------------- +PEEK: lda LINNUM ; SAVE (LINNUM) ON STACK DURING PEEK + pha + lda LINNUM+1 + pha + jsr GETADR ; GET ADDRESS PEEKING AT + ldy #0 + lda (LINNUM),y ; TAKE A QUICK LOOK + tay ; VALUE IN Y-REG + pla ; RESTORE LINNUM FROM STACK + sta LINNUM+1 + pla + sta LINNUM + jmp SNGFLT ; FLOAT Y-REG INTO FAC + + +; ---------------------------------------------------------------------------- +; "POKE" STATEMENT +; ---------------------------------------------------------------------------- +POKE: jsr GTNUM ; GET THE ADDRESS AND VALUE + txa ; VALUE IN A, + ldy #0 + sta (LINNUM),y ; STORE IT AWAY, +RTS10: rts ; AND THAT'S ALL FOR TODAY + + +; ---------------------------------------------------------------------------- +; ADD 0.5 TO FAC +; ---------------------------------------------------------------------------- +FADDH: lda # FAC + ldy #>CON_HALF + jmp FADD + + +; ---------------------------------------------------------------------------- +; FAC = (Y,A) - FAC +; ---------------------------------------------------------------------------- +FSUB: jsr LOAD_ARG_FROM_YA + + +; ---------------------------------------------------------------------------- +; FAC = ARG - FAC +; ---------------------------------------------------------------------------- +FSUBT: lda FACSIGN ; COMPLEMENT FAC AND ADD + eor #$FF + sta FACSIGN + eor ARGSIGN ; FIX SGNCPR TOO + sta SGNCPR + lda FAC ; MAKE STATUS SHOW FAC EXPONENT + jmp FADDT ; JOIN FADD + + +; ---------------------------------------------------------------------------- +; SHIFT SMALLER ARGUMENT MORE THAN 7 BITS +; ---------------------------------------------------------------------------- +FADD1: jsr SHIFT_RIGHT ; ALIGN RADIX BY SHIFTING + bcc FADD3 ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; FAC = (Y,A) + FAC +; ---------------------------------------------------------------------------- +FADD: jsr LOAD_ARG_FROM_YA + + +; ---------------------------------------------------------------------------- +; FAC = ARG + FAC +; ---------------------------------------------------------------------------- +FADDT: bne @1 ; FAC IS NON-ZERO + jmp COPY_ARG_TO_FAC ; FAC = 0 + ARG +@1: ldx FACEXTENSION + stx ARGEXTENSION + ldx #ARG ; SET UP TO SHIFT ARG + lda ARG ; EXPONENT + +; ---------------------------------------------------------------------------- +FADD2: tay + beq RTS10 ; IF ARG=0, WE ARE FINISHED + sec + sbc FAC ; GET DIFFNCE OF EXP + beq FADD3 ; GO ADD IF SAME EXP + bcc @1 ; ARG HAS SMALLER EXPONENT + sty FAC ; EXP HAS SMALLER EXPONENT + ldy ARGSIGN + sty FACSIGN + eor #$FF ; COMPLEMENT SHIFT COUNT + adc #0 ; CARRY WAS SET + ldy #0 + sty ARGEXTENSION + ldx #FAC ; SET UP TO SHIFT FAC + bne @2 ; ...ALWAYS +@1: ldy #0 + sty FACEXTENSION +@2: cmp #$F9 ; SHIFT MORE THAN 7 BITS? + bmi FADD1 ; YES + tay ; INDEX TO # OF SHIFTS + lda FACEXTENSION + lsr 1,x ; START SHIFTING... + jsr SHIFT_RIGHT4 ; ...COMPLETE SHIFTING +FADD3: bit SGNCPR ; DO FAC AND ARG HAVE SAME SIGNS? + bpl FADD4 ; YES, ADD THE MANTISSAS + ldy #FAC ; NO, SUBTRACT SMALLER FROM LARGER + cpx #ARG ; WHICH WAS ADJUSTED? + beq @1 ; IF ARG, DO FAC-ARG + ldy #ARG ; IF FAC, DO ARG-FAC +@1: sec ; SUBTRACT SMALLER FROM LARGER (WE HOPE) + eor #$FF ; (IF EXPONENTS WERE EQUAL, WE MIGHT BE + adc ARGEXTENSION ; SUBTRACTING LARGER FROM SMALLER) + sta FACEXTENSION + lda 4,y + sbc 4,x + sta FAC+4 + lda 3,y + sbc 3,x + sta FAC+3 + lda 2,y + sbc 2,x + sta FAC+2 + lda 1,y + sbc 1,x + sta FAC+1 + + +; ---------------------------------------------------------------------------- +; NORMALIZE VALUE IN FAC +; ---------------------------------------------------------------------------- +NORMALIZE_FAC1: + bcs NORMALIZE_FAC2 + jsr COMPLEMENT_FAC +; ---------------------------------------------------------------------------- +NORMALIZE_FAC2: + ldy #0 ; SHIFT UP SIGNIF DIGIT + tya ; START A=0, COUNT SHIFTS IN A-REG + clc +@1: ldx FAC+1 ; LOOK AT MOST SIGNIFICANT BYTE + bne NORMALIZE_FAC4 ; SOME 1-BITS HERE + ldx FAC+2 ; HI-BYTE OF MANTISSA STILL ZERO, + stx FAC+1 ; SO DO A FAST 8-BIT SHUFFLE + ldx FAC+3 + stx FAC+2 + ldx FAC+4 + stx FAC+3 + ldx FACEXTENSION + stx FAC+4 + sty FACEXTENSION ; ZERO EXTENSION BYTE + adc #8 ; BUMP SHIFT COUNT + cmp #32 ; DONE 4 TIMES YET? + bne @1 ; NO, STILL MIGHT BE SOME 1'S (YES, VALUE OF FAC IS ZERO) + + +; ---------------------------------------------------------------------------- +; SET FAC = 0 +; (ONLY NECESSARY TO ZERO EXPONENT AND SIGN CELLS) +; ---------------------------------------------------------------------------- +ZERO_FAC: + lda #0 +; ---------------------------------------------------------------------------- +STA_IN_FAC_SIGN_AND_EXP: + sta FAC +; ---------------------------------------------------------------------------- +STA_IN_FAC_SIGN: + sta FACSIGN + rts + + +; ---------------------------------------------------------------------------- +; ADD MANTISSAS OF FAC AND ARG INTO FAC +; ---------------------------------------------------------------------------- +FADD4: adc ARGEXTENSION + sta FACEXTENSION + lda FAC+4 + adc ARG+4 + sta FAC+4 + lda FAC+3 + adc ARG+3 + sta FAC+3 + lda FAC+2 + adc ARG+2 + sta FAC+2 + lda FAC+1 + adc ARG+1 + sta FAC+1 + jmp NORMALIZE_FAC5 + + +; ---------------------------------------------------------------------------- +; FINISH NORMALIZING FAC +; ---------------------------------------------------------------------------- +NORMALIZE_FAC3: + adc #1 ; COUNT BITS SHIFTED + asl FACEXTENSION + rol FAC+4 + rol FAC+3 + rol FAC+2 + rol FAC+1 +; ---------------------------------------------------------------------------- +NORMALIZE_FAC4: + bpl NORMALIZE_FAC3 ; UNTIL TOP BIT = 1 + sec + sbc FAC ; ADJUST EXPONENT BY BITS SHIFTED + bcs ZERO_FAC ; UNDERFLOW, RETURN ZERO + eor #$FF + adc #1 ; 2'S COMPLEMENT + sta FAC ; CARRY=0 NOW +; ---------------------------------------------------------------------------- +NORMALIZE_FAC5: + bcc RTS11 ; UNLESS MANTISSA CARRIED +; ---------------------------------------------------------------------------- +NORMALIZE_FAC6: + inc FAC ; MANTISSA CARRIED, SO SHIFT RIGHT + beq OVERFLOW ; OVERFLOW IF EXPONENT TOO BIG + ror FAC+1 + ror FAC+2 + ror FAC+3 + ror FAC+4 + ror FACEXTENSION +RTS11: rts + + +; ---------------------------------------------------------------------------- +; 2'S COMPLEMENT OF FAC +; ---------------------------------------------------------------------------- +COMPLEMENT_FAC: + lda FACSIGN + eor #$FF + sta FACSIGN + + +; ---------------------------------------------------------------------------- +; 2'S COMPLEMENT OF FAC MANTISSA ONLY +; ---------------------------------------------------------------------------- +COMPLEMENT_FAC_MANTISSA: + lda FAC+1 + eor #$FF + sta FAC+1 + lda FAC+2 + eor #$FF + sta FAC+2 + lda FAC+3 + eor #$FF + sta FAC+3 + lda FAC+4 + eor #$FF + sta FAC+4 + lda FACEXTENSION + eor #$FF + sta FACEXTENSION + inc FACEXTENSION ; START INCREMENTING MANTISSA + bne RTS12 + + +; ---------------------------------------------------------------------------- +; INCREMENT FAC MANTISSA +; ---------------------------------------------------------------------------- +INCREMENT_FAC_MANTISSA: + inc FAC+4 ; ADD CARRY FROM EXTRA + bne RTS12 + inc FAC+3 + bne RTS12 + inc FAC+2 + bne RTS12 + inc FAC+1 +RTS12: rts +; ---------------------------------------------------------------------------- +OVERFLOW: + ldx #ERR_OVERFLOW + jmp ERROR + + +; ---------------------------------------------------------------------------- +; SHIFT 1,X THRU 5,X RIGHT +; (A) = NEGATIVE OF SHIFT COUNT +; (X) = POINTER TO BYTES TO BE SHIFTED +; +; RETURN WITH (Y)=0, CARRY=0, EXTENSION BITS IN A-REG +; ---------------------------------------------------------------------------- +SHIFT_RIGHT1: + ldx #RESULT-1 ; SHIFT RESULT RIGHT +SHIFT_RIGHT2: + ldy 4,x ; SHIFT 8 BITS RIGHT + sty FACEXTENSION + ldy 3,x + sty 4,x + ldy 2,x + sty 3,x + ldy 1,x + sty 2,x + ldy SHIFTSIGNEXT ; $00 IF +, $FF IF - + sty 1,x + + +; ---------------------------------------------------------------------------- +; MAIN ENTRY TO RIGHT SHIFT SUBROUTINE +; ---------------------------------------------------------------------------- +SHIFT_RIGHT: + adc #8 + bmi SHIFT_RIGHT2 ; STILL MORE THAN 8 BITS TO GO + beq SHIFT_RIGHT2 ; EXACTLY 8 MORE BITS TO GO + sbc #8 ; UNDO ADC ABOVE + tay ; REMAINING SHIFT COUNT + lda FACEXTENSION + bcs SHIFT_RIGHT5 ; FINISHED SHIFTING +SHIFT_RIGHT3: + asl 1,x ; SIGN -> CARRY (SIGN EXTENSION) + bcc @1 ; SIGN + + inc 1,x ; PUT SIGN IN LSB +@1: ror 1,x ; RESTORE VALUE, SIGN STILL IN CARRY + ror 1,x ; START RIGHT SHIFT, INSERTING SIGN + + +; ---------------------------------------------------------------------------- +; ENTER HERE FOR SHORT SHIFTS WITH NO SIGN EXTENSION +; ---------------------------------------------------------------------------- +SHIFT_RIGHT4: + ror 2,x + ror 3,x + ror 4,x + ror a ; EXTENSION + iny ; COUNT THE SHIFT + bne SHIFT_RIGHT3 +SHIFT_RIGHT5: + clc ; RETURN WITH CARRY CLEAR + rts + + +; ---------------------------------------------------------------------------- +CON_ONE: + .byte $81,$00,$00,$00,$00 +; ---------------------------------------------------------------------------- +POLY_LOG: + .byte $03 ; # OF COEFFICIENTS - 1 + .byte $7F,$5E,$56,$CB,$79 ; * X^7 + + .byte $80,$13,$9B,$0B,$64 ; * X^5 + + .byte $80,$76,$38,$93,$16 ; * X^3 + + .byte $82,$38,$AA,$3B,$20 ; * X +; ---------------------------------------------------------------------------- +CON_SQR_HALF: + .byte $80,$35,$04,$F3,$34 +CON_SQR_TWO: + .byte $81,$35,$04,$F3,$34 +CON_NEG_HALF: + .byte $80,$80,$00,$00,$00 +CON_LOG_TWO: + .byte $80,$31,$72,$17,$F8 + + +; ---------------------------------------------------------------------------- +; "LOG" FUNCTION +; ---------------------------------------------------------------------------- +LOG: jsr SIGN ; GET -1,0,+1 IN A-REG FOR FAC + beq GIQ ; LOG (0) IS ILLEGAL + bpl LOG2 ; >0 IS OK +GIQ: jmp IQERR ; <= 0 IS NO GOOD +LOG2: lda FAC ; FIRST GET LOG BASE 2 + sbc #$7F ; SAVE UNBIASED EXPONENT + pha + lda #$80 ; NORMALIZE BETWEEN .5 AND 1 + sta FAC + lda #CON_SQR_HALF + jsr FADD ; COMPUTE VIA SERIES OF ODD + lda #CON_SQR_TWO ; (SQR(2)X-1)/(SQR(2)X+1) + jsr FDIV + lda #CON_ONE + jsr FSUB + lda #POLY_LOG + jsr POLYNOMIAL_ODD + lda #CON_NEG_HALF + jsr FADD + pla + jsr ADDACC ; ADD ORIGINAL EXPONENT + lda #CON_LOG_TWO ; NATURAL LOG OF X + + +; ---------------------------------------------------------------------------- +; FAC = (Y,A) * FAC +; ---------------------------------------------------------------------------- +FMULT: jsr LOAD_ARG_FROM_YA + + +; ---------------------------------------------------------------------------- +; FAC = ARG * FAC +; ---------------------------------------------------------------------------- +FMULTT: bne @1 ; FAC .NE. ZERO + rts ; FAC = 0 * ARG = 0 +@1: jsr ADD_EXPONENTS + lda #0 + sta RESULT ; INIT PRODUCT = 0 + sta RESULT+1 + sta RESULT+2 + sta RESULT+3 + lda FACEXTENSION + jsr MULTIPLY1 + lda FAC+4 + jsr MULTIPLY1 + lda FAC+3 + jsr MULTIPLY1 + lda FAC+2 + jsr MULTIPLY1 + lda FAC+1 + jsr MULTIPLY2 + jmp COPY_RESULT_INTO_FAC + + +; ---------------------------------------------------------------------------- +; MULTIPLY ARG BY (A) INTO RESULT +; ---------------------------------------------------------------------------- +MULTIPLY1: + bne MULTIPLY2 ; THIS BYTE NON-ZERO + jmp SHIFT_RIGHT1 ; (A)=0, JUST SHIFT ARG RIGHT 8 +; ---------------------------------------------------------------------------- +MULTIPLY2: + lsr a ; SHIFT BIT INTO CARRY + ora #$80 ; SUPPLY SENTINEL BIT +@1: tay ; REMAINING MULTIPLIER TO Y + bcc @2 ; THIS MULTIPLIER BIT = 0 + clc ; = 1, SO ADD ARG TO RESULT + lda RESULT+3 + adc ARG+4 + sta RESULT+3 + lda RESULT+2 + adc ARG+3 + sta RESULT+2 + lda RESULT+1 + adc ARG+2 + sta RESULT+1 + lda RESULT + adc ARG+1 + sta RESULT +@2: ror RESULT ; SHIFT RESULT RIGHT 1 + ror RESULT+1 + ror RESULT+2 + ror RESULT+3 + ror FACEXTENSION + tya ; REMAINING MULTIPLIER + lsr a ; LSB INTO CARRY + bne @1 ; IF SENTINEL STILL HERE, MULTIPLY + rts ; 8 X 32 COMPLETED + + +; ---------------------------------------------------------------------------- +; UNPACK NUMBER AT (Y,A) INTO ARG +; ---------------------------------------------------------------------------- +LOAD_ARG_FROM_YA: + sta INDEX ; USE INDEX FOR PNTR + sty INDEX+1 + ldy #4 ; FIVE BYTES TO MOVE + lda (INDEX),y + sta ARG+4 + dey + lda (INDEX),y + sta ARG+3 + dey + lda (INDEX),y + sta ARG+2 + dey + lda (INDEX),y + sta ARGSIGN + eor FACSIGN ; SET COMBINED SIGN FOR MULT/DIV + sta SGNCPR + lda ARGSIGN ; TURN ON NORMALIZED INVISIBLE BIT + ora #$80 ; TO COMPLETE MANTISSA + sta ARG+1 + dey + lda (INDEX),y + sta ARG ; EXPONENT + lda FAC ; SET STATUS BITS ON FAC EXPONENT + rts + + +; ---------------------------------------------------------------------------- +; ADD EXPONENTS OF ARG AND FAC +; (CALLED BY FMULT AND FDIV) +; +; ALSO CHECK FOR OVERFLOW, AND SET RESULT SIGN +; ---------------------------------------------------------------------------- +ADD_EXPONENTS: + lda ARG +; ---------------------------------------------------------------------------- +ADD_EXPONENTS1: + beq ZERO ; IF ARG=0, RESULT IS ZERO + clc + adc FAC + bcc @1 ; IN RANGE + bmi JOV ; OVERFLOW + clc + .byte $2C ; TRICK TO SKIP +@1: bpl ZERO ; OVERFLOW + adc #$80 ; RE-BIAS + sta FAC ; RESULT + beq @3 +@2: lda SGNCPR ; SET SIGN OF RESULT +@3: sta FACSIGN + rts + + +; ---------------------------------------------------------------------------- +; IF (FAC) IS POSITIVE, GIVE "OVERFLOW" ERROR +; IF (FAC) IS NEGATIVE, SET FAC=0, POP ONE RETURN, AND RTS +; CALLED FROM "EXP" FUNCTION +; ---------------------------------------------------------------------------- +OUTOFRNG: + lda FACSIGN + eor #$FF + bmi JOV ; ERROR IF POSITIVE # + + +; ---------------------------------------------------------------------------- +; POP RETURN ADDRESS AND SET FAC=0 +; ---------------------------------------------------------------------------- +ZERO: pla + pla + jmp ZERO_FAC +; ---------------------------------------------------------------------------- +JOV: jmp OVERFLOW + + +; ---------------------------------------------------------------------------- +; MULTIPLY FAC BY 10 +; ---------------------------------------------------------------------------- +MUL10: jsr COPY_FAC_TO_ARG_ROUNDED + tax ; TEXT FAC EXPONENT + beq @1 ; FINISHED IF FAC=0 + clc + adc #2 ; ADD 2 TO EXPONENT GIVES (FAC)*4 + bcs JOV ; OVERFLOW + ldx #0 + stx SGNCPR + jsr FADD2 ; MAKES (FAC)*5 + inc FAC ; *2, MAKES (FAC)*10 + beq JOV ; OVERFLOW +@1: rts + +; ---------------------------------------------------------------------------- +CONTEN: .byte $84,$20,$00,$00,$00 + + +; ---------------------------------------------------------------------------- +; DIVIDE FAC BY 10 +; ---------------------------------------------------------------------------- +DIV10: jsr COPY_FAC_TO_ARG_ROUNDED + lda #CONTEN ; 10 IN FAC + ldx #0 + + +; ---------------------------------------------------------------------------- +; FAC = ARG / (Y,A) +; ---------------------------------------------------------------------------- +DIV: stx SGNCPR + jsr LOAD_FAC_FROM_YA + jmp FDIVT ; DIVIDE ARG BY FAC + + +; ---------------------------------------------------------------------------- +; FAC = (Y,A) / FAC +; ---------------------------------------------------------------------------- +FDIV: jsr LOAD_ARG_FROM_YA + + +; ---------------------------------------------------------------------------- +; FAC = ARG / FAC +; ---------------------------------------------------------------------------- +FDIVT: beq @8 ; FAC = 0, DIVIDE BY ZERO ERROR + jsr ROUND_FAC + lda #0 ; NEGATE FAC EXPONENT, SO + sec ; ADD.EXPONENTS FORMS DIFFERENCE + sbc FAC + sta FAC + jsr ADD_EXPONENTS + inc FAC + beq JOV ; OVERFLOW + ldx #-4 ; INDEX FOR RESULT + lda #1 ; SENTINEL +@1: ldy ARG+1 ; SEE IF FAC CAN BE SUBTRACTED + cpy FAC+1 + bne @2 + ldy ARG+2 + cpy FAC+2 + bne @2 + ldy ARG+3 + cpy FAC+3 + bne @2 + ldy ARG+4 + cpy FAC+4 +@2: php ; SAVE THE ANSWER, AND ALSO ROLL THE + rol a ; BIT INTO THE QUOTIENT, SENTINEL OUT + bcc @3 ; NO SENTINEL, STILL NOT 8 TRIPS + inx ; 8 TRIPS, STORE BYTE OF QUOTIENT + sta RESULT+3,x + beq @6 ; 32-BITS COMPLETED + bpl @7 ; FINAL EXIT WHEN X=1 + lda #1 ; RE-START SENTINEL +@3: plp ; GET ANSWER, CAN FAC BE SUBTRACTED? + bcs @5 ; YES, DO IT +@4: asl ARG+4 ; NO, SHIFT ARG LEFT + rol ARG+3 + rol ARG+2 + rol ARG+1 + bcs @2 ; ANOTHER TRIP + bmi @1 ; HAVE TO COMPARE FIRST + bpl @2 ; ...ALWAYS +@5: tay ; SAVE QUOTIENT/SENTINEL BYTE + lda ARG+4 ; SUBTRACT FAC FROM ARG ONCE + sbc FAC+4 + sta ARG+4 + lda ARG+3 + sbc FAC+3 + sta ARG+3 + lda ARG+2 + sbc FAC+2 + sta ARG+2 + lda ARG+1 + sbc FAC+1 + sta ARG+1 + tya ; RESTORE QUOTIENT/SENTINEL BYTE + jmp @4 ; GO TO SHIFT ARG AND CONTINUE +; ---------------------------------------------------------------------------- +@6: lda #$40 ; DO A FEW EXTENSION BITS + bne @3 ; ...ALWAYS +; ---------------------------------------------------------------------------- +@7: asl a ; LEFT JUSTIFY THE EXTENSION BITS WE DID + asl a + asl a + asl a + asl a + asl a + sta FACEXTENSION + plp + jmp COPY_RESULT_INTO_FAC +; ---------------------------------------------------------------------------- +@8: ldx #ERR_ZERODIV + jmp ERROR + + +; ---------------------------------------------------------------------------- +; COPY RESULT INTO FAC MANTISSA, AND NORMALIZE +; ---------------------------------------------------------------------------- +COPY_RESULT_INTO_FAC: + lda RESULT + sta FAC+1 + lda RESULT+1 + sta FAC+2 + lda RESULT+2 + sta FAC+3 + lda RESULT+3 + sta FAC+4 + jmp NORMALIZE_FAC2 + + +; ---------------------------------------------------------------------------- +; UNPACK (Y,A) INTO FAC +; ---------------------------------------------------------------------------- +LOAD_FAC_FROM_YA: + sta INDEX ; USE INDEX FOR PNTR + sty INDEX+1 + ldy #4 ; PICK UP 5 BYTES + lda (INDEX),y + sta FAC+4 + dey + lda (INDEX),y + sta FAC+3 + dey + lda (INDEX),y + sta FAC+2 + dey + lda (INDEX),y + sta FACSIGN ; FIRST BIT IS SIGN + ora #$80 ; SET NORMALIZED INVISIBLE BIT + sta FAC+1 + dey + lda (INDEX),y + sta FAC ; EXPONENT + sty FACEXTENSION ; Y=0 + rts + + +; ---------------------------------------------------------------------------- +; ROUND FAC, STORE IN TEMP2 +; ---------------------------------------------------------------------------- +STORE_FAC_IN_TEMP2_ROUNDED: + ldx #TEMP2 ; PACK FAC INTO TEMP2 + .byte $2C ; TRICK TO BRANCH + + +; ---------------------------------------------------------------------------- +; ROUND FAC, STORE IN TEMP1 +; ---------------------------------------------------------------------------- +STORE_FAC_IN_TEMP1_ROUNDED: + ldx #TEMP1 ; HI-BYTE OF TEMP1 SAME AS TEMP2 + beq STORE_FAC_AT_YX_ROUNDED ; ...ALWAYS + + +; ---------------------------------------------------------------------------- +; ROUND FAC, AND STORE WHERE FORPNT POINTS +; ---------------------------------------------------------------------------- +SETFOR: ldx FORPNT + ldy FORPNT+1 + + +; ---------------------------------------------------------------------------- +; ROUND FAC, AND STORE AT (Y,X) +; ---------------------------------------------------------------------------- +STORE_FAC_AT_YX_ROUNDED: + jsr ROUND_FAC ; ROUND VALUE IN FAC USING EXTENSION + stx INDEX ; USE INDEX FOR PNTR + sty INDEX+1 + ldy #4 ; STORING 5 PACKED BYTES + lda FAC+4 + sta (INDEX),y + dey + lda FAC+3 + sta (INDEX),y + dey + lda FAC+2 + sta (INDEX),y + dey + lda FACSIGN ; PACK SIGN IN TOP BIT OF MANTISSA + ora #$7F + and FAC+1 + sta (INDEX),y + dey + lda FAC ; EXPONENT + sta (INDEX),y + sty FACEXTENSION ; ZERO THE EXTENSION + rts + + +; ---------------------------------------------------------------------------- +; COPY ARG INTO FAC +; ---------------------------------------------------------------------------- +COPY_ARG_TO_FAC: + lda ARGSIGN ; COPY SIGN +MFA: sta FACSIGN + ldx #5 ; MOVE 5 BYTES +@1: lda ARG-1,x + sta FAC-1,x + dex + bne @1 + stx FACEXTENSION ; ZERO EXTENSION + rts + + +; ---------------------------------------------------------------------------- +; ROUND FAC AND COPY TO ARG +; ---------------------------------------------------------------------------- +COPY_FAC_TO_ARG_ROUNDED: + jsr ROUND_FAC ; ROUND FAC USING EXTENSION +MAF: ldx #6 ; COPY 6 BYTES, INCLUDES SIGN +@1: lda FAC-1,x + sta ARG-1,x + dex + bne @1 + stx FACEXTENSION ; ZERO FAC EXTENSION +RTS14: rts + + +; ---------------------------------------------------------------------------- +; ROUND FAC USING EXTENSION BYTE +; ---------------------------------------------------------------------------- +ROUND_FAC: + lda FAC + beq RTS14 ; FAC = 0, RETURN + asl FACEXTENSION ; IS FAC.EXTENSION >= 128? + bcc RTS14 ; NO, FINISHED + + +; ---------------------------------------------------------------------------- +; INCREMENT MANTISSA AND RE-NORMALIZE IF CARRY +; ---------------------------------------------------------------------------- +INCREMENT_MANTISSA: + jsr INCREMENT_FAC_MANTISSA ; YES, INCREMENT FAC + bne RTS14 ; HIGH BYTE HAS BITS, FINISHED + jmp NORMALIZE_FAC6 ; HI-BYTE=0, SO SHIFT LEFT + + +; ---------------------------------------------------------------------------- +; TEST FAC FOR ZERO AND SIGN +; +; FAC > 0, RETURN +1 +; FAC = 0, RETURN 0 +; FAC < 0, RETURN -1 +; ---------------------------------------------------------------------------- +SIGN: lda FAC ; CHECK SIGN OF FAC AND + beq RTS15 ; RETURN -1,0,1 IN A-REG +; ---------------------------------------------------------------------------- +SIGN1: lda FACSIGN +; ---------------------------------------------------------------------------- +SIGN2: rol a ; MSBIT TO CARRY + lda #$FF ; -1 + bcs RTS15 ; MSBIT = 1 + lda #1 ; +1 +RTS15: rts + + +; ---------------------------------------------------------------------------- +; "SGN" FUNCTION +; ---------------------------------------------------------------------------- +SGN: jsr SIGN ; CONVERT FAC TO -1,0,1 + + +; ---------------------------------------------------------------------------- +; CONVERT (A) INTO FAC, AS SIGNED VALUE -128 TO +127 +; ---------------------------------------------------------------------------- +FLOAT: sta FAC+1 ; PUT IN HIGH BYTE OF MANTISSA + lda #0 ; CLEAR 2ND BYTE OF MANTISSA + sta FAC+2 + ldx #$88 ; USE EXPONENT 2^9 + + +; ---------------------------------------------------------------------------- +; FLOAT UNSIGNED VALUE IN FAC+1,2 +; (X) = EXPONENT +; ---------------------------------------------------------------------------- +FLOAT1: lda FAC+1 ; MSBIT=0, SET CARRY; =1, CLEAR CARRY + eor #$FF + rol a + + +; ---------------------------------------------------------------------------- +; FLOAT UNSIGNED VALUE IN FAC+1,2 +; (X) = EXPONENT +; C=0 TO MAKE VALUE NEGATIVE +; C=1 TO MAKE VALUE POSITIVE +; ---------------------------------------------------------------------------- +FLOAT2: lda #0 ; CLEAR LOWER 16-BITS OF MANTISSA + sta FAC+4 + sta FAC+3 + stx FAC ; STORE EXPONENT + sta FACEXTENSION ; CLEAR EXTENSION + sta FACSIGN ; MAKE SIGN POSITIVE + jmp NORMALIZE_FAC1 ; IF C=0, WILL NEGATE FAC + + +; ---------------------------------------------------------------------------- +; "ABS" FUNCTION +; ---------------------------------------------------------------------------- +ABS: lsr FACSIGN ; CHANGE SIGN TO + + rts + + +; ---------------------------------------------------------------------------- +; COMPARE FAC WITH PACKED # AT (Y,A) +; RETURN A=1,0,-1 AS (Y,A) IS <,=,> FAC +; ---------------------------------------------------------------------------- +FCOMP: sta DEST ; USE DEST FOR PNTR + + +; ---------------------------------------------------------------------------- +; SPECIAL ENTRY FROM "NEXT" PROCESSOR +; "DEST" ALREADY SET UP +; ---------------------------------------------------------------------------- +FCOMP2: sty DEST+1 + ldy #0 ; GET EXPONENT OF COMPARAND + lda (DEST),y + iny ; POINT AT NEXT BYTE + tax ; EXPONENT TO X-REG + beq SIGN ; IF COMPARAND=0, "SIGN" COMPARES FAC + lda (DEST),y ; GET HI-BYTE OF MANTISSA + eor FACSIGN ; COMPARE WITH FAC SIGN + bmi SIGN1 ; DIFFERENT SIGNS, "SIGN" GIVES ANSWER + cpx FAC ; SAME SIGN, SO COMPARE EXPONENTS + bne @1 ; DIFFERENT, SO SUFFICIENT TEST + lda (DEST),y ; SAME EXPONENT, COMPARE MANTISSA + ora #$80 ; SET INVISIBLE NORMALIZED BIT + cmp FAC+1 + bne @1 ; NOT SAME, SO SUFFICIENT + iny ; SAME, COMPARE MORE MANTISSA + lda (DEST),y + cmp FAC+2 + bne @1 ; NOT SAME, SO SUFFICIENT + iny ; SAME, COMPARE MORE MANTISSA + lda (DEST),y + cmp FAC+3 + bne @1 ; NOT SAME, SO SUFFICIENT + iny ; SAME, COMPARE REST OF MANTISSA + lda #$7F ; ARTIFICIAL EXTENSION BYTE FOR COMPARAND + cmp FACEXTENSION + lda (DEST),y + sbc FAC+4 + beq RTS16 ; NUMBERS ARE EQUAL, RETURN (A)=0 +@1: ror ; PUT CARRY INTO SIGN BIT + eor FACSIGN ; TOGGLE WITH SIGN OF FAC +@2: jmp SIGN2 ; CONVERT +1 OR -1 + + +; ---------------------------------------------------------------------------- +; QUICK INTEGER FUNCTION +; +; CONVERTS FP VALUE IN FAC TO INTEGER VALUE +; IN FAC+1...FAC+4, BY SHIFTING RIGHT WITH SIGN +; EXTENSION UNTIL FRACTIONAL BITS ARE OUT. +; +; THIS SUBROUTINE ASSUMES THE EXPONENT < 32. +; ---------------------------------------------------------------------------- +QINT: lda FAC ; LOOK AT FAC EXPONENT + beq QINT3 ; FAC=0, SO FINISHED + sec ; GET -(NUMBER OF FRACTIONAL BITS) + sbc #$A0 ; IN A-REG FOR SHIFT COUNT + bit FACSIGN ; CHECK SIGN OF FAC + bpl @1 ; POSITIVE, CONTINUE + tax ; NEGATIVE, SO COMPLEMENT MANTISSA + lda #$FF ; AND SET SIGN EXTENSION FOR SHIFT + sta SHIFTSIGNEXT + jsr COMPLEMENT_FAC_MANTISSA + txa ; RESTORE BIT COUNT TO A-REG +@1: ldx #FAC ; POINT SHIFT SUBROUTINE AT FAC + cmp #$F9 ; MORE THAN 7 BITS TO SHIFT? + bpl QINT2 ; NO, SHORT SHIFT + jsr SHIFT_RIGHT ; YES, USE GENERAL ROUTINE + sty SHIFTSIGNEXT ; Y=0, CLEAR SIGN EXTENSION +RTS16: rts +; ---------------------------------------------------------------------------- +QINT2: tay ; SAVE SHIFT COUNT + lda FACSIGN ; GET SIGN BIT + and #$80 + lsr FAC+1 ; START RIGHT SHIFT + ora FAC+1 ; AND MERGE WITH SIGN + sta FAC+1 + jsr SHIFT_RIGHT4 ; JUMP INTO MIDDLE OF SHIFTER + sty SHIFTSIGNEXT ; Y=0, CLEAR SIGN EXTENSION + rts + + +; ---------------------------------------------------------------------------- +; "INT" FUNCTION +; +; USES QINT TO CONVERT (FAC) TO INTEGER FORM, +; AND THEN REFLOATS THE INTEGER. +; ---------------------------------------------------------------------------- +INT: lda FAC ; CHECK IF EXPONENT < 32 + cmp #$A0 ; BECAUSE IF > 31 THERE IS NO FRACTION + bcs RTS17 ; NO FRACTION, WE ARE FINISHED + jsr QINT ; USE GENERAL INTEGER CONVERSION + sty FACEXTENSION ; Y=0, CLEAR EXTENSION + lda FACSIGN ; GET SIGN OF VALUE + sty FACSIGN ; Y=0, CLEAR SIGN + eor #$80 ; TOGGLE ACTUAL SIGN + rol a ; AND SAVE IN CARRY + lda #$A0 ; SET EXPONENT TO 32 + sta FAC ; BECAUSE 4-BYTE INTEGER NOW + lda FAC+4 ; SAVE LOW 8-BITS OF INTEGER FORM + sta CHARAC ; FOR EXP AND POWER + jmp NORMALIZE_FAC1 ; NORMALIZE TO FINISH CONVERSION +; ---------------------------------------------------------------------------- +QINT3: sta FAC+1 ; FAC=0, SO CLEAR ALL 4 BYTES FOR + sta FAC+2 ; INTEGER VERSION + sta FAC+3 + sta FAC+4 + tay ; Y=0 TOO +RTS17: rts + + +; ---------------------------------------------------------------------------- +; CONVERT STRING TO FP VALUE IN FAC +; +; STRING POINTED TO BY TXTPTR +; FIRST CHAR ALREADY SCANNED BY CHRGET +; (A) = FIRST CHAR, C=0 IF DIGIT. +; ---------------------------------------------------------------------------- +FIN: ldy #0 ; CLEAR WORKING AREA ($99...$A3) + ldx #10 ; TMPEXP, EXPON, DPFLG, EXPSGN, FAC, SERLEN +@1: sty TMPEXP,x + dex + bpl @1 +; ---------------------------------------------------------------------------- + bcc FIN2 ; FIRST CHAR IS A DIGIT + cmp #'-' ; CHECK FOR LEADING SIGN + bne @2 ; NOT MINUS + stx SERLEN ; MINUS, SET SERLEN = $FF FOR FLAG + beq FIN1 ; ...ALWAYS +@2: cmp #'+' ; MIGHT BE PLUS + bne FIN3 ; NOT PLUS EITHER, CHECK DECIMAL POINT + +; ---------------------------------------------------------------------------- +FIN1: jsr CHRGET ; GET NEXT CHAR OF STRING + +; ---------------------------------------------------------------------------- +FIN2: bcc FIN9 ; INSERT THIS DIGIT + +; ---------------------------------------------------------------------------- +FIN3: cmp #'.' ; CHECK FOR DECIMAL POINT + beq FIN10 ; YES + cmp #'E' ; CHECK FOR EXPONENT PART + bne FIN7 ; NO, END OF NUMBER + jsr CHRGET ; YES, START CONVERTING EXPONENT + bcc FIN5 ; EXPONENT DIGIT + cmp #TOKEN_MINUS ; NEGATIVE EXPONENT? + beq @1 ; YES + cmp #'-' ; MIGHT NOT BE TOKENIZED YET + beq @1 ; YES, IT IS NEGATIVE + cmp #TOKEN_PLUS ; OPTIONAL "+" + beq FIN4 ; YES + cmp #'+' ; MIGHT NOT BE TOKENIZED YET + beq FIN4 ; YES, FOUND "+" + bne FIN6 ; ...ALWAYS, NUMBER COMPLETED +@1: ror EXPSGN ; C=1, SET FLAG NEGATIVE + +; ---------------------------------------------------------------------------- +FIN4: jsr CHRGET ; GET NEXT DIGIT OF EXPONENT + +; ---------------------------------------------------------------------------- +FIN5: bcc GETEXP ; CHAR IS A DIGIT OF EXPONENT + +; ---------------------------------------------------------------------------- +FIN6: bit EXPSGN ; END OF NUMBER, CHECK EXP SIGN + bpl FIN7 ; POSITIVE EXPONENT + lda #0 ; NEGATIVE EXPONENT + sec ; MAKE 2'S COMPLEMENT OF EXPONENT + sbc EXPON + jmp FIN8 +; ---------------------------------------------------------------------------- +; FOUND A DECIMAL POINT +; ---------------------------------------------------------------------------- +FIN10: ror DPFLG ; C=1, SET DPFLG FOR DECIMAL POINT + bit DPFLG ; CHECK IF PREVIOUS DEC. PT. + bvc FIN1 ; NO PREVIOUS DECIMAL POINT +; A SECOND DECIMAL POINT IS TAKEN AS A TERMINATOR +; TO THE NUMERIC STRING. +; "A=11..22" WILL GIVE A SYNTAX ERROR, BECAUSE +; IT IS TWO NUMBERS WITH NO OPERATOR BETWEEN. +; "PRINT 11..22" GIVES NO ERROR, BECAUSE IT IS +; JUST THE CONCATENATION OF TWO NUMBERS. + +; ---------------------------------------------------------------------------- +; NUMBER TERMINATED, ADJUST EXPONENT NOW +; ---------------------------------------------------------------------------- +FIN7: lda EXPON ; E-VALUE +FIN8: sec ; MODIFY WITH COUNT OF DIGITS + sbc TMPEXP ; AFTER THE DECIMAL POINT + sta EXPON ; COMPLETE CURRENT EXPONENT + beq @15 ; NO ADJUST NEEDED IF EXP=0 + bpl @14 ; EXP>0, MULTIPLY BY TEN +@13: jsr DIV10 ; EXP<0, DIVIDE BY TEN + inc EXPON ; UNTIL EXP=0 + bne @13 + beq @15 ; ...ALWAYS, WE ARE FINISHED +@14: jsr MUL10 ; EXP>0, MULTIPLY BKY TEN + dec EXPON ; UNTIL EXP=0 + bne @14 +@15: lda SERLEN ; IS WHOLE NUMBER NEGATIVE? + bmi @16 ; YES + rts ; NO, RETURN, WHOLE JOB DONE! +@16: jmp NEGOP ; NEGATIVE NUMBER, SO NEGATE FAC + + +; ---------------------------------------------------------------------------- +; ACCUMULATE A DIGIT INTO FAC +; ---------------------------------------------------------------------------- +FIN9: pha ; SAVE DIGIT + bit DPFLG ; SEEN A DECIMAL POINT YET? + bpl @1 ; NO, STILL IN INTEGER PART + inc TMPEXP ; YES, COUNT THE FRACTIONAL DIGIT +@1: jsr MUL10 ; FAC = FAC * 10 + pla ; CURRENT DIGIT + and #$0F + jsr ADDACC ; ADD THE DIGIT + jmp FIN1 ; GO BACK FOR MORE + + +; ---------------------------------------------------------------------------- +; ADD (A) TO FAC +; ---------------------------------------------------------------------------- +ADDACC: pha ; SAVE ADDEND + jsr COPY_FAC_TO_ARG_ROUNDED + pla ; GET ADDEND AGAIN + jsr FLOAT ; CONVERT TO FP VALUE IN FAC + lda ARGSIGN + eor FACSIGN + sta SGNCPR + ldx FAC ; TO SIGNAL IF FAC=0 + jmp FADDT ; PERFORM THE ADDITION + + +; ---------------------------------------------------------------------------- +; ACCUMULATE DIGIT OF EXPONENT +; ---------------------------------------------------------------------------- +GETEXP: lda EXPON ; CHECK CURRENT VALUE + cmp #10 ; FOR MORE THAN 2 DIGITS + bcc @1 ; NO, THIS IS 1ST OR 2ND DIGIT + lda #100 ; EXPONENT TOO BIG + bit EXPSGN ; UNLESS IT IS NEGATIVE + bmi @2 ; LARGE NEGATIVE EXPONENT MAKES FAC=0 + jmp OVERFLOW ; LARGE POSITIVE EXPONENT IS ERROR +@1: asl a ; EXPONENT TIMES 10 + asl a + clc + adc EXPON + asl a + ldy #0 ; ADD THE NEW DIGIT + adc (TXTPTR),y ; BUT THIS IS IN ASCII, + sec ; SO ADJUST BACK TO BINARY + sbc #'0' +@2: sta EXPON ; NEW VALUE + jmp FIN4 ; BACK FOR MORE + +; ---------------------------------------------------------------------------- +CON_99999999_9: + .byte $9B,$3E,$BC,$1F,$FD ; 99,999,999.9 + +CON_999999999: + .byte $9E,$6E,$6B,$27,$FD ; 999,999,999 + +CON_BILLION: + .byte $9E,$6E,$6B,$28,$00 ; 1,000,000,000 + + +; ---------------------------------------------------------------------------- +; PRINT "IN " +; ---------------------------------------------------------------------------- +INPRT: lda #QT_IN + jsr STROUT + lda CURLIN+1 + ldx CURLIN + + +; ---------------------------------------------------------------------------- +; PRINT A,X AS DECIMAL INTEGER +; ---------------------------------------------------------------------------- +LINPRT: sta FAC+1 ; PRINT A,X IN DECIMAL + stx FAC+2 + ldx #$90 ; EXPONENT = 2^16 + sec ; CONVERT UNSIGNED + jsr FLOAT2 ; CONVERT LINE # TO FP + jsr FOUT ; CONVERT (FAC) TO STRING AT STACK + jmp STROUT ; PRINT STRING AT A,Y + + +; ---------------------------------------------------------------------------- +; CONVERT (FAC) TO STRING STARTING AT STACK +; RETURN WITH (Y,A) POINTING AT STRING +; ---------------------------------------------------------------------------- +FOUT: ldy #1 ; NORMAL ENTRY PUTS STRING AT STACK... + + +; ---------------------------------------------------------------------------- +; "STR$" FUNCTION ENTERS HERE, WITH (Y)=0 +; SO THAT RESULT STRING STARTS AT STACK-1 +; (THIS IS USED AS A FLAG) +; ---------------------------------------------------------------------------- +FOUT1: lda #'-' ; IN CASE VALUE NEGATIVE + dey ; BACK UP PNTR + bit FACSIGN + bpl @1 ; VALUE IS + + iny ; VALUE IS - + sta STACK-1,y ; EMIT "-" +@1: sta FACSIGN ; MAKE FAC.SIGN POSITIVE ($2D) + sty STRNG2 ; SAVE STRING PNTR + iny + lda #'0' ; IN CASE (FAC)=0 + ldx FAC ; NUMBER=0? + bne @2 ; NO, (FAC) NOT ZERO + jmp FOUT4 ; YES, FINISHED +; ---------------------------------------------------------------------------- +@2: lda #0 ; STARTING VALUE FOR TMPEXP + cpx #$80 ; ANY INTEGER PART? + beq @3 ; NO, BTWN .5 AND .999999999 + bcs @4 ; YES +; ---------------------------------------------------------------------------- +@3: lda #CON_BILLION ; TO GIVE ADJUSTMENT A HEAD START + jsr FMULT + lda #-9 ; EXPONENT ADJUSTMENT +@4: sta TMPEXP ; 0 OR -9 +; ---------------------------------------------------------------------------- +; ADJUST UNTIL 1E8 <= (FAC) <1E9 +; ---------------------------------------------------------------------------- +@5: lda #CON_999999999 + jsr FCOMP ; COMPARE TO 1E9-1 + beq @10 ; (FAC) = 1E9-1 + bpl @8 ; TOO LARGE, DIVIDE BY TEN +@6: lda #CON_99999999_9 + jsr FCOMP ; COMPARE TO 1E8-.1 + beq @7 ; (FAC) = 1E8-.1 + bpl @9 ; IN RANGE, ADJUSTMENT FINISHED +@7: jsr MUL10 ; TOO SMALL, MULTIPLY BY TEN + dec TMPEXP ; KEEP TRACK OF MULTIPLIES + bne @6 ; ...ALWAYS +@8: jsr DIV10 ; TOO LARGE, DIVIDE BY TEN + inc TMPEXP ; KEEP TRACK OF DIVISIONS + bne @5 ; ...ALWAYS +; ---------------------------------------------------------------------------- +@9: jsr FADDH ; ROUND ADJUSTED RESULT +@10: jsr QINT ; CONVERT ADJUSTED VALUE TO 32-BIT INTEGER + + +; ---------------------------------------------------------------------------- +; FAC+1...FAC+4 IS NOW IN INTEGER FORM +; WITH POWER OF TEN ADJUSTMENT IN TMPEXP +; +; IF -10 < TMPEXP > 1, PRINT IN DECIMAL FORM +; OTHERWISE, PRINT IN EXPONENTIAL FORM +; ---------------------------------------------------------------------------- +FOUT2: ldx #1 ; ASSUME 1 DIGIT BEFORE "." + lda TMPEXP ; CHECK RANGE + clc + adc #10 + bmi @1 ; < .01, USE EXPONENTIAL FORM + cmp #11 + bcs @2 ; >= 1E10, USE EXPONENTIAL FORM + adc #$FF ; LESS 1 GIVES INDEX FOR "." + tax + lda #2 ; SET REMAINING EXPONENT = 0 +@1: sec ; COMPUTE REMAINING EXPONENT +@2: sbc #2 + sta EXPON ; VALUE FOR "E+XX" OR "E-XX" + stx TMPEXP ; INDEX FOR DECIMAL POINT + txa ; SEE IF "." COMES FIRST + beq @3 ; YES + bpl @5 ; NO, LATER +@3: ldy STRNG2 ; GET INDEX INTO STRING BEING BUILT + lda #'.' ; STORE A DECIMAL POINT + iny + sta STACK-1,y + txa ; SEE IF NEED ".0" + beq @4 ; NO + lda #'0' ; YES, STORE "0" + iny + sta STACK-1,y +@4: sty STRNG2 ; SAVE OUTPUT INDEX AGAIN +; ---------------------------------------------------------------------------- +; NOW DIVIDE BY POWERS OF TEN TO GET SUCCESSIVE DIGITS +; ---------------------------------------------------------------------------- +@5: ldy #0 ; INDEX TO TABLE OF POWERS OF TEN + ldx #$80 ; STARTING VALUE FOR DIGIT WITH DIRECTION +@6: lda FAC+4 ; START BY ADDING -100000000 UNTIL + clc ; OVERSHOOT. THEN ADD +10000000, + adc DECTBL+3,y ; THEN ADD -1000000, THEN ADD + sta FAC+4 ; +100000, AND SO ON. + lda FAC+3 ; THE # OF TIMES EACH POWER IS ADDED + adc DECTBL+2,y ; IS 1 MORE THAN CORRESPONDING DIGIT + sta FAC+3 + lda FAC+2 + adc DECTBL+1,y + sta FAC+2 + lda FAC+1 + adc DECTBL,y + sta FAC+1 + inx ; COUNT THE ADD + bcs @7 ; IF C=1 AND X NEGATIVE, KEEP ADDING + bpl @6 ; IF C=0 AND X POSITIVE, KEEP ADDING + bmi @8 ; IF C=0 AND X NEGATIVE, WE OVERSHOT +@7: bmi @6 ; IF C=1 AND X POSITIVE, WE OVERSHOT +@8: txa ; OVERSHOT, SO MAKE X INTO A DIGIT + bcc @9 ; HOW DEPENDS ON DIRECTION WE WERE GOING + eor #$FF ; DIGIT = 9-X + adc #10 +@9: adc #'0'-1 ; MAKE DIGIT INTO ASCII + iny ; ADVANCE TO NEXT SMALLER POWER OF TEN + iny + iny + iny + sty VARPNT ; SAVE PNTR TO POWERS + ldy STRNG2 ; GET OUTPUT PNTR + iny ; STORE THE DIGIT + tax ; SAVE DIGIT, HI-BIT IS DIRECTION + and #$7F ; MAKE SURE $30...$39 FOR STRING + sta STACK-1,y + dec TMPEXP ; COUNT THE DIGIT + bne @10 ; NOT TIME FOR "." YET + lda #'.' ; TIME, SO STORE THE DECIMAL POINT + iny + sta STACK-1,y +@10: sty STRNG2 ; SAVE OUTPUT PNTR AGAIN + ldy VARPNT ; GET PNTR TO POWERS + txa ; GET DIGIT WITH HI-BIT = DIRECTION + eor #$FF ; CHANGE DIRECTION + and #$80 ; $00 IF ADDING, $80 IF SUBTRACTING + tax + cpy #DECTBL_END-DECTBL + bne @6 ; NOT FINISHED YET + + +; ---------------------------------------------------------------------------- +; NINE DIGITS HAVE BEEN STORED IN STRING. NOW LOOK +; BACK AND LOP OFF TRAILING ZEROES AND A TRAILING +; DECIMAL POINT. +; ---------------------------------------------------------------------------- +FOUT3: ldy STRNG2 ; POINTS AT LAST STORED CHAR +@1: lda STACK-1,y ; SEE IF LOPPABLE + dey + cmp #'0' ; SUPPRESS TRAILING ZEROES + beq @1 ; YES, KEEP LOOPING + cmp #'.' ; SUPPRESS TRAILING DECIMAL POINT + beq @2 ; ".", SO WRITE OVER IT + iny ; NOT ".", SO INCLUDE IN STRING AGAIN +@2: lda #'+' ; PREPARE FOR POSITIVE EXPONENT "E+XX" + ldx EXPON ; SEE IF ANY E-VALUE + beq FOUT5 ; NO, JUST MARK END OF STRING + bpl @3 ; YES, AND IT IS POSITIVE + lda #0 ; YES, AND IT IS NEGATIVE + sec ; COMPLEMENT THE VALUE + sbc EXPON + tax ; GET MAGNITUDE IN X + lda #'-' ; E SIGN +@3: sta STACK+1,y ; STORE SIGN IN STRING + lda #'E' ; STORE "E" IN STRING BEFORE SIGN + sta STACK,y + txa ; EXPONENT MAGNITUDE IN A-REG + ldx #'0'-1 ; SEED FOR EXPONENT DIGIT + sec ; CONVERT TO DECIMAL +@4: inx ; COUNT THE SUBTRACTION + sbc #10 ; TEN'S DIGIT + bcs @4 ; MORE TENS TO SUBTRACT + adc #'0'+10 ; CONVERT REMAINDER TO ONE'S DIGIT + sta STACK+3,y ; STORE ONE'S DIGIT + txa + sta STACK+2,y ; STORE TEN'S DIGIT + lda #0 ; MARK END OF STRING WITH $00 + sta STACK+4,y + beq FOUT6 ; ...ALWAYS +FOUT4: sta STACK-1,y ; STORE "0" IN ASCII +FOUT5: lda #0 ; STORE $00 ON END OF STRING + sta STACK,y +FOUT6: lda #STACK ; (STR$ STARTED STRING AT STACK-1, BUT + rts ; STR$ DOESN'T USE Y,A ANYWAY.) + + +; ---------------------------------------------------------------------------- +CON_HALF: + .byte $80,$00,$00,$00,$00 ; FP CONSTANT 0.5 + + +; ---------------------------------------------------------------------------- +; POWERS OF 10 FROM 1E8 DOWN TO 1, +; AS 32-BIT INTEGERS, WITH ALTERNATING SIGNS +; ---------------------------------------------------------------------------- +DECTBL: .byte $FA,$0A,$1F,$00 ; -100000000 + .byte $00,$98,$96,$80 ; 10000000 + .byte $FF,$F0,$BD,$C0 ; -1000000 + .byte $00,$01,$86,$A0 ; 100000 + .byte $FF,$FF,$D8,$F0 ; -10000 + .byte $00,$00,$03,$E8 ; 1000 + .byte $FF,$FF,$FF,$9C ; -100 + .byte $00,$00,$00,$0A ; 10 + .byte $FF,$FF,$FF,$FF ; -1 +DECTBL_END: + + +; ---------------------------------------------------------------------------- +; "SQR" FUNCTION +; ---------------------------------------------------------------------------- +SQR: jsr COPY_FAC_TO_ARG_ROUNDED + lda #CON_HALF + jsr LOAD_FAC_FROM_YA + + +; ---------------------------------------------------------------------------- +; EXPONENTIATION OPERATION +; +; ARG ^ FAC = EXP( LOG(ARG) * FAC ) +; ---------------------------------------------------------------------------- +FPWRT: beq EXP ; IF FAC=0, ARG^FAC=EXP(0) + lda ARG ; IF ARG=0, ARG^FAC=0 + bne @1 ; NEITHER IS ZERO + jmp STA_IN_FAC_SIGN_AND_EXP ; SET FAC = 0 +@1: ldx #TEMP3 ; SAVE FAC IN TEMP3 + ldy #0 + jsr STORE_FAC_AT_YX_ROUNDED + lda ARGSIGN ; NORMALLY, ARG MUST BE POSITIVE + bpl @2 ; IT IS POSITIVE, SO ALL IS WELL + jsr INT ; NEGATIVE, BUT OK IF INTEGRAL POWER + lda #TEMP3 ; SEE IF INT(FAC)=FAC + ldy #0 + jsr FCOMP ; IS IT AN INTEGER POWER? + bne @2 ; NOT INTEGRAL, WILL CAUSE ERROR LATER + tya ; MAKE ARG SIGN + AS IT IS MOVED TO FAC + ldy CHARAC ; INTEGRAL, SO ALLOW NEGATIVE ARG +@2: jsr MFA ; MOVE ARGUMENT TO FAC + tya ; SAVE FLAG FOR NEGATIVE ARG (0=+) + pha + jsr LOG ; GET LOG(ARG) + lda #TEMP3 ; MULTIPLY BY POWER + ldy #0 + jsr FMULT + jsr EXP ; E ^ LOG(FAC) + pla ; GET FLAG FOR NEGATIVE ARG + bpl RTS18 ; NOT NEGATIVE, FINISHED + + +; ---------------------------------------------------------------------------- +; NEGATE VALUE IN FAC +; ---------------------------------------------------------------------------- +NEGOP: lda FAC ; IF FAC=0, NO NEED TO COMPLEMENT + beq RTS18 ; YES, FAC=0 + lda FACSIGN ; NO, SO TOGGLE SIGN + eor #$FF + sta FACSIGN +RTS18: rts + + +; ---------------------------------------------------------------------------- +CON_LOG_E: + .byte $81,$38,$AA,$3B,$29 ; LOG(E) TO BASE 2 +; ---------------------------------------------------------------------------- +POLY_EXP: + .byte $07 ; ( # OF TERMS IN POLYNOMIAL) - 1 + .byte $71,$34,$58,$3E,$56 ; (LOG(2)^7)/8! + .byte $74,$16,$7E,$B3,$1B ; (LOG(2)^6)/7! + .byte $77,$2F,$EE,$E3,$85 ; (LOG(2)^5)/6! + .byte $7A,$1D,$84,$1C,$2A ; (LOG(2)^4)/5! + .byte $7C,$63,$59,$58,$0A ; (LOG(2)^3)/4! + .byte $7E,$75,$FD,$E7,$C6 ; (LOG(2)^2)/3! + .byte $80,$31,$72,$18,$10 ; LOG(2)/2! + .byte $81,$00,$00,$00,$00 ; 1 + + +; ---------------------------------------------------------------------------- +; "EXP" FUNCTION +; +; FAC = E ^ FAC +; ---------------------------------------------------------------------------- +EXP: lda #CON_LOG_E ; E^X = 2^(LOG2(E)*X) + jsr FMULT + lda FACEXTENSION ; NON-STANDARD ROUNDING HERE + adc #$50 ; ROUND UP IF EXTENSION > $AF + bcc @1 ; NO, DON'T ROUND UP + jsr INCREMENT_MANTISSA +@1: sta ARGEXTENSION ; STRANGE VALUE + jsr MAF ; COPY FAC INTO ARG + lda FAC ; MAXIMUM EXPONENT IS < 128 + cmp #$88 ; WITHIN RANGE? + bcc @3 ; YES +@2: jsr OUTOFRNG ; OVERFLOW IF +, RETURN 0.0 IF - +@3: jsr INT ; GET INT(FAC) + lda CHARAC ; THIS IS THE INETGRAL PART OF THE POWER + clc ; ADD TO EXPONENT BIAS + 1 + adc #$81 + beq @2 ; OVERFLOW + sec ; BACK OFF TO NORMAL BIAS + sbc #1 + pha ; SAVE EXPONENT +; ---------------------------------------------------------------------------- + ldx #5 ; SWAP ARG AND FAC +@4: lda ARG,x + ldy FAC,x + sta FAC,x + sty ARG,x + dex + bpl @4 + lda ARGEXTENSION + sta FACEXTENSION + jsr FSUBT ; POWER-INT(POWER) --> FRACTIONAL PART + jsr NEGOP + lda #POLY_EXP + jsr POLYNOMIAL ; COMPUTE F(X) ON FRACTIONAL PART + lda #0 + sta SGNCPR + pla ; GET EXPONENT + jmp ADD_EXPONENTS1 + + +; ---------------------------------------------------------------------------- +; ODD POLYNOMIAL SUBROUTINE +; +; F(X) = X * P(X^2) +; +; WHERE: X IS VALUE IN FAC +; Y,A POINTS AT COEFFICIENT TABLE +; FIRST BYTE OF COEFF. TABLE IS N +; COEFFICIENTS FOLLOW, HIGHEST POWER FIRST +; +; P(X^2) COMPUTED USING NORMAL POLYNOMIAL SUBROUTINE +; ---------------------------------------------------------------------------- +POLYNOMIAL_ODD: + sta SERPNT ; SAVE ADDRESS OF COEFFICIENT TABLE + sty SERPNT+1 + jsr STORE_FAC_IN_TEMP1_ROUNDED + lda #TEMP1 ; Y=0 ALREADY, SO Y,A POINTS AT TEMP1 + jsr FMULT ; FORM X^2 + jsr SERMAIN ; DO SERIES IN X^2 + lda #TEMP1 + jmp FMULT ; MULTIPLY X BY P(X^2) AND EXIT + + +; ---------------------------------------------------------------------------- +; NORMAL POLYNOMIAL SUBROUTINE +; +; P(X) = C(0)*X^N + C(1)*X^(N-1) + ... + C(N) +; +; WHERE: X IS VALUE IN FAC +; Y,A POINTS AT COEFFICIENT TABLE +; FIRST BYTE OF COEFF. TABLE IS N +; COEFFICIENTS FOLLOW, HIGHEST POWER FIRST +; ---------------------------------------------------------------------------- +POLYNOMIAL: + sta SERPNT ; POINTER TO COEFFICIENT TABLE + sty SERPNT+1 +; ---------------------------------------------------------------------------- +SERMAIN: + jsr STORE_FAC_IN_TEMP2_ROUNDED + lda (SERPNT),y ; GET N + sta SERLEN ; SAVE N + ldy SERPNT ; BUMP PNTR TO HIGHEST COEFFICIENT + iny ; AND GET PNTR INTO Y,A + tya + bne @1 + inc SERPNT+1 +@1: sta SERPNT + ldy SERPNT+1 +@2: jsr FMULT ; ACCUMULATE SERIES TERMS + lda SERPNT ; BUMP PNTR TO NEXT COEFFICIENT + ldy SERPNT+1 + clc + adc #5 + bcc @3 + iny +@3: sta SERPNT + sty SERPNT+1 + jsr FADD ; ADD NEXT COEFFICIENT + lda #TEMP2 ; POINT AT X AGAIN + ldy #0 + dec SERLEN ; IF SERIES NOT FINISHED, + bne @2 ; THEN ADD ANOTHER TERM +RTS19: rts ; FINISHED + +; ---------------------------------------------------------------------------- +CONRND1: + .byte $98,$35,$44,$7A ; THESE ARE MISSING ONE BYTE FOR FP VALUES + +CONRND2: + .byte $68,$28,$B1,$46 + + +; ---------------------------------------------------------------------------- +; "RND" FUNCTION +; ---------------------------------------------------------------------------- +RND: jsr SIGN ; REDUCE ARGUMENT TO -1, 0, OR +1 + tax ; SAVE ARGUMENT + bmi @1 ; = -1, USE CURRENT ARGUMENT FOR SEED + lda #RNDSEED + jsr LOAD_FAC_FROM_YA + txa ; RECALL SIGN OF ARGUMENT + beq RTS19 ; =0, RETURN SEED UNCHANGED + lda #CONRND1 + jsr FMULT + lda #CONRND2 + jsr FADD +@1: ldx FAC+4 ; SHUFFLE HI AND LO BYTES + lda FAC+1 ; TO SUPPOSEDLY MAKE IT MORE RANDOM + sta FAC+4 + stx FAC+1 + lda #0 ; MAKE IT POSITIVE + sta FACSIGN + lda FAC ; A SOMEWHAT RANDOM EXTENSION + sta FACEXTENSION + lda #$80 ; EXPONENT TO MAKE VALUE < 1.0 + sta FAC + jsr NORMALIZE_FAC2 + ldx #RNDSEED + jmp STORE_FAC_AT_YX_ROUNDED + + +; ---------------------------------------------------------------------------- +; GENERIC COPY OF CHRGET SUBROUTINE, WHICH +; IS COPIED INTO $00B1...$00C8 DURING INITIALIZATION +; +; CORNELIS BONGERS DESCRIBED SEVERAL IMPROVEMENTS +; TO CHRGET IN MICRO MAGAZINE OR CALL A.P.P.L.E. +; (I DON'T REMEMBER WHICH OR EXACTLY WHEN) +; ---------------------------------------------------------------------------- +GENERIC_CHRGET: + inc TXTPTR + bne @1 + inc TXTPTR+1 +@1: lda $EA60 ; ACTUAL ADDRESS FILLED IN LATER + cmp #':' ; EOS, ALSO TOP OF NUMERIC RANGE + bcs @2 ; NOT NUMBER, MIGHT BE EOS + cmp #' ' ; IGNORE BLANKS + beq GENERIC_CHRGET + sec ; TEST FOR NUMERIC RANGE IN WAY THAT + sbc #'0' ; CLEARS CARRY IF CHAR IS DIGIT + sec ; AND LEAVES CHAR IN A-REG + sbc #-'0' +@2: rts + + +; ---------------------------------------------------------------------------- +; INITIAL VALUE FOR RANDOM NUMBER, ALSO COPIED +; IN ALONG WITH CHRGET, BUT ERRONEOUSLY: +; THE LAST BYTE IS NOT COPIED +; ---------------------------------------------------------------------------- + .byte $80,$4F,$C7,$52,$58 ; APPROX. = .811635157 +GENERIC_END: + + +; ---------------------------------------------------------------------------- +COLDSTART: + ldx #$FF ; SET DIRECT MODE FLAG + stx CURLIN+1 + ldx #$FB ; SET STACK POINTER, LEAVING ROOM FOR + txs ; LINE BUFFER DURING PARSING + lda #COLDSTART ; UNTIL COLDSTART IS COMPLETED + sta GOWARM+1 + sty GOWARM+2 + sta GOSTROUTZ+1 ; ALSO SECOND USER VECTOR... + sty GOSTROUTZ+2 ; ..WE SIMPLY MUST FINISH COLD.START! + lda #$4C ; "JMP" OPCODE FOR 4 VECTORS + sta GOWARM ; WARM START + sta GOSTROUTZ ; ANYONE EVER USE THIS ONE? + sta JMPADRS ; USED BY FUNCTIONS (JSR JMPADRS) + +; ---------------------------------------------------------------------------- +; MOVE GENERIC CHRGET AND RANDOM SEED INTO PLACE +; +; NOTE THAT LOOP VALUE IS WRONG! +; THE LAST BYTE OF THE RANDOM SEED IS NOT +; COPIED INTO PAGE ZERO! +; ---------------------------------------------------------------------------- + ldx #GENERIC_END-GENERIC_CHRGET-1 +@1: lda GENERIC_CHRGET-1,x + sta CHRGET-1,x + dex + bne @1 +; ---------------------------------------------------------------------------- + txa ; A=0 + sta SHIFTSIGNEXT + sta LASTPT+1 + pha ; PUT $00 ON STACK (WHAT FOR?) + lda #3 ; SET LENGTH OF TEMP. STRING DESCRIPTORS + sta DSCLEN ; FOR GARBAGE COLLECTION SUBROUTINE + jsr CRDO ; PRINT + lda #1 ; SET UP FAKE FORWARD LINK + sta INPUTBUFFER-3 + sta INPUTBUFFER-4 + ldx #TEMPST ; INIT INDEX TO TEMP STRING DESCRIPTORS + stx TEMPPT +; ---------------------------------------------------------------------------- +; FIND HIGH END OF RAM +; ---------------------------------------------------------------------------- + lda #<$0800 ; SET UP POINTER TO LOW END OF RAM + ldy #>$0800 + sta LINNUM + sty LINNUM+1 + ldy #0 +@2: inc LINNUM+1 ; TEST FIRST BYTE OF EACH PAGE + lda (LINNUM),y ; BY COMPLEMENTING IT AND WATCHING + eor #$FF ; IT CHANGE THE SAME WAY + sta (LINNUM),y + cmp (LINNUM),y ; ROM OR EMPTY SOCKETS WON'T TRACK + bne @3 ; NOT RAM HERE + eor #$FF ; RESTORE ORIGINAL VALUE + sta (LINNUM),y + cmp (LINNUM),y ; DID IT TRACK AGAIN? + beq @2 ; YES, STILL IN RAM +@3: ldy LINNUM ; NO, END OF RAM + lda LINNUM+1 + and #$F0 ; FORCE A MULTIPLE OF 4096 BYTES + sty MEMSIZ ; (BAD RAM MAY HAVE YIELDED NON-MULTIPLE) + sta MEMSIZ+1 + sty FRETOP ; SET HIMEM AND BOTTOM OF STRINGS + sta FRETOP+1 + ldx #<$0800 ; SET PROGRAM POINTER TO $0800 + ldy #>$0800 + stx TXTTAB + sty TXTTAB+1 + ldy #0 ; TURN OFF SEMI-SECRET LOCK FLAG + sty LOCK + tya ; A=0 TOO + sta (TXTTAB),y ; FIRST BYTE IN PROGRAM SPACE = 0 + inc TXTTAB ; ADVANCE PAST THE $00 + bne @4 + inc TXTTAB+1 +@4: lda TXTTAB + ldy TXTTAB+1 + jsr REASON ; SET REST OF POINTERS UP + jsr SCRTCH ; MORE POINTERS + lda #STROUT ; USER VECTORS + sta GOSTROUTZ+1 + sty GOSTROUTZ+2 + lda #RESTART + sta GOWARM+1 + sty GOWARM+2 + jmp (GOWARM+1) ; SILLY, WHY NOT JUST "JMP RESTART" + + +; ---------------------------------------------------------------------------- +; "CALL" STATEMENT +; +; EFFECTIVELY PERFORMS A "JSR" TO THE SPECIFIED +; ADDRESS, WITH THE FOLLOWING REGISTER CONTENTS: +; (A,Y) = CALL ADDRESS +; (X) = $9D +; +; THE CALLED ROUTINE CAN RETURN WITH "RTS", +; AND APPLESOFT WILL CONTINUE WITH THE NEXT +; STATEMENT. +; ---------------------------------------------------------------------------- +CALL: jsr FRMNUM ; EVALUATE EXPRESSION FOR CALL ADDRESS + jsr GETADR ; CONVERT EXPRESSION TO 16-BIT INTEGER + jmp (LINNUM) ; IN LINNUM, AND JUMP THERE. + + +; ---------------------------------------------------------------------------- +; "HIMEM:" STATEMENT +; ---------------------------------------------------------------------------- +HIMEM: jsr FRMNUM ; GET VALUE SPECIFIED FOR HIMEM + jsr GETADR ; AS 16-BIT INTEGER + lda LINNUM ; MUST BE ABOVE VARIABLES AND ARRAYS + cmp STREND + lda LINNUM+1 + sbc STREND+1 + bcs SETHI ; IT IS ABOVE THEM +JMM: jmp MEMERR ; NOT ENOUGH MEMORY +SETHI: lda LINNUM ; STORE NEW HIMEM: VALUE + sta MEMSIZ + sta FRETOP ; NOTE THAT "HIMEM:" DOES NOT + lda LINNUM+1 ; CLEAR STRING VARIABLES. + sta MEMSIZ+1 ; THIS COULD BE DISASTROUS. + sta FRETOP+1 + rts + + +; ---------------------------------------------------------------------------- +; "LOMEM:" STATEMENT +; ---------------------------------------------------------------------------- +LOMEM: jsr FRMNUM ; GET VALUE SPECIFIED FOR LOMEM + jsr GETADR ; AS 16-BIT INTEGER IN LINNUM + lda LINNUM ; MUST BE BELOW HIMEM + cmp MEMSIZ + lda LINNUM+1 + sbc MEMSIZ+1 + bcs JMM ; ABOVE HIMEM, MEMORY ERROR + lda LINNUM ; MUST BE ABOVE PROGRAM + cmp VARTAB + lda LINNUM+1 + sbc VARTAB+1 + bcc JMM ; NOT ABOVE PROGRAM, ERROR + lda LINNUM ; STORE NEW LOMEM VALUE + sta VARTAB + lda LINNUM+1 + sta VARTAB+1 + jmp CLEARC ; LOMEM CLEARS VARIABLES AND ARRAYS + + +; ---------------------------------------------------------------------------- +; "ON ERR GO TO" STATEMENT +; ---------------------------------------------------------------------------- +ONERR: lda #TOKEN_GOTO ; MUST BE "GOTO" NEXT + jsr SYNCHR + lda TXTPTR ; SAVE TXTPTR FOR HANDLERR + sta TXTPSV + lda TXTPTR+1 + sta TXTPSV+1 + sec ; SET SIGN BIT OF ERRFLG + ror ERRFLG + lda CURLIN ; SAVE LINE # OF CURRENT LINE + sta CURLSV + lda CURLIN+1 + sta CURLSV+1 + jsr REMN ; IGNORE REST OF LINE <<>> + jmp ADDON ; CONTINUE PROGRAM + + +; ---------------------------------------------------------------------------- +; ROUTINE TO HANDLE ERRORS IF ONERR GOTO ACTIVE +; ---------------------------------------------------------------------------- +HANDLERR: + stx ERRNUM ; SAVE ERROR CODE NUMBER + ldx REMSTK ; GET STACK PNTR SAVED AT NEWSTT + stx ERRSTK ; REMEMBER IT + lda CURLIN ; GET LINE # OF OFFENDING STATEMENT + sta ERRLIN ; SO USER CAN SEE IT IF DESIRED + lda CURLIN+1 + sta ERRLIN+1 + lda OLDTEXT ; ALSO THE POSITION IN THE LINE + sta ERRPOS ; IN CASE USER WANTS TO "RESUME" + lda OLDTEXT+1 + sta ERRPOS+1 + lda TXTPSV ; SET UP TXTPTR TO READ TARGET LINE # + sta TXTPTR ; IN "ON ERR GO TO XXXX" + lda TXTPSV+1 + sta TXTPTR+1 + lda CURLSV + sta CURLIN ; LINE # OF "ON ERR" STATEMENT + lda CURLSV+1 + sta CURLIN+1 + jsr CHRGOT ; START CONVERSION + jsr GOTO ; GOTO SPECIFIED ONERR LINE + jmp NEWSTT + + +; ---------------------------------------------------------------------------- +; "RESUME" STATEMENT +; ---------------------------------------------------------------------------- +RESUME: lda ERRLIN ; RESTORE LINE # AND TXTPTR + sta CURLIN ; TO RE-TRY OFFENDING LINE + lda ERRLIN+1 + sta CURLIN+1 + lda ERRPOS + sta TXTPTR + lda ERRPOS+1 + sta TXTPTR+1 + ldx ERRSTK ; RETRIEVE STACK PNTR AS IT WAS + txs ; BEFORE STATEMENT SCANNED + jmp NEWSTT ; DO STATEMENT AGAIN + diff --git a/cffa1.s b/cffa1.s new file mode 100644 index 0000000..8c26821 --- /dev/null +++ b/cffa1.s @@ -0,0 +1,185 @@ +; CFFA1 I/O routines for Applesoft Lite +; by Tom Greene +; 8-May-2008 + +.setcpu "6502" +.segment "BASIC" + +.include "zeropage.s" + +.importzp ERR_SYNTAX, ERR_NOCFFA +.import ERROR, FIX_LINKS +.export CFFALoad, CFFASave, CFFAMenu + +; ---------------------------------------------------------------------------- +; CFFA1 firmware addresses + +;CFFA_ID1 := $AFFC ; CFFA1 API documentation says AFFC and AFFD... +;CFFA_ID2 := $AFFD +CFFA_ID1 := $AFDC ; But the CFFA1 firmware says AFDC and AFDD... +CFFA_ID2 := $AFDD +CFFA_MENU := $9006 ; Entry point for the CFFA1 menu +CFFA_API := $900C ; Entry point for the CFFA1 API + +; ---------------------------------------------------------------------------- +; CFFA1 API functions + +CFFA1_DisplayError = $04 ; Displays error message for error value in A +CFFA1_WriteFile = $20 +CFFA1_ReadFile = $22 + +; ---------------------------------------------------------------------------- +; CFFA1 API parameters in the ZP + +Destination := $00 ; File load/save address +Filename := $02 ; Pointer to file name +Filetype := $06 ; ProDOS file type +AuxType := $07 ; ProDOS file auxtype +FileSize := $09 ; File size + +; ---------------------------------------------------------------------------- +; Scratch memory used during API calls + +ZPTemp := $0380 ; ZP locations get backed up here +CFFAFileName := $03C0 ; File name string + +; ---------------------------------------------------------------------------- +; ProDOS file type value for write operations +; The CFFA1 doesn't really care, so this is just for show. + +SaveType = $F8 ; F8 = "PRG"? + +; ---------------------------------------------------------------------------- + + +; ---------------------------------------------------------------------------- +; See if CFFA1 card is present and display error if not +; ---------------------------------------------------------------------------- +CheckCFFA: + ldy CFFA_ID1 + cpy #$CF + bne CFFAErr + ldy CFFA_ID2 + cpy #$FA + bne CFFAErr + rts + + +; ---------------------------------------------------------------------------- +; Bring up the CFFA1 menu +; ---------------------------------------------------------------------------- +CFFAMenu: + jsr CheckCFFA + jmp CFFA_MENU + + +; ---------------------------------------------------------------------------- +; This sets up the zero page locations file name for the read/write calls +; ---------------------------------------------------------------------------- +APISetup: + jsr CheckCFFA ; Make sure CFFA card is present first + ldy #0 +@1: lda GOWARM,y ; Back up first 12 bytes of the ZP + sta ZPTemp,y ; so they can used during CFFA API call + iny + cpy #12 + bne @1 +GetFileName: ; Get file name from input line + dec TXTPTR + ldy #0 +@1: jsr CHRGET ; Get next character from the input line + beq @2 ; Is it null (EOL)? + sta CFFAFileName+1,y ; Not EOL, store it in filename string + iny + cpy #15 ; 15 chars yet? + bne @1 ; no, go back for more +@2: cpy #0 ; Read 15 chars or EOL, did we get anything? + beq SynErr ; No, syntax error + sty CFFAFileName ; Store file name length + lda #CFFAFileName + sta Filename ; and store it for API call + sty Filename+1 + lda PRGEND ; Set up file size + sbc TXTTAB ; (PRGEND - TXTTAB) + sta FileSize + lda PRGEND+1 + sbc TXTTAB+1 + sta FileSize+1 + lda TXTTAB ; Set up start address and auxtype + ldy TXTTAB+1 ; (these will be the same) + sta Destination + sta AuxType + sty Destination+1 + sty AuxType+1 + lda #SaveType ; Set up ProDOS file type + sta Filetype + rts + + +; ---------------------------------------------------------------------------- +; Display an error message if something went wrong during APISetup +; Uses the Applesoft ERROR routine +; ---------------------------------------------------------------------------- +CFFAErr: + ldx #ERR_NOCFFA + .byte $2C ; Bogus BIT instruction +SynErr: + ldx #ERR_SYNTAX + jmp ERROR ; Jump to Applesoft ERROR routine + + +; ---------------------------------------------------------------------------- +; Restores the first 12 bytes of the ZP which were saved during APISetup +; ---------------------------------------------------------------------------- +RestoreZP: + ldy #0 +@1: lda ZPTemp,y ; Load byte from temporary storage + sta GOWARM,y ; put it back in its original location + iny + cpy #12 ; Repeat for next 11 bytes + bne @1 + rts + + +; ---------------------------------------------------------------------------- +; Write a file to the CFFA card (SAVE command) +; ---------------------------------------------------------------------------- +CFFASave: + jsr APISetup ; Set up zero page locations for API call + ldx #CFFA1_WriteFile; Select WriteFile API function + jsr DoCFFACall ; Do it +@1: jsr RestoreZP ; put ZP back together +@2: rts + + +; ---------------------------------------------------------------------------- +; Read file from CFFA, then fix up Applesoft zero page to point to the +; loaded program (LOAD command) +; ---------------------------------------------------------------------------- +CFFALoad: + jsr APISetup + ldx #CFFA1_ReadFile ; Select ReadFile API function + jsr DoCFFACall ; Do it + lda TXTTAB ; Compute program end address + adc FileSize ; (Add file size to program start) + sta VARTAB ; Store end address + lda TXTTAB+1 + adc FileSize+1 + sta VARTAB+1 + jsr RestoreZP ; Put the zero page back + jmp FIX_LINKS ; Done loading, fix pointers and restart + + +; ---------------------------------------------------------------------------- +; Call the CFFA1 API and display error message if one occurred +; CFFA function number is passed in X +; CFFA API returns error status in C, error number in A +; ---------------------------------------------------------------------------- +DoCFFACall: + jsr CFFA_API ; Call CFFA API + ldx #CFFA1_DisplayError ; Set next command to show error message + bcs DoCFFACall ; Call API again if error occurred + rts + + diff --git a/io.s b/io.s new file mode 100644 index 0000000..ba6ce12 --- /dev/null +++ b/io.s @@ -0,0 +1,92 @@ +; Apple-1 I/O routines for Applesoft Lite +; Last modified 10-May-2008 + +.setcpu "6502" +.segment "BASIC" + +.export KEYBOARD, GETLN, RDKEY, CLS, OUTDO, CRDO, OUTQUES, OUTSP +.import INPUTBUFFER + +.include "zeropage.s" + +; ---------------------------------------------------------------------------- +; I/O Locations +; ---------------------------------------------------------------------------- +KEYBOARD := $D010 +KEYBOARDCR := $D011 + + +; ---------------------------------------------------------------------------- +; Monitor Subroutines +; ---------------------------------------------------------------------------- +MONECHO := $FFEF + + +; ---------------------------------------------------------------------------- +; Get keystroke from keyboard (RDKEY) +; ---------------------------------------------------------------------------- +RDKEY: + lda KEYBOARDCR ; Key ready? + bpl RDKEY ; Loop until ready + lda KEYBOARD ; Load character + and #$7F ; Clear hi bit + rts + +; ---------------------------------------------------------------------------- +; Get line of input (GETLN) +; adapted from Apple II monitor +; ---------------------------------------------------------------------------- +NOTCR: + cmp #$18 ; CTRL-X? + beq CANCEL ; Cancel line if so + jsr MONECHO ; Output using monitor ECHO routine + cmp #'_' ; backspace? + beq BCKSPC ; Yes, do backspace... +NOTCR1: inx + bne NXTCHAR ; Wasn't backspace or CTRL+X, get next key +CANCEL: jsr OUTSLASH ; Output a "\" to indicate cancelled line +GETLNZ: jsr CRDO ; new line +GETLN: jsr OUTPROMPT ; Display the prompt + ldx #$01 ; Set cursor at 1, it gets decremented later +BCKSPC: txa + beq GETLNZ ; Backspace with nothing on the line? start new line + dex ; Move "cursor" back one space +NXTCHAR: + jsr RDKEY ; Read key from keyboard +ADDINP: sta INPUTBUFFER,x ; Put it in the input buffer + cmp #$0D ; CR? + bne NOTCR ; No, keep looping + jsr CRDO ; Output CR + rts + + +; ---------------------------------------------------------------------------- +; These moved here from the main Applesoft code to save a few bytes +; ---------------------------------------------------------------------------- +OUTSLASH: + lda #'\' + .byte $2C ; Fake BIT instruction to skip next 2 bytes +OUTPROMPT: + lda PROMPT + .byte $2C +OUTSP: lda #' ' + .byte $2C +OUTQUES: + lda #'?' + .byte $2C +CRDO: lda #$0D +OUTDO: ora #$80 ; Set hi bit + jsr MONECHO ; Send character to monitor ECHO + and #$7F ; clear hi bit + rts + + +; ---------------------------------------------------------------------------- +; Corny method of clearing the screen by sending a bunch of CR's. +; ---------------------------------------------------------------------------- +CLS: + ldy #24 ; loop 24 times +@1: jsr CRDO ; ouput CR + dey + bpl @1 ; ... do it again + rts diff --git a/macros.s b/macros.s new file mode 100644 index 0000000..9be51eb --- /dev/null +++ b/macros.s @@ -0,0 +1,10 @@ +; ---------------------------------------------------------------------------- +; Macros + +; htasc - set the hi bit on the last byte of a string for termination +.macro htasc str + .repeat .strlen(str)-1,I + .byte .strat(str,I) + .endrep + .byte .strat(str,.strlen(str)-1) | $80 +.endmacro diff --git a/replica1.cfg b/replica1.cfg new file mode 100644 index 0000000..2537660 --- /dev/null +++ b/replica1.cfg @@ -0,0 +1,10 @@ +MEMORY { + BASROM: start = $E000, size = $1F00, fill = yes, file = %O; + MONROM: start = $FF00, size = $100, fill = yes, file = %O; +} + +SEGMENTS { + BASIC: load = BASROM, type = ro; + MONITOR: load = MONROM, type = ro; +} + diff --git a/wozmon.s b/wozmon.s new file mode 100644 index 0000000..6918274 --- /dev/null +++ b/wozmon.s @@ -0,0 +1,183 @@ +; Apple I Monitor ROM +; Steve Wozniak +; 1976 +; -------------------------------------------------------- + +.setcpu "6502" +.segment "MONITOR" + +.export ECHO + +; -------------------------------------------------------- +; Zero page variables +XAML := $24 +XAMH := $25 +STL := $26 +STH := $27 +L := $28 +H := $29 +YSAV := $2A +MODE := $2B + +; I/O locations +IN := $0200 ; Input buffer is $0200 to $027F +KBD := $D010 ; Keyboard data +DSP := $D012 ; Display data +KBDCR := $D011 ; Keyboard control register +DSPCR := $D013 ; Display control register + +; ASCII codes +CR = $0D | $80 ; Carriage return +ESC = $1B | $80 ; Escape +SLASH = '\' | $80 ; \ +UNDERSC = '_' | $80 ; Underscore (acts as backspace) +DOT = '.' | $80 ; . +COLON = ':' | $80 ; : +R = 'R' | $80 ; "R" +SPACE = ' ' | $80 ; blank +ZERO = '0' | $80 ; "0" + +; -------------------------------------------------------- +RESET: cld ; Clear decimal arithmetic mode + cli + ldy #$7F ; Mask for DSP data direction register + sty DSP ; Set it up + lda #$A7 ; KBD and DSP control register mask + sta KBDCR ; Enable interrupts, set CA1, CB1 for + sta DSPCR ; positive edge sense/output mode +NOTCR: cmp #UNDERSC ; Backspace? + beq BACKSPACE ; Yes + cmp #ESC ; ESC? + beq ESCAPE ; Yes + iny ; Advance text index + bpl NEXTCHAR ; Auto ESC if > 127 +ESCAPE: lda #SLASH ; "\" + jsr ECHO ; Output it +GETLINE: + lda #CR ; CR + jsr ECHO ; Output it + ldy #$01 ; Initialize text index +BACKSPACE: + dey ; Back up text index + bmi GETLINE ; Beyond start of line, reinitialize +NEXTCHAR: + lda KBDCR ; Key ready? + bpl NEXTCHAR ; Loop until ready + lda KBD ; Load character. B7 should be '1' + sta IN,y ; Add to text buffer + jsr ECHO ; Display character + cmp #CR ; CR? + bne NOTCR ; No + ldy #$FF ; Reset text index + lda #$00 ; For XAM mode + tax ; 0 -> x +SETSTOR: + asl ; Leaves $7B if setting STOR mode +SETMODE: + sta MODE ; $00 = XAM, $7B = STOR, $AE = BLOCK XAM +BLSKIP: iny ; Advance text index +NEXTITEM: + lda IN,y ; Get character + cmp #CR ; CR? + beq GETLINE ; Yes, done this line + cmp #DOT ; "."? + bcc BLSKIP ; Skip delimiter + beq SETMODE ; Set BLOCK XAM mode + cmp #COLON ; ":"? + beq SETSTOR ; Yes, set STOR mode + cmp #R ; "R"? + beq RUN ; Yes, run user program + stx L ; $00 -> L + stx H ; and H + sty YSAV ; Save Y for comparison +NEXTHEX: + lda IN,y ; Get character for hex test + eor #$B0 ; Map digits to $0-9 + cmp #$0A ; Digit? + bcc DIG ; Yes + adc #$88 ; Map letter "A"-"F" to $FA-FF + cmp #$FA ; Hex letter? + bcc NOTHEX ; No, character not hext +DIG: asl + asl ; Hex digit to MSD of A + asl + asl + ldx #$04 ; Shift count +HEXSHIFT: + asl ; Hex digit left, MSB to carry + rol L ; Rotate into LSD + rol H ; Rotate into MSD's + dex ; Done 4 shifts? + bne HEXSHIFT ; No, loop + iny ; Advance text index + bne NEXTHEX ; Always taken. Check next character for hex +NOTHEX: + cpy YSAV ; Check if L, H empty (no hex digits) + beq ESCAPE ; Yes, generate ESC sequence + bit MODE ; Test MODE byte + bvc NOTSTOR ; B6 = 0 for STOR, 1 for XAM and BLOCK XAM + lda L ; LSD's of hex data + sta (STL,x) ; Store at current 'store index' + inc STL ; Increment store index + bne NEXTITEM ; Get next item (no carry) + inc STH ; Add carry to 'store index' high order +TONEXTITEM: + jmp NEXTITEM ; Get next command item +RUN: jmp (XAML) ; Run at current XAM index +NOTSTOR: + bmi XAMNEXT ; B7=0 for XAM, 1 for BLOCK XAM + ldx #$02 ; Byte count +SETADR: lda L-1,x ; Copy hex data to + sta STL-1,x ; 'store index' + sta XAML-1,x ; And to 'XAM index' + dex ; Next of 2 bytes + bne SETADR ; Loop unless X=0 +NXTPRNT: + bne PRDATA ; NE means no address to print + lda #CR ; CR + jsr ECHO ; Output it + lda XAMH ; 'Examine index' high-order byte + jsr PRBYTE ; Output it in hex format + lda XAML ; Low-order 'examine index' byte + jsr PRBYTE ; Output it in hex format + lda #COLON ; ":" + jsr ECHO ; Output it +PRDATA: lda #SPACE ; Blank + jsr ECHO ; Output it + lda (XAML,x) ; Get data byte at 'examine index' + jsr PRBYTE ; Output it in hex format +XAMNEXT: + stx MODE ; 0 -> MODE (XAM mode) + lda XAML + cmp L ; Compare 'examine index' to hex data + lda XAMH + sbc H + bcs TONEXTITEM ; Not less, so no more data to output + inc XAML + bne MOD8CHK ; Increment 'examine index' + inc XAMH +MOD8CHK: + lda XAML ; Check low-order 'examine index' byte + and #$07 ; For MOD 8 = 0 + bpl NXTPRNT ; Always taken +PRBYTE: pha ; Save A for LSD + lsr + lsr + lsr ; MSD to LSD position + lsr + jsr PRHEX ; Output hex digit + pla ; Restore A +PRHEX: and #$0F ; Mask LSD for hex print + ora #ZERO ; Add "0" + cmp #$BA ; Digit? + bcc ECHO ; Yes, output it + adc #$06 ; Add offset for letter +ECHO: bit DSP ; DA bit (B7) cleared yet? + bmi ECHO ; No, wait for display + sta DSP ; Output character. Sets DA. + rts ; Return +; -------------------------------------------------------- + .word $0000 ; (unused) + .addr $0F00 ; (NMI vector) + .addr RESET ; (RESET vector) + .addr $0000 ; (IRQ vector) diff --git a/zeropage.s b/zeropage.s new file mode 100644 index 0000000..1e91040 --- /dev/null +++ b/zeropage.s @@ -0,0 +1,88 @@ +; Zero Page locatinos used by Applesoft Lite + +GOWARM := $0000 ; Gets "jmp RESTART" +GOSTROUTZ := $0003 ; Gets "jmp STROUT" +CHARAC := $000D ; Alternate string terminator +ENDCHR := $000E ; String terminator +TKNCNTR := $000F ; Used in PARSE +EOLPNTR := $000F ; Used in NXLIN +NUMDIM := $000F ; Used in array routines +DIMFLG := $0010 +VALTYP := $0011 ; $: VALTYP=$FF; %: VALTYP+1=$80 +DATAFLG := $0013 ; Used in PARSE +GARFLG := $0013 ; Used in GARBAG +SUBFLG := $0014 +INPUTFLG := $0015 ; = $40 for GET, $98 for READ +CPRMASK := $0016 ; Receives CPRTYP in FRMEVL +PROMPT := $0033 +LINNUM := $0050 ; Converted line # +TEMPPT := $0052 ; Last used temp string desc +LASTPT := $0053 ; Last used temp string pntr +TEMPST := $0055 ; Holds up to 3 descriptors +INDEX := $005E +DEST := $0060 +RESULT := $0062 ; Result of last * or / +TXTTAB := $0067 ; Start of program text +VARTAB := $0069 ; Start of variable storage +ARYTAB := $006B ; Start of array storage +STREND := $006D ; End of array storage +FRETOP := $006F ; Start of string storage +FRESPC := $0071 ; Temp pntr, string routines +MEMSIZ := $0073 ; End of string space (HIMEM) +CURLIN := $0075 ; Current line number +OLDLIN := $0077 ; Addr. of last line executed +OLDTEXT := $0079 +DATLIN := $007B ; Line # of current data stt. +DATPTR := $007D ; Addr of current data stt. +INPTR := $007F +VARNAM := $0081 ; Name of variable +VARPNT := $0083 ; Addr of variable +FORPNT := $0085 +TXPSV := $0087 ; Used in INPUT +LASTOP := $0087 ; Scratch flag used in FRMEVL +CPRTYP := $0089 ; >,=,< flag in FRMEVL +TEMP3 := $008A +FNCNAM := $008A +DSCPTR := $008C +DSCLEN := $008F ; used in GARBAG +JMPADRS := $0090 ; gets "jmp ...." +LENGTH := $0091 ; used in GARBAG +ARGEXTENSION := $0092 ; FP extra precision +TEMP1 := $0093 ; save areas for FAC +ARYPNT := $0094 ; used in GARBAG +HIGHDS := $0094 ; pntr for BLTU +HIGHTR := $0096 ; pntr for BLTU +TEMP2 := $0098 +TMPEXP := $0099 ; used in FIN (EVAL) +INDX := $0099 ; used by array rtns +EXPON := $009A ; " +DPFLG := $009B ; flags dec pnt in FIN +LOWTR := $009B +EXPSGN := $009C +FAC := $009D ; main floating point accumulator +VPNT := $00A0 ; temp var ptr +FACSIGN := $00A2 ; holds unpacked sign +SERLEN := $00A3 ; holds length of series - 1 +SHIFTSIGNEXT := $00A4 ; sign extension, right shifts +ARG := $00A5 ; secondary FP accumulator +ARGSIGN := $00AA +SGNCPR := $00AB ; flags opp sign in FP routines +FACEXTENSION := $00AC ; FAC extension byte +SERPNT := $00AD ; pntr to series data in FP +STRNG1 := $00AB +STRNG2 := $00AD +PRGEND := $00AF +CHRGET := $00B1 +CHRGOT := $00B7 +TXTPTR := $00B8 +RNDSEED := $00C9 +LOCK := $00D6 ; no user access if > 127 +ERRFLG := $00D8 ; $80 if ON ERR active +ERRLIN := $00DA ; line # where error occurred +ERRPOS := $00DC ; TXTPTR save for HANDLERR +ERRNUM := $00DE ; which error occurrred +ERRSTK := $00DF ; stack pntr before error +TRCFLG := $00F2 +TXTPSV := $00F4 +CURLSV := $00F6 +REMSTK := $00F8 ; stack pntr before each stt.