Google
 

Trailing-Edge - PDP-10 Archives - bb-h138f-bm - 7-sources/mthprm.mac
There are 13 other files named mthprm.mac in the archive. Click here to see a list.
	UNIVERSAL MTHPRM	 FOR MATH LIBRARY, 2(4001)

;	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 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 THAT IS NOT SUPPLIED BY DIGITAL.
;

	.DIRECT	.NOBIN
	SALL
;REVISION HISTORY


COMMENT \

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

3200	JLC
	Create MTHPRM from FORPRM

3205	JLC	3-Jun-82
	Move error character to 1st position in the error macros.

3207	AHM	14-Jun-82
	Remove definitions  of random  .JB??? symbols  fron the  FSRCH
	macro and just have it always SEARCH JOBDAT.

3220	PLB	12-Oct-82
	Add IFIW to definition of FUNCT macro, for extended addressing use.

3230	JLC	12-Jan-83
	Add OPDEFs.

***** Begin Version 1A *****

3236	PLB	25-Mar-83
	Once again, change the FUNCT macro.  It should
	not OR the IFIW in, since that implies a 30 bit
	argument address.

3241	TGS	31-Mar-83
	Fix FUNCT macro to correctly expand arguments of the type
	(SUB,<<TP%SPR,adr>>).  FORPL2 was getting Q compilation errors.

3242	TGS	1-Apr-83
	Turn on FTGFL flag so gfloating arguments passed to MTHCDX routines
	will correctly call their gfloating counterparts. Move ARGKWD, ARGTYP
	and ARGADR definitions from FORPRM to MTHPRM and delete FTGFL flag
	from FORPRM (Forots edit 3300).

3243	BCM	29-Mar-83
	Get and clear PC flags with new GETFLG and RESFLG macros.  Fixes
	always clearing underflow in MTHTRP.  Only applies to JOV branches.

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

4001	PLB	6-Jul-83
	Remove indexing from XJRSTF AC in RESFLG macro.  This should
	also get fixed in ML1A: since it affects all extended
	addressing.
\

FTMATH==-1			;TELL APPENDED xxxPRM FILES WE HAVE MTHPRM
;SET OPERATING SYSTEM/PROCESSOR DEFAULTS

IFNDEF FT10,<FT10==0>			;MAKE SURE ALL ARE DEFINED
IFNDEF FT20,<FT20==0>
IFE FT10!FT20,<IF1,<PRINTX ?Neither TOPS-10 nor TOPS-20 specified>
		    END>
IFNDEF FTKL,<FTKL==-1>


;SET OTHER PARAMETER DEFAULTS

IFNDEF FTGFL,<FTGFL==1>		;[3242] G-FLOATING ARG CHECKS
IFNDEF FTSHR,<FTSHR==-1>	;SHARABLE
IFNDEF FTPSCT,<FTPSCT==0>	;NOT PSECTED BY DEFAULT

;INDICATE WHICH ASSEMBLY IS BEING DONE

IF2,<
IFN FTKL,<%C=='KL'>
IFN FT10,<%M=='10'>
IFN FT20,<%M=='20'>

	DEFINE	TELL (CPU,MON) <

IFN FTPSCT,<PRINTX	[CPU-MON PSECTed version]>

IFE FTPSCT,<PRINTX	[CPU-MON TWOSEG version]>

> ;END TELL

	TELL	\'%C,\'%M

	PURGE	%C,%M,TELL
> ;END IF2

	DEFINE	IF10 <IFN FT10>		;SIMPLIFIED PROCESSOR MACROS
	DEFINE	IF20 <IFN FT20>
