;-----------------------------------------------------------------
; Float.mu -- Microcode source for Alto running
;	XMesa and using microcode floating point.
; adapted from bcpl float microcode (Sproull, Maleson)
; Copywrite Xerox Corporation 1980
; Last modified by LStewart May 14, 1980  7:43 PM
;-----------------------------------------------------------------

#AltoConsts23.mu;

; Reserve 774-1003 for Ram Utility Area.
%7, 1777, 774, RU774, RU775, RU776, RU777, RU1000, RU1001, RU1002, RU1003;

; For the moment, just throw these locations away.  This is done only
; to squelch the "unused predef" warnings that would otherwise occur.
; If we ever run short of Ram, assign these to real instructions
; somewhere in microcode executed only by the Emulator.

RU774:	NOP;
RU775:	NOP;
RU776:	NOP;
RU777:	NOP;
RU1000:	NOP;
RU1001:	NOP;
RU1002:	NOP;
RU1003:	NOP;

; Reserve 0-17 for Task startup locations.
%17, 1777, 0, L0, L1, L2, L3, L4, L5, L6, L7, L10, L11, L12, L13, L14, L15, L16, L17;

L0:	TASK, :L0;
L1:	TASK, :L1;
L2:	TASK, :L2;
L3:	TASK, :L3;
L4:	TASK, :L4;
L5:	TASK, :L5;
L6:	TASK, :L6;
L7:	TASK, :L7;
L10:	TASK, :L10;
L11:	TASK, :L11;
L12:	TASK, :L12;
L13:	TASK, :L13;
L14:	TASK, :L14;
L15:	TASK, :L15;
L16:	TASK, :L16;
L17:	TASK, :L17;

; Entry point for IME
%1,1777,500,IMEXfer;	pre-define IMEXfer entry point, 500B

; Entry points for FP
; Ram entry vector, for access via Mesa JRAM instruction.

%1,1777,540,ucFloat;	Float
%1,1777,541,ucFix;	Fix
%1,1777,542,ucMul;	Multiply
%1,1777,543,ucDiv;	Divide
%1,1777,544,ucAdd;	Add
%1,1777,545,ucSub;	Subtract
%1,1777,546,ucFixC;	Fix to CARDINAL
%1,1777,547,ucFixI;	Fix to INTEGER

; Microcode for griffin
%1,1777,550,HBlt;	HBlt is the entry point.
%1,1777,177,MULret;

;  **** Overflow from ROM1 for XM Mesa ****


;
;	Now bring in Mesa overflow microcode
;

#XMesaRAM.mu;

;-----------------------------------------------------------------
; MISC - Miscellaneous instructions specified by alpha
;	alpha=11 => RCLK has been handled by ROM
;	T contains alpha on arrival at MISC in RAM
;-----------------------------------------------------------------

; Precisely one of the following lines must be commented out.

MISC:	L_0, SWMODE, :Setstkp;	dummy MISC implementation

;#MesaMisc.mu;	real implementation

; Microcode for griffin
#HBlt.mu;  -- entry point is 550B 

;-----------------------------------------------------------------
; IMERAM.mu - microcode for IME in RAM
; Last modified by Birrell - April 26, 1979  1:52 PM
;-----------------------------------------------------------------
; Microcode for IME

; %1,1777,500,IMEXfer;	pre-define IMEXfer entry point, 500B

IMEXfer:	L_stk4,TASK;	stack is: argL,argH,srce,sMDS,dest
	mx_L;	destination for Xfer
	L_stk2;
	my_L;	source for Xfer
	L_stkp-1,SWMODE;	pop stack
	stkp_L,:romXfer;	jump into Xfer code in ROM
;-----------------------------------------------------------------

; Microcode subroutines are defined and called from Mesa programs
; as shown in the following example:

; routineAddr: CARDINAL = 400B;  -- Ram address of microcode --
; CalluRoutine: PROCEDURE[x, y: REAL] RETURNS [z: REAL] =
;   MACHINE CODE BEGIN
;   Mopcodes.zLIW, routineAddr/256, routineAddr MOD 256;
;   Mopcodes.zJRAM;
;   END;

; []_CalluRoutine[a, b];  -- the call --

; All these routines assume they are called with a clean stack.
; Hence, an invocation such as "[]_CalluRoutine[a, b]" must be
; written as a complete statement, not as an embedded expression.
; If the routine returns a value, it must be called in a statement
; of the form "simpleVariable_Routine[args]".
; This permits the Ram subroutine to access fixed S-registers for
; arguments and return values.  It must still adjust the stack 
; pointer appropriately, however.

;Registers used internally to float microcode
;  these should all be available during execution of a mesa
;  bytecode


$LastL	$R40;	M register

; R registers
$mSAD	$R1;	mx
$N2	$R2;	saveret
$M2	$R3;	newfield
$M1	$R5;	count

$Arg1	$R7;	taskhole

$N1	$R35;	temp

$Arg0	$R36;	temp2
$ShiftCount	$R36;	entry --used only in add/sub

; S registers
$Mode	$R41;	mask --used only in add/sub
$SubRet	$R42;	unused1
$S1	$R43;	unused2  --sign
$Mxreg	$R44;	alpha
$Arg2	$R50;	unused3
$E1	$R55;	ATPreg   --exponent
$S2	$R56;	OTPreg
$E2	$R57;	XTPreg

!1,2,LowNZero1,LowZero1;	define before use!

;---------------------------------------------------------------
; returns control to emulator in Rom1
;---------------------------------------------------------------

retCom:	stkp_L;
	SWMODE;	Switch to Rom1
	L_T_0,:romnextA;	Mesa emulator entry point

