PDP-10 Archive: cnstcm.mac from FORTRAN-10_Alpha

Trailing-Edge - PDP-10 Archives - FORTRAN-10_Alpha_31-jul-86 - cnstcm.mac

There are 12 other files named cnstcm.mac in the archive. Click here to see a list.

	TITLE	CNSTCM - CONSTANT COMBINE MODULE
	SUBTTL	S. MURPHY/SRM/HPW/NEA/HPW/SJW/DCE/TFV/RVM/PLB

;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1986
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR ANY  OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
;AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

	INTERN	CNSTCV
	CNSTCV= BYTE (3)0(9)10(6)0(18)2472	; Version Date:	26-Oct-84


	SUBTTL	Revision History

Comment \

***** Begin Revision History *****

54	-----	-----	FIX CONVERSION OF LITERALS
55	-----	-----	ADD CONVERSION ROUTINE TO
			CMPLX WITH CONSTANT ARGUMENTS
			AT KILFBR+1
56	-----	-----	ADD ROUTINES TO FOLD INTEGER EXPONENTIATION
57	-----	-----	ADD SPECIFIC DISPATCH KDPINT FOR REAL TO INTEGER
			TRUNCATION
58	-----	-----	PATCH CALL TO WARNERR
59	-----	-----	ADD CODE FOR INLINE DABS
60	-----	-----	ADD CODE FOR SQUARE OF DP
61	-----	-----	ADD CODE FOR EXPONEN OF DP
62	-----	-----	REMOVE CODE FOR SQUARE,CUBE,P4 (THEY ARE NOW
				ALL UNDER EXPCIOP)
63	-----	-----	FIX BUG IN "EXPRL" (REAL NUMBER TO INTEGER
			POWER) -WHEN CALL KADPML, C1H-C1L MUST
			CONTAIN THE FIRST ARG TO BE MULTIPLIED
64	-----	-----	IN "EXPINT" AND "EXPRL" MUSTCHECK FOR THE
			POWER EQUAL TO 0 (AND SET RESULT TO 1 IN
			THAT CASE)
65	275	-----	FOR FLOATING UNDEFLOW, CHECK UNDERFLOW AND NOT
			OVERFLOW + DIVIDE CHECK BECAUSE OVERFLOW IS SET, (JNT)

***** Begin Version 5 *****

66	413	-----	DON'T USE FADL IN INTDP IF NOT ON KA10

***** Begin Version 5A *****

67	606	22795	CATCH ALL OVERFLOWS AND UNDERFLOWS IN EXPRL, (DCE)

***** Begin Version 6 *****

68	761	TFV	1-Mar-80	-----
	Remove all KA tables and add /GFLOATING tables.
	Clean up everything

69	1006	TFV	1-Jul-80	------
	Add code for specops (p2mul, p2div, p21mul) for reals and dp

70	1025	TFV	21-Nov-80	------
	Fix conversion of reals to logical under GFLOATING.
	Just taking the high order word losses.

71	1030	TFV	25-Nov-80	------
	Fix GFLOATING DP conversion to INT.  Truncate don't round.

72	1031	TFV	25-Nov-80	------
	Fix ABS of GFLOATING reals. Use DABS routine since low word has some
	mantissa bits for the SP representation

***** Begin Version 7 *****

1542	RVM	25-May-82
	Create some new conversions to be used under /GFLOATING. The
	new conversions, unlike the old conversions, do not normalize
	their results.  This is important because the starting and
	ending bit pattern must be the same for a LOGICAL constant
	converted to REAL (which is really GFLOATING) converted back
	to LOGICAL.  The new conversions are:
		GOCTRL		SINGLE OCTAL/LOGICAL to REAL (GFLOATING)
		GLITRL		LITERAL to REAL (GFLOATING)
		GRLLOG		REAL (GFLOATING) to LOGICAL
		GREAL		GFLOATING to true single precision

1605	RVM	2-Aug-82
	The DIM function would underflow at compile-time for gfloating
	numbers, if the first number was less than the second.  The
	reason was that the DIM would only zero the high order word
	for this case, which is normally OK because the number has been
	rounded to the precision of a single precision number.  But, under
	/GFLOAT, the numbers have 3 bits of precision in the low order
	word.

1637	CKS	29-Sep-82
	Don't give repeated overflow warning if overflowed double precision
	number is rounded to single.

1707	CKS	4-Jan-83
	Fix exponentiation routines.  Use DEXP2 and GEXP2 from FORLIB.

***** End V7 Development *****

1724	CKS	3-Feb-83
	EXPGF was copied from EXPRL and G-ized.  Unfortunately, it
	wasn't G-ized enough.  Change 1.0 to 200140000000.


***** Begin Version 10 *****

2213	RVM	11-Sep-83
	Hide some symbol definitions from DDT by changing "=" to "==".
	(These sysmbols were obscuring op codes.)

2472	PLB	26-Oct-84
	o	Add code for COMPLEX * COMPLEX, COMPLEX / COMPLEX,
		and COMPLEX ** INTEGER.
	o	Define symbol for floating underflow PC flag (PC.FUF)
	o	Changed from HISEG to TWOSEG to add local statics.

***** End V10 Development *****

***** End Revision History *****

\

	SUBTTL	COMBIND CONSTANTS

	TWOSEG	400K		;[2472] PURE CODE

;TO COMBINE CONSTANTS AT RUN TIME
;CALLED WITH THE GLOBALS
;	C1H - HIGH ORDER WD OF 1ST CONSTANT
;	C1L - LOW ORDER WD OF 1ST CONSTANTS
;	C2H - HIGH ORDER WD OF 2ND CONSTNT (HIGH ORDER WD OF RESULT
;		IS LEFT HERE)
;	C2L - LOW ORDER WD OF 2ND CONSTANT (LOW ORDER WD OF RESULT IS 
;		LEFT HERE)
;	COPRIX - TABLE INDEX FOR OPERATION TO BE PERFORMED
;		FOR ARITH OPERATIONS - 2 BITS FOR OP FOLLOWED
;			BY 2 BITS FOR VALUE-TYPE
;		FOR TYPE CONVERSIONS - "KTYPCB" (BASE IN TABLE FOR TYPE
;			CONV) PLUS 2 BITS FOR SOURCE TYPE FOLLOWED
;			BY 2 BITS FOR DESTINATION TYPE
;		FOR BOOLEAN OPERATIONS - "KBOOLB" (BASE IN TABLE FOR
;			BOOLEANS) PLUS 2 BITS  SPECIFYING
;			THE OPERATION
;

	SEARCH GFOPDF	;[761] OPDEFS FOR GFLOAT INSTRUCTIONS

	ENTRY	CNSTCM
	EXTERN	SKERR,C1H,C1L,C2H,C2L,COPRIX
	EXTERN	ADJUST,COMPMUL	;[2472] SCALED DOUBLE COMPLEX ROUTINES
	EXTERN	COMPDIV,COMPSQ	;[2472] SCALED DOUBLE COMPLEX ROUTINES

	INTERN	KDPINT		;REAL TO INTEGER TRUNCATION
	INTERN	KGFINT		;[761] REAL TO INTEGER TRUNCATION
	INTERN	KARIIB		;BASE FOR ARITH OPERATIONS FOR KI10
	INTERN	KARIGB		;[761] BASE FOR GFLOATING ARITH OPS
	INTERN	KBOOLB,KDNEGB,KILFBA,KILFBR,KILFBG
	INTERN	KTYPCB,KTYPCG,KSPECB,KSPECG	;[761] type conversions

	INTERN	KDPRL,KGFRL	;[761] TO ROUND A DOUBLE-WD REAL DOWN TO A
				; SINGLE WD OF PRECISION. USED ONLY WITH THE
				; OPTIMIZER
	INTERN KGFSPR		;[761] to round /GFLOATING to SP accuracy
				; keeping /GFLOATING format
	INTERN KGFOCT		;[1542] Convert REAL to OCTAL
	INTERN KILDAB		;TO FOLD DABS

	SREG==17		;[2213] STACK REG
	FLGREG==0		;[2213] FLAGS REGISTER
	TH==1			;[2213] TEMP DOUBLE REGISTER
	TL==2			;[2213] MORE TEMP DOUBLE REGISTER
	RH==4			;[2213] HIGH ORDER WD OF RESULT DEVELOPED
				; INTO THIS REG
	RL==5			;[2213] LOW ORDER WD OF RESULT DEVELOPED
				; INTO THIS REG
	RGDSP==6		;[2213] INDEX INTO TABLE OF OPERATIONS
				; INDICATING  OPERATION TO BE PERFORMED
	T==7			;[2213] REGISTER USED AS A TEMPORARY

	PC.FUF==1B11		;[2472] FLOATING UNDERFLOW PC FLAG
	G1==200140000000	;[2213] GFLOATING 1.0

DEFINE	BLCALL(ROUT,ARGS) <	;;;[2472] CALL BLISS -- (MUST HAVE ARGS)
	PUSH	SREG,T		;;;[2472] ENSURE T IS SAVED
...CNT==0			;;;[2472] CLEAR ARG COUNT
IRP <ARGS>,<			;;;[2472]
...CNT==...CNT+1		;;;[2472] COUNT THIS ARG
	PUSH	SREG,ARGS	;;;[2472] PUSH VALUE ON STACK
> ;IRP				;;;[2472]
	PUSHJ	SREG,ROUT	;;;[2472] CALL ROUTINE
	ADJSP	SREG,-...CNT	;;;[2472] TOSS ARGUMENTS FROM STACK
	POP	SREG,T		;;;[2472] RESTORE T
PURGE	...CNT			;;;[2472]
> ;BLCALL			;;;[2472]

