; Copyright Xerox Corporation 1979
.TITL FLOAT
;BCPL FLOATING POINT ROUTINES
; R. Sproull
;
;Brief description of the routines:
;
;There are 32 floating-point accumulators, numbered 0-31.
;These accumulators may be loaded, stored, operated on,
;and tested with the following operations.
;
; FLD (acnumber,arg)
; Load the specified accumulator from source specified
; by arg. See below for a definition of 'arg'.
;
; FST (acnumber, ptr-to-fp-number)
; Store the contents of the accumulator into a 2-word
; packed floating point format. Error if exponent is too
; large or small to fit into the packed representation.
;
; FTR (acnumber) ==> integer
; Truncate the floating point number in the accumu-
; lator and return the integer value. Error if number
; in ac cannot fit in an integer representation.
;
; FLDI (acnumber,integer)
; Load-immediate of an accumulator with the integer
; contents (signed 2's complement).
;
; FNEG (acnumber)
; Negate the contents of the accumulator.
;
; FAD (acnumber,arg)
; Add the number in the accumulator to the number
; specified by arg and leave the result in
; the accumulator. See below for a definition of 'arg'.
;
; FSB (acnumber,arg)
; Subtract the number specified by 'arg' from the
; number in the accumulator, and leave the result
; in the accumulator.
;
; FML (acnumber,arg) [ also FMP ]
; Multiply the number specified by 'arg' by the number
; in the accumulator, and leave the result in the ac.
;
; FDV (acnumber,arg)
; Divide the contents of the accumulator by the number
; specified by arg, and leave the result in the ac.
; Error if attempt to divide by zero.
;
; FCM (acnumber,arg) ==> integer
; Compare the number in the ac with the number
; specified by 'arg'. Return
; -1 IF ARG1 < ARG2
; 0 IF ARG1 = ARG2
; 1 IF ARG1 > ARG2
;
; FSN (acnumber) ==> integer
; Return the sign of the floating point number.
; -1 if sign negative
; 0 if value is exactly 0 (quick test!)
; 1 if sign positive and number non-zero
;
; FEXP (acnumber,increment)
; Add increment to exponent of ac.
;
;For special hackers only:
; FLDV (acnumber,ptr-to-vector)
; Read the 4-element vector into the internal
; representation of a floating point number.
;
; FSTV (acnumber,ptr-to-vector)
; Write the accumulator into the 4-element vector in
; internal representation.
;
;'ARG' in the above discussion means: if the 16-bit value is
;less than the number of accumulators (32), then use the
;contents of the accumulator of that number. Otherwise,
;the 16-bit value is assumed to be a pointer to a packed
;floating-point number.
;
;All of the functions listed above that do not have "==>"
;after them return their first argument as their value.
;
;A word about the packing format:
; The first word is:
; sign -- 1 bit
; exponent -- excess 128 format (8 bits)
; will be complemented if sign negative
; mantissa -- first 7 bits
; The second word is:
; mantissa -- 16 more bits
;
;Note this format permits packed numbers to be tested for
;sign, to be compared (by comparing first words first), to
;be tested for zero (first word zero is sufficient), and
;(with some care) to be complemented.
;
;There are also some functions for dealing with 2-word
;fixed point numbers. The functions are chosen to be
;helpful to DDA scan-converters and the like.
;
;FSTDP(ac,ptr-to-dp-number)
; Stores the contents of the floating point ac into
; the specified double-precision number. First word
; of the number is the integer part, second is fraction.
; Two's complement. Error if exponent too large.
;
;FLDDP(ac,ptr-to-dp-number)
; Loads floating point ac from dp number.
;
;DPAD(a,b) => integer part of answer
; a and b are both pointers to dp numbers. The dp
; sum is formed, and stored in a.
;
;DPSB(a,b) => integer part of answer
; Same as DPAD, but subtraction.
;
;DPSHR(a) => integer part of answer
; Shift double-precision number right 1 place.
;
;If you wish to capture errors, put the address of a BCPL
;subroutine in the static FPerrprint. The routine will be
;called with one parameter:
; 0 Exponent too large -- FTR
; 1 Exponent too large -- FST
; 2 Dividing by zero -- FDV
; 3 Ac number out of range (any routine)
; 4 Exponent too large -- FSTDP
; A word about the internal format of an AC. There are four words:
; S (sign) 0 => positive; -1 => negative
; E (exponent) Signed binary exponent
; M (mantissa, high order) Normalized
; N (mantissa, low order).
; Zero is represented by S=0,M=0 (thus it is unnormalized)
.NREL ;MAKE RELOCATABLE
ACNO=40 ;NUMBER OF FLOATING-POINT ACCUMULATORS
BCPLT=1 ;TEMPORARY CELL IN FRAME OF CALLER THAT
;CAN BE USED BRIEFLY BY THE CODE.
BCPLT2=2 ;ANOTHER TEMP
;DISPATCH TABLE
.ENT FLD ;LOAD
.ENT FST ;STORE
.ENT FTR ;TRUNCATE
.ENT FLDI ;LOAD IMMEDIATE
.ENT FNEG ;NEGATE
.ENT FAD ;ADD
.ENT FSB ;SUBTRACT
.ENT FML ;MULTIPLY
.ENT FMP ; (ANOTHER VERSION OF MULTIPLY)
.ENT FDV ;DIVIDE
.ENT FCM ;COMPARE
.ENT FSN ;SIGN
.ENT FEXP ;Exponent change
.ENT FLDV ;READ
.ENT FSTV ;WRITE
.ENT FSTDP ;STORE DP
.ENT FLDDP ;LOAD DP
.ENT DPAD ;DP ADD
.ENT DPSB ;DP SUB
.ENT DPSHR ;Shift right
.ENT FPerrprint ;error printer routine
.ENT FPwork ;pointer to ac storage area
.SREL ;STATICS FOR ENTRIES, ETC.
FLD: .FLD
FST: .FST
FTR: .FTR
FLDI: .FLDI
FNEG: .FNEG
FAD: .FAD
FSB: .FSB
FML: .FML
FMP: .FML
FDV: .FDV
FCM: .FCM
FSN: .FSN
FEXP: .FEXP
FLDV: .FLDV
FSTV: .FSTV
FSTDP: .FSTDP
FLDDP: .FLDDP
DPAD: .DPAD
DPSB: .DPSB
DPSHR: .DPSHR
;POINTERS TO VARIOUS PROCEDURES
FPenter: ENTR ;entry prologue
FPaccheck: .ACCK ;check ac number
FPargcheck: .ARGCHK ;check general argument
FPerrxx: .ERR ;error printer
FPerrprint: .EPR ;dummy in case user fails to specify
FParet: .ARET ;return ac number
FPrret: .RRET ;return result in ac 0
FPwork: .WORK ;WORK AREA
.NREL
;INDICES INTO WORK AREA:
; First two entries must be in order (see WORK template)
LENGTH=0 ;Length word
WACNO=1 ;# of AC's allowed
T1=2 ;TEMPORARIES
T2=3
T3=4
T4=5
T5=6
AC0=7 ;SAVED AC 'S
AC1=10
S1=11 ;SIGN, EXPONENT,MANTISSAS FOR ARG 1
E1=12
M1=13
N1=14
S2=15 ;ARGUMENT 2
E2=16
M2=17
N2=20
AAN=21
AAM=22
TMB=23 ;4 WORDS for temporary AC
ACB=27 ;4*ACNO words for AC'S
WORKLENGTH=(4*ACNO)+27 ;Length of work area
I=100000 ;INDIRECT BIT
;%%ALTO%%
.DMR CALL =JSRII 0
.DMR JMPII =64000 ;ALSO JSRII!!
MULX=61020 ;ALTO INSTRUCTIONS
DIVX=61021
;%%NOVA%%
;.DMR CALL =JSR @0,0
;.DMR JMPII =JMP @0,0
;MULX=73301
;DIVX=73101
BCPLFRAME=370
BCPLRETN=366
;ROUTINES TO READ AND WRITE INTERNAL REPRESENTATION.
.FLDV: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
MOV 1,3 ;POINTER TO 4-ELEMENT VECTOR
LDA 0,0,3 ;GET FIRST WORD
STA 0,@S1,2 ;SAVE AS SIGN
LDA 0,1,3
STA 0,@E1,2 ;EXPONENT
LDA 0,2,3
STA 0,@M1,2
LDA 0,3,3
STA 0,@N1,2 ;LAST MANTISSA
JMPII RRET1
.FSTV: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1 ;PROCESS AC ARGUMENT
MOV 1,3
LDA 0,@S1,2 ;SIGN
STA 0,0,3
LDA 0,@E1,2 ;EXPONENT
STA 0,1,3
LDA 0,@M1,2 ;MANTISSA 1
STA 0,2,3
LDA 0,@N1,2 ;MANTISSA 2
STA 0,3,3
JMPII RRET1 ;REGULAR RETURN
; SIGN TEST
.FSN: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
LDA 0,@M1,2 ;GET MANTISSA
MOV 0,0,SNR ;CHECK FOR ZERO NUMBER
JMPII ARET1 ;IT IS 0, RETRUN 0
LDA 0,@S1,2 ;GET SIGN
MOV 0,0,SNR
INC 0,0 ;CHANGE 0 TO 1
JMPII ARET1 ;RETURN ANSWER IN 0
;COMPARE ROUTINE.
.FCM: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
CALL ARGC1
LDA 0,@S1,2 ;SIGN OF FIRST ARG
LDA 1,@S2,2 ;AND SECOND ARG
MOVL 0,0,SZC
JMP CM1N ;FIRST ARGUMENT NEGATIVE
MOVL 1,1,SZC
JMP RET1 ;SECOND ARG NEGATIVE (+ -)
MOVZL 3,3 ;TURN OFF LOW ORDER BIT OF AC3
JMP CM ;SECOND ARG POSITIVE (+ +)
CM1N: MOVL 1,1,SNC
JMP RETM1 ;SECOND ARGUMENT POSITIVE (- +)
MOVOL 3,3 ;TURN ON LOW ORDER BIT OF AC3
CM: LDA 0,@M1,2
LDA 1,@M2,2 ;GET MANTISSAS
AND# 0,1,SNR ;CHECK TO SEE IF EITHER IS 0
JMP CMZ ; YES -- ONE IS.
LDA 0,@E1,2
LDA 1,@E2,2
SUB 0,1,SZR
JMP CMA ;IF EXPONENTS NOT EQUAL, DONE
LDA 0,@M1,2
LDA 1,@M2,2
SUBO 0,1,SZR
JMP CMC ;IF FIRST MANTISSAS NOT EQUAL, DONE
LDA 0,@N1,2
LDA 1,@N2,2
SUBO 0,1,SZR
JMP CMC ;IF SECOND MANTISSAS NOT EQUAL, DONE
CMB: SUB 0,0
JMPII ARET1 ;ZERO IS THE ANSWER
CMZ: SUB# 0,1,SNR ;CHECK TO SEE WHICH IS ZERO
JMP CMB ;BOTH -- RETURN EQUALITY
COM 1,1,SKP
CMC: MOVR 1,1 ;COPY CARRY TO HIGH ORDER BIT
CMA: MOVL 1,1,SZC ;CHECK SIGN OF AC1
COM 3,3 ;COMPLEMENT 3 (ESSENTIALLY COMPUTING
;XOR OF AC1SIGN AND AC3LOWBIT)
MOVR 3,3,SZC ;NOW CHECK LOW ORDER BIT OF AC3
RET1: SUBZL 0,0,SKP ;RETURN 1
RETM1: ADC 0,0 ;MINUS 1
JMPII ARET1 ;RETURN
;NEGATE ROUTINE
.FNEG: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
LDA 0,@S1,2 ;GET SIGN
LDA 1,@M1,2 ;AND FIRST MANTISSA
MOV 1,1,SZR ;
COM 0,0 ;CHANGE SIGN IF NUMBER NOT
;ALREADY ZERO
STA 0,@S1,2
JMPII RRET1
;EXPONENT change
.FEXP: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
LDA 0,@E1,2 ;EXPONENT
ADD 1,0
STA 0,@E1,2
JMPII RRET1
;TRUNCATE
.FTR: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
LDA 0,@E1,2 ;GET EXPONENT
SUBZL 1,1 ;AC1 <= 1
SUBZL# 1,0,SZC ;IF EXPONENT <=0,
JMP CMB ;RETURN ZERO.
LDA 3,TR16 ;GET 16 DECIMAL
SUB 0,3
MOVL# 3,3,SZC
JMP FTRER ;EXPONENT TOO LARGE!
LDA 0,@M1,2 ;MANTISSA
SUBZ 1,3,SNC ;SUBTRACT 1 FROM SHIFT COUNT
JMP .+3
MOVZR 0,0
JMP .-3 ;LOOP SHIFTING
LDA 1,@S1,2 ;SIGN
MOVL 1,1,SZC
NEG 0,0 ;COMPLEMENT ANSWER
JMPII ARET1 ;RETURN ANSWER.
TR16: 16.
FTRER: CALL ERR1 ;CALL ERROR PRINTER
0 ;EXPONENT TOO LARGE
;%%ALTO%%
ACCK1: FPaccheck ;goddamned Alto microcoders that
ENTR1: FPenter ;don't allow JSRII to have index field
ARGC1: FPargcheck
RRET1: FPrret
ARET1: FParet
ERR1: FPerrxx
;%%NOVA%%
;ACCK1: @FPaccheck
;ENTR1: @FPenter
;ARGC1: @FPargcheck
;RRET1: @FPrret
;ARET1: @FParet
;ERR1: @FPerrxx
;LOAD AND STORE
.FLD: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
CALL ARGC1 ;PROCESS SECOND ARG.
LDA 0,@S2,2 ;TRANSFER SECOND ARGUMENT
STA 0,@S1,2 ;TO FIRST
LDA 0,@E2,2 ;IN ALL FOUR POSITIONS.
STA 0,@E1,2
LDA 0,@M2,2
STA 0,@M1,2
LDA 0,@N2,2
STA 0,@N1,2
JMPII RRET1 ;FINI!
;STORE
.FST: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
LDA 3,@M1,2 ;MANTISSA
LDA 0,@E1,2 ;EXPONENT
LDA 1,STBIAS ;GET EXPONENT BIAS
MOV 3,3,SZR ;IF ZERO, NO BIAS
ADD 1,0
LDA 1,STL377 ;177400
AND# 1,0,SZR
JMP FSTER ;EXPONENT TOO LARGE
AND 1,3
ADDS 3,0
MOVZR 0,0 ;SHIFT INTO POSITION,
;CARRY REMEMBERS A BIT
STA 0,T1,2 ;SAVE (MAY NEED TO BE COMPLEMENTED)
LDA 3,@N1,2
AND 1,3
LDA 0,@M1,2
COM 1,1
AND 1,0 ;SECOND 8 BITS OF MANTISSA
ADDS 3,0
MOVR 0,0 ;NOW SHIFT THE BIT IN....
LDA 1,T1,2
LDA 3,@S1,2 ;GET SIGN
MOV 3,3,SNR
JMP .+4
NEG 0,0,SNR ;DOUBLE LENGTH NEGATE
NEG 1,1,SKP
COM 1,1
LDA 3,AC1,2 ;GET SAVED SECOND ARGUMENT
STA 1,0,3 ;FIRST WORD
STA 0,1,3 ;SECOND WORD
JMPII RRET1 ;AND RETURN...
STBIAS: 200 ;EXPONDENT BIAS
STL377: 177400
FSTER: CALL ERR1 ;CALL ERROR PRINTER
1 ;EXPONENT TOO LARGE
;ARITHMETIC ROUTINES (UGH)
.FML: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
CALL ARGC1 ;GET ALL ARGUMENTS IN SHAPE
LDA 0,@E1,2
LDA 1,@E2,2
ADD 1,0 ;ADD EXPONENTS, LIKE IN ANY MULTIPLY
STA 0,@E1,2
LDA 0,@S1,2
LDA 1,@S2,2
MOV 1,1,SZR ;AND XOR SIGNS
COM 0,0
STA 0,@S1,2
MOV 2,3 ;*** PUT BASE REGISTER IN 3 ***
SUB 0,0 ;CLEAR AC0
LDA 1,@M1,3
LDA 2,@N2,3
MULX ;HIGH*LOW
STA 0,T1,3 ;SAVE HIGH ORDER 16 BITS
SUB 0,0 ;CLEAR 0
LDA 1,@M2,3
LDA 2,@N1,3
MULX ;OTHER HIGH*OTHER LOW
LDA 1,T1,3
ADDZ 1,0 ;ADD RESULTS, SET CARRY IF OVL
LDA 1,@M1,3 ;HIGH
LDA 2,@M2,3 ;HIGH
MULX ;HIGH*HIGH (PLUS STUFF LEFT IN AC0!)
MOV 0,0,SZC ;IF LOW+LOW RESULTED INA CARRY,
INC 0,0 ;NOW IS THE TIME TO ADD IT IN
;NOW CHECK NORMALIZATION
MOVL# 0,0,SZC
JMP .+5
MOVZL 1,1 ;SHIFT LEFT LOW BITS
MOVL 0,0 ;AND HIGH BITS
DSZ @E1,3 ;DECREMENT EXPONENT TO ACCOUNT
MOV 0,0 ;IF IT DOES NOT SKIP
;NOW CHECK ZERO RESULT.
MOV 0,0,SZR ;IF HIGH BITS ZERO, TROUBLE.
JMP .+3
STA 0,@E1,3
STA 1,@S1,3 ;THAT IS ZERO.
;STORE RESULTS.
STA 0,@M1,3
STA 1,@N1,3
MOV 3,2
JMPII RRET1 ;AND RETURN.
.FDV: STA 3,BCPLT,2
CALL ENTR1
CALL ACCK1
CALL ARGC1
LDA 1,@M2,2 ;GET DIVISOR MANTISSA
MOV 1,1,SNR ;CHECK FOR ZERO.
JMP DIVER ;YES -- DIVIDE ERROR.
LDA 0,@E2,2 ;SUBTRACT EXPONENTS
LDA 1,@E1,2
SUB 0,1
STA 1,@E1,2 ;
LDA 0,@S1,2
LDA 1,@S2,2 ;XOR SIGNS
MOV 1,1,SZR
COM 0,0
STA 0,@S1,2
MOV 2,3 ;*** PUT BASE REGISTER IN 3 ***
LDA 0,@M1,3
MOV 0,0,SNR ;CHECK FOR DIVIDEND ZERO.
JMP DIV0 ;YUP
LDA 1,@N1,3
LDA 2,@M2,3 ;HIGH ORDER DIVISOR
ADCZ# 0,2,SZC ;SKIPS IF AC0 GEQ AC2 UNSIGNED
JMP D0 ;IF AC0 < AC2 GO DIVIDE
MOVZR 0,0
MOVR 1,1 ;DIVIDE DIVIDEND BY TWO.
ISZ @E1,3 ;BUMP EXPONENT BECAUSE OF SHIFT
MOV# 0,0 ;NOP
D0: DIVX ;DIVIDEND/ HIGH-ORDER-DIVISOR
;GUARANTEED NOT TO OVERFLOW BECAUSE
;OF TEST A FEW LINES ABOVE
MOV# 0,0 ;ALTO DIVIDE SKIPS
STA 1,@M1,3 ;SAVE HIGH ORDER RESULTS.
SUB 1,1 ;NOW AC0&1 HAVE REMAINDER,0
DIVX ;REMAINDER/ HIGH-ORDER-DIVISOR
;NO OVERFLOW BECAUSE REMAINDER<DIVISOR
MOV# 0,0 ;ALTO DIVIDE SKIPS
STA 1,@N1,3 ;SAVE LOW ORDER RESULT.
;NOW THE ANSWER IS 'TOO BIG' BECAUSE
;LOW ORDER BITS OF DIVISOR WERE NOT
;INCLUDED. SO WE FORM CORRECTION
;TERM (N2/M2)*HIGHANS
SUB 0,0
LDA 1,@N2,3 ;LOW ORDER DIVISOR
LDA 2,@M1,3 ;HIGH ORDER ANSWER SO FAR
MULX
LDA 2,@M2,3 ;HIGH ORDER DIVISOR
ADCZ# 0,2,SZC ;CHECK TO SEE IF DIVIDE WILL OVERFLOW.
;ADCZ SKIPS IF AC0 GEQ AC2 UNSIGNED
JMP D2 ;NO -- GO DIVIDE
DSZ @M1,3 ;YES -- DECREMENT HIGH ORDER PART OF
;ANSWER (BECAUSE CORRECTION IS TO LOW
;ORDER PART). DSZ WILL NEVER SKIP.
SUB 2,0 ;AND SUBTRACT 'ONE' FROM DIVIDEND
D2: DIVX
MOV# 0,0 ;ALTO DIVIDE SKIPS
LDA 0,@N1,3 ;UNCORRECTED LOW ORDER RESULT.
SUBZ 1,0,SNC ;SUBTRACT SECOND CORRECTION
DSZ @M1,3 ;DECREASE HIGH ORDER PART TOO -- WILL
;NOT SKIP (HIGH PART NORMALIZED)
LDA 2,@M1,3 ;GET HIGH ORDER PART OF ANSWER
D3: MOVL# 2,2,SZC ;CHECK NORMALIZATION -- COULD BECOME
JMP D1 ;UNNORMALIZED BECAUSE OF EITHER 'DSZ'
MOVZL 0,0 ;CORRECTION ABOVE
MOVL 2,2
DSZ @E1,3 ;DECREMENT EXPONENT
MOV# 0,0
D1: STA 2,@M1,3 ;STORE ANSWER
STA 0,@N1,3
MOV 3,2
JMPII RRET2
DIV0: STA 0,@E1,3 ;ZERO EXPONENT
STA 0,@S1,3 ;AND SIGN
MOV 0,2
JMP D1 ;AND EXIT
DIVER: CALL ERR2
2 ;DIVIDE BY ZERO
;ADDITION AND SUBTRACTION ROUTINES (EVEN HARDER)
; SHIFT EITHER OF ARGUMENTS UNTIL THEY MATCH.
; RESULTS ARE LEFT AS FOLLOWS:
; EXPONENT -- IN E1
; MANTISSA OF ARG 1 -- IN M1,N1
; MANTISSA OF ARG 2 -- IN AAM,AAN
PRESHIFT:
STA 3,T1,2 ;SAVE RETURN ADDRESS
LDA 0,@M1,2 ;MANTISSA FOR ZERO CHECK
LDA 1,@M2,2
AND# 0,1,SNR ;IF EITHER ARGUMENT ZERO,
JMP NOSHZ ;NO SHIFT REQUIRED BECAUSE ZERO
LDA 0,@E1,2
LDA 3,@E2,2
SUB 0,3,SNR ;ARE EXPONENTS THE SAME?
JMP NOSH ;NO SHIFT
MOVL# 3,3,SZC ;CHECK SIGNS
JMP SE2 ; E2 < E1
; E1 < E2
LDA 0,@E2,2
STA 0,@E1,2 ;SHIFT UNTIL EXPONENT MATCHES E2
NEG 3,3 ;- NUMBER OF SHIFTS
LDA 0,C31 ;
ADDL# 0,3,SZC ;SEE IF TOO FAR TO SHIFT.
JSR SE4 ; YES -- FIX -- IGNORE NEXT 6 INSTRS.
LDA 0,@M1,2 ;! GET THE NUMBER
LDA 1,@N1,2 ;!
MOVZR 0,0 ;!
MOVR 1,1 ;! SHIFTED
INC 3,3,SZR ;!
JMP .-3 ;! LOOP UNTIL SHIFTS DONE.
STA 0,@M1,2
STA 1,@N1,2
NOSH: LDA 0,@M2,2 ;COPY SECOND ARGUMENT
STA 0,AAM,2
LDA 0,@N2,2
STA 0,AAN,2
JMP @T1,2 ;RETURN
NOSHZ: MOV 0,0,SZR ;IF SECOND ARGUMENT ZERO,
JMP NOSH ;JUST COPY IT TO ITS TEMPS.
LDA 0,@E2,2 ;ELSE COPY SECOND ARGUMENT'S EXPONENT
STA 0,@E1,2 ;INTO ARGUMENT 1'S, AND
JMP NOSH ;COPY ARGUMENT 2 TO ITS PLACE
SE2: LDA 0,C31
ADDL# 0,3,SZC
JSR SE4 ;TOO FAR TOOHIFT -- IGNORE 6 INSTRS.
LDA 0,@M2,2 ;! SHIFT ARG2
LDA 1,@N2,2 ;!
MOVZR 0,0 ;!
MOVR 1,1 ;!
INC 3,3,SZR ;!
JMP .-3 ;! LOOP SHIFTING
STA 0,AAM,2 ;SAVE IN SPECIAL PLACE
STA 1,AAN,2 ;TO AVOID CLOBBERING NUMBER.
JMP @T1,2
SE4: SUB 0,0 ;MAKE BOTH MANTISSAS ZERO
MOV 0,1
JMP 6,3 ;AND BYPASS THE SHIFT LOOP
C31: 37
;%%ALTO%%
ACCK2: FPaccheck ;goddamned Alto microcoders that
ENTR2: FPenter ;don't allow JSRII to have index field
ARGC2: FPargcheck
RRET2: FPrret
ARET2: FParet
ERR2: FPerrxx
;%%NOVA%%
;ACCK2: @FPaccheck
;ENTR2: @FPenter
;ARGC2: @FPargcheck
;RRET2: @FPrret
;ARET2: @FParet
;ERR2: @FPerrxx
.FAD: STA 3,BCPLT,2
CALL ENTR2
CALL ACCK2
CALL ARGC2
JSR PRESHIFT ;GO SHIFT ARGUMENTS.
LDA 0,@S1,2 ;ARG 1
LDA 1,@S2,2 ;ARG 2
MOV# 0,0,SZR
JMP AD1N ;FIRST ARG NEGATIVE
MOV# 1,1,SZR
JMP ADD2 ;SECOND ARG NEGATIVE (+ + -)
JMP ADD1 ;SECOND ARG POSITIVE (+ + +)
AD1N: MOV# 1,1,SZR
JMP ADD1 ;SECONG ARG NEGATIVE (- + -)
JMP ADD2 ;SECOND ARG POSITIVE (- + +)
.FSB: STA 3,BCPLT,2
CALL ENTR2
CALL ACCK2
CALL ARGC2
JSR PRESHIFT ;GO SHIFT ARGUMENTS.
LDA 0,@S1,2 ;ARG 1
LDA 1,@S2,2 ;ARG 2
MOV# 0,0,SZR
JMP SB1N ;FIRST ARG NEGATIVE
MOV# 1,1,SZR
JMP ADD1 ;SECOND ARG NEGATIVE (+ - -)
JMP ADD2 ;SECOND ARG POSITIVE (+ - +)
SB1N: MOV# 1,1,SZR
JMP ADD2 ;SECOND ARG NEGATIVE (- - -)
; JMP ADD1 ;SECOND ARG POSITIVE (- - +)
ADD1: LDA 0,@N1,2 ;LOW ORDER ARG 1
LDA 1,AAN,2 ;LOW ORDER ARG 2
LDA 3,@M1,2 ;HIGH ORDER ARG 1
ADDZ 1,0,SZC ;ADD LOW PARTS
INCZ 3,3 ;BUMP HIGH PART IF CARRY
LDA 1,AAM,2 ;HIGH ORDER ARG 2
ADD 3,1,SNC ;ADD HIGH PARTS
JMP .+5 ;NO CARRY
MOVR 1,1 ;POSTSHIFT
MOVR 0,0
ISZ @E1,2
MOV 0,0 ;NOP
STA 0,@N1,2 ;STORE RESULTS
STA 1,@M1,2
JMPII RRET2 ;DONE
ADD2: LDA 0,@N1,2 ;LOW ARG 1
LDA 1,AAN,2 ;LOW ARG 2
SUBZ 1,0 ;0 HAS LOW ORDER RESULT.
LDA 1,@M1,2 ;HIGH ORDER
LDA 3,AAM,2
MOV 0,0,SZC ;LOOK AT CARRY FROM SUBZ
SUBZ 3,1,SKP ;IF THERE WAS A CARRY,
;DO 2'S COMPL SUBTRACT
ADCZ 3,1 ;ELSE ONE'S COMPL SUB
MOV 0,0,SZC ;IF NO CARRY, SIGN CHANGED!!!!
JMP NORMALIZE ;CARRY -- ALL DONE.
NEG 0,0,SNR ;DOUBLE LENGTH NEGATE
NEG 1,1,SKP
COM 1,1
LDA 3,@S1,2 ;COMPLEMENT SIGN
COM 3,3
STA 3,@S1,2
NORMALIZE:
;NUMBER IN 1 (HIGH) AND 0 (LOW)
SUB 3,3 ;SHIFT COUNT
MOV 1,1,SNR ;IS HIGH ORDER PART ZERO?
JMP HIZ ;YES
NO1: MOVL# 1,1,SZC ;NORMALIZED?
JMP NO2 ;YES
MOVZL 0,0 ;LOW ORDER LEFT
MOVL 1,1
INC 3,3 ;COUNT
JMP NO1 ;AND LOOP.
HIZ: MOV 0,1,SNR ;TRY JUST USING LOW BITS
JMP ALZ ;RESULT ALL ZEROES.
LDA 3,NO16 ;16 SHIFTS DONE LIKE WILDFIRE
SUB 0,0 ;AND ZERO LOW ORDER
JMP NO1 ;REJOIN LOOP
NO16: 16.
ALZ: STA 0,@E1,2 ;ZERO EXPONENT.
STA 0,@S1,2 ;POSITIVE SIGN
NO2: STA 1,@M1,2 ;HIGH ORDER ANSWER
STA 0,@N1,2
LDA 1,@E1,2
SUB 3,1 ;ADJUST EXPONENT
STA 1,@E1,2
JMPII RRET2 ;AND RETURN.
;LOAD IMMEDIATE (OR 'LOAD INTEGER')
.FLDI: STA 3,BCPLT,2
CALL ENTR2
CALL ACCK2
LDA 0,NO16 ;GET 16 (10)
STA 0,@E1,2 ;EXPONENT
SUB 3,3
MOVL# 1,1,SNC
JMP .+3
COM 3,3 ;FLIP SIGN
NEG 1,1 ;AND NUMBER
SUB 0,0 ;LOW ORDER BITS OF MANTISSA
STA 3,@S1,2 ;STORE SIGN
JMP NORMALIZE
.FLDDP: STA 3,BCPLT,2
CALL ENTR2
CALL ACCK2
MOV 1,3 ;POINTER TO DP NUMBER
LDA 1,0,3 ;HIGH ORDER BITS
LDA 0,1,3 ;LOW
MOVL# 1,1,SNC ;CHECK SIGN.
JMP FLDP1 ;POSITIVE
NEG 0,0,SNR ;DOUBLE LENGTH NEGATE
NEG 1,1,SKP
COM 1,1
ADC 3,3,SKP ;SIGN -1
FLDP1: SUB 3,3 ;SIGN 0
STA 3,@S1,2
LDA 3,NO16 ;16 DECIMAL
STA 3,@E1,2 ;EXPONENT
JMP NORMALIZE
.FSTDP: STA 3,BCPLT,2
CALL ENTR2
CALL ACCK2
LDA 3,@E1,2 ;GET EXPONENT
LDA 0,NO16 ;16 DECIMAL
SUB 0,3 ;C(3) = - NUMBER OF SHIFTS
MOVL# 3,3,SNC ;MUST SHIFT AT LEAST 1.
JMP FSTDER ;NOPE
LDA 0,@N1,2 ;LOW BITS
LDA 1,@M1,2 ;HIGH
MOVZR 1,1 ;SHIFT LOOP
MOVR 0,0
INC 3,3,SZR
JMP .-3
LDA 3,@S1,2 ;SIGN
MOV# 3,3,SNR
JMP .+4
NEG 0,0,SNR ;COMPLEMENT DP NUMBER
NEG 1,1,SKP
COM 1,1
LDA 3,AC1,2 ;GET POINTER BACK.
STA 1,0,3 ;HIGH ORDER BITS
STA 0,1,3 ;LOW
JMPII RRET3
FSTDER: CALL ERR3
4
.DPAD: STA 3,BCPLT,2 ;..
STA 1,BCPLT2,2
MOV 1,3 ;=> FIRST WORD OF ARG 2
LDA 1,1,3 ; WORD 2 ARG 2
MOV 0,3
LDA 0,1,3 ; WORD 2 ARG 1
ADDZ 1,0 ; SETS CARRY IF OVERFLOW
STA 0,1,3 ; WORD 2 ARG 1
LDA 0,0,3 ; WORD 1 ARG 1
LDA 1,@BCPLT2,2 ; WORD 1 ARG 2
MOV 0,0,SZC ; INCLUDE CARRY
INC 0,0
ADD 1,0
STA 0,0,3 ; WORD 1 OF ARG 1
LDA 3,BCPLT,2
JMP 1,3 ;RETURN INTEGER PART...
.DPSB: STA 3,BCPLT,2 ;..
STA 1,BCPLT2,2
MOV 1,3 ;=> FIRST WORD OF ARG 2
LDA 1,1,3 ; WORD 2 ARG 2
MOV 0,3
LDA 0,1,3 ; WORD 2 ARG 1
SUBZ 1,0 ; SETS CARRY IF OVERFLOW
STA 0,1,3 ; WORD 2 ARG 1
LDA 0,0,3 ; WORD 1 ARG 1
LDA 1,@BCPLT2,2 ; WORD 1 ARG 2
MOV 0,0,SZC ; INCLUDE CARRY
INC 0,0
ADC 1,0
STA 0,0,3 ; WORD 1 OF ARG 1
LDA 3,BCPLT,2
JMP 1,3 ;RETURN INTEGER PART...
.DPSHR: STA 3,BCPLT,2
MOV 0,3 ;SAVE POINTER TO NUMBER
LDA 0,0,3 ;HIGH ORDER PART
MOVL# 0,0,SZC ;TEST SIGN BIT
MOVOR 0,0,SKP ;SHIFT IN A 1
MOVZR 0,0 ;SHIFT IN A 0
STA 0,0,3
LDA 1,1,3 ;LOW ORDER
MOVR 1,1 ;SHIFT CARRY BIT IN
STA 1,1,3 ;AND REPLACE
LDA 3,BCPLT,2
JMP 1,3 ;RETURN INTEGER PART...
; VARIOUS INITIALIZATION ROUTINES.
ACER: CALL ERR3 ;CALL ERROR PRINTER
3 ;AC NUMBER OUT OF RANGE
;%%ALTO%%
ERR3: FPerrxx
RRET3: FPrret
;%%NOVA%%
;ERR3: @FPerrxx
;RRET3: @FPrret
;CHECK AN ARGUMENT THAT MAY BE EITHER AN AC NUMBER
;OR A POINTER TO A FLOATING POINT NUMBER
; ARG IS IN AC 1. DESTROYS ALL AC'S EXCEPT 2
.ARGCHK: STA 3,T1,2 ;SAVE RETURN ADDRESS
LDA 3,WACNO,2
SUBZ# 3,1,SZC ;skips if ac1 < ac3 unsigned
JMP ARG0 ;NOT AN AC!
LDA 3,ACBEG ;INDEX INTO WORK TABLE
ADD 2,3 ;+ WORK TABLE BASE
ADD 3,1
STA 1,S2,2 ;SIGN
LDA 3,WACNO,2
ADD 3,1
STA 1,E2,2 ;EXPONENT
ADD 3,1
STA 1,M2,2 ;MANTISSA 1
ADD 3,1
STA 1,N2,2 ;MANTISSA 2
JMP @T1,2 ;RETURN
ARG0: LDA 0,TMPAC ;INDEX IN WORK TABLE FOR TEMP AC
ADD 2,0 ;+ WORK TABLE BASE
STA 0,S2,2
INC 0,0
STA 0,E2,2
INC 0,0
STA 0,M2,2
INC 0,0
STA 0,N2,2 ;ADDRESSES SET UP.
;NOW UNPACK THE NUMBER ==> 1
MOV 1,3 ;ADDRESS OF PACKED NUMBER
LDA 0,0,3 ;FIRST WORD
LDA 1,1,3 ;SECOND WORD
SUB 3,3
MOVL# 0,0,SNC ;CHECK SIGN
JMP .+5 ;POSITIVE
COM 3,3
NEG 1,1,SNR ;DOUBLE PRECISION NEGATE
NEG 0,0,SKP
COM 0,0
MOVZL 1,1
MOVL 0,0 ;HIGH 8 BITS OF AC0 ARE EXPONENT
STA 3,@S2,2 ;SAVE SIGN
LDA 3,M377
ANDS 1,3
STA 3,@N2,2 ;LOW 8 BITS OF MANTISSA
LDA 3,Q377
AND 3,1
COM 3,3
AND 0,3
ADDS 1,3
STA 3,@M2,2 ;HIGH 16 BITS OF MANTISSA
LDA 1,Q377
ANDS 1,0
LDA 1,BIAS
MOV 3,3,SZR ;IF MANTISSA IS NOT ZERO,
SUB 1,0 ;BIAS THE EXPONENT
STA 0,@E2,2 ;SAVE EXPONENT
JMP @T1,2 ;RETURN...
M377: 377 ;RIGHT HALF
Q377: 177400 ;LEFT HALF
BIAS: 200 ;EXPONENT BIAS
;EXIT ROUTINES:
; ARET -- RETURN FIRST ARGUMENT
; RRET -- RETURN CONTENTS OF AC0
ZRET: SUB 0,0,SKP ;RETURN ZERO
.RRET: LDA 0,AC0,2 ;RESTORE FIRST ARGUMENT
.ARET: LDA 2,CALLER ;GET FRAME
LDA 3,BCPLT,2 ;RETURN ADDRESS
JMP 1,3 ;SKIP RETURN!!!
;ENTRY PROLOGUE -- PRESERVES CONTENTS OF AC0 AND AC1
ENTR: STA 2,CALLER ;SAVE CALLER FRAME POINTER
LDA 2,@LCON ;POINTER TO MY WORK AREA
STA 0,AC0,2 ;SAVE PARAMETERS
STA 1,AC1,2
JMP 0,3 ;RETURN.
LCON: FPwork ;POINTER TO STATIC FOR WORK AREA
;CHECK AN ARGUMENT THAT IS SUPPOSED TO BE
;AN ACCUMULATOR NUMBER
; ARGUMENT IN AC0. PRESERVES AC1
.ACCK: STA 3,T1,2 ;RETURN ADDRESS
LDA 3,WACNO,2
SUBZ# 3,0,SZC ;AC NUMBER IN RANGE? (skips if ac0 < ac3)
JMP ACER ;ERROR
LDA 3,ACBEG ;FIRST LOCATION OF AC SAVE AREA.
ADD 2,3 ;+ WORK TABLE ADDRESS
ADD 3,0
STA 0,S1,2 ;POINTER TO SIGN
LDA 3,WACNO,2 ;GET NUMBER OF AC'S
ADD 3,0
STA 0,E1,2 ;EXPONENT
ADD 3,0
STA 0,M1,2 ;MANTISSA 1
ADD 3,0
STA 0,N1,2 ;MANTISSA 2
JMP @T1,2 ;RETURN.
CALLER: 0 ;CALLER'S BCPL FRAME
TMPAC: TMB ;INDEX IN WORK AREA OF TEMP AC
ACBEG: ACB ;INDEX IN WORK AREA OF AC'S
;ERROR PRINTING MECHANISM
;
.EPR: JMP 1,3 ;DUMMY ERROR PRINTER
;COME HERE ON ERROR
; ERROR NUMBER IMBEDDED UNDER CALL
.ERR: LDA 0,0,3 ;ERROR CODE TO AC 0
LDA 2,CALLER ;GET CALLER FRAME
LDA 3,BCPLT,2 ;RETURN ADDRESS
JSR @BCPLFRAME ;DEPENDS ON @(AC3) =1 OR 2!!!!!
6
MOV 0,0
LDA 0,4,2 ;GET ARGUMENT TO ERROR.
CALL .ERRA ;CALL USER'S ROUTINE
1 ;1 ARGUMENT
JSR @BCPLRETN
;%%ALTO%%
.ERRA: FPerrprint
;%%NOVA%%
;.ERRA: @FPerrprint
;********** WORK AREA AND OTHER GOODIES ****************
.WORK: WORKLENGTH ;LENGTH OF WORK AREA
ACNO ;number of AC's
.BLK WORKLENGTH-2
.END