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