; 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