```; 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.
;
;	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.
;
;	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 FST		;STORE
.ENT FTR		;TRUNCATE
.ENT FNEG		;NEGATE
.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 FSTV		;WRITE
.ENT FSTDP		;STORE DP
.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
FSB:	.FSB
FML:	.FML
FMP:	.FML
FDV:	.FDV
FCM:	.FCM
FSN:	.FSN
FEXP:	.FEXP
FLDV:	.FLDV
FSTV:	.FSTV
FSTDP:	.FSTDP
FLDDP:	.FLDDP
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
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
STA	0,@S1,2
JMPII	RRET1

;EXPONENT change

.FEXP:	STA	3,BCPLT,2
CALL	ENTR1
CALL	ACCK1
LDA	0,@E1,2	;EXPONENT
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

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

.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
LDA	1,STL377 ;177400
AND#	1,0,SZR
JMP	 FSTER	;EXPONENT TOO LARGE
AND	1,3
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
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
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
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
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:
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
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

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
MOV#	1,1,SZR
JMP	 ADD2	;SECOND ARG NEGATIVE (+ + -)
JMP	ADD1	;SECOND ARG POSITIVE (+ + +)
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
INCZ	3,3	;BUMP HIGH PART IF CARRY
LDA	1,AAM,2	;HIGH ORDER ARG 2
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
STA	1,@E1,2
JMPII	RRET2	;AND RETURN.

.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
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

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
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
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
STA	1,S2,2	;SIGN
LDA	3,WACNO,2
STA	1,E2,2	;EXPONENT
STA	1,M2,2	;MANTISSA 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
;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
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
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

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.
STA	0,S1,2	;POINTER TO SIGN
LDA	3,WACNO,2	;GET NUMBER OF AC'S
STA	0,E1,2	;EXPONENT
STA	0,M1,2	;MANTISSA 1
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
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

```