;AC DEFINITIONS

	T0=0			;TEMP ACS
	T1=1			;MAY BY DESTROYED BY ANY ROUTINE UNLESS IT
	T2=2			;IS EXPLICITLY DOCUMENTED TO SAVE THEM
	T3=3
	T4=4
	T5=5

	P1=6			;PRESERVED ACS
	P2=7			;MUST BE PRESERVED BY ANY ROUTINE UNLESS IT
	P3=10			;IS EXPLICITLY DOCUMENTED THAT IT DESTROYS THEM
	P4=11

	G1=P1			;USED IN MTHLIB
	G2=P2
	G3=P3
	G4=P4

	D=12			;POINTER TO CURRENT DDB
	U=13			;THE UNIT BLOCK POINTER
	F=14			;LOCAL FLAGS
	FREEAC=15		;FOR NOW, IT'S THE "FREE AC"
	S=15			;THE CHARACTER AND %SAVEn STACK

	L=16			;ARG LIST POINTER
	P=17			;STACK POINTER


	SYN OCT,DOUBLE		;PSUEDO-OP FOR DP CONSTANTS

;ARG LISTS			;[3242] MOVED HERE FROM FORPRM

;BYTES IN ARG POINTERS		;[3242]

ARGKWD==177000000000		;[3242] KEYWORD INDEX, WHERE APPROPRIATE
ARGTYP==000740000000		;[3242] ARG TYPE, SEE BELOW
ARGADR==000037777777		;[3242] I, X, Y OF INSTRUCTION-FORMAT ADDRESS



;ARG TYPE CODES


TP%UDF==0			;NOT SPECIFIED
TP%LOG==1			;LOGICAL
TP%INT==2			;INTEGER
TP%3==3				;UNDEFINED
TP%SPR==4			;SINGLE REAL
TP%5==5				;UNDEFINED
TP%SPO==6			;SINGLE OCTAL
TP%LBL==7			;STATEMENT LABEL
TP%DPR==10			;DOUBLE REAL
TP%DPI==11			;DOUBLE INTEGER
TP%DPO==12			;DOUBLE OCTAL
TP%DPX==13			;EXTENDED-EXPONENT DOUBLE REAL (G-FLOATING)
TP%CPX==14			;COMPLEX
TP%CHR==15			;CHARACTER
TP%16==16			;UNDEFINED
TP%LIT==17			;QUOTED LITERAL (ASCIZ)

;CHARACTER CODES
%LF==12
%VT==13
%FF==14
%CR==15
%DC0==20
%DC1==21
%DC2==22
%DC3==23
%DC4==24

;PC FLAGS - HERE BECAUSE THEY ARE DEFINED DIFFERENTLY ON -10 AND -20

PC%OVF==1B0		;OVERFLOW
PC%CY0==1B1		;CARRY 0
PC%CY1==1B2		;CARRY 1
PC%FOV==1B3		;FLOATING OVERFLOW
PC%BIS==1B4		;BYTE INCREMENT SUPPRESSION
PC%USR==1B5		;USER MODE
PC%UIO==1B6		;USER IOT MODE
PC%LIP==1B7		;LAST INSTRUCTION PUBLIC
PC%AFI==1B8		;ADDRESS FAILURE INHIBIT
PC%ATN==3B10		;APR TRAP NUMBER
PC%FUF==1B11		;FLOATING UNDERFLOW
PC%NDV==1B12		;NO DIVIDE

;FUNCT. CODES

	FN%ILL==0		;ILLEGAL FUNCT. CALL
	FN%GAD==1		;GET LS MEMORY AT SPECIFIED ADDR
	FN%COR==2		;GET LS MEMORY ANYWHERE
	FN%RAD==3		;RETURN LS MEMORY
	FN%GCH==4		;[3203] Get I/O channel
	FN%RCH==5		;[3203] Return I/O channel
	FN%GOT==6		;[3203] Get OTS core
	FN%ROT==7		;[3203] Return OTS core
	FN%RNT==10		;[3203] Return initial runtime
	FN%IFS==11		;[3203] Return initial run-time file spec
	FN%CBC==12		;[3203] Cut back core
	FN%RRS==13		;[3203] Read retain status (reserved for DBMS)
	FN%WRS==14		;[3203] Write retain status (reserved for DBMS)
	FN%GPG==15		;[3203] Get memory on a page boundary
	FN%RPG==16		;[3203] Return memory on a page boundary
	FN%GPS==17		;GET PSI CHANNEL
	FN%RPS==20		;RELEASE PSI CHANNEL
	FN%MPG==21		;MARK PAGES USED
	FN%UPG==22		;MARK PAGES UNUSED