CNSTCM:	JRSTF	@[0,,.+1]	;CLEAR FLAGS FOR OVERFLOW AND UNDERFLOW
	DMOVE	RH,C1H		;LOW 1ST CONSTANT
	HRRZ	RGDSP,COPRIX	;LOAD INDEX
	XCT	0(RGDSP)	;PERFORM DESIRED OPERATION
	JSP	T,.+1		;LOAD FLAGS INTO T
	TLNE	T,440140	;IF OVERFLOW,UNDERFLOW,OR DIVIDE CHECK IS
	PUSHJ	SREG,OVFLW	;SET, GO HANDLE THE OVERFLOW
	DMOVEM	RH,C2H		;RETURN RESULTS IN GLOBALS C2H AND C2L
	POPJ	SREG,		;RETURN
;TABLE OF OPERATIONS TO BE PERFORMED
;CODE FOR EACH OPERATION IS IDENTICAL TO THE CODE THAT WOULD BE
;EXECUTED AT RUN-TIME.
;
;
;ARITH OPERATIONS 
; NOGFLOATING - Clean up table
KARIIB:	ADD	RL,C2L
	DFAD	RH,C2H		;[761]
	DFAD	RH,C2H		;[761]
	PUSHJ	SREG,CMPADD
	SUB	RL,C2L
	DFSB	RH,C2H		;[761]
	DFSB	RH,C2H		;[761]
	PUSHJ	SREG,CMPSUB
	IMUL	RL,C2L
	DFMP	RH,C2H		;[761]
	DFMP	RH,C2H		;[761]
	PUSHJ	SREG,CMPMUL
	IDIV	RL,C2L
	DFDV	RH,C2H		;[761]
	DFDV	RH,C2H		;[761]
	PUSHJ	SREG,CMPDIV
;ARITH OPERATIONS 
; GFLOATING [761]	
KARIGB:	ADD	RL,C2L		;[761]
	GFAD	RH,C2H		;[761]
	GFAD	RH,C2H		;[761]
	PUSHJ	SREG,CMPADD	;[761]
	SUB	RL,C2L		;[761]
	GFSB	RH,C2H		;[761]
	GFSB	RH,C2H		;[761]
	PUSHJ	SREG,CMPSUB	;[761]
	IMUL	RL,C2L		;[761]
	GFMP	RH,C2H		;[761]
	GFMP	RH,C2H		;[761]
	PUSHJ	SREG,CMPMUL	;[761]
	IDIV	RL,C2L		;[761]
	GFDV	RH,C2H		;[761]
	GFDV	RH,C2H		;[761]
	PUSHJ	SREG,CMPDIV	;[761]
;
; FOR TYPE CONVERSIONS
; NOGFLOATING
KTYPCB=.
;	FROM OCTAL/LOGICAL
	JFCL			;TO OCTAL/LOGICAL
	PUSHJ	SREG,SKERR	;TO CONTROL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,OCTRL	;TO DOUBLE-OCTAL - THIS WD BECOMES HIGH WD
	PUSHJ	SREG,OCTRL	;TO LITERAL - THIS WD IS HIGH WD
	JFCL			;TO INTEGER
	PUSHJ	SREG,OCTRL	;TO REAL
	PUSHJ	SREG,OCTRL	;TO DOUBLE-PREC
	PUSHJ	SREG,OCTRL	;TO COMPLEX
;	FROM CONTROL
	JFCL			;TO OCTAL
	JFCL			;TO CONTROL
	PUSHJ	SREG,OCTRL	;TO DOUBLE-OCTAL
	PUSHJ	SREG,OCTRL	;TO LITERAL
	JFCL			;TO INTEGER
	PUSHJ	SREG,OCTRL	;TO REAL - MUST MOVE CONST2 TO CONST1
	PUSHJ	SREG,OCTRL	;TO DOUBLE-PREC
	PUSHJ	SREG,OCTRL	;TO COMPLEX
;	FROM DOUBLE-OCTAL
	PUSHJ	SREG,DOCTIN	;TO LOGICAL - USE HIGH WD ONLY,SET OVFLW
	PUSHJ	SREG,DOCTIN	;TO CONTROL
	JFCL			;TO DOUBLE-OCTAL
	JFCL			;TO LITERAL
	PUSHJ	SREG,DOCTIN	;TO INTEGER
	JFCL			;TO REAL
	JFCL			;TO DOUBLE-PREC
	JFCL			;TO COMPLEX
;	FROM LITERAL
	PUSHJ	SREG,LITINT	;TO LOGICAL - USE HIGH WD ONLY
	PUSHJ	SREG,LITINT	;TO CONTROL
	PUSHJ	SREG,LITTWD	;TO DOUBLE-OCTAL (COMPLEX/DOUBLE PRECISION)
	JFCL			;TO LITERAL
	PUSHJ	SREG,LITINT	;TO INTEGER
	PUSHJ	SREG,LITRL	;TO REAL
	PUSHJ	SREG,LITTWD	;TO DOUBLE PREC
	PUSHJ	SREG,LITTWD	;TO COMPLEX
;	FROM INTEGER
	JFCL			;TO LOGICAL
	JFCL			;TO CONTROL
	PUSHJ	SREG,SKERR	;TO DOUBLE-OCTAL - SHOULD NEVER OCCUR
	PUSHJ	SREG,SKERR	;TO LITERAL - SHOULD NEVER OCCUR
	JFCL
	PUSHJ	SREG,INTDP	;TO REAL
	PUSHJ	SREG,INTDP	;TO DOUBLE PRECISION
	PUSHJ	SREG,INTCM	;TO COMPLEX
;	FROM REAL
	PUSHJ	SREG,RLLOG	;TO LOGICAL
	PUSHJ	SREG,RLLOG	;TO CONTROL
	PUSHJ	SREG,SKERR	;TO DOUBLE-OCTAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,SKERR	;TO LITERAL (SHOULD NEVER OCCUR)
KDPINT:	PUSHJ	SREG,DPINT	;TO INTEGER (SAME AS FROM DOUBLE-PREC)
	JFCL
	JFCL			;TO DOUBLE PREC (SINCE REAL KEPT 2 WDS OF PREC)
	PUSHJ	SREG,DPCM	;TO COMPLEX - ROUND AND USE HIGH WD
;	FROM DOUBLE PREC
	PUSHJ	SREG,RLLOG	;TO LOGICAL - USE HIGH WD ONLY
	PUSHJ	SREG,RLLOG	;TO CONTROL
	PUSHJ	SREG,SKERR	;TO DOUBLE-OCTAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,SKERR	;TO LITERAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,DPINT
	JFCL			;TO REAL - KEEP SAME 2 WDS OF PREC
	JFCL			;DOUBLE-PREC TO DOUBLE-PREC
	PUSHJ	SREG,DPCM	;DOUBLE-PREC TO COMPLEX-USE HIGH ORDER WD
;	FROM COMPLEX
	PUSHJ	SREG,RLLOG	;TO LOGICAL - USE REAL PART ONLY
	PUSHJ	SREG,RLLOG	;TO CONTROL
	PUSHJ	SREG,SKERR	;TO DOUBLE-OCTAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,SKERR	;TO LITERAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,CMINT	;TO INTEGER - CONVERT REAL PART
	MOVEI	RL,0		;TO REAL - USE HIGH WD ONLY
	MOVEI	RL,0		;COMPLEX TO DOUBLE-PREC- USE HIGH ORDER WD
	JFCL			;COMPLEX TO COMPLEX

; FOR TYPE CONVERSIONS [761]
; GFLOATING
KTYPCG=.
;	FROM OCTAL/LOGICAL
	JFCL			;[761] TO OCTAL/LOGICAL
	PUSHJ	SREG,SKERR	;[761] TO CONTROL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,OCTRL	;[761] TO DOUBLE-OCTAL--THIS WD BECOMES HIGH WD
	PUSHJ	SREG,OCTRL	;[761] TO LITERAL - THIS WD IS HIGH WD
	JFCL			;[761] TO INTEGER
	PUSHJ	SREG,GOCTRL	;[1542] TO REAL
	PUSHJ	SREG,OCTRL	;[761] TO DOUBLE-PREC
	PUSHJ	SREG,OCTRL	;[761] TO COMPLEX
;	FROM CONTROL
	JFCL			;[761] TO OCTAL
	JFCL			;[761] TO CONTROL
	PUSHJ	SREG,OCTRL	;[761] TO DOUBLE-OCTAL
	PUSHJ	SREG,OCTRL	;[761] TO LITERAL
	JFCL			;[761] TO INTEGER
	PUSHJ	SREG,GOCTRL	;[1542] TO REAL - MUST MOVE CONST2 TO CONST1
	PUSHJ	SREG,OCTRL	;[761] TO DOUBLE-PREC
	PUSHJ	SREG,OCTRL	;[761] TO COMPLEX
;	FROM DOUBLE-OCTAL
	PUSHJ	SREG,DOCTIN	;[761] TO LOGICAL - USE HIGH WD ONLY,SET OVFLW
	PUSHJ	SREG,DOCTIN	;[761] TO CONTROL
	JFCL			;[761] TO DOUBLE-OCTAL
	JFCL			;[761] TO LITERAL
	PUSHJ	SREG,DOCTIN	;[761] TO INTEGER
	JFCL			;[761] TO REAL
	JFCL			;[761] TO DOUBLE-PREC
	JFCL			;[761] TO COMPLEX
;	FROM LITERAL
	PUSHJ	SREG,LITINT	;[761] TO LOGICAL - USE HIGH WD ONLY
	PUSHJ	SREG,LITINT	;[761] TO CONTROL
	PUSHJ	SREG,LITTWD	;[761] TO DOUBLE-OCTAL (COMPLEX/DOUBLE PRECISION)
	JFCL			;[761] TO LITERAL
	PUSHJ	SREG,LITINT	;[761] TO INTEGER
	PUSHJ	SREG,GLITRL	;[1542] TO REAL
	PUSHJ	SREG,LITTWD	;[761] TO DOUBLE PREC
	PUSHJ	SREG,LITTWD	;[761] TO COMPLEX