;---------------------------------------------------------------
; pushes Arg0,,Arg1 and returns control to emulator in Rom1
;---------------------------------------------------------------
!17,20,LTpush0,LTpush1,LTpush2,LTpush3,LTpush4,LTpush5,LTpush6,LTpush7,LTpush8,,,,,,,;
FPdpush:	L_Arg0;
	SINK_stkp,BUS;
	T_Arg1,:LTpush0;

LTpush0:	stk1_L,L_T;
	stk0_L,:LTpushCom;
LTpush1:	stk2_L,L_T;
	stk1_L,:LTpushCom;
LTpush2:	stk3_L,L_T;
	stk2_L,:LTpushCom;
LTpush3:	stk4_L,L_T;
	stk3_L,:LTpushCom;
LTpush4:	stk5_L,L_T;
	stk4_L,:LTpushCom;
LTpush5:	stk6_L,L_T;
	stk5_L,:LTpushCom;
LTpush6:	stk7_L,L_T;
	stk6_L,:LTpushCom;
LTpush7:	NOP,:RamStkErr;	can't happen!
LTpush8:	NOP,:RamStkErr;	can't happen!
LTpushCom:	T_2;
	L_stkp+T,TASK,:retCom;

;---------------------------------------------------------------
; pushes Arg0 and returns control to emulator in Rom1
;---------------------------------------------------------------
!17,20,LUpush0,LUpush1,LUpush2,LUpush3,LUpush4,LUpush5,LUpush6,LUpush7,LUpush8,,,,,,,;
ShortRet:	SINK_stkp,BUS;
	L_Arg0,:LUpush0;

LUpush0:	stk0_L,:LUpushCom;
LUpush1:	stk1_L,:LUpushCom;
LUpush2:	stk2_L,:LUpushCom;
LUpush3:	stk3_L,:LUpushCom;
LUpush4:	stk4_L,:LUpushCom;
LUpush5:	stk5_L,:LUpushCom;
LUpush6:	stk6_L,:LUpushCom;
LUpush7:	stk7_L,:LUpushCom;
LUpush8:	NOP,:RamStkErr;	can't happen!
LUpushCom:	L_stkp+1,TASK,:retCom;

;---------------------------------------------------------------
;  Code to trap through SD in case of error
;  Pushes signword and error code.
;  Control gets to error handler with signword in next-to-TOS, code in TOS
;---------------------------------------------------------------

!17,20,LWpush0,LWpush1,LWpush2,LWpush3,LWpush4,LWpush5,LWpush6,LWpush7,LWpush8,,,,,,,;
$romKFCB$L005747,0,0;	secret definition
DoErrorReturn:
	SINK_stkp,BUS;	called with error code in L
	T_S1,:LWpush0;

LWpush0:	stk1_L,L_T;
	stk0_L,:LWpushCom;
LWpush1:	stk2_L,L_T;
	stk1_L,:LWpushCom;
LWpush2:	stk3_L,L_T;
	stk2_L,:LWpushCom;
LWpush3:	stk4_L,L_T;
	stk3_L,:LWpushCom;
LWpush4:	stk5_L,L_T;
	stk4_L,:LWpushCom;
LWpush5:	stk6_L,L_T;
	stk5_L,:LWpushCom;
LWpush6:	stk7_L,L_T;
	stk6_L,:LWpushCom;
LWpush7:	NOP,:RamStkErr;	can't happen!
LWpush8:	NOP,:RamStkErr;	can't happen!
LWpushCom:
	T_2;
	L_stkp+T,TASK;
	stkp_L;
	T_100;	construct SD index of error handler
	L_37+T,SWMODE;
	ib_L,L_0,:romKFCB;	KFCB 137B

RamStkErr:	L_2,TASK;	KFCB 2
	ib_L;
	SWMODE;
	L_0,:romKFCB;

;---------------------------------------------------------------
;multiply subroutine
;---------------------------------------------------------------

!7,10,MulRet,MulRet1,MulRet2,MulRet3;
!1,2,DOMUL,NOMUL;
!1,2,MPYL,MPYA;
!1,2,NOADDIER,ADDIER;
!1,2,NOSPILL,SPILL;
!1,2,NOADDX,ADDX;
!1,2,NOSPILLX,SPILLX;

ramMUL:	SubRet_L;
	L_Arg2-1, BUS=0;
	mSAD_L,L_0,:DOMUL;
DOMUL:	TASK,L_-10+1;
	Mxreg_L;
MPYL:	L_Arg1,BUSODD;
	T_Arg0,:NOADDIER;
NOADDIER:
	Arg1_L MRSH 1,L_T,T_0,:NOSPILL;
ADDIER:	L_T_mSAD+INCT;
	L_Arg1,ALUCY,:NOADDIER;
SPILL:	T_ONE;
NOSPILL:	Arg0_L MRSH 1;
	L_Arg1,BUSODD;
	T_Arg0,:NOADDX;
NOADDX:	Arg1_L MRSH 1,L_T,T_0,:NOSPILLX;
ADDX:	L_T_mSAD+INCT;
	L_Arg1,ALUCY,:NOADDX;
SPILLX:	T_ONE;
NOSPILLX:	Arg0_L MRSH 1;
	L_Mxreg+1,BUS=0,TASK;
	Mxreg_L,:MPYL;
NOMUL:	T_Arg0;
	Arg0_L,L_T,TASK;
	Arg1_L;
MPYA:	SINK_SubRet,BUS,TASK;
	NOP,:MulRet;

;---------------------------------------------------------------
;divide subroutine
;---------------------------------------------------------------