;ERROR TABLE ENTRIES

;0 thru 7 are various arithmetic traps
;0-7 entry numbers are determined by 3 flag bits in combination
;   and their values are fixed.

.ETIOV==0			;Integer overflow
.ETIDC==1			;Integer divide check
.ETFU1==2			;Floating underflow (impossible)
.ETFC1==3			;Floating divide check (impossible)
.ETFO1==4			;Floating overflow
.ETFC2==5			;Floating divide check
.ETFU2==6			;Floating underflow
.ETFC3==7			;Floating divide check (impossible)

.ETLRE==^D8			;Library routine errors
.ETOCE==^D9			;Output conversion errors
.ETIIO==^D10			;INTEGER OVERFLOW ON INPUT
.ETIFO==^D11			;FLOATING OVERFLOW ON INPUT
.ETIFU==^D12			;FLOATING UNDERFLOW ON INPUT

.ETLST==.ETIFU

.ETNUM==.ETLST+1		;# OF ENTRIES

;MATHOP DEFINITIONS
ML$APR==0		;GET ADDR OF APR TABLES
;OPDEFS & PSEUDO-INSTRUCTIONS

OPDEF	NOP	[TRN]		;THE CORRECT NOP
OPDEF	PJRST	[JUMPA 17,]	;JUMP TO A ROUTINE THAT RETURNS
OPDEF	HALT	[HALT]		;REAL HALT
OPDEF	XMOVEI	[SETMI]		;EXTENDED MOVE IMMEDIATE
OPDEF	XBLT	[020B8]		;Extended BLT opcode
OPDEF	XJRSTF	[JRST 5,]
OPDEF	JRSTF	[JRST 2,]
OPDEF	PORTAL	[JRST 1,]
OPDEF	ERJMP	[JUMP 16,]
OPDEF	ERCAL	[JUMP 17,]
OPDEF	IFIW	[1B0]		;INSTRUCTION FORMAT INDIRECT WORD
.NODDT	IFIW			;NO USE FOR DDT

IF20,<
OPDEF	SMAP%	[JSYS 767]
OPDEF	RSMAP%	[JSYS 610]
OPDEF	PDVOP%	[JSYS 605]
OPDEF	XGVEC%	[JSYS 606]
OPDEF	XSVEC%	[JSYS 607]
> ;END IF20


;EXTENDED PRECISION (G-FLOATING) OPCODES

OPDEF	GFAD	[102B8]		;GFLOAT ADD
OPDEF	GFSB	[103B8]		;GFLOAT SUBTRACT
OPDEF	GFMP	[106B8]		;GFLOAT MULTIPLY
OPDEF	GFDV	[107B8]		;GFLOAT DIVIDE

;EXTEND OPCODES FOR G-FLOATING

OPDEF	GSNGL	[021B8]		;GFLOAT TO SINGLE PRECISION
OPDEF	GDBLE	[022B8]		;SINGLE PRECISION TO GFLOAT
OPDEF	DGFIX	[023B8]		;GFLOAT TO DOUBLE PRECISION INTEGER, TRUNC.
OPDEF	GFIX	[024B8]		;GFLOAT TO SINGLE PRECISION INTEGER, TRUNC.
OPDEF	DGFIXR	[025B8]		;GFLOAT TO DOUBLE PRECISION INTEGER, ROUND
OPDEF	GFIXR	[026B8]		;GFLOAT TO SINGLE PRECISION INTEGER, ROUND
OPDEF	DGFLTR	[027B8]		;DOUBLE PRECISION INTEGER TO GFLOAT
OPDEF	GFLTR	[030B8]		;SINGLE PRECISION INTEGER TO GFLOAT
OPDEF	GFSC	[031B8]		;GFLOAT FLOATING SCALE
;UNIVERSAL FILE SEARCHER
; ALLOWS RETRIEVAL OF OPERATING SYSTEM SPECIFIC SYMBOLS

	DEFINE	FSRCH <
	SALL
	SEARCH	JOBDAT		;[3207] For  .JBxyz   symbols.    This
				;[3207] *MUST* preceed  the search  of
				;[3207] UUOSYM, which contains EXTERNs
				;[3207] of the JOBDAT symbols.