;	FROM INTEGER
	JFCL			;[761] TO LOGICAL
	JFCL			;[761] TO CONTROL
	PUSHJ	SREG,SKERR	;[761] TO DOUBLE-OCTAL - SHOULD NEVER OCCUR
	PUSHJ	SREG,SKERR	;[761] TO LITERAL - SHOULD NEVER OCCUR
	JFCL
	PUSHJ	SREG,INTGF	;[761] TO REAL
	PUSHJ	SREG,INTGF	;[761] TO DOUBLE PRECISION
	PUSHJ	SREG,INTCM	;[761] TO COMPLEX
;	FROM REAL
KGFOCT:	PUSHJ	SREG,GRLLOG	;[1542] TO LOGICAL
	PUSHJ	SREG,GRLLOG	;[1542] TO CONTROL
	PUSHJ	SREG,SKERR	;[761] TO DOUBLE-OCTAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,SKERR	;[761] TO LITERAL (SHOULD NEVER OCCUR)
KGFINT:	PUSHJ	SREG,GFINT	;[761] TO INTEGER (SAME AS FROM DOUBLE-PREC)
	JFCL			;[761]
	JFCL			;[761] TO DOUBLE PREC (SINCE REAL KEPT 2 WDS OF PREC)
	PUSHJ	SREG,GFCM	;[761] TO COMPLEX - ROUND AND USE HIGH WD
;	FROM DOUBLE PREC
	PUSHJ	SREG,RLLOG	;[761] TO LOGICAL - USE HIGH WD ONLY
	PUSHJ	SREG,RLLOG	;[761] TO CONTROL
	PUSHJ	SREG,SKERR	;[761] TO DOUBLE-OCTAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,SKERR	;[761] TO LITERAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,GFINT
	JFCL			;[761] TO REAL - KEEP SAME 2 WDS OF PREC
	JFCL			;[761] DOUBLE-PREC TO DOUBLE-PREC
	PUSHJ	SREG,GFCM	;[761] DOUBLE-PREC TO COMPLEX-USE HIGH ORDER WD
;	FROM COMPLEX
	PUSHJ	SREG,RLLOG	;[761] TO LOGICAL - USE REAL PART ONLY
	PUSHJ	SREG,RLLOG	;[761] TO CONTROL
	PUSHJ	SREG,SKERR	;[761] TO DOUBLE-OCTAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,SKERR	;[761] TO LITERAL (SHOULD NEVER OCCUR)
	PUSHJ	SREG,CMINT	;[761] TO INTEGER - CONVERT REAL PART
	EXTEND	RH,[GDBLE RH]	;[761] TO REAL - USE HIGH WD ONLY
	EXTEND	RH,[GDBLE RH]	;[761] COMPLEX TO DOUBLE-PREC- USE HIGH ORDER WD
	JFCL			;[761] COMPLEX TO COMPLEX
;
;TO ROUND A DOUBLE-WD REAL TO A SINGLE WORD. USED WITH THE OPTIMIZER
; FOR THE CASE:
;	R=5.4
;	DP=R
; SO THAT WHEN THE CONSTANT 5.4 IS PROPAGATED, ONLY ONE WORD OF
; PRECISION WILL BE PROPAGATED
KDPRL:	PUSHJ	SREG,DPCM		;USE SAME ROUTINE AS IS USED FOR
					; CONVERTING DOUBLE-WD REAL TO COMPLEX
KGFRL:	PUSHJ	SREG,GREAL		;[1542] Convert internal real (gfloat)
					; to external real.

;[761] Round /GFLOATING DP to SP precision without changing the form
KGFSPR:	PUSHJ	SREG,GFSPR		;[761] 

;GFSPR rounds a REAL number stored in GFLOATING format to the precision
;of a single precision real.
;[1542] GFSPR should only round (and normalize) the number if the bit
;pattern of the number can not be represented in a full word when the
;number is finally converted to single precision REAL.
GFSPR:	TDNN	RL,[037777777777]	;[1542] Only need to round if some bits
					; are not zero
	 POPJ	SREG,			;[1542] We won--return
	EXTEND	RH,[GSNGL RH]		;[761] first convert to SP
	MOVEI	RL,0			;[761] zero second word
	EXTEND	RH,[GDBLE RH]		;[761] convert back to DP format
	POPJ	SREG,			;[761] return
;
;
;

;
;
;FOR BOOLEAN OPS - ALWAYS PERFORMED ON ONE WD ONLY
KBOOLB=.
	AND	RL,C2L
	OR	RL,C2L
	EQV	RL,C2L
	XOR	RL,C2L