!7,10,DivRet,DivRet1,DivRet2;
!1,2,DODIV,NODIV;
!1,2,DIVL,ENDDIV;
!1,2,NOOVF,OVF;
!1,2,DX0,DX1;
!1,2,NOSUB,DOSUB;

ramDIV:	SubRet_L;
	T_Arg2;
	L_Arg0-T;	Do the divide only if Arg2>Arg0
	ALUCY,TASK,mSAD_L,L_0+1;
	:DODIV,mSAD_L LSH 1;	mSAD_2, count the loop by shifting
NODIV:	SINK_SubRet,BUS,TASK;
DRET:	NOP,:DivRet;
DODIV:	L_Arg0,:DIV1;
DIVL:	L_Arg0;
DIV1:	SH<0,T_Arg1;	will the left shift of the dividend overflow?
	:NOOVF,Arg0_L MLSH 1,L_T_0+T;	L_Arg1,T_0
OVF:	Arg1_L LSH 1,L_0+INCT,:NOV1;	L_1: shift overflowed
NOOVF:	Arg1_L LSH 1,L_T;	L_0: shift ok
NOV1:	T_Arg2,SH=0;
	L_Arg0-T,:DX0;
DX1:	ALUCY;	do the test only if the shift didn't overflow.  If it did, L is still correct
	T_Arg1,:NOSUB;	but the test would go the wrong way
DX0:	T_Arg1,:DOSUB;
DOSUB:	Arg0_L,L_0+INCT,TASK;	do the subtract
	Arg1_L;	and put a 1 in the quotient
NOSUB:	L_mSAD,BUS=0,TASK;
	mSAD_L LSH 1,:DIVL;
ENDDIV:	SINK_SubRet,BUS,TASK,:DRET;

;---------------------------------------------------------------
;UnPack:  load up arguments into registers
;---------------------------------------------------------------
; Purpose is to unpack the two float numbers on mesa stack (there are
; assumed to be exactly two!) and save them in S,E,M,N 1 and 2
; We unpack the b argument first, so Fix can jump into middle and
; just unpack a

!7,10,LoadRet,LoadRet1,LoadRet2,LoadRet3,LoadRet4,LoadRet5;
!17,20,LRpop,LRpop0,LRpop1,LRpop2,LRpop3,LRpop4,LRpop5,LRpop6,LRpop7,,,,,,,;
!1,2,PVbPos,PVbNeg;
!1,2,PVbLNZ,PVbLZ;
!1,2,PVbBias,PVbNoBias;

LoadArgs:	SubRet_L;	save return address
	T_2;
	L_stkp-T,BUS,TASK;
	stkp_L,:LRpop;

LRpop:	NOP,:RamStkErr;	stkp=0!
LRpop0:	NOP,:RamStkErr;	stkp=1!

LRpop1:	L_stk1;	stkp=2
	T_stk0,SH<0,:LRpopCom;
LRpop2:	L_stk2;
	T_stk1,SH<0,:LRpopCom;
LRpop3:	L_stk3;
	T_stk2,SH<0,:LRpopCom;
LRpop4:	L_stk4;
	T_stk3,SH<0,:LRpopCom;
LRpop5:	L_stk5;
	T_stk4,SH<0,:LRpopCom;
LRpop6:	L_stk6;
	T_stk5,SH<0,:LRpopCom;
LRpop7:	L_stk7;
	T_stk6,SH<0,:LRpopCom;
LRpopCom:	Arg0_L,L_T,:PVbPos;	!1,2,PVbPos,PVbNeg;
PVbPos:	Arg1_L,L_0,TASK,:PVbSign;
PVbNeg:	L_0-T;	negate double word, store S1=-1
	Arg1_L,SH=0;
	T_Arg0,:PVbLNZ;	!1,2,PVbLNZ,PVbLZ;

PVbLNZ:	L_0-T-1,:PVbStore;	complement
PVbLZ:	L_0-T,:PVbStore;	negate if low word 0
PVbStore:	Arg0_L,L_0-1,TASK,:PVbSign;	set sign=-1

PVbSign:	S2_L;
	T_377;
	L_Arg1 AND T;	Low 8 bits of mantissa
	N2_L LCY 8;	Store in left half word
	L_Arg1 AND NOT T;	Middle 8 bits of mantissa
	Arg1_L LCY 8;	Store in right half word
	; Now here we are using 377 instead of 177, but it doesn't matter
	; because we will or in a one bit there anyway, later.
	L_Arg0 AND T,TASK;	High 7 bits of mantissa
	M2_L LCY 8;	Store in left half word

	T_100000;	hidden bit
	T_M2 OR T;	high 7 bits of mantissa
	L_Arg1 OR T,TASK;	next 8 bits
	M2_L;	mantissa finished

	; Here we use 177600 instead of 77600, but the left shift clears it.
	; The SH=0 test works because the test depends on L from the
	; previous microinstruction plus shifter operation during
	; current microinstruction
	T_177600;	exponent mask
	L_Arg0 AND T;
	Arg0_L LSH 1,SH=0;	exponent left justified now
	L_Arg0,:PVbBias;	!1,2,PVbBias,PVbNoBias;
PVbBias:	Arg0_L LCY 8;	exponent right justified now
	T_200;
	L_Arg0-T,TASK,:PVbCom;

PVbNoBias:
	L_0;	true zero
	M2_L;
	N2_L,TASK,:PVbCom;
PVbCom:	E2_L,:PackedVectora;

;---------------------------------------------------------------
; now unpack second argument
;---------------------------------------------------------------
!17,20,LSpop,LSpop0,LSpop1,LSpop2,LSpop3,LSpop4,LSpop5,LSpop6,LSpop7,,,,,,,;
!1,2,PVPos,PVNeg;
!1,2,PVLNZ,PVLZ;
!1,2,PVBias,PVNoBias;