IF10,<	SEARCH	UUOSYM,MACTEN>

IF20,<	SEARCH	MONSYM,MACSYM>

	.DIRECT	FLBLST
> ;END FSRCH
;PSUEDO INSTRUCTIONS TXYY
; DEFINE THE VARIOUS FLAVORS

	DEFINE	DEFTX (Y,Z) <
 IRP Y,<
  IRP Z,<
   DEFINE TX'Y'Z (AC,E) <
    IFE <<E>&777777000000>,<TR'Y'Z AC,<E> ;> 
    IFE <<E>&000000777777>,<TL'Y'Z AC,(E) ;> 
			    TD'Y'Z AC,[E]
   > ;END TXYZ
  > ;END IRP Z
 > ;END IRP Y
> ;END DEFTX

;CREATE THE VARIOUS FLAVORS OF TXYY

DEFTX (<N,Z,O,C>,<N,E,A,>)


;PSUEDO INSTRUCTIONS MOVX
; CREATE THE VARIOUS FLAVORS

	DEFINE	MOVX (AC,E) <
 IFE <<E>&777777000000>,<MOVEI AC,<E> ;> 
 IFE <<E>&000000777777>,<MOVSI AC,(E) ;> 
 IFE <<E>_-22 - 777777>,<HRROI AC,<<E>&777777> ;> 
 IFE <<E>&777777-777777>,<HRLOI AC,<<E>_-22> ;> 
			 MOVE AC,[E]
> ;END MOVX

;PRODUCE RADIX50 REPRESENTATION FOR 'CHR'

	DEFINE	R50 (CHR) <<RADIX50 0,CHR>>

;SEGMENT MACRO
; DEFINES SEGMENTS IN TERMS OF PSECTS (FTPSCT==-1)
; OR LOW/HIGH RELOCS (FTPSCT==0)
; .PSECTS TO SEGMENT 'S', WITH ATTRIBUTE SWITCHS 'ATR'
;  CURRENT SEGMENTS ARE CODE, DATA, AND ERR

IFN FTPSCT,<
	DEFINE	SEGMENT (SNAME) <

  IFDEF $SEG$,<
IF1,<IFE <$SEG$-1>,<.ENDPS>>
IF2,<IFE <$SEG$-2>,<.ENDPS>
    IFN <$SEG$-2>,<$SEG$==2>
 > ;END IF2
> ;END IFDEF $SEG$

  IFNDEF $SEG$,<
IF1,<	$SEG$==1>
IF2,<	$SEG$==2>
> ;END IFNDEF

	.PSECT	.'SNAME'.
	$NAME$==''SNAME''
 > ;END SEGMENT
> ;END IFN FTPSCT

IFE FTPSCT,<
	DEFINE	SEGMENT (SNAME) <

  IFDEF $SEG$,<
IF2,<
IFE <$SEG$-1>,<$SEG$==2
	TWOSEG	400000
  > ;END IFE $SEG$-1
IFE <$SEG$+1>,<$SEG$==2
	TWOSEG	400000
  > ;END IFE $SEG$+1
 > ;END IF2
> ;END IFDEF $SEG$

  IFNDEF $SEG$,<
	TWOSEG	400000
