PAG ***************************** * * * Applesoft - Part C * * * * Copywrite Apple Computer, * * Inc. and Microsoft, Inc.; * * not for publication or * * distribution. * * * ***************************** * * * Floating Point Routines * * * * $E7A0 - $F1D4 * * * ***************************** FADDH LDA #HALF ;FAC+1/2 -> FAC LDY #>HALF JMP FADD FSUB JSR CONUPK ;Load ARG from (A,Y) FSUBT NEG FACSGN ;ARG - FAC -> FAC EOR ARGSGN STA SGNCPR LDA FAC JMP FADDT AD0 JSR SHIFT ;Do byte shift BCC AD3 ;Always taken FADD JSR CONUPK ;(A,Y) to ARG FADDT BNE :A1 ;ARG + FAC -> FAC JMP MOVFA ;If FAC=0 just move ARG over :A1 LDX EXTRAFAC ;Extra byte for precision STX EXTRASV ; in all FP routines. LDX #ARG ;Set up to shift ARG LDA ARG AD2 TAY BEQ RTN4 ;If ARG=0 exit SEC SBC FAC ;Get diffnce of exp BEQ AD3 ;Go add if same exp BCC :A2 STY FAC ;Sneaky exchange LDY ARGSGN STY FACSGN EOR #$FF ADC #0 LDY #0 STY EXTRASV LDX #FAC ;Set up to shift FAC BNE :A3 :A2 LDY #0 STY EXTRAFAC :A3 CMP #$F9 ;How many bits to shift? BMI AD0 ;Branch if more than 7 TAY ;Index to # of shifts LDA EXTRAFAC LSR 1,X JSR SHFTR ;Do shift AD3 BIT SGNCPR ;Same sign? BPL ADMAN ;Yes, add mantissas LDY #FAC CPX #ARG ;Which was adjusted? BEQ SUBMAN ;If ARG, do FAC-ARG LDY #ARG ;If FAC, do ARG-FAC SUBMAN SEC EOR #$FF ADC EXTRASV STA EXTRAFAC SB 4,Y;4,X;FAC+4 SB 3,Y;3,X;FAC+3 SB 2,Y;2,X;FAC+2 SB 1,Y;1,X;FAC+1 SGNIF BCS SIGNIF ;Branch if difference posv JSR NEGFAC SIGNIF LDY #0 ;Shift up signif digit TYA ;Counting shift in A CLC FLOOP LDX FAC+1 BNE FR2 ;Repeat till not 0 LDX FAC+2 STX FAC+1 LDX FAC+3 STX FAC+2 LDX FAC+4 STX FAC+3 LDX EXTRAFAC STX FAC+4 STY EXTRAFAC ;Zero extra byte ADC #8 ;Count the 8 bits CMP #8*4 ;Done 4 times? BNE FLOOP ;Loop if not ZEROFAC LDA #0 AtoFAC STA FAC AtoFACS STA FACSGN RTS ADMAN ADC EXTRASV ;Add mantissas (frac parts) STA EXTRAFAC AD FAC+4;ARG+4;FAC+4 AD FAC+3;ARG+3;FAC+3 AD FAC+2;ARG+2;FAC+2 AD FAC+1;ARG+1;FAC+1 JMP FR3 FR1 ADC #1 ;Count bits shifted ASL EXTRAFAC ROL FAC+4 ROL FAC+3 ROL FAC+2 ROL FAC+1 FR2 BPL FR1 ;Repeat till FAC+1 neg SEC SBC FAC ;Fix exponent BCS ZEROFAC EOR #$FF ADC #1 STA FAC ;Carry is clear here FR3 BCC RTN5 FROUND INC FAC BEQ OVERFLOW ROR FAC+1 ROR FAC+2 ROR FAC+3 ROR FAC+4 ROR EXTRAFAC RTN5 RTS NEGFAC NEG FACSGN ;Take ones complement NEG2 NEG FAC+1 NEG FAC+2 NEG FAC+3 NEG FAC+4 NEG EXTRAFAC INC EXTRAFAC ;Add bit to get BNE RTN6 ; twos complement PLUSEPS INC FAC+4 ;Add carry from EXTRA BNE RTN6 INC FAC+3 BNE RTN6 INC FAC+2 BNE RTN6 INC FAC+1 RTN6 RTS OVERFLOW LDX #OVFLOW-ERRMSG JMP ERROR SHFTRES LDX #RESULT-1 ;Entry from FMULT but carry NXSFT LDY 4,X ; should have been set! STY EXTRAFAC LDY 3,X STY 4,X LDY 2,X STY 3,X LDY 1,X STY 2,X LDY FPGEN ;$FF if from QINT for neg # STY 1,X ; otherwise 0 SHIFT ADC #8 ;Shift 1,X right $100-A bits BMI NXSFT ;Do byte shift if in range BEQ NXSFT SBC #8 TAY ;Count for final bit shift LDA EXTRAFAC BCS SH3 ;Exit if none needed SH1 ASL 1,X ;Shift only the lower 7 bits BCC SH2 ; of 1,X INC 1,X ;Force next instrn to set carry SH2 ROR 1,X ROR 1,X SHFTR ROR 2,X ROR 3,X ROR 4,X ROR INY BNE SH1 SH3 CLC RTS ONE HEX 8100000000 LOGSER DFB 3 ;Index to # of coefs: HEX 7F5E56CB79 HEX 80139B0B64 HEX 8076389316 HEX 8238AA3B20 SQRhalf HEX 803504F334 ;SQR(1/2) SQRtwo HEX 813504F334 ;SQR(2) HALFneg HEX 8080000000 ;-1/2 LOGtwo HEX 80317217F8 ;ln(2) LOG JSR SIGN ;Natural log of FAC BEQ GIQ ;Argument must be > 0 BPL LG2 GIQ JMP IQERR LG2 LDA FAC ;Save exponent-$80 SBC #$7F ;Carry is clear PHA LDA #$80 ;Normalize between .5 and 1 STA FAC LDA #SQRhalf LDY #>SQRhalf JSR FADD ;Compute via series of odd LDA #SQRtwo ; powers of LDY #>SQRtwo ; (SQR(2)X-1)/(SQR(2)X+1) JSR FDIV LDA #ONE LDY #>ONE JSR FSUB LDA #LOGSER LDY #>LOGSER JSR ODDSER ;Computes LOG +.5 base 2 LDA #HALFneg LDY #>HALFneg JSR FADD PLA JSR ADDACC ;Add original exponent - $80 LDA #LOGtwo ;Now have LOG base 2, convert LDY #>LOGtwo ; to base e by *LOG(2). FMULT JSR CONUPK ;(A,Y) to ARG FMULTT BNE FMU ;FAC * ARG -> FAC JMP RTN7 ;Should just RTS FMU JSR ADEXP LDA #0 ;Init product STA RESULT STA RESULT+1 STA RESULT+2 STA RESULT+3 LDA EXTRAFAC ;Multiply digits of FAC by JSR FM1 ; ARG and add to RESULT LDA FAC+4 JSR FM1 LDA FAC+3 JSR FM1 LDA FAC+2 JSR FM1 LDA FAC+1 JSR FM2 JMP RES>FAC ;Move RESULT to FAC & normalize * Routine to multiply A-reg by ARG and add to RESULT. FM1 BNE FM2 ;Do 8 bit mult if not 0 * BUG: There should be a SEC here. Usually it is set * since FM2 leaves it that way, but SHFTRES leaves it * clear. Using SHFTRES from THIS entry assumes carry * set. Thus, if SHFTRES is used twice in a row then * calculation will be off in the last 8 bits! This * happens when FAC+2, FAC+3 are both 0 but FAC+4 is * nonzero. For example, try PRINT 1*998244415 or * PRINT 1*10.0000009 JMP SHFTRES ;Shift product one byte ; (used for extra speed) FM2 LSR ;Shift off low bit ORA #$80 ;Set for 8 bit count FM3 TAY ;Save it BCC FM4 ;Branch if low bit = 0 CLC ;Mult bit by ARG to RESULT AD RESULT+3;ARG+4;RESULT+3 AD RESULT+2;ARG+3;RESULT+2 AD RESULT+1;ARG+2;RESULT+1 AD RESULT;ARG+1;RESULT FM4 ROR RESULT ;Shift product one bit ROR RESULT+1 ROR RESULT+2 ROR RESULT+3 ROR EXTRAFAC TYA ;Retrieve acc LSR ;Shift off next bit BNE FM3 ;Loop 8 times (via the ORA #$80) RTN7 RTS * Unpack number at (A,Y) and move to ARG: CONUPK STA INDEX STY INDEX+1 LDY #4 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 ARGSGN ;Store sign EOR FACSGN STA SGNCPR ;Set sign comparison LDA ARGSGN ;Retrieve MSB ORA #$80 ;Set leading bit STA ARG+1 ;Store MSB DEY LDA (INDEX),Y STA ARG ;Store exp LDA FAC ;To set status reg RTS ADEXP LDA ARG ADEX2 BEQ ZERO CLC ADC FAC BCC ADEX3 ;Branch if no overflow BMI JOV CLC ;Ok since +$80 will not ovflow HEX 2C ;Trick to branch ADEX3 BPL ZERO ;Underflow if still + ADC #$80 ;Correct for $80 displacement STA FAC BNE ADEX4 JMP AtoFACS ADEX4 LDA SGNCPR STA FACSGN RTS OUTOFRNG LDA FACSGN EOR #$FF BMI JOV ;Error if positive # ZERO PLA PLA JMP ZEROFAC ;Return 0 if negative # JOV JMP OVERFLOW * Routine to multiply FAC by 10: MUL10 JSR MOVAF ;Copy FAC to ARG TAX ;A-reg holds FAC BEQ :RET ;Exit if FAC=0 CLC ADC #2 ;Simulate *4 BCS JOV LDX #0 ;Flag we are adding things STX SGNCPR ; of same sign. JSR AD2 ;FAC*4 + ARG -> FAC INC FAC ;= mult by 2 BEQ JOV :RET RTS NUM10 HEX 8420000000 * Routine to divide ABS(FAC) by 10: DIV10 JSR MOVAF ;Copy FAC to ARG LDA #NUM10 ;Set up to put LDY #>NUM10 ; 10 in FAC LDX #0 DIV STX SGNCPR JSR MOVFM ;Put (A,Y) in FAC JMP FDIVT ;Divide ARG by FAC FDIV JSR CONUPK ;(A,Y) -> ARG FDIVT BEQ DIVZ ;ARG/FAC -> FAC JSR RNDB LDA #0 SEC SBC FAC STA FAC JSR ADEXP ;Get exp of ARG/(2*FAC) INC FAC ;*2 BEQ JOV LDX #-4 ;Looping index LDA #1 ;Bit count & partial quotient :D1 LDY ARG+1 ;Is ARG >= FAC? CPY FAC+1 BNE :D2 LDY ARG+2 CPY FAC+2 BNE :D2 LDY ARG+3 CPY FAC+3 BNE :D2 LDY ARG+4 CPY FAC+4 :D2 PHP ; carry set if so. ROL ;Bump bit count & rot quot bit BCC :D3 ;Skip until 8 bits done INX ;Bump loop index STA RESULT+3,X ;Store a quotient byte BEQ :D6 ;Branch if last one BPL :D7 ;Final exit when X=1 LDA #1 ;Reset bit count :D3 PLP ;Was ARG >= FAC? BCS :D5 ;Subtract divisor if so :D4 ASL ARG+4 ;Shift ARG one bit ROL ARG+3 ROL ARG+2 ROL ARG+1 BCS :D2 ;Branch if new ARG overflows BMI :D1 ;Check if can divide BPL :D2 ;No comparison needed :D5 TAY ;Protect partial quotient SB ARG+4;FAC+4;ARG+4 SB ARG+3;FAC+3;ARG+3 SB ARG+2;FAC+2;ARG+2 SB ARG+1;FAC+1;ARG+1 TYA JMP :D4 :D6 LDA #$40 ;Set bit count for last one BNE :D3 ;Always :D7 LUP 6 ASL --^ STA EXTRAFAC ;Last two bits to EXTRAFAC PLP JMP RES>FAC DIVZ LDX #DIVbyZRO-ERRMSG JMP ERROR RES>FAC MOVD RESULT;FAC+1 MOVD RESULT+2;FAC+3 JMP SIGNIF * Routine to get packed floating # at (A,Y) * unpack it and move it to FAC: MOVFM STA INDEX STY INDEX+1 LDY #4 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 FACSGN ;Unpack ORA #$80 STA FAC+1 DEY LDA (INDEX),Y STA FAC STY EXTRAFAC ;Y=0 RTS ;Status according to FAC MOV2F LDX #TEMP2 ;Pack FAC into TEMP2 HEX 2C ;Trick to branch to MOVML MOV1F LDX #TEMP1 ;Pack FAC into TEMP1 MOVML LDY #0 ;High byte of dest adrs=0 BEQ MOVMF SETFOR LDX FORPNT ;Called by LET and NEXT LDY FORPNT+1 MOVMF JSR RNDB ;Pack FAC into memory (X,Y) STX INDEX STY INDEX+1 LDY #4 LDA FAC+4 STA (INDEX),Y DEY LDA FAC+3 STA (INDEX),Y DEY LDA FAC+2 STA (INDEX),Y DEY LDA FACSGN ORA #$7F AND FAC+1 STA (INDEX),Y DEY LDA FAC STA (INDEX),Y STY EXTRAFAC ;Y=0 RTS MOVFA LDA ARGSGN ;Move ARG to FAC MFA STA FACSGN ;Entry from FPWRT to do LDX #5 ; ABS first. :L LDA ARG-1,X STA FAC-1,X DEX BNE :L STX EXTRAFAC RTS MOVAF JSR RNDB ;Round, then MAF LDX #6 ; move FAC to ARG :L LDA FAC-1,X ; including sign STA ARG-1,X DEX BNE :L STX EXTRAFAC RTN9 RTS * General purpose routine to round FAC using * the most significant bit of EXTRAFAC: RNDB LDA FAC ;Avoid if #=0 BEQ RTN9 ASL EXTRAFAC ;If EXTRAFAC is neg BCC RTN9 ; then add one bit ROUND JSR PLUSEPS ; to number in FAC. BNE RTN9 JMP FROUND ;Round if exp affected SIGN LDA FAC ;Check sign of FAC and BEQ RTN10 ; return -1,0,1 in A-reg SIGN1 LDA FACSGN ; according to result. SIGN2 ROL LDA #$FF BCS RTN10 LDA #1 RTN10 RTS SGN JSR SIGN ;Convert FAC to -1,0,1 FLOAT STA FAC+1 ;Float signed contents LDA #0 ; of A-reg. STA FAC+2 LDX #$88 ;DP 8 bits to right FLO1 LDA FAC+1 ;Entry from GIVAYF to float EOR #$FF ; 2 byte signed integer. ROL ;Set carry if + number FLO2 LDA #0 ;Entry from LINPRT to float STA FAC+4 ; 2 byte unsigned integer. STA FAC+3 STX FAC ;Set exponent STA EXTRAFAC ;Clear extra byte STA FACSGN ;Make + JMP SGNIF ;Adjust sign & most sig bit ABS LSR FACSGN ;Change sign to + RTS * Routine to compare FAC with packed # at (A,Y): FCOMP STA DEST FCOMP2 STY DEST+1 ;Entry from NEXT LDY #0 LDA (DEST),Y INY TAX BEQ SIGN ;Branch if (A,Y) is zero LDA (DEST),Y EOR FACSGN BMI SIGN1 ;Branch if different signs CPX FAC BNE :C1 ;Branch if different exponents LDA (DEST),Y ;Unpack and compare ORA #$80 CMP FAC+1 BNE :C1 INY LDA (DEST),Y CMP FAC+2 BNE :C1 INY LDA (DEST),Y CMP FAC+3 BNE :C1 INY LDA #$7F ;Use extra FAC bit to CMP EXTRAFAC ; determine carry for LDA (DEST),Y ; last compare. SBC FAC+4 BEQ RTN11 ;Exit if #s = :C1 LDA FACSGN BCC :C2 ;Branch if (A,Y) FAC. QINT LDA FAC ;Convert FAC to BEQ ZFAC ; its integer part. SEC ; Assumes FAC < 2^31. SBC #$A0 ; Result is left in BIT FACSGN ; FAC+1 to FAC+4 BPL :Q1 ; ($9E-$A2). TAX LDA #$FF STA FPGEN JSR NEG2 TXA :Q1 LDX #FAC CMP #$F9 ;More than 7 bits to shift? BPL QI2 ;Branch if not JSR SHIFT ;Do byte shift if so STY FPGEN ;Y=0 RTN11 RTS QI2 TAY ;# bits to shift LDA FACSGN AND #$80 ;Get sign LSR FAC+1 ORA FAC+1 STA FAC+1 ;Reestablish sign JSR SHFTR ;Do the shift STY FPGEN ;Y=0 RTS INT LDA FAC CMP #$A0 ;< 2^31 ? BCS RTN12 ;Exit if not JSR QINT STY EXTRAFAC ;Y=0 LDA FACSGN STY FACSGN EOR #$80 ;Test sign ROL ;Save as carry status LDA #$A0 ;Set initial exp of 2^31 STA FAC LDA FAC+4 ;Save least signif digit STA CHARAC ; for EXP and parity test JMP SGNIF ; in FPWRT. ZFAC STA FAC+1 ;INT routine needs ALL STA FAC+2 ; bytes 0 STA FAC+3 STA FAC+4 TAY ; and Y=0 RTN12 RTS * Evaluate floating point number at TXTPTR: FIN LDY #0 LDX #10 ;Zero TMPEXP to SERLEN FIN2 STY TMPEXP,X ;($99-$A3) DEX BPL FIN2 BCC NXDIGIT CMP #'-' BNE :OV STX SERLEN ;Flags neg num if - BEQ EVAL :OV CMP #'+' BNE CHKDP EVAL JSR CHRGET NXDIGIT BCC INSRTDIG CHKDP CMP #'.' BEQ SETDP CMP #'E' BNE ADJEXP JSR CHRGET ;Get exponent BCC GOGEX CMP #minus ;Neg exp? BEQ SETSGN ;Flag if so CMP #'-' ;May not be in token form BEQ SETSGN CMP #plus ;Similarly for + BEQ DPDIG CMP #'+' BEQ DPDIG BNE SGNCHK ;Number completed SETSGN ROR EXPSGN ;Flag neg exp DPDIG JSR CHRGET ;Get next exp digit GOGEX BCC GETEXP ;Branch if number SGNCHK BIT EXPSGN BPL ADJEXP LDA #0 SEC ;Negate exponent SBC EXPON JMP AEX SETDP ROR DPFLG BIT DPFLG BVC EVAL ;Branch if first "." * Appears that there should be a jump to error here. * In fact, multiple decimal points give strange results * in PRINT statements. Variable assignments correctly * give syntax errors. ADJEXP LDA EXPON ;Adjust the exponent and exit AEX SEC SBC TMPEXP STA EXPON BEQ EVDONE BPL DPRIGHT DPLEFT JSR DIV10 INC EXPON BNE DPLEFT BEQ EVDONE DPRIGHT JSR MUL10 DEC EXPON BNE DPRIGHT EVDONE LDA SERLEN ;Negative? BMI :EVD RTS :EVD JMP NEGOP INSRTDIG PHA ;Save digit BIT DPFLG ;Was there a decimal pnt? BPL :OV ;Branch if not INC TMPEXP ;Adjust if so :OV JSR MUL10 ;Dec pnt over PLA ;Add digit to left of dp SEC SBC #'0' ;Mask JSR ADDACC JMP EVAL ;Loop until done * Routine to add A-register to FAC: ADDACC PHA JSR MOVAF ;Copy FAC to ARG PLA JSR FLOAT LDA ARGSGN EOR FACSGN STA SGNCPR LDX FAC ;To signal if FAC=0 JMP FADDT GETEXP LDA EXPON ;Will new expon be > 99 CMP #10 BCC :MD ;Branch if not LDA #100 ;Too big BIT EXPSGN ;Is exp neg? BMI :SE ;If so will get 0 JMP OVERFLOW ;If not, overflow :MD ASL ;Old expon times 10 ASL CLC ADC EXPON ASL CLC LDY #0 ADC (TXTPTR),Y ;Add next digit SEC SBC #'0' ;Compensate for ASCII :SE STA EXPON JMP DPDIG HMmiTNTH HEX 9B3EBC1FFD ;99,999,999.9 BILmiONE HEX 9E6E6B27FD ;999,999,999 BILLION HEX 9E6E6B2800 ;1,000,000,000 INPRT LDA #INMSG ;Print " IN " LDY #>INMSG JSR PRSTR LDA CURLIN+1 LDX CURLIN LINPRT STA FAC+1 ;Print A,X in decimal STX FAC+2 LDX #$90 SEC JSR FLO2 PRNTFAC JSR FOUT ;Print FP # in FAC PRSTR JMP STROUT ;Print string at A,Y * Convert FAC to a string at STACK and point * A,Y to it: FOUT LDY #1 * Entry from STR$ routine puts string at $FF (Y=0) * so as to force moving string to string space: FACSTRNG LDA #'-' DEY BIT FACSGN BPL :OV INY STA STACK-1,Y :OV STA FACSGN ;Abs value STY STRNG2 INY LDA #'0' LDX FAC ;Number=0? BNE :NZ JMP WNDUP ;Finish up if so :NZ LDA #0 CPX #$80 ;Number>=1? BEQ :MB BCS :ST ;Branch if so :MB LDA #BILLION LDY #>BILLION JSR FMULT ;Move dec pnt and LDA #$F7 ; fix exp for more speed :ST STA TMPEXP :BM1 LDA #BILmiONE LDY #>BILmiONE JSR FCOMP ;Normalize between BEQ :INTPRT ; 100,000,000 and BPL :D10 ; 999,999,999 :HM LDA #HMmiTNTH LDY #>HMmiTNTH JSR FCOMP BEQ :M10 BPL :RND ;Branch if now in range :M10 JSR MUL10 DEC TMPEXP BNE :HM :D10 JSR DIV10 INC TMPEXP BNE :BM1 :RND JSR FADDH ;Round it :INTPRT JSR QINT ;Convert normal form to int LDX #1 ;DP pointer LDA TMPEXP CLC ADC #10 ;Check if num < .01 BMI :DPLOC ;Branch if - exp needed CMP #11 ;Check if num > 999,999,999 BCS :DP ;Branch if + exp needed ADC #$FF ;Subtract 1 TAX ;Point to DP location LDA #2 :DPLOC SEC ;Calculate correct exponent :DP SBC #2 STA EXPON ; 0 if no exponent STX TMPEXP ;# digits before DP TXA BEQ :PUTDP BPL :MAKSTR ;Branch if doesn't start :PUTDP LDY STRNG2 ; with DP LDA #'.' INY STA STACK-1,Y TXA BEQ :SVY LDA #'0' INY STA STACK-1,Y :SVY STY STRNG2 :MAKSTR LDY #0 ;Zero in on # while LDX #$80 ; building string. :MSL LDA FAC+4 CLC ADC DECTBL+3,Y STA FAC+4 LDA FAC+3 ADC DECTBL+2,Y STA FAC+3 LDA FAC+2 ADC DECTBL+1,Y STA FAC+2 LDA FAC+1 ADC DECTBL,Y STA FAC+1 INX ;Count in X BCS :PARITY ;Continue add/subt if BPL :MSL ; dec # pos & carry clear or BMI :CNTED :PARITY BMI :MSL ; dec # neg & carry set. :CNTED TXA BCC :DIGIT EOR #$FF ;Adjust count for case ADC #10 ; of positive dec # :DIGIT ADC #'0'-1 ;Convert count to ascii digit LUP 4 INY --^ STY VARPNT ;Save ptr to DECTBL LDY STRNG2 ;Get ptr to string INY TAX AND #$7F STA STACK-1,Y DEC TMPEXP ;Shift decimal point BNE :SAVY LDA #'.' ;Insert it at proper location INY STA STACK-1,Y :SAVY STY STRNG2 ;Save string ptr LDY VARPNT ;Get DECTBL ptr TXA EOR #$FF ;Toggle sign of X-reg AND #$80 TAX CPY #TEND-DECTBL BNE :MSL ;Loop till done LDY STRNG2 :MVBK LDA STACK-1,Y DEY CMP #'0' ;Suppress trailing 0's BEQ :MVBK CMP #'.' ;If ends in DP, write over it BEQ :NEEDEX INY :NEEDEX LDA #'+' LDX EXPON BEQ MARKEND ;Branch if no exp BPL :PUTEX ;Branch if + exp LDA #0 SEC SBC EXPON ;Negate it TAX LDA #'-' :PUTEX STA STACK+1,Y LDA #'E' STA STACK,Y TXA ;Exp to A LDX #'0'-1 ;Use X to count ASCII exp high SEC :WHATX INX SBC #10 ;Divide by 10 BCS :WHATX ADC #'0'+10 ;Adjust remainder STA STACK+3,Y ; = ASCII exp low TXA ;Get quotient STA STACK+2,Y ; = ASCII exp high LDA #0 STA STACK+4,Y ;Mark end BEQ PNTSTK WNDUP STA STACK-1,Y MARKEND LDA #0 STA STACK,Y PNTSTK LDA #STACK RTS HALF HEX 8000000000 * 32 bit hex reps of powers of 10: DECTBL HEX FA0A1F00 ;-100000000 HEX 00989680 ;10000000 HEX FFF0BDC0 ;-1000000 HEX 000186A0 ;100000 HEX FFFFD8F0 ;-10000 HEX 000003E8 ;1000 HEX FFFFFF9C ;-100 HEX 0000000A ;10 HEX FFFFFFFF ;-1 TEND = * SQR JSR MOVAF ;Compute as 1/2 power LDA #HALF LDY #>HALF JSR MOVFM ;Put 1/2 in FAC FPWRT BEQ EXP ;ARG^FAC -> FAC LDA ARG BNE :P1 JMP AtoFAC ;Set FAC=0 if ARG=0 :P1 LDX #TEMP3 LDY #0 JSR MOVMF ;Store at TEMP3 LDA ARGSGN BPL :P2 ;Branch if argument is + JSR INT ;Get INT part of exponent LDA #TEMP3 LDY #0 JSR FCOMP ;Is it an integer power? BNE :P2 TYA ;If so, allow neg argument LDY CHARAC ;Get parity (from INT) :P2 JSR MFA ;Move argument to FAC TYA ;Least signif bit can be set PHA ; only from the LDY CHARAC JSR LOG ;Get LOG(argument) LDA #TEMP3 LDY #0 JSR FMULT ;Compute expon*LOG(argum) JSR EXP ;Raise to e-th power PLA ;Was exponent a negative LSR ; odd integer? BCC RTN13 ;Return if not NEGOP LDA FAC ;Is result 0? BEQ RTN13 ;Return if so NEG FACSGN RTN13 RTS * The values indicated here are not exact since * the coefficients are adjusted for accuracy: LOGe HEX 8138AA3B29 ;LOG(e) to base 2 EXPSER DFB 7 ;Index to # of coefs: HEX 7134583E56 ;(log(2)^7)/7! HEX 74167EB31B ;(log(2)^6)/6! HEX 772FEEE385 ;(log(2)^5)/5! HEX 7A1D841C2A ;(log(2)^4)/4! HEX 7C6359580A ;(log(2)^3)/3! HEX 7E75FDE7C6 ;(log(2)^2)/2! HEX 8031721810 ;log(2) HEX 8100000000 ;1 * Because of bug in FMULT, EXP(x) is off for approx. * 1 < x < 1.00000012 and many other values, [eg., * near any integer (not too large), half integer, etc.] EXP LDA #LOGe ; e^FAC -> FAC LDY #>LOGe JSR FMULT ;Set up to compute as 2^(xLOG(e)) LDA EXTRAFAC ADC #$50 BCC :OV JSR ROUND :OV STA EXTRASV JSR MAF ;Copy to ARG LDA FAC CMP #$88 ;Within range? BCC X2 ;Branch if not OOR JSR OUTOFRNG ;Make zero or overflow X2 JSR INT ;Get integer part in FAC LDA CHARAC CLC ADC #$81 ;Second range test BEQ OOR SEC SBC #1 PHA LDX #5 X3 LDA ARG,X ;Swap ARG and FAC LDY FAC,X STA FAC,X STY ARG,X DEX BPL X3 LDA EXTRASV STA EXTRAFAC JSR FSUBT ;Subtract off integer part JSR NEGOP LDA #EXPSER LDY #>EXPSER JSR SERIES ;Use series on frac. part LDA #0 STA SGNCPR PLA JSR ADEX2 ;Add exponent of int. part RTS ODDSER STA SERPNT ;Computes ax+bx^3+cx^5+... STY SERPNT+1 ; where SERPNT points to JSR MOV1F ; coef ...c,b,a. LDA #TEMP1 ; # of coef = SERLEN+1 JSR FMULT ;Square x JSR SERMAIN ;Do series in x^2 LDA #TEMP1 ;Get x again LDY #0 JMP FMULT ;Multiply by series and exit SERIES STA SERPNT ;Computes a+bx+cx^2+... STY SERPNT+1 ; where SERPNT points to SERMAIN JSR MOV2F ; coef ...c,b,a. LDA (SERPNT),Y STA SERLEN ;Set up SERLEN from table start LDY SERPNT ; and point SERPNT to last coef INY ; (which comes first in table). TYA BNE :OV INC SERPNT+1 :OV STA SERPNT LDY SERPNT+1 :SERL JSR FMULT LDA SERPNT LDY SERPNT+1 CLC ADC #5 ;Move SERPNT to next coef BCC :NXTERM INY :NXTERM STA SERPNT STY SERPNT+1 JSR FADD ;Add next coef LDA #TEMP2 ;Get x again LDY #0 DEC SERLEN BNE :SERL ;Loop till done RTN14 RTS RNDADJ1 HEX 9835447A ;The "missing" 5th bytes here RNDADJ2 HEX 6828B146 ; account for known RND bug. RND JSR SIGN ;Get sign of argument TAX ;Remember it BMI :R1 ;If - use current FAC LDA #RNDSEED LDY #0 ;Move current seed to FAC JSR MOVFM TXA ;Recall sign BEQ RTN14 ;Exit now if RND(0) LDA #RNDADJ1 ;Mix it up LDY #>RNDADJ1 JSR FMULT LDA #RNDADJ2 ;More mixing LDY #>RNDADJ2 JSR FADD :R1 LDX FAC+4 ;Still more LDA FAC+1 ;(Interchange least and STA FAC+4 ; most significant bytes.) STX FAC+1 LDA #0 STA FACSGN ;Take abs val LDA FAC STA EXTRAFAC ;Set up extra bit "randomly" LDA #$80 ;Adjust to range 0-1 STA FAC JSR SIGNIF ;Normalize it LDX #RNDSEED ;Move FAC to rnd seed LDY #0 RD2 JMP MOVMF * Because of bug in FMULT, COS(x) is off for approx. * -.000000184 < x < .000000184, X not 0, and many * other values. COS LDA #PIhalf ;Cos(x)=sin(x + pi/2) LDY #>PIhalf JSR FADD * SIN(x) is off for x near pi/2 (but not = pi/2) * and many other places. SIN JSR MOVAF ;Copy FAC to ARG LDA #PIdoub LDY #>PIdoub LDX ARGSGN JSR DIV ;Divide by 2pi JSR MOVAF ;Copy to ARG JSR INT ;Take integer part LDA #0 ;Does nothing STA SGNCPR ; " JSR FSUBT ;Subtract to get mod(2pi) LDA #QUARTER LDY #>QUARTER JSR FSUB ;Convert argument to 1st quad LDA FACSGN ; range 0 to 1/4 as PHA ; multiples of 2pi BPL SIN1 JSR FADDH LDA FACSGN BMI SIN2 NEG SIGNFLG SIN1 JSR NEGOP SIN2 LDA #QUARTER LDY #>QUARTER JSR FADD PLA BPL :OV JSR NEGOP :OV LDA #SINSER ;Do standard sin series LDY #>SINSER JMP ODDSER TAN JSR MOV1F ;Save FAC in TEMP1 LDA #0 STA SIGNFLG JSR SIN LDX #TEMP3 LDY #0 ;Store sin at TEMP3 JSR RD2 LDA #TEMP1 LDY #0 JSR MOVFM ;Retrieve FAC LDA #0 ; and compute cos STA FACSGN LDA SIGNFLG JSR TAN2 LDA #TEMP3 ;Retrieve sin LDY #0 JMP FDIV ; and divide TAN2 PHA JMP SIN1 PIhalf HEX 81490FDAA2 PIdoub HEX 83490FDAA2 QUARTER HEX 7F00000000 * These coefficients are adjusted for accuracy: SINSER DFB 5 ;Index to # of coefs: HEX 84E61A2D1B ;(2pi)^11/11! HEX 862807FBF8 ;(2pi)^9/9! HEX 8799688901 ;(2pi)^7/7! HEX 872335DFE1 ;(2pi)^5/5! HEX 86A55DE728 ;(2pi)^3/3! HEX 83490FDAA2 ;2pi HEX A6D3C1C8D4 ;Does not appear used HEX C8D5C4CECA ;" ATN LDA FACSGN ;A modified Gregory series PHA ; is used here. (Gregory BPL :A1 ; converges too slowly) JSR NEGOP :A1 LDA FAC PHA CMP #$81 ;Normalize between 0 & 1 BCC :A2 LDA #ONE LDY #>ONE JSR FDIV :A2 LDA #ATNSER LDY #>ATNSER JSR ODDSER PLA CMP #$81 BCC :A3 LDA #PIhalf LDY #>PIhalf JSR FSUB ;Compensate for normalization :A3 PLA BPL :RET JMP NEGOP :RET RTS ATNSER DFB 11 ;Index to # of coefs: HEX 76B383BDD3 HEX 791EF4A6F5 HEX 7B83FCB010 HEX 7C0C1F67CA HEX 7CDE53CBC1 HEX 7D1464704C HEX 7DB7EA517A HEX 7D6330887E HEX 7E9244993A HEX 7E4CCC91C7 HEX 7FAAAAAA13 HEX 8100000000 * CHRGET routine (and RND seed) * to be placed at $B1 on zero page. ZPSTUFF INCR TXTPTR LDA $EA60 ;Address of no importance CMP #':' ;Return carry set if not # BCS :RET ;Z-flag set if ':' or eol CMP #' ' ;Skip spaces BEQ ZPSTUFF SEC SBC #'0' ;This code clears carry if SEC ; numeric, sets it if not, SBC #$100-'0' ; and leaves A-reg as found :RET RTS HEX 804FC75258 ;Random number seed COLDST LDX #$FF STX CURLIN+1 ;Init direct mode LDX #$FB ; and stack pointer. TXS ;Upper 4 bytes of stack used for ; link and line # in line input. LDA #COLDST LDY #>COLDST STA GOWARM+1 ;Why? These changed later! STY GOWARM+2 STA GOSTROUT+1 STY GOSTROUT+2 JSR NORMAL ;Init normal text LDA #$4C ;Set up jump locations STA GOWARM STA GOSTROUT STA JMPADRS STA USR ;USR adrs inited LDA #IQERR ; to illegal quantity LDY #>IQERR ; error routine. STA USR+1 STY USR+2 LDX #$1C ;Should be $1D? :MVZ LDA ZPSTUFF-1,X STA CHRGET-1,X STX SPEEDZ ;Init SPEED to 255 (SPEEDZ = 1) DEX BNE :MVZ STX TRCFLG ;Set NOTRACE TXA STA FPGEN ;Holds 0 except in INT routine STA LASTPT+1 ;ALWAYS holds 0 PHA ;Put 0 at $1FB, (not used!) LDA #3 ;Init DSCLEN to value STA DSCLEN ; expected by GARBAG JSR CRDO LDA #1 ;Set up fake STA IN-3 ; link of $101 STA IN-4 LDX #$55 ;Init index to temp STX TEMPPT ; string descriptors LDA #0 LDY #8 STA LINNUM STY LINNUM+1 LDY #0 :FNDMEM INC LINNUM+1 ;Test first byte of each page LDA (LINNUM),Y EOR #$FF ; until ROM or empty location STA (LINNUM),Y ; is found. CMP (LINNUM),Y BNE :MEMFND EOR #$FF ;Put back as found STA (LINNUM),Y CMP (LINNUM),Y ;Test again to make sure BEQ :FNDMEM :MEMFND LDY LINNUM LDA LINNUM+1 AND #$F0 ;Make sure it is a multiple STY MEMSIZ ; of 4K in case test faulty. STA MEMSIZ+1 STY FRETOP STA FRETOP+1 LDX #0 ;Set program pointer LDY #8 ; to $800. STX TXTTAB STY TXTTAB+1 LDY #0 STY LOCK ;Init lock byte and TYA STA (TXTTAB),Y ; program beginning byte. INCR TXTTAB LDA TXTTAB LDY TXTTAB+1 JSR REASON JSR SCRTCH * Now frustrate machine language programmers by * wasting the prime real estate at 0-5: LDA #STROUT LDY #>STROUT STA GOSTROUT+1 ;Afterthought? STY GOSTROUT+2 LDA #RESTART LDY #>RESTART STA GOWARM+1 STY GOWARM+2 JMP (GOWARM+1)