PackedVectora:
	T_2;
	L_stkp-T,BUS,TASK;
	stkp_L,:LSpop;

LSpop:	NOP,:RamStkErr;	stkp=0!
LSpop0:	NOP,:RamStkErr;	stkp=1!

LSpop1:	L_stk1;
	T_stk0,SH<0,:LSpopCom;
LSpop2:	L_stk2;
	T_stk1,SH<0,:LSpopCom;
LSpop3:	L_stk3;
	T_stk2,SH<0,:LSpopCom;
LSpop4:	L_stk4;
	T_stk3,SH<0,:LSpopCom;
LSpop5:	L_stk5;
	T_stk4,SH<0,:LSpopCom;
LSpop6:	L_stk6;
	T_stk5,SH<0,:LSpopCom;
LSpop7:	L_stk7;
	T_stk6,SH<0,:LSpopCom;
LSpopCom:	Arg0_L,L_T,:PVPos;	!1,2,PVPos,PVNeg;
PVPos:	Arg1_L,L_0,TASK,:PVSign;
PVNeg:	L_0-T;	negate double word, store S1=-1
	Arg1_L,SH=0;
	T_Arg0,:PVLNZ;	!1,2,PVLNZ,PVLZ;

PVLNZ:	L_0-T-1,:PVStore;	complement
PVLZ:	L_0-T,:PVStore;	negate if low word 0
PVStore:	Arg0_L,L_0-1,TASK,:PVSign;	set sign=-1

PVSign:	S1_L;
	T_377;
	L_Arg1 AND T;	Low 8 bits of mantissa
	N1_L LCY 8;	Store in left half word
	L_Arg1 AND NOT T;	Middle 8 bits of mantissa
	Arg1_L LCY 8;	Store in right half word
	; Now here we are using 377 instead of 177, but it doesn't matter
	; because we will or in a one bit there anyway, later.
	L_Arg0 AND T,TASK;	High 7 bits of mantissa
	M1_L LCY 8;	Store in left half word

	T_100000;	hidden bit
	T_M1 OR T;	high 7 bits of mantissa
	L_Arg1 OR T,TASK;	next 8 bits
	M1_L;	mantissa finished

	; Here we use 177600 instead of 77600, but the left shift clears it.
	; The SH=0 test works because the test depends on L from the
	; previous microinstruction plus shifter operation during
	; current microinstruction
	T_177600;	exponent mask
	L_Arg0 AND T;
	Arg0_L LSH 1,SH=0;	exponent left justified now
	L_Arg0,:PVBias;	!1,2,PVBias,PVNoBias;
PVBias:	Arg0_L LCY 8;	exponent right justified now
	T_200;
	L_Arg0-T,TASK,:LRET;

PVNoBias:	L_0;	true zero
	M1_L;
	N1_L,TASK,:LRET;
LRET:	E1_L;
	SINK_SubRet,BUS,TASK;	;and, the big return
	NOP,:LoadRet;	[LoadRet,LoadRet1,LoadRet2,LoadRet3]

;--------------------------------------------------------------
;repack into Arg0,,Arg1, push and return [ERROR 2: exponent too large]
;--------------------------------------------------------------
!1,2,FSTNZero,FSTZero;
!1,2,FSTNoR,FSTR;
!1,2,FSTNoR2,FSTR2;
!1,2,FSTNoSh,FSTSh;
!1,2,FSTError,FSTOK;
!1,2,FSTRetZ,FSTSig;
!1,2,FSTNeg,FSTPos;
!1,2,FSTLNZ,FSTLZ;
!1,2,FixShift,FSTSgn;	Used by Fix

RePack:	SINK_M1,BUS=0;	check for zero result
; do a form of rounding, by checking value in low N1 bits
	T_377,:FSTNZero;	!1,2,FSTNZero,FSTZero;
FSTZero: 	L_0,:LowZero1;
FSTNZero:
	T_N1.T;
	L_177-T;	Is remaining >= 1/2?
	L_M1,SH<0,TASK;
	NOP,:FSTNoR;	!1,2,FSTNoR,FSTR;
FSTNoR:	NOP,:FSTNoSh;

FSTR:	T_400;
	L_N1+T;
	N1_L,ALUCY;
	L_M1+1,:FSTNoR2;	!1,2,FSTNoR2,FSTR2;
FSTR2:	M1_L,ALUCY,TASK,:FSTNoR2;
FSTNoR2:	NOP,:FSTNoSh;	!1,2,FSTNoSh,FSTSh;
FSTSh:	L_T_M1;	low order
	M1_L RSH 1;
	L_N1,TASK;
	N1_L MRSH 1;
	L_E1+1,TASK;
	E1_L;
FSTNoSh:	T_377;
	L_M1 AND T;
	Arg0_L;	low 8 bits, r.j.
	L_M1 AND NOT T;
	M1_L LSH 1;	high 7 bits, l.j.
	L_N1 AND NOT T;
	T_LastL;	high 8 bits, l.j.
	L_Arg0 OR T,TASK;
	N1_L LCY 8;

	T_200;
	L_E1+T,TASK;
	Arg0_L LCY 8;	exp (8 bit) l.j.
	;check low order 8 bits of M1 are 0, else ERROR=2
	T_377;
	L_Arg0 AND T;
	L_M1,TASK,SH=0;	M1 has high 7 bits, l.j.
	M1_L LCY 8,:FSTError;	!1,2,FSTError,FSTOK;