IF1,<	$SEG$==1>
IF2,<	$SEG$==2>
> ;END IFNDEF $SEG$

	$NAME$==''SNAME''

  IFIDN <SNAME><DATA>,<
   IFG $SEG$,<
	RELOC
IF1,<	$SEG$==-1>
IF2,<	$SEG$==-2>>>

  IFDIF <SNAME><DATA>,<
   IFL $SEG$,<
	RELOC
IF1,<	$SEG$==1>
IF2,<	$SEG$==2>>>
 > ;END SEGMENT
> ;END IFE FTPSCT


	DEFINE	REMOVE(ARG),<ARG> ;[3241] STRIP EXTRA BRACKETS

;GENERALIZED LIBRARY FUNCTION CALL
; CALL 'SUB', USING ARGLIST 'ARGS'
; GENERATES STANDARD ARGUMENT LIST
; AND SETS UP L PRIOR TO THE CALL

	DEFINE	FUNCT (SUB,ARGS) <
 IF2,<IFNDEF SUB,<EXTERN SUB>>
 .ARGN.=0
 IRP ARGS,<.ARGN.=.ARGN.+1>
	PUSH	P,L
	XMOVEI	L,1+[-.ARGN.,,0
		     IRP ARGS,<IFIW REMOVE(ARGS)>] ;;;[3236][3241]
	PUSHJ	P,SUB
	POP	P,L
 PURGE	.ARGN.
> ;END FUNCT

;LIBRARY ROUTINE ENTRY DEFINITIONS
; SETS UP APPROPRIATE INFORMATION FOR TRACEBACK
; 1. ASCIZ STRING: 'NAME', 'ENT', OR 'ENT.'
; 2. ENTRY LABEL: 'ENT', OR 'ENT.'
; 3. START LABEL: SAME AS 2.
; DOTTED ROUTINE NAMES INDICATE FORTRAN DEFINED
; INTRINSIC FUNCTIONS
; NAME IS USUALLY FULL NAME WITHOUT THE DOT

	DEFINE	HELLO (ENT,NAME) <
 IFNB <NAME>,<
  IFDIF <NAME><.>,<
	ENTRY ENT
	SIXBIT /NAME/
ENT:
  > ;END IFDIF

  IFIDN <NAME><.>,<
	ENTRY ENT'.
	SIXBIT /ENT'./
ENT'.:
  > ;END IFIDN
 > ;END IFNB

 IFB <NAME>,<
	ENTRY ENT
	SIXBIT /ENT/
ENT:
 > ;END IFB
> ;END HELLO




;LIBRARY ROUTINE STANDARD EXIT
; ARGUMENT 'N' IS NOT USED

	DEFINE	GOODBY (N) <
	POPJ	P,
> ;END GOODBY

;TITLE & VERSION MACRO

;DEFINES VMAJOR, VMINOR, VEDIT, VWHO FROM STANDARD VERSION NUMBER STRING
; ROUTINE IS ENTITLED 'T', WITH VERSION NUMBER 'V'
; 'V' IS TAKEN APPART TO PRODUCE THE VERSION NUMBER ITEMS

	DEFINE	TV (T,V) <

 TITLE T'  'V
 FSRCH

 VMAJOR==<VMINOR==<VEDIT==<VWHO==0>>>
 %VWHO==0

 IRPC V,<

  IFLE <"V"-"A">*<"V"-"Z">,<VMINOR==VMINOR*^D26 + "V" - "A" + 1>

  IFLE <"V"-"0">*<"V"-"9">,<VMAJOR==VMAJOR*^D8 + "V" - "0">

  IFIDN <V><(>,<%VMAJOR==VMAJOR
		VMAJOR==0>

  IFIDN <V><)>,<VEDIT==VMAJOR
		VMAJOR==%VMAJOR>

  IFIDN <V><->,<%VMAJOR==VMAJOR
		VMAJOR==0
		%VWHO==-1>
 > ;END IRPC

 IFN %VWHO,<VWHO==VMAJOR
	    VMAJOR==%VMAJOR>

	DEFINE	VER <	BYTE	(3)VWHO(9)VMAJOR(6)VMINOR(18)VEDIT>

 PURGE %VMAJOR,%VWHO
