Google
 

Trailing-Edge - PDP-10 Archives - FORTRAN-10_V7wLink_Feb83 - mthprm.mac
There are 13 other files named mthprm.mac in the archive. Click here to see a list.
;	UNIVERSAL MTHPRM
;	UNIVERSAL FILE FOR MATH LIBRARY, 1(3230)

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1983

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


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

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

\

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==0>		;NO 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,X1,X2) <

IFN FTPSCT,<
  IFN FTSHR,<PRINTX	[CPU-MON PSECTed sharable version]>
  IFE FTSHR,<PRINTX	[CPU-MON PSECTed relocatable version]>
> ;END IFN FTPSCT

IFE FTPSCT,<
  IFN FTSHR,<PRINTX	[CPU-MON TWOSEG sharable version]>
  IFE FTSHR,<PRINTX	[CPU-MON TWOSEG relocatable version]>
> ;END IFE FTPSCT

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




;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!<ARGS>>] ;;;[3220]
	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

; 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