FSTOK:	T_Arg0;	r.h. zero, so don't mask
	L_M1 OR T,TASK;
	M1_L RSH 1,:FSTSgn;
; at this point, M1,,N1 has everything but sign

FSTError:	T_E1;
	L_177-T;
	NOP,SH<0,TASK;
	NOP,:FSTRetZ;	!1,2,FSTRetZ,FSTSig;
FSTRetZ:	L_0,:LowZero1;	expo underflow
FSTSig:	L_2,:DoErrorReturn;	expo overflow

; This is code common to the end of Fix (please note)
FSTSgn:	SINK_S1,BUS=0;
	L_T_N1,:FSTNeg;	!1,2,FSTNeg,FSTPos;

FSTPos:	Arg1_L;
	L_M1,TASK,:FSTStore;
FSTNeg:	L_0-T;
	Arg1_L,SH=0;	negate the double word
	T_M1,:FSTLNZ;	!1,2,FSTLNZ,FSTLZ;

FSTLNZ:	L_0-T-1,TASK,:FSTStore;	complement
FSTLZ:	L_0-T,TASK,:FSTStore;	negate if low word 0
FSTStore:	Arg0_L,:FPdpush;

;---------------------------------------------------------------
;Float:  a long integer is on the stack
;---------------------------------------------------------------
!17,20,LVpop,LVpop0,LVpop1,LVpop2,LVpop3,LVpop4,LVpop5,LVpop6,LVpop7,,,,,,,;
!1,2,FltPos,FltNeg;
!1,2,FltLNZ,FltLZ;
!1,2,FltHNZ,FltHZ;
!1,2,FltCont,FltAllZ;
!1,2,FltMore,FltNorm;

ucFloat:	T_2;
	L_stkp-T,BUS,TASK;
	stkp_L,:LVpop;

LVpop:	NOP,:RamStkErr;	stkp=0!
LVpop0:	NOP,:RamStkErr;	stkp=1!

LVpop1:	L_stk1;
	T_stk0,SH<0,:LVpopCom;
LVpop2:	L_stk2;
	T_stk1,SH<0,:LVpopCom;
LVpop3:	L_stk3;
	T_stk2,SH<0,:LVpopCom;
LVpop4:	L_stk4;
	T_stk3,SH<0,:LVpopCom;
LVpop5:	L_stk5;
	T_stk4,SH<0,:LVpopCom;
LVpop6:	L_stk6;
	T_stk5,SH<0,:LVpopCom;
LVpop7:	L_stk7;
	T_stk6,SH<0,:LVpopCom;
LVpopCom:	M1_L,L_T,:FltPos;	!1,2,FltPos,FltNeg;
FltPos:	N1_L,L_0,TASK,:FltSign;
FltNeg:	L_0-T;	negate the double word, store S2=-1
	N1_L,SH=0;
	T_M1,:FltLNZ;	!1,2,FltLNZ,FltLZ;

FltLNZ:	L_0-T-1,:FltStore;	complement
FltLZ:	L_0-T,:FltStore;	negate if low word 0
FltStore:	M1_L,L_0-1,TASK,:FltSign;	set sign=-1
FltSign:	S1_L;

	;now, double word LShift until normalized
	L_40,TASK;
	E1_L;	32 decimal if already normalized

; we will always shift at least once, so max exponent will be 31

	SINK_M1,BUS=0,TASK;
	NOP,:FltHNZ;	!1,2,FltHNZ,FltHZ;

FltHZ:	T_N1,BUS=0;
	L_20,:FltCont;	!1,2,FltCont,FltAllZ;
FltAllZ:	L_0,:LowZero1;
FltCont:	E1_L,L_T;	16 shifts like wildfire
	M1_L,L_0,TASK;
	N1_L,:FltHNZ;

FltHNZ:	L_M1;
	T_N1,SH<0;
	M1_L MLSH 1,L_T,:FltMore;	!1,2,FltMore,FltNorm;
FltMore:	N1_L LSH 1;
	L_E1-1,TASK;
	E1_L,:FltHNZ;

	; We just shifted out the leading one, so put it back.
FltNorm:	L_M1;
	T_ONE,TASK;
	M1_L MRSH 1,:RePack;

;---------------------------------------------------------------
;  Fix
;---------------------------------------------------------------
!1,2,FixEPlus,FixENeg;
!1,2,FixEOK,FixEOv;
;!1,2,FixShift,FSTSgn;	This occurs earlier

ucFix:	L_3,TASK;
	SubRet_L,:PackedVectora;	middle of unpack routine!
LoadRet3:	L_E1-1;
	T_E1,SH<0;	E1 must be positive
	L_37-T,:FixEPlus;	!1,2,FixEPlus,FixENeg;

FixEPlus:	E1_L,SH<0;	E1 must be < 32 decimal
FixShift:	L_T_M1,:FixEOK;	!1,2,FixEOK,FixEOv;
FixEOK:	M1_L RSH 1;
	L_N1,TASK;
	N1_L MRSH 1;
	L_E1-1,BUS=0;
	E1_L,:FixShift;	!1,2,FixShift,FSTSgn;
; Cleanup and return is done by the end of RePack

FixENeg:	L_0,:LowZero1;	store 0 and return
FixEOv:	L_ONE,:DoErrorReturn;	FixExponentOverflow (trap)

;---------------------------------------------------------------
;  FixC  Fix to CARDINAL
;---------------------------------------------------------------
!1,2,FixCVNeg,FixCVOK;
!1,2,FixCEPlus,FixCENeg;
!1,2,FixCEOK,FixCEOv;
!1,2,FixCMore,FixCDone;

ucFixC:	L_4,TASK;
	SubRet_L,:PackedVectora;	middle of unpack routine!