;
;
;FOR NEGATION OF DOUBLE-PREC CONSTANTS (NOTE THAT ALL CONSTANTS ARE 
; STORED IN KI10 FORMAT
KDNEGB=.
	DMOVN	RH,RH		;FOR COMPILATION ON KI10
 
;OPERATIONS THAT TAKE MORE THAN 1 INSTR
;
;COMPLEX ARITHMETIC
;
;COMPLEX ADD
CMPADD:	FADR	RH,C2H
	FADR	RL,C2L
	POPJ	SREG,
;
;COMPLEX SUBTRACT
CMPSUB:	FSBR	RH,C2H
	FSBR	RL,C2L
	POPJ	SREG,

;++
; New [2472]/PLB
; FUNCTIONAL DESCRIPTION:
;
;	Perform COMPLEX multiplication for PARAMETER statement.
;
; CALLING SEQUENCE:
;
;	PUSHJ	SREG,CMPMUL
;
; INPUT PARAMETERS:
;
;	(Loaded but not used)
;	RH/	A
;	RL/	B
;
; IMPLICIT INPUTS:
;
;	C1H/	A
;	C1L/	B
;	C2H/	C
;	C2L/	D
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	PC Flags.
;
; FUNCTION VALUE:
;
;	COMPLEX result in RH/RL register pair
;
; SIDE EFFECTS:
;
;	None
;
;--

CMPMUL:	MOVE	RH,C1H		;GET A
	MOVEI	T,ARGA		;GET POINTER TO BLOCK
	PUSHJ	SREG,SCALIFY	;CONVERT TO SCALED DOUBLE
	MOVE	RH,C1L		;GET B
	MOVEI	T,ARGB		;GET POINTER TO BLOCK
	PUSHJ	SREG,SCALIFY	;CONVERT TO SCALED DOUBLE
	MOVE	RH,C2H		;GET C
	MOVEI	T,ARGC		;GET POINTER TO BLOCK
	PUSHJ	SREG,SCALIFY	;CONVERT TO SCALED DOUBLE
	MOVE	RH,C2L		;GET D
	MOVEI	T,ARGD		;GET POINTER TO BLOCK
	PUSHJ	SREG,SCALIFY	;CONVERT TO SCALED DOUBLE
	BLCALL	(COMPMUL,<[ARGA],[ARGB],[ARGC],[ARGD]>) ;(A,B) := (A,B)*(C,D)
	DMOVE	RH,ARGB		;GET IMAGINARY RESULT
	MOVE	T,SCALEB	;GET SCALE
	PUSHJ	SREG,UNSCALE	;CONVERT TO SINGLE
	PUSH	SREG,RH		;SAVE IT
	DMOVE	RH,ARGA		;GET REAL PART
	MOVE	T,SCALEA	;GET SCALE
	PUSHJ	SREG,DPCM	;MAKE INTO SINGLE
	POP	SREG,RL		;RESTORE COMPLEX PART
	POPJ	SREG,		;RETURN

;++
; New [2472]/PLB
; FUNCTIONAL DESCRIPTION:
;
;	Perform COMPLEX division for compiler PARAMETER statement.
;
; CALLING SEQUENCE:
;
;	PUSHJ	SREG,CMPDIV
;
; INPUT PARAMETERS:
;
;	(Loaded but not used)
;	RH/	A
;	RL/	B
;
; IMPLICIT INPUTS:
;
;	C1H/	A
;	C1L/	B
;	C2H/	C
;	C2L/	D
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	PC Flags
;
; FUNCTION VALUE:
;
;	COMPLEX result in RH/RL register pair
;
; SIDE EFFECTS:
;
;	None
;
;--

CMPDIV:	MOVE	RH,C1H		;GET A
	MOVEI	T,ARGA		;GET POINTER TO BLOCK
	PUSHJ	SREG,SCALIFY	;CONVERT TO SCALED DOUBLE
	MOVE	RH,C1L		;GET B
	MOVEI	T,ARGB		;GET POINTER TO BLOCK
	PUSHJ	SREG,SCALIFY	;CONVERT TO SCALED DOUBLE
	MOVE	RH,C2H		;GET C
	MOVEI	T,ARGC		;GET POINTER TO BLOCK
	PUSHJ	SREG,SCALIFY	;CONVERT TO SCALED DOUBLE
	MOVE	RH,C2L		;GET D
	MOVEI	T,ARGD		;GET POINTER TO BLOCK
	PUSHJ	SREG,SCALIFY	;CONVERT TO SCALED DOUBLE
	BLCALL	(COMPDIV,<[ARGA],[ARGB],[ARGC],[ARGD]>) ;(C,D) := (A,B)/(C,D)
	DMOVE	RH,ARGD		;GET IMAGINARY RESULT
	MOVE	T,SCALED	;GET SCALE
	PUSHJ	SREG,UNSCALE	;CONVERT TO SINGLE
	PUSH	SREG,RH		;SAVE IT
	DMOVE	RH,ARGC		;GET REAL PART
	MOVE	T,SCALEC	;GET SCALE
	PUSHJ	SREG,UNSCALE	;MAKE INTO SINGLE
	POP	SREG,RL		;RESTORE COMPLEX PART
	POPJ	SREG,		;DONE

;
;FOR FOLDING OF SPECIAL-OPS (P2MUL,P2DIV,PLPL1MUL,EXPCIOP
;NOGFLOATING
KSPECB:	PUSHJ	SREG,P2MI
	PUSHJ	SREG,P2MR	;[1006]
	PUSHJ	SREG,P2MR	;[1006]
	PUSHJ	SREG,P2MC
;
	PUSHJ	SREG,P2DI
	PUSHJ	SREG,P2DR	;[1006]
	PUSHJ	SREG,P2DR	;[1006]
	PUSHJ	SREG,P2DC
;
	PUSHJ	SREG,P21MI
	PUSHJ	SREG,P21MR	;[1006]
	PUSHJ	SREG,P21MR	;[1006]
	PUSHJ	SREG,P21MC
;
;	UNUSED OPERSP (FORMERLY USED FOR SQUARE)
	PUSHJ	SREG,SKERR
	PUSHJ	SREG,SKERR
	PUSHJ	SREG,SKERR
	PUSHJ	SREG,SKERR
;
;	UNUSED OPERSP (FORMERLY USED FOR CUBE)
	PUSHJ	SREG,SKERR
	PUSHJ	SREG,SKERR
	PUSHJ	SREG,SKERR
	PUSHJ	SREG,SKERR
;
;	UNUSED OPERSP (FORMERLY USED FOR POWER OF 4)
	PUSHJ	SREG,SKERR
	PUSHJ	SREG,SKERR
	PUSHJ	SREG,SKERR
	PUSHJ	SREG,SKERR
;
;
;FOR INTEGER EXPONENTIATION
	PUSHJ	SREG,EXPINT
	PUSHJ	SREG,EXPRL
	PUSHJ	SREG,EXPRL
	PUSHJ	SREG,EXPCMP	;[2472]

;GFLOATING [761]
KSPECG:	PUSHJ	SREG,P2MI	;[761]
	PUSHJ	SREG,P2MG	;[761]
	PUSHJ	SREG,P2MG	;[761]
	PUSHJ	SREG,P2MC	;[761]
;
	PUSHJ	SREG,P2DI	;[761]
	PUSHJ	SREG,P2DG	;[761]
	PUSHJ	SREG,P2DG	;[761]
	PUSHJ	SREG,P2DC	;[761]
;
	PUSHJ	SREG,P21MI	;[761]
	PUSHJ	SREG,P21MG	;[761]
	PUSHJ	SREG,P21MG	;[761]
	PUSHJ	SREG,P21MC	;[761]
;
;	UNUSED OPERSP (FORMERLY USED FOR SQUARE)
	PUSHJ	SREG,SKERR	;[761]
	PUSHJ	SREG,SKERR	;[761]
	PUSHJ	SREG,SKERR	;[761]
	PUSHJ	SREG,SKERR	;[761]
;
;	UNUSED OPERSP (FORMERLY USED FOR CUBE)
	PUSHJ	SREG,SKERR	;[761]
	PUSHJ	SREG,SKERR	;[761]
	PUSHJ	SREG,SKERR	;[761]
	PUSHJ	SREG,SKERR	;[761]
;
;	UNUSED OPERSP (FORMERLY USED FOR POWER OF 4)
	PUSHJ	SREG,SKERR	;[761]
	PUSHJ	SREG,SKERR	;[761]
	PUSHJ	SREG,SKERR	;[761]
	PUSHJ	SREG,SKERR	;[761]
;
;
;FOR INTEGER EXPONENTIATION
	PUSHJ	SREG,EXPINT	;[761]
	PUSHJ	SREG,EXPGF	;[761]
	PUSHJ	SREG,EXPGF	;[761]
	PUSHJ	SREG,EXPCMP	;[2472]

P2MI:	MOVE	T,C2L
	ASH	RL,0(T)
	POPJ	SREG,
;
P2MR:	SKIPA	RH,C2L		;[1006]
P2DR:	MOVN	RH,C2L		;[1006]
	ASH	RH,^D27		;[1006]
	ADD	RH,[201400,,0]	;[1006]
	SETZ	RL,		;[1006]
	DFMP	RH,C1H		;[1006]
	POPJ	SREG,		;[1006]
;
P2MG:	MOVE	T,C2L			;[761]
	EXTEND	RH,[GFSC 0,0(T)]	;[761]
	POPJ	SREG,			;[761]
;
P2MC:	MOVE	T,C2L
	FSC	RH,0(T)
	FSC	RL,0(T)
	POPJ	SREG,
;
P2DI:	JUMPGE	RL,P2DI1	;FOR A DIVIDING A NEGATIVE CONST
				; BY 2**N BY DOING A RIGHT SHIFT
	MOVEI	T,1		; MUST ADD IN 2**N -1. MUST COMPUTE
	ASH	T,@C2L		; 2**N
	SUBI	T,1		; MINUS ONE
	ADD	RL,T		;THEN ADD IT TO THE NEG CONST 
P2DI1:	MOVN	T,C2L		;GET NEG OF THE POWER - TOSHIFT RIGHT
	ASH	RL,0(T)		;SHIFT RIGHT N PLACES
	POPJ	SREG,
;
P2DG:	MOVN	T,C2L			;[761]
	EXTEND	RH,[GFSC 0,0(T)]	;[761]
	POPJ	SREG,			;[761]
;
P2DC:	MOVN	T,C2L
	FSC	RH,0(T)
	FSC	RL,0(T)
	POPJ	SREG,
;
P21MI:	MOVE	T,C2L
	ASH	RL,0(T)
	ADD	RL,C1L
	POPJ	SREG,
;
P21MR:	MOVE	RH,C2L		;[1006]
	ASH	RH,^D27		;[1006]
	ADD	RH,[201400,,0]	;[1006]
	SETZ	RL,		;[1006]
	DFMP	RH,C1H		;[1006]
	DFAD	RH,C1H		;[1006]
	POPJ	SREG,		;[1006]
;
P21MG:	MOVE	T,C2L			;[761]
	EXTEND	RH,[GFSC 0,0(T)]	;[761]
	GFAD	RH,C1H			;[761]
	POPJ	SREG,			;[761]
;
P21MC:	MOVE	T,C2L
	FSC	RH,0(T)
	FADR	RH,C1H
	FSC	RL,0(T)
	FADR	RL,C1L
	POPJ	SREG,
;
;
;
;RAISE TO AN ARBITRARY INTEGER POWER
EXPINT:	SKIPN	T,C2L		;CHECK FOR POWER=0
	JRST	EXPIN0		; IF SO RETURN 1
	JUMPL	T,EXPING	;[1707] CHECK FOR NEGATIVE EXPONENT
	MOVEM	T,C2H		;STORE POWER  SOMEWHERE FOR COMPARE
	SETZ	RH,		;NOTHING BACK IN HIGH ORDER
EXPIN1:	TRNN	T,777776	;BITS OTHER THAN 1
	JRST	EXPIN2		;NO
	ROT	T,-1		;CYCLE
	JRST	EXPIN1		;TRY AGAIN
EXPIN2:	CAMN	T,C2H		;ANOTHER POWER
	POPJ	SREG,		;DONE
	ROT	T,1		;CYCLE
	IMUL	RL,RL		;MULTIPLY BY POWER
	TRNE	T,1		;BY NUMBER ITSELF?
	IMUL	RL,C1L		;YES
	JRST	EXPIN2		;ITERATE

EXPIN0:	SKIPE	C1L		;[1707] EXPONENT ZERO, IS BASE NONZERO?
	 JRST	EXPINZ		;[1707] YES, GO RETURN +1
	MOVEI	RL,0		;[1707] ELSE RETURN 0 WITH ERROR MESSAGE
EXPINO:	SETZ	T,		;[1707] SET NO-FIXUP FLAG
	PUSHJ	SREG,OVFLW	;[1707] TYPE ERROR MESSAGE
	POPJ	SREG,

EXPINZ:	MOVEI	RL,1		;[1707] RETURN 1
	POPJ	SREG,		;[1707]

EXPING:	HRLOI	RL,377777	;[1707] GUESS RESULT WILL OVERFLOW
	SKIPN	RH,C1L		;[1707] GET BASE
	 JRST	EXPINO		;[1707] IF BASE = 0, RESULT OVERFLOWS
	MOVEI	RL,1		;[1707] GUESS RESULT = 1
	TRNE	T,1		;[1707] IS EXPONENT ODD?
	 MOVE	RL,RH		;[1707] YES, RESULT WILL BE -1 IF BASE IS -1
	CAME	RH,[-1]		;[1707] CHECK FOR BASE = -1
	 CAIN	RH,1		;[1707] OR BASE = +1
	  JRST	EXPINR		;[1707] YES, RESULT IS +1 OR -1
	SETZ	RL,		;[1707] ELSE RESULT IS 0
EXPINR:	SETZ	RH,		;[1707] CLEAR HIGH WORD
	POPJ	SREG,		;[1707] DONE

;RAISE A REAL (OR DOUBLE PREC) TO AN ARBITRARY INTEGER POWER

EXPRL:				;[1707] from DEXP2. in FORLIB

	DMOVE	RH,[EXP 1.0,0]	;Floating 1 to RH-RL
	MOVM	T,C2L		;|exponent| to T
	JUMPE	T,DEXP0		;Exponent = 0 is special
	DMOVE	TH,C1H		;Base to TH-TL
	JUMPN	TH,DSTEP1	;If base not 0 go to main flow
	JRST	DBASE0		;Else to special code

DLOOP:	DFMP	TH,TH		;Square current result
	  JOV	DOVER2		;Over/underflow possible
DSTEP1:	TRNE	T,1		;If exponent is odd
	  DFMP	RH,TH		;  update current result
	    JOV  DOVER		;  Branch on over/underflow
	LSH	T,-1		;Discard low bit of exponent
	JUMPN	T,DLOOP		;Iterate if not 0

	SKIPL	C2L		;If exponent > 0
	  JRST	DRET		;  return
	DMOVE	TH,[EXP 1.0,0]	;Else get reciprocal of result
	DFDV	TH,RH		;Underflow impossible
	  JOV	DOVMSG		;  On overflow get message
	DMOVE	RH,TH		;Copy result
	JRST	DRET

DEXP0:	SKIPE	C1H		;Exponent 0. If base not
	  JRST	DRET		;  0, result is 1. Return
	SETZ	T,		;Set flag to prevent fixup
	PUSHJ	SREG,OVFLW	;Type overflow error message
	SETZB	RH,RL		;Zero**zero, store 0
	JRST	DRET

DBASE0:	SKIPL	C2L		;If exponent > 0
	  JRST	DZERO		;  result is 0
	SETZ	T,		;Set flag to prevent fixup
	PUSHJ	SREG,OVFLW	;Type overflow error message
	HRLOI	RH,377777	;Store +biggest
	HRLOI	RL,377777
	JRST	DRET

DZERO:	SETZB	RH,RL		;Result is 0
	JRST	DRET		;Return

;
;The following block of code deals with over/underflow in the
;square operation at LOOP:. Note that the "exponent" cannot be
;0 -- LOOP: is entered only if T is not 0. Moreover, if T is
;not 1 subsequent operations will aggravate the over/underflow
;condition in such a way that both the result of the iteration
;and its reciprocal will have the same exception as currently
;indicated. If, however, T = 1, and the square overflowed, it
;is possible that its reciprocal will be in range. We therefore
;complete the current pass through the loop, and if the LSH of T
;makes it zero, we join the handling at OVER: for overflow/underflow
;on the MUL of RH by TH. Note that no exception can occur on the
;MUL of RH by a wrapped over/underflow of the square, so that the
;exception flags will still be valid after this step.
;

DOVER2:	DFMP	RH,TH		;No over/underflow. Hence flags
				;  from square of T still valid
	LSH	T,-1		;Discard low bit of exponent
	JUMPE	T,DOVER		;If T = 0, RH has wrapped final
				;  result or its reciprocal
				;  which may be in range

				;Final product surely
	JSP	T,.+1		;over/underflows. Get exception flags
	TLNE	T,(PC.FUF)	;[2472] If underflow flag set, reciprocal
	  JRST	DUNDER		;  overflows. Go test sign of exponent

	SKIPL	C2L		;For overflow, if exponent > 0
	  JRST	DUNMSG		;  final result underflows.
	JRST	DOVMSG		;Else reciprocal gives overflow

;
;The rest of the code handles over/underflow on the product of
;RH by T and calculation of the reciprocal, if this is done.
;

DOVER:	JSP	T,.+1		;Get exception flags
	TLNE	T,(PC.FUF)	;[2472] If underflow flag set
	  JRST	DUNDER		;  underflow on product
	SKIPL	C2L		;Else, overflow on result if
	  JRST	DOVMSG		;  exponent > 0. Get message
	DMOVE	TH,[EXP 1.0,0]	;For exponent < 0, get reciprocal
	DFDV	TH,RH		;of wrapped overflow
	  JOV	DRRET		;Underflow impossible; overflow
				;  compensates previous overflow
	JRST	DUNMSG		;Else, get underflow message

DRRET:	DMOVE	RH,TH		;Copy reciprocated result
DRET:	POP	SREG,T		;Get PC and flags
	TLZ	T,-1		;Clear flags
	JRSTF	@(T)		;Return

DUNDER:	SKIPL	C2L		;Product underflowed. If exponent
	  JRST	DUNMSG		;  >/= 0, result underflows
				;Else reciprocal overflows

DOVMSG:	SETZ	T,		;Set screwy flag to prevent fixup
	PUSHJ	SREG,OVFLW	;Type overflow message
	JUMPL	RH,DNEGOV	;If result > 0
	HRLOI	RH,377777	;Store +BIGGEST
	HRLOI	RL,377777
	JRST	DRET		;  and return

DNEGOV:	MOVSI	RH,400000	;If result < 0, store -BIGGEST
	MOVEI	RL,1
	JRST	DRET		;  and return

DUNMSG:	SETZ	T,		;Set screwy flag to prevent fixup
	PUSHJ	SREG,OVFLW	;Type error message
	SETZB	RH,RL		;Result underflow
	JRST	DRET

;RAISE G-FLOATING TO AN INTEGER POWER

EXPGF:				;[1707] from DEXP2. in FORLIB

	DMOVE	RH,[EXP G1,0]	;[1724]Floating 1 to RH-RL
	MOVM	T,C2L		;|exponent| to T
	JUMPE	T,GEXP0		;Exponent = 0 is special
	DMOVE	TH,C1H		;Base to TH-TL
	JUMPN	TH,GSTEP1	;If base not 0 go to main flow
	JRST	GBASE0		;Else to special code

GLOOP:	GFMP	TH,TH		;Square current result
	  JOV	GOVER2		;Over/underflow possible
GSTEP1:	TRNE	T,1		;If exponent is odd
	  GFMP	RH,TH		;  update current result
	    JOV  GOVER		;  Branch on over/underflow
	LSH	T,-1		;Discard low bit of exponent
	JUMPN	T,GLOOP		;Iterate if not 0

	SKIPL	C2L		;If exponent > 0
	  JRST	GRET		;  return
	DMOVE	TH,[EXP G1,0]	;[1724]Else get reciprocal of result
	GFDV	TH,RH		;Underflow impossible
	  JOV	GOVMSG		;  On overflow get message
	DMOVE	RH,TH		;Copy result
	JRST	GRET

GEXP0:	SKIPE	C1H		;Exponent 0. If base not
	  JRST	GRET		;  0, result is 1. Return
	SETZ	T,		;Set flag to prevent fixup
	PUSHJ	SREG,OVFLW	;Type overflow error message
	SETZB	RH,RL		;Zero**zero, store 0
	JRST	GRET

GBASE0:	SKIPL	C2L		;If exponent > 0
	  JRST	GZERO		;  result is 0
	SETZ	T,		;Set flag to prevent fixup
	PUSHJ	SREG,OVFLW	;Type overflow error message
	HRLOI	RH,377777	;Store +biggest
	HRLOI	RL,377777
	JRST	GRET

GZERO:	SETZB	RH,RL		;Result is 0
	JRST	GRET		;Return

;
;The following block of code deals with over/underflow in the
;square operation at LOOP:. Note that the "exponent" cannot be
;0 -- LOOP: is entered only if T is not 0. Moreover, if T is
;not 1 subsequent operations will aggravate the over/underflow
;condition in such a way that both the result of the iteration
;and its reciprocal will have the same exception as currently
;indicated. If, however, T = 1, and the square overflowed, it
;is possible that its reciprocal will be in range. We therefore
;complete the current pass through the loop, and if the LSH of T
;makes it zero, we join the handling at OVER: for overflow/underflow
;on the MUL of RH by TH. Note that no exception can occur on the
;MUL of RH by a wrapped over/underflow of the square, so that the
;exception flags will still be valid after this step.
;

GOVER2:	GFMP	RH,TH		;No over/underflow. Hence flags
				;  from square of T still valid
	LSH	T,-1		;Discard low bit of exponent
	JUMPE	T,GOVER		;If T = 0, RH has wrapped final
				;  result or its reciprocal
				;  which may be in range

				;Final product surely
	JSP	T,.+1		;over/underflows. Get exception flags
	TLNE	T,(PC.FUF)	;[2472] If underflow flag set, reciprocal
	  JRST	GUNDER		;  overflows. Go test sign of exponent

	SKIPL	C2L		;For overflow, if exponent > 0
	  JRST	GUNMSG		;  final result underflows.
	JRST	GOVMSG		;Else reciprocal gives overflow

;
;The rest of the code handles over/underflow on the product of
;RH by T and calculation of the reciprocal, if this is done.
;

GOVER:	JSP	T,.+1		;Get exception flags
	TLNE	T,(PC.FUF)	;[2472] If underflow flag set
	  JRST	GUNDER		;  underflow on product
	SKIPL	C2L		;Else, overflow on result if
	  JRST	GOVMSG		;  exponent > 0. Get message
	DMOVE	TH,[EXP G1,0]	;[1724]For exponent < 0, get reciprocal
	GFDV	TH,RH		;of wrapped overflow
	  JOV	GRRET		;Underflow impossible; overflow
				;  compensates previous overflow
	JRST	GUNMSG		;Else, get underflow message

GRRET:	DMOVE	RH,TH		;Copy reciprocated result
GRET:	POP	SREG,T		;Get PC and flags
	TLZ	T,-1		;Clear flags
	JRSTF	@(T)		;Return

GUNDER:	SKIPL	C2L		;Product underflowed. If exponent
	  JRST	GUNMSG		;  >/= 0, result underflows
				;Else reciprocal overflows

GOVMSG:	SETZ	T,		;Set screwy flag to prevent fixup
	PUSHJ	SREG,OVFLW	;Type overflow message
	JUMPL	RH,GNEGOV	;If result > 0
	HRLOI	RH,377777	;Store +BIGGEST
	HRLOI	RL,377777
	JRST	GRET		;  and return

GNEGOV:	MOVSI	RH,400000	;If result < 0, store -BIGGEST
	MOVEI	RL,1
	JRST	GRET		;  and return

GUNMSG:	SETZ	T,		;Set screwy flag to prevent fixup
	PUSHJ	SREG,OVFLW	;Type error message
	SETZB	RH,RL		;Result underflow
	JRST	GRET

;++
; New [2472] /PLB
; FUNCTIONAL DESCRIPTION:
;
;	Perform COMPLEX ** INTEGER by repeated multiplication of 
;	powers of 2 of the base (A,B).
;
;	(A + Bi) ** I
;
;      ------
;	|  |
;	|  |  (A + Bi) ** (2 ** n)
;	|  |
;	
;
; CALLING SEQUENCE:
;
;	PUSHJ	SREG,EXPCMP
;
; INPUT PARAMETERS:
;
;	None
;
; IMPLICIT INPUTS:
;
;	C1H/	A
;	C1L/	B
;	C2L/	I
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	Returns with clear PC flags.
;
; FUNCTION VALUE:
;
;	COMPLEX result in RH/RL register pair.
;
; SIDE EFFECTS:
;
;	Will output error message on over/underflow.
;
;--

EXPCMP:	SKIPN	C2L		;CHECK FOR EXPONENT = 0
	 JRST	CEXP0		; EXPONENT = 0 IS SPECIAL
	SKIPN	C1H		;CHECK FOR ZERO REAL ...
	 SKIPE	C1L		; ... AND IMAGINARY PARTS
	  TRNA			;  ONE IS NOT ZERO, MOVE AHEAD
	   JRST	DBASE0		;   BOTH ZERO -- SPECIAL CASE DETECTED

	DMOVE	RH,SCONE	;GET DOUBLE 1.0
	DMOVEM	RH,ARGA		;STORE AS REAL PART OF ACCUMULATION
	SETZM	SCALEA		;CLEAR SCALE FOR A

	SETZB	RH,RL		;GET DOUBLE 0.0
	DMOVEM	RH,ARGB		;STORE IMAG PART OF ACCUMULATION
	SETZM	SCALEB		;CLEAR SCALE

	MOVE	RH,C1H		;GET REAL PART OF BASE
	MOVEI	T,ARGC		;GET BLOCK
	PUSHJ	SREG,SCALIFY	;COPY AND SCALE

	MOVE	RH,C1L		;GET IMAGINARY PART OF BASE
	MOVEI	T,ARGD		;GET BLOCK
	PUSHJ	SREG,SCALIFY	;COPY AND SCALE

	MOVM	T,C2L		;GET ABS(EXPONENT) INTO T
	JRST	CSTEP1		;GO INTO LOOP

; MAIN LOOP
CLOOP:
;;;	BLCALL	(COMPMUL,<[ARGC],[ARGD],[ARGC],[ARGD]>) ;SQUARE BASE (C,D)
	BLCALL	(COMPSQ,<[ARGC],[ARGD]>) ;SQUARE BASE (C,D)
CSTEP1:	TRNN	T,1		;IF EXPONENT IS ODD
	 JRST	CSTEP2		; NO, NOT ODD
	BLCALL	(COMPMUL,<[ARGA],[ARGB],[ARGC],[ARGD]>) ;(A,B) := (A,B)*(C,D)
CSTEP2:	LSH	T,-1		;DISCARD LOW BIT OF EXPONENT
	JUMPN	T,CLOOP		;ITERATE IF NOT ZERO

	SKIPL	C2L		;IF EXPONENT .GT. 0
	 JRST	CRET		; RETURN
	BLCALL	(COMPDIV,<[SCONE],[SCZER],[ARGA],[ARGB]>) ;RECIPROCATE
	 JOV	.POPJ		;WE BLEW IT??? RETURN WITH FLAGS NOW

CRET:	DMOVE	RH,ARGB		;GET IMAGINARY RESULT
	MOVE	T,SCALEB	;GET SCALE
	PUSHJ	SREG,UNSCALE	;CONVERT TO SINGLE
	PUSH	SREG,RH		;SAVE IT
	DMOVE	RH,ARGA		;GET REAL PART
	MOVE	T,SCALEA	;GET SCALE
	PUSHJ	SREG,UNSCALE	;MAKE INTO SINGLE
	POP	SREG,RL		;RESTORE COMPLEX PART
	POPJ	SREG,		;RETURN WITH FLAGS
				;OUR CALLER WILL HANDLE OVER/UNDERFLOW

;HERE FOR SPECIAL CASE OF 0 AS AN EXPONENT
CEXP0:	DMOVE	RH,[EXP 1.0,0]	;GET (1.,0.)
	SKIPN	C1H		;EXPONENT WAS 0.
	 SKIPE	C1L		; IF BASE NOT
	  JRST	DRET		;  (0.,0.) RESULT IS (1.,0.) -- RETURN CLEAN
	SETZ	T,		;SET FLAG TO PREVENT FIXUP
	PUSHJ	SREG,OVFLW	;TYPE UNDER/OVERFLOW ERROR MESSAGE
	SETZB	RH,RL		;ZERO**ZERO, STORE 0
	JRST	DRET		;RETURN CLEAN FLAGS

SCONE:	EXP	1.0,0,0		;DOUBLE SCALED 1.0
SCZER:	EXP	0,0,0		;DOUBLE SCALED 0.0

;++
; New [2472]/PLB
; FUNCTIONAL DESCRIPTION:
;
;	Take a Single Precision floating point number and convert to a
;	"Scaled" Double Precision number.
;
; CALLING SEQUENCE:
;
;	PUSHJ	SREG,SCALIFY
;
; INPUT PARAMETERS:
;
;	RH/	Single precision floating point number
;	T/	Pointer to 3 word block for Scaled Double number
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	Scaled number stored in block pointed to by T.
;
; FUNCTION VALUE:
;
;	None
;
; SIDE EFFECTS:
;
;	None
;
;--

SCALIFY:
	SETZ	RL,		;MAKE DOUBLE PRECISION
	DMOVEM	RH,0(T)		;STORE
	SETZM	2(T)		;CLEAR SCALE FACTOR
	BLCALL	(ADJUST,<T>)	;PERFORM SCALING IF NEEDED
	POPJ	SREG,

;++
; New [2472]/PLB
; FUNCTIONAL DESCRIPTION:
;
;	Convert Scaled double to single precision.
;
; CALLING SEQUENCE:
;
;	PUSHJ	SREG,UNSCALE
;
; INPUT PARAMETERS:
;
;	RH/	High Order word of Double
;	RL/	Low Order word of Double
;	T/	Integer Scale factor
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	Sets PC flags on under/overflow (no un-scaled representation exists).
;
; FUNCTION VALUE:
;
;	Single Precision number returned in RH.
;
; SIDE EFFECTS:
;
;	None
;
;--

UNSCALE:
	PUSH	SREG,T		;SAVE SCALE FACTOR
	PUSHJ	SREG,DPCM	;CONVERT DOUBLE TO SINGLE
	POP	SREG,T		;RESTORE SCALE FACTOR
	JUMPE	T,.POPJ		;SCALE FACTOR OF ZERO?
	JUMPE	RH,.POPJ	;IF NUMBER IS ZERO, FORGET IT
	LSH	T,6		;NO, MULTIPLY BY 100 OCTAL
	FSC	RH,0(T)		;PERFORM DE-SCALING (MAY UNDER/OVERFLOW)
.POPJ:	POPJ	SREG,		;RETURN

;FOR THE FOLDING OF IN-LINE-FNS
;
KILFBA:	MOVM	RL,RL
	PUSHJ	SREG,SKERR		;UNUSED OPERSP
	PUSHJ	SREG,ISIGN
	PUSHJ	SREG,DIM
	PUSHJ	SREG,MOD
	PUSHJ	SREG,MAX
	PUSHJ	SREG,MIN
;FOR ARGS REAL NOGFLOATING
KILFBR:	MOVM	RH,RH
	PUSHJ	SREG,CMPLX	;FOR REAL TO CMPLX
	PUSHJ	SREG,SIGN
	PUSHJ	SREG,DIM
	PUSHJ	SREG,SKERR	;PUSHJ	SREG,MOD
	PUSHJ	SREG,AMAX
	PUSHJ	SREG,AMIN
;FOR ARGS REAL GFLOATING [761]
;[1031] Use DABS routine for GFLOATING ABS since low word has some SP mantissa
KILFBG:	PUSHJ	SREG,ILDABS	;[1031] GFLOATING must do both words
	PUSHJ	SREG,GCMPLX	;[761] FOR REAL TO CMPLX
	PUSHJ	SREG,SIGN	;[761]
	PUSHJ	SREG,GDIM	;[761]
	PUSHJ	SREG,SKERR	;[761] PUSHJ	SREG,MOD
	PUSHJ	SREG,AMAX	;[761]
	PUSHJ	SREG,AMIN	;[761]
;
;SPECIAL CODE TO HANDLE DABS

KILDAB:	PUSHJ SREG,ILDABS

ILDABS:	SKIPGE	0,RH
	DMOVN	RH,RH
	POPJ	SREG,

;
;
CMPLX:	PUSHJ	SREG,DPCM	;COMBINE HIGH ORDER WORD
	EXCH	RH,C2H		;STORE HIGH ORDER, GET NEW HIGH ORDER
	MOVEM	RH,C1H		;STORE FOR DPCM
	EXCH	RL,C2L		;STORE LOW ORDER, LOAD NEW LOW ORDER
	MOVEM	RL,C1L		;SET FOR DPCM
	PUSHJ	SREG,DPCM	;COMBINE LOW ORDER
	MOVE	RL,RH		;COPY LOW ORDER
	MOVE	RH,C2H		;COPY HIGH ORDER
	POPJ	SREG,		;DONE
;
GCMPLX:	PUSHJ	SREG,GFCM	;[761] COMBINE HIGH ORDER WORD
	EXCH	RH,C2H		;[761] STORE HIGH ORDER, GET NEW HIGH ORDER
	MOVEM	RH,C1H		;[761] STORE FOR GFCM
	EXCH	RL,C2L		;[761] STORE LOW ORDER, LOAD NEW LOW ORDER
	MOVEM	RL,C1L		;[761] SET FOR GFCM
	PUSHJ	SREG,GFCM	;[761] COMBINE LOW ORDER
	MOVE	RL,RH		;[761] COPY LOW ORDER
	MOVE	RH,C2H		;[761] COPY HIGH ORDER
	POPJ	SREG,		;[761] DONE
;
SIGN:	MOVM	RH,RH
	SKIPGE	C2H
	MOVNS	RH,RH
	POPJ	SREG,
;
DIM:	CAMG	RH,C2H
	TDZA	RH,RH
	FSBR	RH,C2H
	POPJ	SREG,
;
GDIM:	CAMG	RH,C2H	;[761]
	 JRST	GDIMX	;[1605]
	GFSB	RH,C2H	;[761]
	POPJ	SREG,	;[761]
GDIMX:	SETZB	RH,RL	;[1605] Zero both words (Gfloating has 3 bits in RL)
	POPJ	SREG,	;[1605]
;
MOD:	MOVE	RH,RL
	IDIV	RH,C2L
	POPJ	SREG,
;
MAX:	CAMGE	RL,C2L
	MOVE	RL,C2L
	POPJ	SREG,
;
MIN:	CAMLE	RL,C2L
	MOVE	RL,C2L
	POPJ	SREG,

AMAX:	CAMGE	RH,C2H
	MOVE	RH,C2H
	POPJ	SREG,
;
AMIN:	CAMLE	RH,C2H
	MOVE	RH,C2H
	POPJ	SREG,
;
ISIGN:	MOVM	RL,RL
	SKIPGE	C2L
	MOVNS	RL,RL
	POPJ	SREG,



;
;
;
;TYPE CONVERSION
;
;FROM LOGICAL/OCTAL TO REAL,DOUBLE-PREC,COMPLEX
OCTRL:	MOVE	RH,RL
LITRL:	MOVEI	RL,0
	POPJ	SREG,
;[1542]
;From OCTAL/LOGICAL to REAL under GFLOATING.  Note that GDBLE can not
;be used because we want the GFLOATING number to be unnormalized if
;the OCTAL/LOGICAL number was not normalized.
GOCTRL:	MOVE	RH,RL		;Get constant from low order word
GLITRL:	SETZ	RL,		;Zero low order word
	JUMPE	RH,GOCTRET	;True zero is double word of zeros
	ASHC	RH,-3		;Make room for new exponent
	TLZ	RH,340000	;Clear any copies if sign bit in high word
	TLZ	RL,400000	;Clear the accidently set sign bit in low word
	ADD	RH,[XWD 160000,0] ;Fixup exponent scale factor
GOCTRET:POPJ	SREG,

;FROM DOUBLE-OCTAL TO INTEGER
; OR LITERAL TO OCTAL/LOGICAL/CONTROL/INTEGER
DOCTIN:
LITINT:	MOVE	RL,RH
	MOVEI	RH,0
	POPJ	SREG,
;
;FROM LITERAL TO DOUBLE OCTAL (COMPLEX OR DOUBLE PRECISION)
;
LITTWD:	JUMPN	RL,CPOPJ		;SET LOW ORDER WORD TO
	MOVE	RL,[ASCII /     /]	;BLANKS IF ZERO
	POPJ	SREG,			;AND RETURN
;
;FROM REAL (DOUBLE-PREC OR COMPLEX) TO LOGICAL. USE HIGH ORDER OR
; REAL PART ONLY
RLLOG:	MOVE	RL,RH
	MOVEI	RH,0
	POPJ	SREG,
;
;[1542] From REAL to LOGICAL under GFLOATING.  Convert to number to single
;precision, preserving the unnormalized properities (if any) of the number.
GRLLOG:	SKIPN	RH		;If High order word is not zero, skip
	 JUMPE	RL,GRLRET	;If Low order word is zero, return

	JUMPL	RH,GRLNEG	;If number is negative then goto GRLNEG
	CAMLE	RH,[217777777777];Make sure number doesn't overflow
	 JRST	GRLOVL		;Number will overflow
	CAMGE	RH,[160000000000];Make sure number doesn't underflow
	 JRST	GRLUNDR		;Number will underflow

GRLCON:	SUB	RH,[XWD 160000,0] ;Subtract Scaling Factor between Gfloat/Real
	SKIPGE	RH		;Skip if number is not negative
	 TLO	RH,340000	;Turn on bits so ASHC won't overflow
	ASHC	RH,3		;Make exponent field narrower
	MOVE	RL,RH		;Constant lives in low order word
	SETZ	RH,		;Zap high order word

GRLRET:	POPJ	SREG,

GRLNEG:	CAMGE	RH,[560000000000];Make sure number doesn't overflow
	 JRST	GRLOVL		;Number will overflow
	CAMLE	RH,[617777777777];Make sure number doesn't underflow
	 JRST	GRLUNDR		;Number will underflow
	JRST	GRLCON		;Number is ok, go and convert it

GRLOVL:	SETZ	T,		;Set T so that OVFLW knows we called it
	PUSHJ	SREG,OVFLW	;Print error message
	MOVE	RL,[377777777777];Set low order word to infinity
	SKIPGE	RH		;Skip if number is not negative
	 MOVN	RL,RL		;Return Neg. inifinity
	SETZ	RH,		;Zap High order word
	POPJ	SREG,		;Return

GRLUNDR:SETZ	T,		;Set T so that OVFLW knows we called it
	PUSHJ	SREG,OVFLW	;Print error message
	SETZB	RH,RL		;Return Zero
	POPJ	SREG,		;Return


;
;FROM INTEGER TO  COMPLEX
INTCM:	MOVE	RH, RL		;MOVE INTEGER INTO WD WHER REAL PART IS TO
				; BE LEFT
	IDIVI	RH,400		;DIVIDE INTEGER INTO 2 PIECES
	SKIPE	RH		;IMPLIES INTEGER LESS THAN 18 BITS
	TLC	RH, 243000	;SET EXP TO 254 (27+17 DECIMAL)
	TLC	RL, 233000	;SET EXP OF 2ND PART TO 233 (27 DECIMAL)
	FADR	RH,RL		;NORMALIZE AND ADD
	MOVEI	RL,0
	POPJ	SREG,
;FROM INTEGER TO DOUBLE-PREC OR REAL (SINCE WE KEEP 2 WDS)
INTDP:	MOVE	RH, RL		;PUT INTEGER INTO REG IN WHICH HIGH ORDER
				; PART WILL BE RETURNED
	SETZ	RL,		; CLEAR LOW ORDER WORD
	ASHC	RH,-8		; MAKE ROOM FOR EXPONENT IN HIGH WORD
	TLC	RH,243000	; SET EXP TO 27+8 DECIMAL
	DFAD	RH,[EXP 0,0]	; NORMALIZE
	POPJ	SREG,		; RETURN
;
INTGF:	MOVE	RH, RL		;[761]
	EXTEND	RH,[GFLTR 0,RH]	;[761]
	POPJ	SREG,		;[761]

;FROM  COMPLEX TO INTEGER
CMINT:	MOVM	RH, RH		;USE  MAGNITUDE ONLY
	MULI	RH,400		;SEPARATE FRACTION AND EXPONENT
				;(EXPONENT IN RH, FRACTION IN RL)
	ASH	RL, -243(RH)	;USE THE EXPONENT AS AN INDEX REGISTER
	SKIPGE	C1H		;SET THE CORRECT SIGN
	MOVNS	RL,RL
	MOVEI	RH,0		;ZERO 1ST WD
	POPJ	SREG,
;FROM DOUBLE PREC OR REAL (SINCE WE KEEP 2 WDS OF ACCURACY) TO INTEGER
DPINT:
	;TAKE THE ABSOLUTE VALUE - IF THE NUMBER IS NEGATIVE, MUST
	; NEGATE A KI10 FORMAT NUMBER (THIS CODE RUNS ON KA OR KI)
	SKIPGE	RH
	DMOVN	RH,RH

	HLRZ	T,RH		;GET EXPONENT INTO RIGHT
	ASH	T,-9		; 8 BITS OF REGISTER "T"
	TLZ	RH,777000	;WIPE OUT EXPONENT IN ARG
	ASHC	RH,-201-^D26(T)	;CHANGE FRACTION BITS TO INTEGER
	SKIPGE	C1H		;IF ORIGINAL VAL WAS NEGATIVE
	MOVNS	RH		; NEGATE THE INTEGER RESULT
;
	MOVE	RL,RH		;ALWAYS LEAVE INTEGER RESULTS IN RL
	MOVEI	RH,0		; WITH RH EQL TO 0
;
	POPJ	SREG,

GFINT:	EXTEND	RL,[GFIX RH]	;[1030] truncate instead of rounding
	MOVEI	RH,0		;[761]
	POPJ	SREG,		;[761]

;
;FROM DOUBLE PREC TO COMPLEX - ROUND HIGH WD, ZERO IMAGINARY PART

DPCM:	JUMPE	RH,CPOPJ	;FOR ZERO - DO NOTHING

;MUST FIRST TAKE ABSOLUTE VALUE - IF THE NUMBER IS NEG, MUST
; NEGATE A KI10 FORMAT NUMBER (THIS CODE RUNS ON KA OR KI)

	PUSH	SREG,RH		;[2472] SAVE ORIGINAL SIGN
	SKIPGE	RH
	 DMOVN	RH,RH

	CAMN	RH,[377777777777] ;[1637] RESULT OF PREVIOUS OVERFLOW?
	 CAME	RL,[377777777777] ;[1637]
	  TRNA			;[2472] NO
	   JRST	DPRL2		;[1637] YES, DO NOT OVERFLOW AGAIN,
				;[1637] JUST RETURN 377777777777

DPCM0:	TLNN	RL,200000	;IS ROUNDING NECESSARY?
	 JRST	DPRL2		; NO, JUST RETURN
	AOJ	RH,		;[2472] YES, ROUND INTO HIGH WORD
	TLO	RH,400		;TURN ON HI FRAC BIT IN CASE CARRY
				;  ADDED 1 TO EXPONENT
DPCM1:	JUMPGE	RH,DPRL2
	HRLOI	RH,377777	;OVERFLOW, MAKE LARGEST NUMBER AND
	JRSTF	@[XWD 440000,DPRL2] ;SET AROV AND FOV
DPRL2:	POP	SREG,RL		;[2472] GET ORIGINAL SIGN
	SKIPGE	RL		;[2472] IF ORIGINAL NUMBER WAS NEG
	 MOVN	RH,RH		;THEN NEGATE THE RESULT
	MOVEI	RL,0		;CLEAR LOW WORD
	POPJ	SREG,

;FROM MTHPRM SNG.X MACRO
IFN 0,<
	JUMPL	RH,SNG3		;NEGATIVE ARGUMENT?
	TLNE	RL,(1B1)	;POSITIVE. ROUND REQUIRED?
	 TRON	RH,1		;YES, TRY TO ROUND BY SETTING LSB
	  JRST	SNG2		;WE WON, FINISHED
	MOVE	RL,RH		;COPY HIGH PART OF ARG
	AND	RH,[777000,,1]	;MAKE UNNORMALIZED LSB, SAME EXPONENT
	FAD	RH,RL		;ROUND & RENORMALIZE
SNG2:	SETZ	RL,
	POPJ	SREG,

;HERE IF ARG IS NEGATIVE
SNG3:	DMOVN	RH,RH		;MAKE POSITIVE
	TLNE	RL,(1B1)	;NEED ROUNDING?
	 TRON	RH,1		;YES, TRY TO DO IT BY SETTING LSB
	  JRST	SNG4		;DONE
	MOVN	RL,RH		;MAKE RE-NEGATED COPY OF HIGH PART
	ORCA	RH,[777,,-1]	;GET UNNORM NEG LSB WITH SAME EXPONENT
	FADR	RH,RL		;ROUND & NORMALIZE
	SETZ	RL,
	POPJ	SREG,

SNG4:	MOVN	RH,RH		;RE-NEGATE
	SETZ	RL,
	POPJ	SREG,		;EXIT
> ;NEW DPCM
;
;FROM G-FLOATING TO COMPLEX - ROUND HIGH WD, ZERO IMAGINARY PART

GFCM:	CAMN	RH,[377777777777] ;[1637] CHECK FOR PREVIOUS OVERFLOW
	CAME	RL,[377777777777] ;[1637] 
	 JRST	GFCM1		;[1637] 

	SETZ	RL,		;[1637] PREVIOUS OVERFLOW, JUST RETURN
	POPJ	SREG,		;[1637] 377777777777 SO AS NOT TO OVF AGAIN

GFCM1:	CAMN	RH,[400000000000] ;[1637] CHECK FOR NEG OVERFLOW
	CAIE	RL,1		;[1637] 
	 JRST	GFCM2		;[1637] 

	DMOVE	RH,[EXP 400000000001,0]	;[1637] RETURN NEG OV, DON'T OVF AGAIN
	POPJ	SREG,		;[1637] 

GFCM2:	EXTEND	RH,[GSNGL RH]	;[761]
	MOVEI	RL,0		;[761]
	POPJ	SREG,		;[761]

;[1542]
;Convert from internal real (gfloating) to external real.  Note that
;the gfloating number is only rounded and normalized during the conversion
;if its bit pattern can not fit in a single word of precision.
GREAL:	TDNE	RL,[037777777777];Does the number need rounding?
	 JRST	GFCM		;Yes, use GFCM to round and normalize number
	PUSHJ	SREG,GRLLOG	;Convert number
	EXCH	RL,RH		;Swap high order, low order words
	POPJ	SREG,		;Return

;
;WHEN AN OVERFLOW/UNDERFLOW WAS DETECTED
;
;
OVFLW:
	PUSH	SREG,RH		;STORE RESULT OF COMPUTATION HIGH ORDER
	PUSH	SREG,RL		;STORE RESULT OF COMPUTATION LOW ORDER
	PUSH	SREG,T		;STORE FLAGS
				;TYPE OUT MESSAGE
	PUSH	SREG,ISN##	;PASS STATEMENT NUMBER
	PUSH	SREG,[E64##]	;ERROR NUMBER 64(DEC) TO BE PRINTED
	PUSHJ	SREG,WARNERR##	;TYPE WARNING
	POP	SREG,0(SREG)	;RESTORE STACK
	POP	SREG,0(SREG)
	POP	SREG,T		;RESTORE FLAGS
	POP	SREG,RL		;RESTORE RESULT LOW ORDER
	POP	SREG,RH		;RESTORE RESULT HIGH ORDER
	HRRZ	RGDSP,COPRIX	;RESTORE DISPATCH INDEX

	JUMPE	T,CPOPJ		;[1542] T equal to 0 means caller will do fixup

	;DETERMINE THE TYPE OF THE RESULT BEING GENERATED
	; LEAVE THE REGISTER "RGDSP" SET TO 0 FOR INTEGER, 1 FOR REAL,
	; 2 FOR DOUBLE-PREC, 3 FOR COMPLEX
	;
	;THE FIRST ENTRIES IN THE DISPATCH TABLE ARE ARITH FOLLOWED BY TYPE
	; CONVERSION. IN BOTH THESE CASES, THE INDEX INTO THE TABLE WAS BUILT
	; BY ADDING THE BASE FOR THE GIVEN OPERATION TO A 2 BIT TYPE CODE.
	CAIL	RGDSP,KBOOLB	
	JRST	OVFLW1
	; IF DISPATCH-INDEX WAS FOR A TYPE-CNV OR ARITH OP, CAN GET TYPE
	; OF RES BY SUBTRACTING BASE OF TABLE AND THEN USING LAST 2 BITS
	SUBI	RGDSP,KARIIB
	ANDI	RGDSP,3
	JRST	HAVTYP
OVFLW1:	

	; IF THE VAL OF COPRIX IS BETWEEN THE BASE FOR BOOLEANS AND THE 
	; THE BASE FOR SPECIAL-OPS, THEN THE OVERFLOW WAS CAUSED IN
	;  DOUBLE-PREC NEGATION. VALUE TYPE IS ALWAYS DOUBLE-PREC
	CAIL	RGDSP,KSPECB
	JRST	OVFLW2
	MOVEI	RGDSP,2
	JRST	HAVTYP
OVFLW2:

	;IF COPRIX IS IN THE RANGE USED FOR SPECIAL-OPS - USE THE LAST 2 BITS
	CAIL	RGDSP,KILFBA
	JRST	OVFLW3
	SUBI	RGDSP,KSPECB
	ANDI	RGDSP,3
	JRST	HAVTYP
OVFLW3:

	;FOR IN-LINE-FNS ARGS ARE INTEGER BETWEEN "KILFBA" AND "KILFBR"
	; REAL IF GREATER THAN "KILFBR"
	CAIL	RGDSP,KILFBR
	JRST	OVFLW4
	MOVEI	RGDSP,0
	JRST	HAVTYP
OVFLW4:	MOVEI	RGDSP,1



;	AFTER HAVE SET THE REGISTER "RGDSP" TO CONTAIN THE VALTYPE OF
;        THE RESULT
HAVTYP:
	JUMPE	RGDSP,CPOPJ	;IF THE TYPE IS INTEGER, DO NOT ALTER THE
				; RESULT

	TLNN	T,000100	; SKIP IF UNDERFLOW
	JRST	OVERFL		; IF EITHER OVERFLOW OR DIVIDE-CHECK,
				; TREAT AS AN OVERFLOW

	;
	; FOR UNDERFLOW - SET THE RESULT TO 0
	SETZB	RH,RL
CPOPJ:	POPJ	SREG,		;GO STORE THE RESULT AND RETURN

	;
	;FOR OVERFLOW (OR DIVIDE CHECK) - SET THE RESULT TO THE HIGHEST
	; NUMBER (NEG OR POS) AND RETURN
OVERFL:	JUMPL	RH,NEGNUM
	HRLOI	RH,377777
	CAIE	RGDSP,1
	HRLOI	RL,377777		;IF THE VALTYPE WAS DOUBLE-PREC
					; OR COMPLEX
	POPJ	SREG,
;
;      IF THE VAL WAS NEG - USE THE LARGEST NEG NUMBER
NEGNUM:
	CAIN	RGDSP,2
	JRST	DPNEGN
	MOVE	RH,[400000000001]
	CAIN	RGDSP,3
	MOVE	RL,[400000000001] ;IF THE TYPE WAS COMPLEX, SET THE IMAGIN
				; PART AS WELL AS THE REAL PART
	POPJ	SREG,
;
;	FOR A DOUBLE-PREC, WHEN WANT THE LARGEST NEGATIVE DP NUMBER
DPNEGN:	HRLZI	RH,400000
	MOVEI	RL,1
	POPJ	SREG,

	RELOC	0		;[2472] IMPURE DATA

TEMP:	BLOCK	2		;[2472] TEMP PAIR FOR COMPLEX OPERATIONS

; [2472] THE FOLLOWING BLOCKS MUST BE KEPT IN ORDER *********************
ARGA:	BLOCK	2		;[2472] ARGS FOR DOUBLE COMPLEX OPERATIONS
SCALEA:	BLOCK	1		;[2472] INTEGER EXPONENT SCALE FOR ARGA
ARGB:	BLOCK	2		;[2472] ARGS FOR DOUBLE COMPLEX OPERATIONS
SCALEB:	BLOCK	1		;[2472] INTEGER EXPONENT SCALE FOR ARGB
ARGC:	BLOCK	2		;[2472] ARGS FOR DOUBLE COMPLEX OPERATIONS
SCALEC:	BLOCK	1		;[2472] INTEGER EXPONENT SCALE FOR ARGC
ARGD:	BLOCK	2		;[2472] ARGS FOR DOUBLE COMPLEX OPERATIONS
SCALED:	BLOCK	1		;[2472] INTEGER EXPONENT SCALE FOR ARGD
; [2472] ****************************************************************

	RELOC			;[2472] BACK TO HISEG

	END