Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
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(4017)
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1985
;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.
.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.
3250 BCM 26-Jul-83
Fix edit 3243 so XJRSTF will use E and not contents of E.
Only affects extended addressing traps.
3253 TGS 29-Nov-83 10-34340
Make SEGMENT macro case-insensitive by converting its string
argument to SIXBIT.
***** 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.
4002 JLC 8-Aug-83
Add macros for user-fixable library error results.
4007 JLC 29-Feb-84
Added a new error-calling macro $DCALL. Removed the FOROTS
AC definitions, as they don't belong here. Defined S1-S4
as ACs 12-15, so that there could be some standard way to
reference them in FORLIB routines.
4010 JLC 16-Mar-84
Added some new error calls.
4011 JLC 5-May-84
Fixed some error call macros.
4013 JLC 13-Jun-84
Add some OPDEFs for extended addressing.
4016 JLC 17-Oct-84
Remove DCALL and DJCAL, since they really belong in FORPRM.
4017 JLC 16-Jan-85
Remove IF10s and IF20s from GETFLG and RESFLG.
\
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
P2==7
P3==10
P4==11
G1==P1 ;USED IN MTHLIB
G2==P2
G3==P3
G4==P4
S1==12 ;SOME MORE ACS
S2==13
S3==14
S4==15
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 XJRST [JRST 15,]
OPDEF PORTAL [JRST 1,]
OPDEF SFM [JRST 14,]
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 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''
IFE <$NAME$-'DATA'>,< ;;[3253]
IFG $SEG$,<
RELOC
IF1,< $SEG$==-1>
IF2,< $SEG$==-2>>>
IFN <$NAME$-'DATA'>,< ;;[3253]
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
DEFINE $DERR (CHR,PFX,N1,N2,MSG,ARGS,FLAGS) <
INTERN D.'PFX
D.'PFX:
IF2,<IFNDEF %DERR,<EXTERN %DERR>>
PUSHJ P,%DERR
"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 $DERR
DEFINE $AERR (CHR,PFX,N1,N2,MSG,ARGS,FLAGS) <
INTERN A.'PFX
A.'PFX:
IF2,<IFNDEF %AERR,<EXTERN %AERR>>
PUSHJ P,%AERR
"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 $AERR
;$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
;$AJCAL CALLS A FATAL ERROR ROUTINE DEFINED SOMEWHERE BY AN $AERR MACRO
;WITH AN ERCAL, WITH NO CONTINUE ADDRESS
DEFINE $AJCAL (PFX,CONT) <
IFNB <CONT>,<PRINTX ?AJCAL CONTINUATION ADDRESS SPECIFIED - IGNORED>
EXTERN A.'PFX
ERCAL A.'PFX
> ;END $AJCAL
;$ACALL CALLS A FATAL ERROR ROUTINE DEFINED SOMEWHERE BY AN $AERR MACRO
;WITH NO CONTINUE ADDRESS
DEFINE $ACALL (PFX,CONT) <
IFNB <CONT>,<PRINTX ?ACALL CONTINUATION ADDRESS SPECIFIED - IGNORED>
EXTERN A.'PFX
PUSHJ P,A.'PFX
> ;END $ACALL
;$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
;ERROR FIXED-UP RESULT SAVE MACROS
;$SSPR SAVES FIXED-UP RESULT FOR SINGLE PRECISION REAL
DEFINE $SSPR <
IFNDEF %LFIXD,<EXTERN %LFIXD>
IFNDEF %LERTP,<EXTERN %LERTP>
MOVEM T0,%LFIXD
MOVEI T0,TP%SPR
MOVEM T0,%LERTP
> ;END $SSPR
;$SDPR SAVES FIXED-UP RESULT FOR DOUBLE PRECISION
DEFINE $SDPR <
IFNDEF %LFIXD,<EXTERN %LFIXD>
IFNDEF %LERTP,<EXTERN %LERTP>
DMOVEM T0,%LFIXD
MOVEI T0,TP%DPR
MOVEM T0,%LERTP
> ;END $SDPR
;$SDPX SAVES FIXED-UP RESULT FOR G-FLOATING DOUBLE PRECISION
DEFINE $SDPX <
IFNDEF %LFIXD,<EXTERN %LFIXD>
IFNDEF %LERTP,<EXTERN %LERTP>
DMOVEM T0,%LFIXD
MOVEI T0,TP%DPX
MOVEM T0,%LERTP
> ;END $SDPX
;$SCPX SAVES FIXED-UP RESULT FOR COMPLEX
DEFINE $SCPX <
IFNDEF %LFIXD,<EXTERN %LFIXD>
IFNDEF %LERTP,<EXTERN %LERTP>
DMOVEM T0,%LFIXD
MOVEI T0,TP%DPX
MOVEM T0,%LERTP
> ;END $SCPX
;$RSPR RESTORES FIXED-UP RESULT FOR SINGLE PRECISION
DEFINE $RSPR <
IFNDEF %LFIXD,<EXTERN %LFIXD>
MOVE T0,%LFIXD
> ;END $RSPR
;$RDPR RESTORES FIXED-UP RESULT FOR DOUBLE PRECISION
DEFINE $RDPR <
IFNDEF %LFIXD,<EXTERN %LFIXD>
DMOVE T0,%LFIXD
> ;END $RDPR
;$RDPX RESTORES FIXED-UP RESULT FOR G-FLOATING DOUBLE PRECISION
DEFINE $RDPX <
IFNDEF %LFIXD,<EXTERN %LFIXD>
DMOVE T0,%LFIXD
> ;END $RDPX
;$RCPX RESTORES FIXED-UP RESULT FOR COMPLEX
DEFINE $RCPX <
IFNDEF %LFIXD,<EXTERN %LFIXD>
DMOVE T0,%LFIXD
> ;END $RCPX
;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),<
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
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
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
JRSTF (AC) ;;[3243] restore flags
%NOCLR:
> ;ENDDEF RESFLG
END