LoadRet4:	SINK_S1,BUS=0;	Value must be positive.
	L_E1-1,:FixCVNeg;	!1,2,FixCVNeg,FixCVOK;
FixCVOK:	T_E1,SH<0;	E1 must be positive
	L_20-T,:FixCEPlus;	!1,2,FixCEPlus,FixCENeg;

FixCEPlus:	E1_L,SH<0;	E1 must be < 17 decimal
FixCShift:	L_E1-1,:FixCEOK;	!1,2,FixCEOK,FixCEOv;
FixCEOK:	E1_L,SH<0;
	L_M1,TASK,:FixCMore;	!1,2,FixCMore,FixCDone;
FixCMore:	M1_L RSH 1,:FixCShift;

FixCDone:	NOP;
	L_M1,TASK;
FixCStore:	Arg0_L,:ShortRet;

FixCENeg:	L_0,TASK,:FixCStore;	store 0 and return
FixCEOv:	L_4,:DoErrorReturn;	FixCExponentOverflow (trap)
FixCVNeg:	L_5,:DoErrorReturn;	FixCValueNegative (trap)

;---------------------------------------------------------------
;  FixI  Fix to INTEGER
;---------------------------------------------------------------
!1,2,FixIEPlus,FixIENeg;
!1,2,FixIEOK,FixIEOv;
!1,2,FixIShift,FixIDone;
!1,2,FixINeg,FixIPos;
!1,2,FixIEOv1,FixIPossF;
!1,2,FixIEOv2,FixIStore;

ucFixI:	L_5,TASK;
	SubRet_L,:PackedVectora;	middle of unpack routine!
LoadRet5:	L_E1-1;
	T_E1,SH<0;	E1 must be positive
	L_17-T,:FixIEPlus;	!1,2,FixIEPlus,FixIENeg;

FixIEPlus:	E1_L,SH<0;	E1 must be < 16 decimal
FixIShift:	L_M1,TASK,:FixIEOK;	!1,2,FixIEOK,FixIEOv;
FixIEOK:	M1_L RSH 1;
	L_E1-1,BUS=0,TASK;
	E1_L,:FixIShift;	!1,2,FixIShift,FixIDone;

FixIDone:	NOP;
	SINK_S1,BUS=0;
	L_T_M1,:FixINeg;	!1,2,FixINeg,FixIPos;

FixIPos:	NOP,TASK,:FixIStore;
FixINeg:	L_0-T,TASK,:FixIStore;
FixIStore:	Arg0_L,:ShortRet;

FixIENeg:	L_0,TASK,:FixIStore;	store 0 and return
;  Overflow here is a little funny, IF the exponent was exactly 20B AND
;  the number is negative, AND the Mantissa is 100000B THEN we return 100000B.
;  Number<0  =>  S1=177777B;
;  E1=20B  =>  17-E1=177777B;
FixIEOv:	NOP;
	T_M1;
	L_100000 XOR T;	is M1=100000B?
	T_S1,SH=0;
	L_E1 XOR T,:FixIEOv1;	!1,2,FixIEOv1,FixIPossF;
FixIPossF:	NOP,SH=0;
	L_M1,TASK,:FixIEOv2;	!1,2,FixIEOv2,FixIStore;
FixIEOv2:	NOP,:FixIEOv1;
FixIEOv1:	L_6,:DoErrorReturn;	FixIExponentOverflow (trap)

;---------------------------------------------------------------
;Mul: floating point multiply
;---------------------------------------------------------------
!1,2,MulNZero,MulZero;
!1,2,MulNZero1,MulZero1;
!1,2,MulNoCry,MulCry;
!1,2,MulCry1,MulNoCry1;
!1,2,MulNorm,MulNoNorm;
!1,2,MulNZero2,MulZero2;

ucMul:	L_0,TASK,:LoadArgs;

LoadRet:	T_E1;	add exponents, like in any multiply
	L_E2+T,TASK;
	E1_L;

	T_S1;	and xor signs
	L_S2 XOR T,TASK;
	S1_L;

	L_M1;	first multiply: high*low
	Arg1_L,SH=0;
	L_N2,:MulNZero;	!1,2,MulNZero,MulZero;
MulZero:	L_0,:LowZero1;	return 0
MulNZero:	Arg2_L;	Arg2 is S reg so can't combine 
	L_0;
	Arg0_L,TASK,:ramMUL;	L must be 0 for SubRet
MulRet:	L_Arg0,TASK;
; Here we will start using S2 to hold some temporary stuff
	S2_L;

	L_M2;	second multiply: other high*other low
	Arg1_L,SH=0;
	L_N1,:MulNZero1;	!1,2,MulNZero1,MulZero1;
MulZero1:	L_0,:LowZero1;
MulNZero1:	Arg2_L;
	L_0;
	Arg0_L,L_0+1,TASK,:ramMUL;	L must have 1 for SubRet
MulRet1:	T_Arg0;
	L_S2+T;	add results, set carry if overflow
	Arg0_L,ALUCY;
	L_0,:MulNoCry;	!1,2,MulNoCry,MulCry;
MulCry:	L_ONE,TASK;

; Now use S2 to hold carry bit
MulNoCry:	S2_L;

	;last multiply: high*high (plus stuff left in Arg0)
	L_M1,TASK;
	Arg1_L;
	L_M2,TASK;
	Arg2_L;
	L_2,TASK,:ramMUL;
MulRet2:	SINK_S2,BUS=0;
	L_Arg0,:MulCry1;	!1,2,MulCry1,MulNoCry1;
