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