> ;END TV

;ERROR MACROS

;	$ERR	(CHR,COD,N1,N2,MSG,ARGS,FLGS)	;OTS ERROR
;	$LERR	(CHR,COD,N1,N2,MSG,ARGS,FLGS)	;MTHLIB ERROR
;	$TERR	(CHR,COD,N1,N2,MSG,ARGS,FLGS)	;APR TRAP CALL
;
;CHR	INITIAL CHAR FOR ERROR MESSAGE ([, %, ?)
;	IF [, MESSAGE IS TERMINATED WITH ]
;	IF ?, TYPEAHEAD CLEARED AFTER MESSAGE
;	IF NULL, 3-CHAR PREFIX ISN'T TYPED
;	IF $, FIRST ARG IS INITIAL CHAR
;COD	3-CHARACTER PREFIX
;N1	ERROR CLASS NUMBER
;N2	2ND ERROR NUMBER
;MSG	TEXT OF ERROR MESSAGE
;	$ INDICATES AN ARG TO BE SUBSTITUTED INTO THE MESSAGE
;	THE CHAR AFTER THE $ GIVES THE FORMAT OF THE SUBSTITUTION
;ARGS	LIST OF ARGUMENT ADDRESSES, ONE-TO-ONE CORRESPONDENCE WITH $S
;	IN MESSAGE TEXT
;FLGS	ERROR FLAGS
;
;THE ERROR MACROS GENERATE 1 WORD IN LINE, SO CAN BE SKIPPED OVER.
;THEY DO NOT ALTER ANY ACS.


%CHR==0				;OFFSET FROM ERROR BLOCK TO ERROR CHAR
%COD==1				;OFFSET TO ERROR CODE
%NUM1==2			;OFFSET TO ERROR CLASS NUMBER
%NUM2==3			;OFFSET TO ERROR 2ND NUMBER
%MSG==4				;OFFSET TO MESSAGE POINTER
%FLGS==5			;OFFSET TO FLAG WORD
%ARGS==6			;OFFSET TO ARGS


	DEFINE	$ERR (CHR,PFX,N1,N2,MSG,ARGS,FLAGS) <


IFNB <PFX>,<
	ENTRY	E.'PFX
E.'PFX:				;DEFINE THE ERROR IF NOT NULL
>

IF2,<IFNDEF %OTSER,<EXTERN %OTSER>>
		PUSHJ	P,%OTSER	;ERROR CALL
		"CHR"			;ERROR CHARACTER
		SIXBIT	/PFX/		;ERROR PREFIX
		EXP	N1,N2		;ERROR NUMBERS
		POINT 7,[ASCIZ \MSG\]	;POINTER TO MESSAGE
		EXP	FLAGS		;ATTRIBUTE FLAGS
IRP ARGS,	<ARGS>			;ARGUMENTS, IF ANY

> ;END $ERR

;$LERR IS FOR USE BY MATHLIB
; IT CALLS MTHER.
; EXAMPLES:
;  $LERR (SNA,8,23,%,<ENTRY SQRT; NEGATIVE ARG; RESULT=SQRT(-ARG)>)

	DEFINE	$LERR (CHR,PFX,N1,N2,MSG,ARGS,FLAGS) <

	ENTRY	L.'PFX
L.'PFX:
		PUSHJ	P,MTHER.##
		"CHR"			;ERROR CHARACTER
		SIXBIT	/PFX/		;ERROR PREFIX
		EXP	N1,N2		;ERROR NUMBERS
		POINT 7,[ASCIZ \MSG\]	;POINTER TO MESSAGE
		EXP	FLAGS		;ATTRIBUTE FLAGS
IRP ARGS,	<ARGS>			;ARGUMENTS, IF ANY

>; END LERR

;$TERR IS FOR USE BY FORTRP
; IT CALLS %TRPER
; EXAMPLE:
;  $TERR (IOV,0,0,%,Integer overflow)

	DEFINE	$TERR (CHR,PFX,N1,N2,MSG,ARGS,FLAGS) <

	ENTRY	T.'PFX
T.'PFX:
		PUSHJ	P,%TRPER##
		"CHR"			;ERROR CHARACTER
		SIXBIT	/PFX/		;ERROR PREFIX
		EXP	N1,N2		;ERROR NUMBERS
		POINT 7,[ASCIZ \MSG\]	;POINTER TO MESSAGE
		EXP	FLAGS		;ATTRIBUTE FLAGS
IRP ARGS,	<ARGS>			;ARGUMENTS, IF ANY

>; END $TERR

;$ECALL CALLS AN ERROR ROUTINE DEFINED SOMEWHERE BY AN $ERR MACRO

	DEFINE	$ECALL (PFX,CONT) <
	EXTERN E.'PFX
IFB <CONT>,<	PUSHJ	P,E.'PFX >
IFNB <CONT>,<JRST	[PUSHJ P,E.'PFX
			JRST CONT] >
> ;END $ECALL

;$EJCAL CALLS AN ERROR ROUTINE DEFINED SOMEWHERE BY AN $ERR MACRO
;WITH AN ERCAL OR ERJMP

	DEFINE	$EJCAL (PFX,CONT) <
	EXTERN E.'PFX
IFB <CONT>,<	ERCAL	E.'PFX >
IFNB <CONT>,<	ERJMP	[PUSHJ P,E.'PFX
			JRST CONT] >
> ;END $EJCAL

;$LCALL CALLS AN ERROR ROUTINE DEFINED SOMEWHERE BY A $LERR MACRO

	DEFINE	$LCALL (PFX,CONT) <
IF2,<IFNDEF L.'PFX,<	EXTERN	L.'PFX >>
IFB <CONT>,<	PUSHJ	P,L.'PFX >
IFNB <CONT>,<JRST	[PUSHJ P,L.'PFX
			JRST CONT] >

> ;END $LCALL

;$LJCAL CALLS AN ERROR ROUTINE DEFINED SOMEWHERE BY AN $LERR MACRO
;WITH AN ERCAL OR ERJMP

	DEFINE	$LJCAL (PFX,CONT) <
IF2,<IFNDEF L.'PFX,<	EXTERN	L.'PFX>>
IFB <CONT>,<	ERCAL	L.'PFX >
IFNB <CONT>,<	ERJMP	[PUSHJ P,L.'PFX
			JRST CONT] >
> ;END $LJCAL

;$TCALL CALLS AN ERROR ROUTINE DEFINED SOMEWHERE BY A $TERR MACRO

	DEFINE	$TCALL (PFX,CONT) <
IF2,<IFNDEF T.'PFX,<	EXTERN	T.'PFX>>
IFB <CONT>,<	PUSHJ	P,T.'PFX >
IFNB <CONT>,<JRST	[PUSHJ P,T.'PFX
			JRST CONT] >
> ;END $TCALL

;USER FIXUP ARG BLOCK OFFSETS
%OECN==0		;ERROR CLASS NUMBER
%OEPC==1		;PC
%OIEN==2		;INDIVIDUAL ERROR NUMBER
%OTYP==3		;VARIABLE TYPE
%OUFXD==4		;UNFIXED RESULT
%OFIXD==5		;FIXED-UP RESULT

; MACROS FOR MTHDBL

IF1,<				;ONLY ONCE
;	DOUBLE PRECISION FLOAT FUNCTION "DFLOAT"

	DEFINE DFL (X) <
	XALL

	ENTRY	DFL.'X		;ENTRY POINT TO DFL.'X
	SIXBIT	/DFL.'X/
DFL.'X:	MOVEI	X+1,0		;CLEAR LOW ORDER WORD
	ASHC	X,-8		;MAKE ROOM FOR EXPONENT IN HI WORD
	TLC	X,243000	;SET EXP TO 27+8 DECIMAL
	DFAD	X,[EXP 0,0]	;NORMALIZE
	POPJ	P,		;RETURN X=THE DOUBLE PRECISION RESULT
>; END DFL


;	DOUBLE PRECISION FIX FUNCTION "IDINT"
;	DOUBLE TO INTEGER

	DEFINE IDF (X) <
	XALL

	ENTRY	IDF.'X
	SIXBIT	/IDF.'X/
IDF.'X:	PUSH	P,L		;SAVE THE SCRATCH REG
	HLRE	L,X		;GET THE EXPONENT
	ASH	L,-9		;RIGHT 8 BITS
	JUMPGE	X,IDF.XT	;JUMP IF POS.
	DMOVN	X,X		;NEGATE
	TRC	L,-1		;COMPLEMENT THE EXPONENT
IDF.XT:	TLZ	X,777000	;CLEAR THE EXPONENT
	ASHC	X,-201-^D26(L)	;CHANGE FRACTION TO INTEGER
	TLNE	L,400000	;SKIP IF POS.
	MOVN	X,X		;NEGATE
	POP	P,L		;RESTORE THE SCRATCH REG
	POPJ	P,		;RETURN X=FIXED NUMBER
>; END IDF

;	DOUBLE PRECISION TO SINGLE FUNCTION

	DEFINE SNG (X)<
	XALL

	ENTRY	SNG.'X
	SIXBIT	/SNG.'X/
SNG.'X:	JUMPL	X,SNG3		;NEGATIVE ARGUMENT?
	TLNE	X+1,(1B1)	;POSITIVE. ROUND REQUIRED?
	TRON	X,1		;YES, TRY TO ROUND BY SETTING LSB
	  POPJ	P,		;WE WON, FINISHED
	MOVE	X+1,X		;COPY HIGH PART OF ARG
	AND	X,[777000,,1]	;MAKE UNNORMALIZED LSB, SAME EXPONENT
	FAD	X,X+1		;ROUND & RENORMALIZE
	POPJ	P,

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

SNG4:	MOVN	X,X		;RE-NEGATE
	POPJ	P,		;EXIT
>; END SNG

>; END IF1
;[3243]	GETFLG sets up the exeception flags and PC into AC.  In
;	non-zero section AC contains only exception flags of PC.

	DEFINE GETFLG(AC,%EGET),<
IF20,<	 XMOVEI AC,0		;;[3243] check if we are in a non-zero section
	 SKIPN	AC		;;[3243] if not section zero, then skip
>
	 JSP	AC,%EGET	;;[3243] get PC flags and goto end of macro
IF20,<	 XSFM	AC		;;[3243] get the pc flags for non-zero section
>
%EGET:
> ;[3243] ENDDEF GETFLG

;[3243]	RESFLG is called with the PC flags in AC.  It sets up AC+1
;	to restore the flags to PC using a PC double word.  This is legal
;	for extended KL, and KS in zero or non-zero sections.  A conditional
;	for TOPS-10 does only JRSTF.
;
	DEFINE RESFLG(AC,%NOCLR),<
	 TLZ	AC,(PC%OVF+PC%FOV+PC%FUF+PC%NDV) ;;[3243] CLEAR OV,FOV,FUF,NDV
IF20,<	 XMOVEI	AC+1,%NOCLR	;;[3243] setup E in dbl wd PC
	 TLNE	AC+1,-1		;;[3243] skip if non-zero section
	 XJRSTF	AC		;;[4001] restore the flags
	 HRR	AC,AC+1		;;[3243] setup for the reset
>
IF10,<	 HRRI	AC,%NOCLR	;;[3243] setup the new PC
>
	 JRSTF	(AC)		;;[3243] restore flags
%NOCLR:
> ;ENDDEF RESFLG

	END