MulCry1:	L_Arg0+1;	low+low resulted in a carry, add it now
MulNoCry1:	M1_L,SH<0;	now, check normalization
	T_Arg1,:MulNorm;	7 instructions since last TASK
		;  !1,2,MulNorm,MulNoNorm;
MulNorm:	M1_L MLSH 1;	8
	L_Arg1,SH=0;	9
	N1_L LSH 1,:MulNZero2;	10  !1,2,MulNZero2,MulZero2;
MulNZero2:	L_E1-1,TASK;	decrement exponent to account for shift
	E1_L,:RePack;

MulNoNorm:	L_Arg1,TASK;
	N1_L,:RePack;
MulZero2:	L_0,:LowZero1;

;---------------------------------------------------------------
;FDV floating point divide
;---------------------------------------------------------------

!1,2,DivOK,DivErr;
!1,2,DivOK1,DIV0;
!1,2,DivC,D0;
!1,2,DivC2,D2;
!1,2,DivDec,DivNoDec;
!1,2,DivNorm,D1;

ucDiv:	L_ONE,TASK,:LoadArgs;
LoadRet1:	SINK_M2,BUS=0,TASK;	check for /0
	NOP,:DivOK;	!1,2,DivOK,DivErr;

DivErr:	L_3,TASK,:DoErrorReturn;

DivOK:	T_E2;	first, subtract exponents
	L_E1-T,TASK;
	E1_L;

	T_S1;	now, xor signs
	L_S2 XOR T,TASK;
	S1_L;

	;first, (M1,N1)/M2
	L_T_M1,BUS=0;	check for zero dividend
	Arg0_L,:DivOK1;	!1,2,DivOK1,DIV0;
DIV0:	L_0,:LowZero1;	store true zero
DivOK1:	L_ALLONES XOR T,TASK;	NOT Arg0

; Use S2 as a temporary register (to hold data for compare)
	S2_L;
	L_N1,TASK;
	Arg1_L;
	L_T_M2;
	Arg2_L;

	;unsigned test for Arg0<Arg2: ADCZ# 0,2,SZC
	L_S2+T;	(NOT Arg0)+Arg2
	NOP,ALUCY;

	L_T_Arg0,:DivC;	!1,2,DivC,D0;
DivC:	Arg0_L RSH 1;	divide dividend by two (rshift)
	L_Arg1,TASK;
	Arg1_L MRSH 1;
	L_E1+1,TASK;	bump exponent
	E1_L;
D0:	L_0,TASK,:ramDIV;
DivRet:	L_Arg1;
	M1_L,L_0;	save high order results
	Arg1_L,L_0+1,TASK,:ramDIV;	now AC0,1 have remainder,0
DivRet1:	L_Arg1;
	N1_L,L_0,TASK;	save low order result

	;now, answer is "too big" because low order bits
	;of divisor were not included.
	;so, we form correction term (N2/M2)*HighAnswer
	Arg0_L;
	L_N2,TASK;	
	Arg1_L;	low order divisor
	L_M1,TASK;
	Arg2_L;	high order answer so far
	L_3,TASK,:ramMUL;	(N2*M1)
MulRet3:	T_Arg0;
	L_ALLONES XOR T;	NOT Arg0;
	T_M2;	ADCZ# 0,2,SZC	check for divide overflow
	L_LastL+T;	JMP D2	divide won't overflow
	L_M2,ALUCY;

	Arg2_L,:DivC2;	!1,2,DivC2,D2;
DivC2:	L_M1-1,TASK;
	;decrement high order part of answer
	;(because correction is to low order part)
	M1_L;
	T_M2;	and subtract "one" from dividend
	L_Arg0-T,TASK;
	Arg0_L;
D2:	L_2,TASK,:ramDIV;	(N2*M1)/M2
DivRet2:	T_Arg1;
	L_N1-T;	(uncorrected low order result)-(second correction)
	N1_L,ALUCY;	if zero carry, then decrease high order part too

	L_M1,:DivDec;	!1,2,DivDec,DivNoDec;
DivDec:	L_M1-1;
	M1_L;
DivNoDec:	NOP,SH<0;	get high order part of answer
	;  (could be unnormalized from either DSZ above)
	T_N1,:DivNorm;	!1,2,DivNorm,D1;
DivNorm:	M1_L MLSH 1;
	L_E1-1,TASK;	decrement exponent to account for shift
	E1_L;
	L_N1,TASK;
	N1_L LSH 1,:RePack;

D1:	NOP,TASK;
	NOP,:RePack;

;----------------------------------------------------
;floating point add and subtract
;----------------------------------------------------

!1,2,Sh,NoShz;
!1,2,Sh1,NoSh;
!1,2,E1lsE2,E1grE2;
!1,2,NoFix,Fix;
!1,2,More,Shifted;
!1,2,ExpOK,ExpWrite;
!1,2,NoFix1,Fix1;
!1,2,More1,Shifted1;

ucAdd:	L_0,TASK,:StoreMode;
ucSub:	L_ALLONES,TASK;
StoreMode:	Mode_L;
	L_2,TASK,:LoadArgs;

	;Preshift arguments until they match
LoadRet2:	T_M1;	mantissa zero check
	L_M2 AND T;	one OR the other = 0
	SINK_LastL,BUS=0;

	T_E1,:Sh;	!1,2,Sh,NoShz;
Sh:	L_E2-T;	if exponents are the same, no shift either
	SINK_LastL,BUS=0;

	ShiftCount_L,:Sh1;	!1,2,Sh1,NoSh;
Sh1:	TASK,SH<0;
	NOP,:E1lsE2;	!1,2,E1lsE2,E1grE2;
