mac-rom/Toolbox/SANE/881Elems68K1.a
Elliot Nunn 4325cdcc78 Bring in CubeE sources
Resource forks are included only for .rsrc files. These are DeRezzed into their data fork. 'ckid' resources, from the Projector VCS, are not included.

The Tools directory, containing mostly junk, is also excluded.
2017-12-26 09:52:23 +08:00

915 lines
22 KiB
Plaintext

;
; File: 881Elems68K1.a
;
; Contains: Elems68K implementation for machines using an MC68881.
;
; Copyright: © 1983-1991 by Apple Computer, Inc., all rights reserved.
;
; This file is used in these builds: Mac32
;
; Change History (most recent first):
;
; <4> 5/21/91 gbm Nail a couple of warnings
; <3> 9/15/90 BG Removed <2>. 040s are behaving more reliably now.
; <2> 7/4/90 BG Added EclipseNOPs to deal with flakey 040s.
; <1.1> 11/11/88 CCH Fixed Header.
; <1.0> 11/9/88 CCH Adding to EASE.
; <1.1> 5/16/88 BBM FBcc -> FBccL (new macros that donÕt conflict w/ 881) <1.1>
; <1.0> 2/12/88 BBM Adding file for the first time into EASEÉ
; 2/4/87 -S.McD. MC68881 directive caused branches to be wrong.
; 1/24/87 -S.McD. now call HLock instead of setting bit
; 1/24/87 -S.McD. changed version number from 1 to 6 (B3 roms were 5).
; 1/24/87 -S.McD. POLYEVAL now uses FP0 & FP1 and 96bit coeffs.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File: 881Elems68K1.a
;; Implementation of Elems68K for machines using the Motorola MC68881
;; Copyright Apple Computer, Inc. 1983,1984,1985,1986,1987
;; All Rights Reserved
;; Confidential and Proprietary to Apple Computer,Inc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; There are four logarithm functions: LN(x), LOG2(x), LN(1+x), and LOG2(1+x).
; They share much of the same code, but are distinguished by two bits.
; In the same way, EXP(x), EXP2(x), EXP(x)-1, EXP2(x)-1 share the same
; startup code.
;
BLANKS ON
STRING ASIS
BTLOGBASE2 EQU 1 ; SET IF EITHER LOG2(X) OR LOG2(1+X)
; SET IF EITHER EXP2(X) OR EXP2(X)-1
BTLOG1PLUSX EQU 2 ; SET IF EITHER LN(1+X) OR LOG2(1+X)
; SET IF EITHER EXP(X)-1 OR EXP2(X)-1
;
; When ELEMS68 is entered the stack has the form:
; ret adrs < opcode word < dst adrs < src adrs < src2 adrs
; with a second source address only in the case of the financial functions
; Compound and Annuity. A LINK is made through A6 (leaving A5 intact for
; the debugger people) and the following stack frame is set up:
;
; ......
; source2 address -- only if Compound or Annuity
; source address -- for Comp., Ann., X^I, X^Y
; destination address
; opcode word
; return address -- top of stack on entry to ELEMS68
; saved A6 -- for LINK, pntd to by A6 throughout ELEMS68
; environment word -- slot to save user's env across ELEMS68
; I -- word for integer temporary
; J -- word...
; W -- 5 words for extended temporary
; X -- 5 words...
; Y -- 5 words...
; Z -- 5 words...
; saved D0-D7/A0-A4 -- done with MOVEM.L after LINK
;
; After the operand addresses are fetched, the return address is written
; onto the deepest operand address, and the high word of the return address
; (the top of stack after the UNLK) is set to the number of bytes down to
; the relocated return address. To see how simple the subsequent exit
; procedure is, look at the code below label RESULTDELIVERED.
;
; The following constants index the stack frame off of A6:
;
STSRC2 EQU 18 ; SOURCE2
STSRC EQU 14 ; SOURCE
STDST EQU 10 ; DESTINATION
STOPCODE EQU 8 ; OPCODE WORD
STRET EQU 4 ; RETURN ADDRESS
STA5 EQU 0 ; SAVED A6
STENV EQU -2 ; ENVIRONMENT SLOT
STI EQU -4 ; I
STJ EQU -6 ; J
STW EQU -16 ; W
STX EQU -26 ; X
STY EQU -36 ; Y
STZ EQU -46 ; Z
STLOCK EQU -48 ; HIGH WORD OF HANDLE
STFRAMESIZE EQU -48 ; SIZE OR FRAME FROM LINK
;
; The following constants give the number of stack bytes to pop before exit.
;
KI1ADRS EQU 6 ; OLD RET AND OPCODE
KI2ADRS EQU 10 ; OLD RET, OPCODE, DST
KI3ADRS EQU 14 ; OLD RET, OPCODE, DST, SRC
;
; The opword is defined as:
; XY00 0000 NNNN NNN0
; where X=1 for 2- or 3-address functions, Y=1 for 3-address functions,
; and <NNNN NNN0> is the index into the jump table for the specific
; instruction.
;
OP2ADRS EQU 15 ; SET IF 2-ADRS
OP3ADRS EQU 14 ; SET IF 3-ADRS
OPMASK EQU $00FE ; MASK FOR JUMP TABLE INDEX
OPXPWRI EQU $8010 ; OPCODE FOR X^I
;
; For scaling via FSCALBX, integer argument must be kept less than the
; maximum magnitude in a 16-bit integer. When outlandish scaling is
; r.EQUired below, FSCALBX is called in units of MAXINT.
;
MAXINT EQU 32767 ; 2^15 - 1
;
; When raising extended to an integer power, do explicit multiplies when
; the exponent is smaller than some threshold. It's 255 for now.
; When the exponent exceeds this threshold, computation is done with
; log and exp.
;
SMALLEXP EQU 255
;ne 100
;
; First allocate a stack frame as described above and save registers.
; Use conditional assembly to 'protect' Lisabug from Mac Package header.
;
IF fpformac+fpfordeb THEN
BRA.S START
DC.W $00
DC.L ('PACK')
DC.W $5
DC.W $0006
ENDIF
START
LINK A6,#STFRAMESIZE ; ALLOCATE TEMP CELLS
MOVEM.L D0-D7/A0-A4,-(SP) ; PRESERVE WORKING REGS
CLR.L D3 ; ERROR BITS AND OPCODE
IF FPFORMAC THEN
IF ROMRSRC THEN
; NO HASSLE IF ROM RSRC
ELSE
MOVE.L APPPACKS+20,A0 ; HANDLE TO PACK5
;; MOVE.B (A0),STLOCK(A6) ; SAVE STATE OF LOCK BIT
;; BSET #LOCK,(A0) ; LOCK PACKAGE
_HGetState ; puts state byte in D0 -S.McD.
MOVE.B D0,STLOCK(A6) ; current state of lock bit -S.McD.
_HLock ; lock package -S.McD.
ENDIF ; ROMRSRC
ENDIF ; FORMAC
;
; Load the registers as follows:
; A4 <-- dst adrs
; D4 <-- src adrs, if any
; D5 <-- src2 adrs, if any, dst if there is none
; D3 <-- opcode word
; D2 <-- src class, if any
; D1 <-- dst/src2 class
;
; D6 <-- scratch
; D7 <-- scratch
;
; Nuisance: must avoid trying to classify the integer src to the X^I operation.
;
; Note: the assembly language class function FCLASSX returns a nonzero value
; with the sign of the input argument; the magnitude of the value is 1
; greater than the value of the Pascal enumerated type in the Elems interface.
;
; Note after the operand addresses are fetched the stack is set up for later
; exit, that is the return address is moved to the deepest available long
; word and the number of other bytes to kill is stored in the high word of
; the former return address. See the stack notes in the .EQU section above
; and the exit s.EQUence at label RESULTDELIVERED.
;
LEA STRET(A6),A3 ; POINT TO RET ADRS
LEA STOPCODE(A6),A0 ; POINT INTO STACK ARGS
MOVE.W (A0)+,D3 ; GET OPCODE
BPL.S DSTONLY ; QUICK TEST OF #OP2ADRS BIT
MOVEA.L (A0)+,A4 ; DST ADRS, ANOTHER ADRS COMING
MOVE.L (A0),D4 ; SRC TOO, BUT NO INCREMENT
BTST #OP3ADRS,D3
BNE.S HAVESRC2
;
; Get here if have src and dst operands only.
;
MOVE.L (A3),(A0) ; RET ADRS ON SRC ADRS
MOVE.W #KI2ADRS,(A3) ; STACK KILL COUNT
MOVE.L A4,D5 ; PRETEND THERE'S A SRC2
MOVEQ #15,D2 ; PRESET SRC CLASS IN CASE X^I
CMPI.W #OPXPWRI,D3 ; SPECIAL CASE WITH INTEGER OP
BEQ.S CLASSSKIP
CLASSCOM
MOVEA.L D4,A0 ; CLASSIFY SRC OPERAND
BSR.S CLASSIFY
MOVE.W D0,D2 ; SRC CLASS CODE
CLASSSKIP
BRA.S CLASSDSTORSRC2
;
; Get here if src, src2, and dst operands. Get src2 adrs and classify.
; Only Compound and Annuity have a src2.
;
HAVESRC2
ADDQ.L #4,A0 ; SKIP OVER SRC ADRS
MOVE.L (A0),D5 ; SRC2
MOVE.L (A3),(A0) ; RET ADRS ON SRC ADRS
MOVE.W #KI3ADRS,(A3) ; STACK KILL COUNT
BRA.S CLASSCOM
;
; Handy place to stick the following routine.
; Input: A0 = operand address
; Output: D0 = class code
; Uses: stack cell I to receive class
; D0.B has value 1-6 according to SNAN, QNAN, INF, ZERO, NORMAL, DENORMAL
; and the high bit D0.W (i.e. #$8000) is set according to the op's sign.
;
CLASSIFY
PEA (A0) ; EXTENDED SOURCE
PEA STI(A6) ; INTEGER DST FOR CLASS
FCLASSX ; RETURNS SIGNED 1-6
MOVE.W STI(A6),D0
BPL.S @1
NEG.W D0
ORI.W #$8000,D0 ; ISOLATE SIGN IN HIGH BIT
@1
RTS
;
; Get here in usual case of unary operator.
;
DSTONLY
MOVEQ #15,D2 ; FAKE A NON-NAN CLASS CODE
MOVE.L (A0),A4 ; DST ADRS
MOVE.L (A3),(A0) ; RET ADRS
MOVE.W #KI1ADRS,(A3) ; KILL COUNT
MOVE.L A4,D5 ; PRETEND DST IS SRC2
CLASSDSTORSRC2
MOVEA.L D5,A0 ; SRC2 OR DST ADRS
BSR.S CLASSIFY
MOVE.W D0,D1
;ne 100
;
; Now save the user's environment and set all flags and halts off and rounding
; to nearest.
; Output: Environment cell.
; Uses: cell I to hold default environment
;
PEA STENV(A6) ; A0 POINTS TO ENV SAVE SLOT
FPROCENTRY
;
; Check for NANs, either D1 (dst/src2) or D2 (src) .EQUal to 1 or 2.
; If the src is a NAN, there might be two NANs so let floating add
; determine precedence, or propagate the one NAN. If just the dst
; (or possibly src2) is a NAN, do a simple move, in order to touch
; any signaling NAN that may have appeared.
;
SUBQ.B #FCINF,D2 ; IS < 0 FOR SRC NANS
BGE.S NOT2NANS
MOVEA.L D5,A0 ; MIGHT BE DST OR SRC2
MOVEA.L A4,A1 ; ALWAYS DST ADRS
BSR.S A0TOA1 ; JUST BIT COPY
MOVE.L D4,-(SP) ; SRC ADRS
PEA (A4) ; ALWAYS DST ADRS
FADDX
BRA.S NANEXIT
NOT2NANS
SUBQ.B #FCINF,D1 ; CHECK SRC2 OR DST
BGE.S NONANS
MOVE.L D5,-(SP) ; SRC2 OR DST ADRS
PEA (A4) ; DST ADRS
FX2X
NANEXIT
BRA RESULTDELIVERED
NONANS
;ne 100
;
; Fall through to here in typical case of no NANs.
; Have dst address in A4, src address in D4, dst or src2 address in D5.
; D1 and D2 contain the dst/src2 and src class codes, decremented by
; #FCINF.
; Jump to specific routine based on opword in D3.W.
;
LIFTOFF
MOVE.W D3,D0
ANDI.W #OPMASK,D0
MOVE.W ELEMSTAB(D0),D0
;
;
;
; .WORD $FFFF ; BREAKPOINT FOR DEBUGGING
;
;
;
JMP LIFTOFF(D0)
ELEMSTAB
DC.W LOGTOP-LIFTOFF ; LNX
DC.W LOGTOP-LIFTOFF ; LOG2X
DC.W LOGTOP-LIFTOFF ; LN1X
DC.W LOGTOP-LIFTOFF ; LOG21X
DC.W EXPTOP-LIFTOFF ; EXPX
DC.W EXPTOP-LIFTOFF ; EXP2X
DC.W EXP1TOP-LIFTOFF ; EXPX - 1
DC.W EXP1TOP-LIFTOFF ; EXP2X - 1
DC.W XPWRITOP-LIFTOFF
DC.W XPWRYTOP-LIFTOFF
DC.W COMPOUNDTOP-LIFTOFF
DC.W ANNUITYTOP-LIFTOFF
DC.W SINTOP-LIFTOFF
DC.W COSTOP-LIFTOFF
DC.W TANTOP-LIFTOFF
DC.W ATANTOP-LIFTOFF
DC.W RANDTOP-LIFTOFF
;ne 100
;
; Utility to copy an extended operand from (A0) to (A1), resetting
; A1 to point to the head. Turns out not to be useful to reset A0,
; since it is always thrown away.
;
A0TOA1
MOVE.L (A0)+,(A1)+
MOVE.L (A0)+,(A1)+
MOVE.W (A0),(A1)
SUBQ.L #8,A1
RTS
;
; Utility to evaluate a polynomial using Horner's recurrence.
; Input: A0 pts to result field (preserved).
; A1 pts to coefficient table (advanced beyond table).
; A2 pts to function value (preserved).
; Uses: D0,FP0,FP1
; All operands are extended. The polynomial table consists of
; a leading word N, a positive integer giving the degree of the
; polynomial, and then (N+1) extended coefficients, starting with
; that of the leading term.
; RESULT <-- C0 initially.
; RESULT <-- (RESULT * X) + CJ for J = 1 to DEGREE
; Since A1 is advanced beyond the end of the given coefficient table,
; POLEVAL may be used successively with consecutive tables, after setting
; A1 just once.
;
POLYEVAL
MOVE.W (A1)+,D0 ; GET LOOP INDEX
;; FMOVE.X (A1)+,FP0 ; "LEADING COEF -> FP0"
DC.W $F219
DC.W $4800
ADDQ.L #6,A2 ; begin
MOVE.L (A2),-(SP)
MOVE.L -(A2),-(SP) ; "X -> FP1"
SUBQ.L #2,A2
MOVE.L (A2),-(SP)
;; FMOVE.X (SP)+,FP1 ; end
DC.W $F21F
DC.W $4880
POLYLOOP
;; FMUL.X FP1,FP0 ; ACCUM <-- ACCUM * X
DC.W $F200
DC.W $0423
SUBQ.W #1,D0
;; FADD.X (A1)+,FP0 ; ACCUM <-- ACCUM + CJ
DC.W $F219
DC.W $4822
BGT.S POLYLOOP
;; FMOVE.X FP0,-(SP) ; begin
DC.W $F227
DC.W $6800
MOVE.W (SP)+,(A0)+
ADDQ.L #2,SP ; "RESULT -> (A0)"
MOVE.L (SP)+,(A0)+
MOVE.L (SP)+,(A0)
SUBQ.L #6,A0 ; end
RTS
;
; Clear the exception flag by getting, tweaking, and restoring the
; environment word.
; Uses: D0.
;
CLEARUFLOW
MOVEQ #FBUFLOW,D0
BRA.S CLEARX
CLEAROFLOW
MOVEQ #FBOFLOW,D0
BRA.S CLEARX
CLEARINVALID
MOVEQ #FBINVALID,D0
BRA.S CLEARX
CLEARINEXACT
MOVEQ #FBINEXACT,D0
CLEARX
SUBQ.L #2,SP ; ALLOCATE WORD
PEA (SP)
FGETENV
BCLR D0,(SP) ; XCP BIT IN HI BYTE
PEA (SP)
FSETENV
CLEAREXIT
ADDQ.L #2,SP
TST.B D0 ; FINISH FOR TEST
RTS
;
; Utility to force an flag.
; Uses: D0.
;
FORCEOFLOW
MOVEQ #FBOFLOW,D0
BRA.S FORCEX
FORCEUFLOW
MOVEQ #FBUFLOW,D0
BRA.S FORCEX
FORCEDIVZER
MOVEQ #FBDIVZER,D0
BRA.S FORCEX
FORCEINVALID
MOVEQ #FBINVALID,D0
BRA.S FORCEX
FORCEINEXACT
MOVEQ #FBINEXACT,D0
FORCEX
MOVE.W D0,-(SP)
PEA (SP)
FSETXCP
BRA.S CLEAREXIT
;
; Utility to test an exception flag.
; Output: Z flag in CCR is true if flag is off, Z is false if flag is set.
;
TESTDIVZER
MOVEQ #FBDIVZER,D0
BRA.S TESTX
TESTUFLOW
MOVEQ #FBUFLOW,D0
BRA.S TESTX
TESTOFLOW
MOVEQ #FBOFLOW,D0
BRA.S TESTX
TESTINVALID
MOVEQ #FBINVALID,D0
BRA.S TESTX
TESTINEXACT
MOVEQ #FBINEXACT,D0
TESTX
MOVE.W D0,-(SP)
PEA (SP)
FTESTXCP
MOVE.B (SP),D0 ; RESULT IN HI BYTE
BRA.S CLEAREXIT
;
; Floating scalb function computes (A0) <-- (A0) * 2^(A1)
; Because of the 15-bit exponent range, just two invocations
; of FSCALBX are r.EQUired if an over/underflow is to be stimulated.
; A0, A1, and (A1) are not modified.
; Uses: cells J and Y, A3
;
SCALBXX
MOVE.W #MAXINT,STJ(A6) ; SEEDED INTEGER SLOT
LEA STY+10(A6),A3 ; BEYOND CELL Y
MOVE.L 6(A1),-(A3) ; COPY OF (A1)
MOVE.L 2(A1),-(A3)
MOVE.W (A1),-(A3)
BCLR #7,(A3) ; ABS (A1) COPY
;
; If (SP) is larger than MAXINT then do one step of scaling by MAXINT.
;
BSR.S VSMAXINT
FBGES SKIPFIRSTSCALB ; FLOATING >=
;
; Must diminish (A3) by FPKMAXINT.
;
PEA FPKMAXINT
PEA (A3)
FSUBX
TST.B (A1) ; CHECK OPERAND SIGN
BPL.S @1
NEG.W STJ(A6) ; -MAXINT IN INTEGER CELL
@1
BSR.S SCALEINT ; SCALE BY STJ(A6)
;
; If (SP) exceeds FPKMAXINT at this step, just force signed FPMAXINT.
;
SKIPFIRSTSCALB
BSR.S VSMAXINT ; (SP) VS FPMAXINT
FBGES At1 ; FLOATING >= ???? was local @1
PEA FPKMAXINT
BRA.S At3 ; ???? was local @3
At1 ; ???? was local @1
PEA (A3) ; USE REDUCED VALUE
At3 ; ???? was local @3
PEA STJ(A6) ; ADDRESS OF INT SLOT
FX2I
TST.B (A1)
BPL.S @5
NEG.W STJ(A6) ; FORCE SIGN OF INTEGER
@5
; FALL THROUGH AND EXIT
;
; Scale (A0) by integer at STJ(A6).
;
SCALEINT
PEA STJ(A6)
PEA (A0)
FSCALBX
RTS
;
; Compare STY(A6) with FPMAXINT.
;
VSMAXINT
PEA STY(A6)
PEA FPKMAXINT
FCMPX
RTS
;ne 100
;
; Logarithm functions.
; All four functions LN(x), LOG2(x), LN(1+x), and LOG2(1+x)
; are launched by common error-checking code. In the usual case
; that arithmetic is r.EQUired, the computation is cast in the form
; log2(1+z). The only difference between LN and LOG2 is that the
; former r.EQUires a final multiplication by LN(2).
;
; The four functions are distinguished by the BTLOGBASE2 and
; BDLOG1PLUSX bits as described in the .EQU section above.
;
; Since the only operand is the destination, the relevant class code
; (already diminished by FCINF in the NAN check) is in D1.
;
LOGTOP
SUBQ.B #1,D1
BPL.S LOGFINITE ; -1 FOR INF, NONNEG FOR FINITE
TST.W D1 ; CHECK SIGN BIT
BPL PINFSTUFF ; LOG(+INF) IS +INF
LOGERROR
MOVEQ #NANLOG,D0 ; ERROR CODE
BRA ERRORNAN ; LOG(-INF) IS AN ERROR
LOGFINITE
BTST #BTLOG1PLUSX,D3
BNE.S LOG1PLUSX
TST.B D1 ; 0 IF OPERAND IS 0
BEQ.S LOG0 ; -INF, WITH DIVIDE BY 0
TST.W D1 ; CHECK SIGN
BMI.S LOGERROR
BRA.S LOG2R ; COMPUTE LOG(X)
LOG1PLUSX
TST.B D1
BEQ RESULTDELIVERED ; LOG(+-0) IS +-0
PEA (A4)
PEA FPKM1
FCMPX
FBUGTS LOGERROR ; -1 > OPERAND --> ERROR
FBLTS LOG12R ; FIND LOG(1+X)
; FALL THROUGH WHEN = -1
LOG0
BRA DIVM0STUFF
; END OF SPECIAL CASES
;ne 100
;
; Compute LOG2(1+T) for some positive, finite T.
; If 1+T falls outside the range SQRT(1/2) to SQRT(2) then
; just go to the code for LOG2(S) below. Else use LOGAPPROX
; on T itself, IGNORING the sum 1+T.
;
LOG12R
;
; First compute 1+T, saving the input T in cell W.
;
MOVEA.L A4,A0 ; INPUT PTR
LEA STW(A6),A1 ; PTR TO W CELL
BSR A0TOA1 ; COPY OF INPUT IN W
PEA FPK1
PEA (A4)
FADDX ; W <-- 1+T
;
; Now compare with bounds SQRT(1/2) and SQRT(2).
;
PEA FPKSQRTHALF
PEA (A4)
FCMPX
FBULES LOG2R
PEA (A4)
PEA FPKSQRT2
FCMPX
FBLES LOG2R
;
; Input T is within the r.EQUired range so restore input value and
; just LOGAPPROX and finish up.
;
MOVEA.L A1,A0 ; STW(A6) LEFT FROM BEFORE
MOVEA.L A4,A1
BSR A0TOA1
BSR LOGAPPROX
BRA LOGFINI
;ne 100
;
; Compute LOG2(T) for some positive, finite T.
; Represent T as 2^L * Q for SQRT(1/2) <= Q <= SQRT(2).
; Then LOG2(T) is L + LOG2(Q).
; LOG2(Q) for that restricted range is computed at LOGAPPROX below.
;
LOG2R
;
; Compute LOGB(T), i.e. L, in W.
;
MOVEA.L A4,A0
LEA STW(A6),A1
BSR A0TOA1 ; COPY X TO W
PEA (A1)
FLOGBX
;
; Then scale T down to range 1 to 2. Use custom scale function with a
; floating number as the second argument.
;
BCHG #7,(A1) ; -L IN W
MOVEA.L A4,A0
BSR SCALBXX ; (A0) <-- (A0) * 2^(A1)
BCHG #7,(A1) ; BACK TO L IN W
;
; If scaled value exceeds SQRT(2), then halve T and increment L.
;
PEA FPKSQRT2
PEA (A4)
FCMPX
FBULEL At11 ; ???? was local @1 <1.1>
PEA FPK1
PEA STW(A6)
FADDX ; INCREMENT L
PEA FPK2
PEA (A4)
FDIVX ; DIVIDE T BY 2
At11 ; ???? was local @1
;
; Now must subtract 1 from (A4) in order to use LOGAPPROX,
; which approximates LOG2(1+S).
;
PEA FPK1
PEA (A4)
FSUBX
BSR LOGAPPROX
;
; Add L in. Exit via check to see whether to multiply by LN(2).
;
PEA STW(A6)
PEA (A4)
FADDX
;
; Finish up with a multiply by LN(2) if a natural log was r.EQUested.
;
LOGFINI
BTST #BTLOGBASE2,D3
BNE.S @1
PEA FPKLOGE2
PEA (A4)
FMULX ; LOG2(X) * LN(2)
@1
BRA RESULTDELIVERED
;ne 100
;
; Compute LOG2(1+S) for S between SQRT(1/2) and SQRT(2).
; Assume all special cases have been filtered out and that
; number (A4) is indeed within range.
; Let R := S / (2 + S).
; Then LOGAPPROX := R * P(R*R) / Q(R*R),
; where the coefficients are taken from LOG21P and LOG21Q.
;
; Leave cell W alone, for use by LOG2R.
; Use cell Y for R, X for R*R.
; Use (A4) for R * P(R*R); then Y for Q(R*R).
; Registers A0-A2 are used by the POLYEVAL.
;
; To avoid spurious inexact, filter out 0.
; To keep accuracy, filter out denorms.
;
LOGAPPROX
PEA (A4) ; INPUT OPERAND X
PEA STJ(A6) ; CELL J FOR CLASS
FCLASSX ; LEAVES -6, ..., 6 IN CELL J
MOVE.W STJ(A6),D0
BPL.S @1
NEG.W D0
@1
SUBQ.W #FCZERO,D0 ; QUICK EXIT IF ZERO, #FCZERO=4
BNE.S LANONZERO
RTS
LANONZERO
SUBQ.W #1,D0 ; #FCNORM=5, #FCDENORM=6
BEQ.S LANORMAL
;
; Since log2(1 + tiny) = ln(1 + tiny) / ln(2) and ln(1 + tiny) is tiny + ...
; just divide denorm by ln(2) and return. Share exit code with main computation.
;
PEA FPKLOGE2
BSR FORCEUFLOW
BRA.S LAFINI
LANORMAL
MOVEA.L A4,A0
LEA STX(A6),A1
BSR A0TOA1 ; COPY ARGUMENT TO X
PEA FPK2
PEA (A4)
FADDX ; S := S + 2
PEA (A4)
PEA (A1) ; ADRS OF CELL X
FDIVX ; X := S / S + 2
MOVEA.L A1,A0 ; ADRS OF CELL X
PEA (A1) ; TWO COPIES FOR SQUARE
PEA (A1)
LEA STY(A6),A1 ; ADRS OF CELL Y
BSR A0TOA1 ; Y := R
FMULX ; X := R * R
;
; Evaluate P(R*R) into (A4).
;
MOVEA.L A4,A0 ; RESULT SLOT
LEA LOG21P,A1 ; COEFFICIENTS OF P
LEA STX(A6),A2 ; R*R
BSR POLYEVAL ; P(R*R)
;
; Evaluate R * P(R*R) into (A4); then finished with R in Y.
;
PEA STY(A6) ; R
PEA (A4) ; P(R*R)
FMULX ; R * P(R*R)
;
; Evaluate Q(R*R) into cell Y.
;
LEA STY(A6),A0 ; RESULT SLOT
LEA LOG21Q,A1 ; COEFFICIENTS OF Q
LEA STX(A6),A2 ; R*R
BSR POLYEVAL ; Q(R*R)
;
; Be sure inexact is set (isn't it set in the course of things?) and clear
; all underflows up to the last step.
; Finally, divide (R* P(R*R)) in (A4) by Q(R*R) in cell Y.
;
BSR CLEARUFLOW
PEA STY(A6)
LAFINI
PEA (A4)
FDIVX ; (R * P(R*R)) / Q(R*R)
BSR FORCEINEXACT
RTS ; EXIT LOGAPPROX
;ne 100
;
; Trailing stubs to deal with special values to be delivered.
; It is less efficient to use a BSR.S at every label and compute the
; value's address from the return address on the stack.
;
P0STUFF
LEA FPK0,A0
BRA.S STUFFVAL
M0STUFF
LEA FPKM0,A0
BRA.S STUFFVAL
P1STUFF
LEA FPK1,A0
BRA.S STUFFVAL
M1STUFF
LEA FPKM1,A0
BRA.S STUFFVAL
DIVP0STUFF
BSR FORCEDIVZER
PINFSTUFF
LEA FPKINF,A0
BRA.S STUFFVAL
DIVM0STUFF
BSR FORCEDIVZER
MINFSTUFF
LEA FPKMINF,A0 ; AND FALL THROUGH...
STUFFVAL
MOVEA.L A4,A1 ; DST ADRS
BSR A0TOA1 ; STUFF THE VAL
STUFFEXIT
BRA.S RESULTDELIVERED
;
; Fabricate a silent NAN, set Invalid, and deliver to destination.
; D0.B should be a nonzero byte code.
;
ERRORNAN
ORI.L #$7FFF4000,D0 ; MAX EXP AND QNANBIT SET! <01APR85>
MOVE.L D0,(A4)+
CLR.L (A4)+
CLR.W (A4)
SUBQ.L #8,A4
BSR FORCEINVALID
; FALL THROUGH TO...
;ne 100
;
; Finally, a result has been placed in (A4). Restore the environment,
; signaling any r.EQUired exceptions, restore the registers,
; clean up the stack, and go. The return address has been written onto the
; deepest operand address, and the high word of the old return address is
; an integer count of the amount of stack to kill to get to the true return
; address.
;
RESULTDELIVERED
;
; Restore from environment word
;
PEA STENV(A6)
FPROCEXIT
;
; Clean up the regs and exit. Unlike foolishness of May 84, move the state of
; STLOCK(A6) back to package handle.
;
IF FPFORMAC THEN
IF ROMRSRC THEN
; NO HASSLE
ELSE
MOVE.L APPPACKS+20,A0 ; HANDLE TO PACKAGE
;; MOVE.B STLOCK(A6),(A0) ; RESTORE PREVIOUS STATE <26Mar85>
MOVE.B STLOCK(A6),D0 ; restore original state of lock bit-S.McD.
_HSetState ; returns status in D0 -S.McD.
ENDIF ; ROMRSRC
ENDIF ; FPFORMAC
MOVEM.L (SP)+,D0-D7/A0-A4 ; RESTORE ALL REGS
UNLK A6
ADDA.W (SP),SP
RTS