mac-rom/Toolbox/InSANE/ELEMS020_3.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

782 lines
22 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;
; File: ELEMS020_3.a
;
; Contains: xxx put contents here xxx
;
; Written by: The Apple Numerics Group
;
; Copyright: © 1990-1993 by Apple Computer, Inc., all rights reserved.
;
; This file is used in these builds: Mac32
;
; Change History (most recent first):
;
; <SM2> 2/3/93 CSS Update from Horror:
; <H2> 9/29/92 BG Rolling in Jon Okada's latest fixes.
; <1> 11/14/90 BG Added to BBS for the first time.
;
;-----------------------------------------------------------
; CHANGE HISTORY, kept for historical purposes:
;
; 30 APR 92 Filter out small magnitude inputs for all
; functions, as well as large magnitude inputs
; for ATAN function, thus avoiding spurious exceptions (JPO)
;-----------------------------------------------------------
;-----------------------------------------------------------
; Sine function.
; Input: A4 = operand T
; D1 = class (1..6) reduced by #FCINF
; Output: A4 = result
; Uses: A0-A2
;
;
; About the argument reduction: T is reduced MOD approximate pi/2,
; leaving its magnitude no bigger than approximate pi/4.
; Recall the identities:
; sin(T) = sin(T)
; sin(pi/2 + T) = cos(T)
; sin(pi + T) = -sin(T)
; sin(3pi/2 + T) = -cos(T)
; sin(2pi + T) = sin(T)
; Then if input T = q*(pi/2) + r,
; q mod 2 determines whether to use sin (0) or cos (1), and
; q mod 4 determines whether to negate result (2 or 3).
; Note that KLH takes (q + 128) mod 4; this is because of the
; braindamaged Pascal MOD function, which cannot handle a negative
; numerator.
;-----------------------------------------------------------
;-----------------------------------------------------------
SINTOP:
MOVEQ #NANTRIG,D0 ; ASSUME THE WORST
MOVEQ #0,D2 ; QUOTIENT ADJUSTMENT
SUBQ.B #1,D1 ; -1 FOR INF, 0 OR 0, ...
BGT.B @sinfin ; finite, nonzero input
BEQ RESULTDELIVERED ; SIN(+-0) IS +-0
;SINCOSCOM: ; label MOVED below <4/30/92, JPO>
BMI ERRORNAN ; INF IS ILLEGAL
;-----------------------------------------------------------
; Have finite, nonzero argument.
;-----------------------------------------------------------
@sinfin: ; label ADDED <4/30/92, JPO>
BFEXTU (A0){1:15},D0 ; |arg| < 2.0^(-32)? <4/30/92, JPO>
CMPI.W #$3FDF,D0 ; <4/30/92, JPO>
BLT TINYX ; yes, return arg <4/30/92, JPO>
SINCOSCOM: ; label MOVED from above <4/30/92, JPO>
BSR.S TRIGREDUCTION ; T <-- T REM PI/2
BTST #0,D2 ; QUO MOD 2
BNE.S @1
BSR.S SINGUTS ; EVEN, USE SIN
BRA.S @3
@1:
BSR COSGUTS ; ODD, USE COS
@3:
ANDI.W #3,D2 ; QUO MOD 4
SUBQ.W #2,D2 ; >= 0 ONLY IF MOD 2 OR 3
BMI.S @5
BCHG #7,(A4) ; NEGATE RESULT
@5:
;-----------------------------------------------------------
; Common trig finish:
; Clear uflow, except when denormalized.
; Set inexact.
; If result is denormal, set underflow.
; Exit.
;-----------------------------------------------------------
TRIGFINI:
; BSR CLEARUFLOW ; WILL CHECK FOR ERROR LATER DELETED <4/30/92, JPO>
BSR FORCEINEXACT
; PEA (A4) ; DELETED <4/30/92, JPO>
; PEA STI(A6) ; CELL I FOR RETURN CODE DELETED <4/30/92, JPO>
; ELFCLASSX ; DELETED <4/30/92, JPO>
; MOVE.W STI(A6),D0 ; -6, -5, ..., -1, 1, ..., 6 DELETED <4/30/92, JPO>
; BPL.S @11 ; DELETED <4/30/92, JPO>
; NEG.W D0 ; 1, 2, ..., 6 DELETED <4/30/92, JPO>
;@11: ; label DELETED <4/30/92, JPO>
; SUBQ.W #FCDENORM,D0 ; LEAVES ZERO IF DENORMAL DELETED <4/30/92, JPO>
; BNE.S @13 ; DELETED <4/30/92, JPO>
; BSR FORCEUFLOW ; DELETED <4/30/92, JPO>
;@13: ; label DELETED <4/30/92, JPO>
BRA RESULTDELIVERED
;-----------------------------------------------------------
;-----------------------------------------------------------
; Cosine function.
; Input: A4 = operand T
; D1 = class (1..6) reduced by #FCINF
; Output: A4 = result
; Uses: A0-A2
;
;
; About the argument reduction: T is reduced MOD approximate pi/2,
; leaving its magnitude no bigger than approximate pi/4.
; Recall the identities:
; cos(T) = cos(T)
; cos(pi/2 + T) = -sin(T)
; cos(pi + T) = -cos(T)
; cos(3pi/2 + T) = sin(T)
; cos(2pi + T) = cos(T)
; Then if input T = q*(pi/2) + r,
; q mod 2 determines whether to use cos (0) or sin (1), and
; (q+1) mod 4 determines whether to negate result (2 or 3).
; Note that KLH takes (q + 129) mod 4; this is because of the
; braindamaged Pascal MOD function, which cannot handle a negative
; numerator.
;-----------------------------------------------------------
COSTOP:
MOVEQ #NANTRIG,D0 ; ASSUME THE WORST
MOVEQ #1,D2 ; QUO ADJUSTMENT
SUBQ.B #1,D1 ; -1 FOR INF, 0 OR 0, ...
; BNE.S SINCOSCOM ; DELETED <4/30/92, JPO>
; BRA P1STUFF ; COS(+-0) IS 1 DELETED <4/30/92, JPO>
BGT.B @cosfin ; finite, nonzero input <4/30/92, JPO>
BEQ P1STUFF ; COS(+-0) = +1.0 <4/30/92, JPO>
BRA ERRORNAN ; +-INF is INVALID input <4/30/92, JPO>
@cosfin: ; label ADDED <4/30/92, JPO>
BFEXTU (A4){1:15},D0 ; |arg| < 2.0^(-32)? <4/30/92, JPO>
CMPI.W #$3FDF,D0 ; <4/30/92, JPO>
BGE.B SINCOSCOM ; no, reduce argument <4/30/92, JPO>
BRA P1XSTUFF ; yes, return 1.0 and INEXACT <4/30/92, JPO>
;-----------------------------------------------------------
; Reduce A4 mod approximate pi/2, adding quotient to D2.
; Input: A4 = operand T
; D2 = quotient adjustment
; Output: A4 = reduced argument
; D2 = adjusted quotient
; Uses: D0
;-----------------------------------------------------------
TRIGREDUCTION:
PEA FPKPI2 ; APPROXIMATE PI/2
PEA (A4) ; T
ELFREMX ; T REM (PI/2), QUO IN D0
ADD.W D0,D2
RTS
;-----------------------------------------------------------
; Evaluate sin(T) for reduced |T| <= pi/4.
; Use approximation (S = T*T) T - (T*S*(P(S) / Q(S)))
; Input: A4 = T
; Output: A4 = sin(T)
; Uses: A0-A2, cells W, X, Y
; Note use of sin/cos common routine depends on placement of Q coef table
; immediately before P coef table.
;-----------------------------------------------------------
SINGUTS:
LEA SINQ,A2 ; ADDRESS OF SIN Q TABLE
BSR.S POVERQ ; X <-- P/Q
PEA (A4) ; T
PEA (A2) ; T*T
ELFMULX ; W <-- T * (T*T)
PEA (A2) ; W = T^3
PEA (A0) ; X = P/Q
ELFMULX ; X <-- (T * (T*T)) * (P/Q)
PEA (A0) ; X
PEA (A4) ; T
ELFSUBX ; RES <-- T - (...)
RTS
;-----------------------------------------------------------
; Common routine for trig functions guts.
; Input: A4 = operand T
; A2 = ptr to Q coef table, with P immediately after in memory
; Output: cell W = T*T
; cell X = (T*T) * (P(T*T) / Q(T*T))
; A0 = X
; A2 = W
; Uses: A0, A2, cell Y
;-----------------------------------------------------------
T2POVERQ:
BSR.S POVERQ
PEA (A2) ; W = T*T
PEA (A0) ; X = P/Q
ELFMULX ; X <-- (T*T) * P(T*T) / Q(T*T)
RTS
;-----------------------------------------------------------
; Common routine for trig functions guts.
; Called by T2POVERQ and ATANGUTS.
; Input: A4 = operand T
; A2 = ptr to Q coef table, with P immediately after in memory
; Output: cell W = T*T
; cell X = P(T*T) / Q(T*T)
; A0 = X
; A2 = W
; Uses: A0, A2, cell Y
;-----------------------------------------------------------
POVERQ:
MOVEA.L A4,A0 ; T
LEA STW(A6),A1 ; W
BSR A0TOA1 ; COPY W <-- T
PEA (A1) ; W
PEA (A1) ; W
ELFMULX ; W <-- W*W = T*T
EXG A1,A2 ; A1 = Q COEF TABLE, A2 = W
LEA STY(A6),A0 ; CELL Y
BSR POLYEVAL ; EVAL Y <-- Q(T*T)
;-----------------------------------------------------------
; LEAVES A1 = P COEF TABLE
;-----------------------------------------------------------
PEA (A0) ; NEED Y FOR P/Q DIVIDE LATER
LEA STX(A6),A0 ; CELL X
BSR POLYEVAL ; EVAL X <-- P(T*T)
PEA (A0) ; X
ELFDIVX ; X <-- P(T*T) / Q(T*T)
RTS
;-----------------------------------------------------------
; Evaluate cos(T) for reduced |T| <= pi/4.
; Use approximation (S = T*T):
; (S < 1/4): 1 - S/2 + S*S*(P(S) / Q(S))
; else: with Z = |X| - 0.5
; 0.875 - (Z/2 + (Z*Z/2 - S*S*(P(S) / Q(S))))
; Input: A4 = T
; Output: A4 = cos(T)
; Uses: A0-A2, cells W, X, Y
; Note use of sin/cos common routine depends on placement of Q coef table
; immediately before P coef table.
;-----------------------------------------------------------
COSGUTS:
LEA COSQ,A2 ; COS Q COEF TABLE, P THEREAFTER
BSR.S T2POVERQ ; W <-- T*T, X <-- T*T*P/Q
PEA (A2) ; W = T*T
PEA (A0) ; X = (T*T) * P/Q
ELFMULX ; X <-- T^4 * P/Q
;-----------------------------------------------------------
; Now compare T*T in W with 1/4, to determine which formula to continue with.
;-----------------------------------------------------------
PEA FPKFOURTH ; 1/4
PEA (A2) ; W
ELFCMPX ; COMPARE AS W - 1/4
FBGTS CGBIG
;-----------------------------------------------------------
; Finish with first formula above.
;-----------------------------------------------------------
PEA FPKHALF ; 1/2
PEA (A2) ; W = T*T
ELFMULX ; W <-- T*T/2
PEA (A2) ; W
PEA (A0) ; X = T^4 * P/Q
ELFSUBX ; X <-- (T^4 * P/Q) - T*T/2
MOVEA.L A4,A1 ; A1 = RESULT
BSR A0TOA1 ; RESULT = CURRENT X
PEA FPK1 ; 1
PEA (A4) ; RESULT
ELFADDX ; RES = 1 - T*T/2 + T^4*P/Q
RTS
;-----------------------------------------------------------
; Evaluate long form of expression.
;-----------------------------------------------------------
CGBIG:
BCLR #7,(A4) ; RES <-- |T|
PEA FPKHALF ; 1/2
PEA (A4) ; RES
ELFSUBX ; RES <-- T' = |T| - 0.5
PEA (A0) ; SAVE X FOR LATER SUB
MOVEA.L A4,A0 ; RES
MOVEA.L A2,A1 ; W
BSR A0TOA1 ; W <-- T'
PEA FPKHALF ; 1/2
PEA (A1) ; W
ELFMULX ; W <-- T'/2
PEA (A1) ; W
PEA (A4) ; RES
ELFMULX ; RES <-- T'*T'/2
;-----------------------------------------------------------
; X = T^4*P/Q PUSHED ABOVE
;-----------------------------------------------------------
PEA (A4) ; RES
ELFSUBX ; RES <-- T'*T'/2 - T^4*P/Q
PEA (A1) ; W = T'/2
PEA (A4) ; RES
ELFADDX ; RES <-- T'/2 + (T'*T'/2 ...)
BCHG #7,(A4) ; RES <-- -RES
PEA FPK78 ; 0.875 = 7/8
PEA (A4) ; RES
ELFADDX ; RES <-- 0.875 + ...
RTS
;-----------------------------------------------------------
;-----------------------------------------------------------
; Tangent function.
; Input: A4 = operand T
; D1 = class (1..6) reduced by #FCINF
; Output: A4 = result
; Uses: A0-A2, D0-D2
;
;
; About the argument reduction: T is reduced MOD approximate pi/2,
; leaving its magnitude no bigger than approximate pi/4.
; Recall the identities:
; tan(T) = tan(T)
; tan(pi/2 + T) = -1/tan(T)
; tan(pi + T) = tan(T)
; Then if input T = q*(pi/2) + r,
; q mod 2 determines whether to negate and reciprocate tan.
;-----------------------------------------------------------
;-----------------------------------------------------------
TANTOP:
MOVEQ #NANTRIG,D0 ; ASSUME THE WORST
MOVEQ #0,D2 ; NO QUO ADJUSTMENT FOR TAN
SUBQ.B #1,D1 ; -1 FOR INF, 0 OR 0, ...
BMI ERRORNAN ; INF IS ILLEGAL
BEQ RESULTDELIVERED ; TAN(+-0) IS +-0
;-----------------------------------------------------------
; Have finite, nonzero argument.
;-----------------------------------------------------------
BFEXTU (A4){1:15},D0 ; |arg| < 2.0^(-32)? <4/30/92, JPO>
CMPI.W #$3FDF,D0 ; <4/30/92, JPO>
BLT TINYX ; yes, return input <4/30/92, JPO>
BSR TRIGREDUCTION
BSR.S TANGUTS
;-----------------------------------------------------------
; Check q mod 2 ...
;-----------------------------------------------------------
ROR.W #1,D2 ; C BIT <-- QUO MOD 2
BCC.S @21
BCHG #7,(A4) ; NEGATE TAN
MOVEA.L A4,A0
LEA STW(A6),A1 ; MOVE TAN FOR RECIPROCAL
BSR A0TOA1 ; W <-- -TAN
PEA (A1) ; NEED W FOR DIVIDE
LEA FPK1,A0 ; A0 = 1
MOVEA.L A4,A1 ; RES
BSR A0TOA1 ; RES <-- 1
PEA (A4) ; RES
ELFDIVX ; RES <-- -1/TAN
;-----------------------------------------------------------
; If TAN was 0 in last step, have infinity as result. In this case, copy the
; sign of the argument onto the resulting infinity. By the nature of the
; algorithm, flipping the result sign corrects the error.
;-----------------------------------------------------------
BSR TESTDIVZER
BEQ.S @21
BCHG #7,(A4)
@21:
BRA TRIGFINI
;-----------------------------------------------------------
; Evaluate tan(T) for |T| <= pi/4.
; Use formulas: (S = T*T)
; S <= 1/4: T + (T^3/3 + T^5*P(S)/Q*S))
; else: T' = (T - 3/4)/3
; T + S/4 + S*(T' + T^3*P(S)/Q(S))
;-----------------------------------------------------------
TANGUTS:
LEA TANQ,A2 ; TAN Q COEFS, P IMMED AFTER
BSR T2POVERQ ; X <-- T^2*P/Q
;-----------------------------------------------------------
; Compute T^5*P/Q, common to both formulas; save T^3 in cell Z.
;-----------------------------------------------------------
MOVEA.L A4,A0 ; RES = T
LEA STZ(A6),A1
BSR A0TOA1 ; Z = T
PEA (A2) ; W = T*T
PEA (A1) ; Z
ELFMULX ; Z = T^3
PEA (A1) ; Z = T^3
LEA STX(A6),A0
PEA (A0) ; X
ELFMULX ; T^5*P/Q
;-----------------------------------------------------------
; Compare T*T with 1/4 to decide which formula to continue.
;-----------------------------------------------------------
PEA FPKFOURTH ; 1/4
PEA (A2) ; W = T*T
ELFCMPX ; COMPARE AS W - 1/4
FBGTS TGBIG
;-----------------------------------------------------------
; Using first, simpler formula.
;-----------------------------------------------------------
PEA FPK3 ; 3
PEA (A1) ; Z = T^3
ELFDIVX ; Z <-- T^3/3
PEA (A1) ; Z
PEA (A0) ; X
ELFADDX ; X <-- T^3/3 + T^5*P/Q
BRA.S TGFIN ; GO ADD TO T AND EXIT
;-----------------------------------------------------------
; Using more complicated formula.
;-----------------------------------------------------------
TGBIG:
PEA (A0) ; SAVE X ADRS FOR LATER ADD
MOVEA.L A4,A0 ; A0 = T
LEA STY(A6),A1 ; A1 = Y
BSR A0TOA1 ; Y <-- T
PEA FPK34 ; 3/4
PEA (A1) ; Y
ELFSUBX ; Y <-- T - 3/4
PEA FPK3 ; 3
PEA (A1) ; Y
ELFDIVX ; Y <-- (T - 3/4)/3
PEA (A2) ; W = T*T
PEA (A1) ; Y = T'
ELFMULX ; Y <-- T*T*T'
;-----------------------------------------------------------
; X = T^5*P/Q ALREADY PUSHED
;-----------------------------------------------------------
PEA (A1) ; Y
ELFADDX ; Y <-- T*T*T' + T^5*P/Q
PEA FPKFOURTH ; 1/4
PEA (A2) ; W = T*T
ELFMULX ; W <-- T*T/4
PEA (A2) ; W
PEA (A1) ; Y
ELFADDX ; Y <-- T*T/4 + T*T*T'/3 + ...
MOVEA.L A1,A0 ; SET UP FOR LAST ADD...
;-----------------------------------------------------------
; Finish off tangent, adding (A0) into T in RES.
;-----------------------------------------------------------
TGFIN:
PEA (A0) ; EITHER X OR Y
PEA (A4) ; RES = T
ELFADDX ; RES <-- T + (...)
RTS
;-----------------------------------------------------------
;-----------------------------------------------------------
; Arctan(T) for any -INF <= T <= INF.
; Input: A4 = operand T
; D1 = class (1..6) reduced by #FCINF
; Output: A4 = result
; Uses: A0-A2, D0-D2
;
;
; About the argument reduction: ATAN(T) is evaluated for 0 <= T <= 1.
; Recall the identities:
; atan(T) = atan(T)
; atan(-T) = -atan(T)
; atan(1/T) = pi/2 - atan(T)
; If T < 0 then atan(-T) is computed, and the result negated.
; If |T| > 1 then atan(1/|T|) is computed, and the result subtracted from pi/2.
; To compute atan of reduced T use formulas:
; T <= ATnCons = 0.267... T - T * P(T*T) / Q(T*T)
; else T - (A + (B*P(B*B)/Q(B*B) + x2fx2))
; where x2 and x2fx2 are constants, about 0.5 and 0.05, and
; A = (T - x2)/(1 + (1/(T*x2))), and
; B = (T - x2)/(1 + (T*x2)).
;-----------------------------------------------------------
;-----------------------------------------------------------
ATANTOP:
SUBQ.B #1,D1 ; #FCINF ALREADY SUBTRACTED
; BGE.S ATFINITE ; DELETED <4/30/92, JPO>
BGT.B ATHARD ; finite, nonzero input <4/30/92, JPO>
BEQ.B ATQUICK ; ATAN(+-0) = +-0 <4/30/92, JPO>
ATPIBY2: ; label ADDED <4/30/92, JPO>
LEA FPKPI2,A0 ; GET PI/2
MOVEA.L A4,A1 ; RESULT FIELD
BSR A0TOA1
CLR.B D1 ; ISOLATE SIGN IN HI BIT
OR.W D1,(A4) ; FORCE SIGN OF RESULT
; BRA.S ATQUICK ; DELETED <4/30/92, JPO>
;ATFINITE: ; label DELETED <4/30/92, JPO>
; BNE.S ATHARD ; ZERO IF RESULT IS ZERO DELETED <4/30/92, JPO>
ATQUICK:
BRA RESULTDELIVERED
ATHARD:
BFEXTU (A4){1:15},D0 ; <4/30/92, JPO>
CMPI.W #$3FDF,D0 ; |arg| < 2.0^(-32)? <4/30/92, JPO>
BLT TINYX ; yes, return arg <4/30/92, JPO>
CMPI.W #$4040,D0 ; |arg| >= 2.0^(65)? <4/30/92, JPO>
BLT.B @athard2 ; no <4/30/92, JPO>
BSR FORCEINEXACT ; yes, force INEXACT <4/30/92, JPO>
BRA.B ATPIBY2 ; return +-pi/2 <4/30/92, JPO>
@athard2: ; label ADDED <4/30/92, JPO>
BCLR #7,(A4) ; |T|, SIGN IN D1.W
BSR.S ATANGUTS
CLR.B D1 ; CLEAR CLASS CODE
OR.W D1,(A4) ; REPLACE SIGN OF ATAN
BRA TRIGFINI
;-----------------------------------------------------------
; Use D2 to store Boolean about whether input T was inverted in order
; to obtain an argument no bigger than one.
;-----------------------------------------------------------
ATANGUTS:
MOVEQ #0,D2 ; SET TO FALSE
PEA FPK1 ; 1
PEA (A4) ; T
ELFCMPX ; COMPARE AS T-1
FBLES AGNOINV
MOVEQ #-1,D2 ; SET TO TRUE
MOVEA.L A4,A0 ; RES = T
LEA STW(A6),A1 ; CELL W
BSR A0TOA1 ; W <-- T
PEA (A1) ; ADRS OF W FOR DIV BELOW
LEA FPK1,A0 ; 1
MOVEA.L A4,A1 ; RES
BSR A0TOA1 ; RES <-- 1
PEA (A1)
ELFDIVX ; RES <-- 1/T
AGNOINV:
;-----------------------------------------------------------
; Store a copy of reduced T on stack for later.
;-----------------------------------------------------------
MOVE.L (A4)+,-(SP) ; HI ORDER LONG
MOVE.L (A4)+,-(SP) ; MED LONG
MOVE.W (A4),-(SP) ; LOW WORD
SUBQ.L #8,A4 ; RESTORE RES PTR
;-----------------------------------------------------------
; Select short or long form based on RES vs ATnCons, about 0.268.
;-----------------------------------------------------------
PEA FPKATNCONS
PEA (A4) ; RES
ELFCMPX ; COMPARE AS RES - ATNCONS
FBGTS AGLONGFORM
;-----------------------------------------------------------
; Short form.
;-----------------------------------------------------------
LEA ATANQ,A2
BSR POVERQ ; X <-- P(T*T)/Q(T*T)
PEA (A0) ; X = P(T*T)/Q(T*T)
PEA (A4) ; RES = T
ELFMULX ; RES <-- T*P/Q
BRA AGFINI
;-----------------------------------------------------------
; Long form.
;-----------------------------------------------------------
AGLONGFORM:
MOVEA.L A4,A0 ; RES = T
LEA STW(A6),A1 ; CELL W
BSR A0TOA1 ; W <-- T
PEA FPKX2 ; X2
PEA (A1) ; W = T
ELFMULX ; W <-- T*X2
PEA (A1) ; SAVE W FOR DIV BELOW
LEA FPK1,A0 ; 1
LEA STY(A6),A1 ; CELL Y
BSR A0TOA1 ; Y <-- 1
;-----------------------------------------------------------
; W = T*X2 PUSHED ABOVE
;-----------------------------------------------------------
PEA (A1) ; Y
ELFDIVX ; Y <-- 1/(T*X2)
PEA FPK1 ; 1
PEA (A1) ; Y = 1/(T*X2)
ELFADDX ; Y <-- 1 + 1/(T*X2)
PEA FPK1 ; 1
PEA STW(A6) ; W = T*X2
ELFADDX ; W <-- 1 + T*X2
PEA FPKX2 ; CONSTANT X2
PEA (A4) ; RES = T
ELFSUBX ; RES <-- T-X2
MOVEA.L A4,A0 ; RES = T-X2
LEA STZ(A6),A1 ; CELL Z
BSR A0TOA1 ; Z <-- T-X2
PEA STW(A6) ; W = 1 + T*X2
PEA (A4) ; RES = T-X2
ELFDIVX ; RES <-- (T-X2)/(1 + T*X2) = B
PEA STY(A6) ; Y = 1 + 1/(T*X2)
PEA (A1) ; Z = T-X2
ELFDIVX ; Z <-- (T-X2)/(1+1/(T*X2)) = A
LEA ATANQ,A2
BSR POVERQ ; X <-- P(B*B)/Q(B*B)
;-----------------------------------------------------------
; W <-- B*B, UNUSED
; Y <-- JUNK
; Z = A, STILL
; RES = B, STILL
;-----------------------------------------------------------
PEA (A0) ; X = P(B*B)/Q(B*B)
PEA (A4) ; RES = B
ELFMULX ; RES <-- B*P/Q
PEA FPKX2FX2 ; CONSTANT X2FX2
PEA (A4) ; RES = B*P/Q
ELFADDX ; RES <-- B*P/Q + X2FX2
PEA STZ(A6) ; Z = A
PEA (A4) ; RES = ...
ELFADDX ; RES = A + B*P/Q + X2FX2
;-----------------------------------------------------------
; Finish up by computing:
; no inversion above: T - RES in RES
; inversion above: pi/2 - (T - RES) in RES
; Remember that T was pushed onto stack earlier.
;-----------------------------------------------------------
AGFINI:
LEA STW+8(A6),A1 ; 8 BYTES INTO CELL W
MOVE.W (SP)+,(A1) ; LOW WORD
MOVE.L (SP)+,-(A1)
MOVE.L (SP)+,-(A1) ; W <-- SAVED T
PEA (A1) ; W = SAVED T
PEA (A4) ; RES
ELFSUBX ; RES - T
TST.W D2 ; NONZERO IF INVERTED
BNE.S AGSUBPI2
BCHG #7,(A4) ; NEGATE TO T-RES
RTS ; RETURN TO BELOW ATANTOP
AGSUBPI2:
PEA FPKPI2 ; PI/2
PEA (A4) ; RES
ELFADDX ; PI/2 - (T - RES)
RTS ; RETURN TO BELOW ATANTOP
;-----------------------------------------------------------
;-----------------------------------------------------------
; Random number generator. Adapted from "A More Portable FORTRAN Random
; Number Generator," Linus Schrage, ACM Transactions on Mathematical
; Software, Vol. 5, No. 2, June 1979, pp. 132-138.
;
; NextX <-- ARand * X mod PRand
; where ARand = 7^5 and PRand = 2^31-1
; X is presumed to be an integer strictly between 0 and 2^31-1.
; Input: A4 = X
; Output: A4 = NextX
; Uses: D0
;-----------------------------------------------------------
;-----------------------------------------------------------
RANDTOP:
;-----------------------------------------------------------
; convert X to longint
;-----------------------------------------------------------
MOVE.W (A4),D1 ; D1 <- exp
BMI.S OLDRAND ; punt if negative
MOVE.L 2(A4),D2 ; D2 <- sig.HI
BPL.S OLDRAND ; punt if not normalized
MOVE.L 6(A4),D0 ; D0 <- sig.LO
BNE.S OLDRAND ; punt if nonzero
MOVE.L #$401E,D0
SUB.W D1,D0 ; D0 <- right shift count
BLE.S OLDRAND ; punt if <= 0 or if > 31
CMPI #31,D0
BGT.S OLDRAND
BFINS D2,D1{0:D0}
BNE.S OLDRAND ; punt if any shift-out bit is nonzero
LSR.L D0,D2 ; D2 <- longint representation of X
MULU.L #16807,D1:D2 ; multiply by 7^5
DIVU.L #$7FFFFFFF,D1:D2 ; D1 <- (X*7^5) mod (2^31 - 1)
BFFFO D1{0:0},D2
MOVE.W #$401E,D0 ; convert longint in D1 to normalized extended
LSL.L D2,D1 ; D1 <- sig.hi
SUB.W D2,D0 ; D0.W <- sign/exp
TST.B D3 ; 96-bit extended format?
BPL.S @1 ; no. 80-bit
MOVE.W D0,-2(A4) ; yes. write sign/exp to lead word
@1:
MOVE.W D0,(A4)+ ; deliver new X sign/exp (pad word for 96-bit)
MOVE.L D1,(A4)+ ; deliver sig.HI
CLR.L (A4) ; sig.LO must be zero
;-----------------------------------------------------------
; Restore original environment since operation raised no flags
;-----------------------------------------------------------
MOVE.W STENV(A6),(FPSTATE).W
;-----------------------------------------------------------
; Clean up the regs and exit.
;-----------------------------------------------------------
MOVEM.L (SP)+,D0-D7/A0-A4 ; RESTORE ALL REGS
UNLK A6
ADDA.W (SP),SP
RTS
OLDRAND:
PEA FPKARAND
PEA (A4) ; T
ELFMULX ; RES <-- T * ARAND
PEA FPKPRAND
PEA (A4) ; RES = T * ARAND
ELFREMX ; RES <-- (T * ARAND) REM PRAND
TST.B (A4) ; IF RES < 0, MUST ADJUST UP
BPL.S @1
PEA FPKPRAND
PEA (A4)
ELFADDX ; RES <-- (...) + PRAND
@1:
BRA RESULTDELIVERED