E1lsE2:	L_E2,TASK;
	E1_L;	we'll shift until exp matches E2
	T_ShiftCount;
	L_37-T;
	TASK,SH<0;	37 is max number of shifts, if SH ge 0 then fix

	NOP,:NoFix;	!1,2,NoFix,Fix;
NoFix:	L_T_M1;
More:	M1_L RSH 1;
	L_N1,TASK;
	N1_L MRSH 1;
	L_ShiftCount-1;
	ShiftCount_L,SH=0;
	L_T_M1,:More;	!1,2,More,Shifted;

Fix:	L_0;	set both words of mantissa1 to 0
	M1_L,TASK;
	N1_L,:EndShift;

Shifted:	NOP,:EndShift;
NoSh:	NOP,:EndShift;

NoShz:	SINK_M1,BUS=0;	if first arg is zero, then E1_E2
	L_E2,TASK,:ExpOK;	!1,2,ExpOK,ExpWrite;
ExpWrite:	E1_L;
ExpOK:	NOP,:EndShift;

E1grE2:	T_ShiftCount;	actually, negative shift count
	L_37+T;
	TASK,SH<0;

	NOP,:NoFix1;	!1,2,NoFix1,Fix1;
NoFix1:	L_T_M2;
More1:	M2_L RSH 1;
	L_N2,TASK;
	N2_L MRSH 1;
	L_ShiftCount+1;
	ShiftCount_L,SH=0;
	L_T_M2,:More1;	!1,2,More1,Shifted1;

Fix1:	L_0;
	M2_L,TASK;
	N2_L,:EndShift;

Shifted1:	NOP,:EndShift;

;end of PRESHIFT
;now: ADD1 is Add(+ +), Add(- -), Sub(+ -), Sub(- +)
;and  ADD2 is Add(+ -), Add(- +), Sub(+ +), Sub(- -)
; so: ADD1 if ((S1 XOR S2) XOR MODE) eq 0, and ADD2 otherwise

!1,2,ADD1,ADD2;
!1,2,A1NoCry,A1Cry;
!1,2,A1xNoCry,A1xCry;
!1,2,A2NoCry,A2Cry;
!1,2,A2Sign,A2NoSign;
!1,2,LowNZero,LowZero;
!1,2,HiNZero,HiZero;
!1,2,A2Norm,A2NoNorm;
!1,2,A2NoCryL,A2CryL;
;!1,2,LowNZero1,LowZero1;	defined above to avoid predef error

EndShift:	T_S1;
	L_S2 XOR T;	0 if same, -1 if different
	T_Mode;
	L_LastL XOR T;	0 if ADD1, -1 if ADD2
	TASK,SH<0;
	NOP,:ADD1;	!1,2,ADD1,ADD2;

ADD1:	T_N1;
	L_N2+T;
	N1_L,ALUCY;
	T_M1,:A1NoCry;	!1,2,A1NoCry,A1Cry;
A1Cry:	L_M2+T+1,:A1Store;
A1NoCry:	L_M2+T;
A1Store:	M1_L,ALUCY,TASK;
	NOP,:A1xNoCry;	!1,2,A1xNoCry,A1xCry;
A1xCry:	T_L_M1;	post shift
	M1_L RSH 1;
	L_N1,TASK;
	N1_L MRSH 1;
	T_100000;
	L_M1 OR T;	high order bit should have been shifted in
	M1_L;
	L_E1+1,TASK;
	E1_L,:RePack;
A1xNoCry:	NOP,:RePack;

ADD2:	T_N2;
	L_N1-T;
	N1_L,ALUCY;	low order result
	T_M2,:A2NoCry;	!1,2,A2NoCry,A2Cry;
A2NoCry:	L_M1-T-1,:A2C;	no carry, do one's complement subtract
A2Cry:	L_M1-T;	carry, do two's complement subtract
A2C:	M1_L,ALUCY,TASK;
	NOP,:A2Sign;	if no carry, sign changed!!!!
		;  !1,2,A2Sign,A2NoSign;
A2Sign:	T_N1,BUS=0;	double length negate starts here
	L_0-T,:LowNZero;	!1,2,LowNZero,LowZero;
LowNZero:	N1_L,T_0-1;
	L_M1 XOR T,:A2Cx;	complement
LowZero:	T_M1;
	L_0-T;	negate (note that N1 is already 0, so no need to update it)
A2Cx:	M1_L,T_0-1;
	L_S1 XOR T,TASK;	complement sign
	S1_L;

A2NoSign:	L_0,TASK;
	ShiftCount_L;
	L_M1,BUS=0;
	NOP,:HiNZero;	!1,2,HiNZero,HiZero;
HiNZero:	TASK,SH<0;
	NOP,:A2Norm;	!1,2,A2Norm,A2NoNorm;
A2Norm:	L_N1;
	NOP,SH<0;
	N1_L LSH 1,T_0,:A2NoCryL;	!1,2,A2NoCryL,A2CryL;
A2CryL:	T_ALLONES;
A2NoCryL:	L_M1;
	M1_L MLSH 1;
	L_ShiftCount+1,TASK;
	ShiftCount_L;
	L_M1,:HiNZero;

A2NoNorm:	T_ShiftCount;
	L_E1-T,TASK;
	E1_L,:RePack;

HiZero:	L_N1,BUS=0;

	M1_L,L_0,:LowNZero1;	!1,2,LowNZero1,LowZero1;
LowNZero1:	N1_L;	zero out low order
	L_20,TASK;
	ShiftCount_L;	16 shifts done like wildfire
	L_M1,:HiNZero;

LowZero1:	Arg0_L,TASK;
	Arg1_L,:FPdpush;
(0,5376)(1,11264)\f1