Google
 

Trailing-Edge - PDP-10 Archives - BB-D480C-SB_1981 - formsc.mac
There are 19 other files named formsc.mac in the archive. Click here to see a list.
	SEARCH	FORPRM
	TV	FORMSC	Miscellaneous routines ,6(2031)
	SUBTTL	Sue Godsell/EDS/EGM			16-Mar-81


;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1977,1981 BY DIGITAL EQUIPMENT CORPORATION


COMMENT \

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

BEGIN V6

1100	SWG	15-Aug-75
	CLEANUP FOR V6 - REMOVE ALL F40, KA THINGS. JSYSIZE
	THOSE ROUTINES WHICH DO MONITOR CALLS: TIME,TIM2G0,DATE
	SSWTCH
	REMOVE .MXFOR AND FORX40;TAKE KA CONDITIONALS OUT OF UNIVERSAL;
	REMOVE UNNECESSARY AC DEFS FROM FLOAT. AND IFIX.
	Add OUTSTR macro for TOPS-20 IN FDDT.

1175	JLC	12-Dec-80
	Fixed LSNGET routine, did not like nulls in line number
	and did not clear digit AC, always returned error (-1).

1256	DAW	5-FEB-81
	Use new calling sequence for FOROP.

1260	DAW	6-Feb-81
	LSNGET smashed ACs 2 and 3.

1266	DAW	11-Feb-81
	Changes to support extended addressing in DUMP & PDUMP, TIME,
	and DATE routines.

1300	DAW	24-Feb-81
	Get FIN. calls and IOLISTS correct again in DUMP and PDUMP.

1302	JLC	24-Feb-81
	Changed LSNGET to have channel # as arg.

1335	EDS	12-Mar-81	Q10-05759
	Use symbols when testing output of ODCNV% jsys in TIME.
	Make TIME return the arguments correctly.

1342	EDS	13-Mar-81	Q10-05075
	Make routines TRACEable change everything to HELLO macros.
	Fix TWOSEG and RELOC problems.  Clean up TITLEs.

1351	EDS	16-Mar-81	Q10-04786
	Fix TWOSEG and RELOC problems.

1372	EGM	30-Mar-81	________
	Make OVERFL compatible with 5A, and eliminate TIME JSYS conflict.

1425	BL	14-Apr-81	Q10-05076
	Make OVERFL functionality include 'logical function'.
	Returns T0=0 if OVERFLOW=NO, T0=-1 if OVERLFOW=YES.
	Original functionality unchanged.

1464	DAW	12-May-81
	Error messages.

1500	DAW	27-May-81
	Edit 1464 made it get "E" error.

1517	BL	18-Jun-81	Q10-05075
	Use HELLO macro at CLRDIV (FORMSC).

1532	DAW	14-Jul-81
	OPEN rewrite: Base level 1

1560	DAW	28-Jul-81
	OPEN rewrite: Base level 2

1615	DAW	19-Aug-81
	Get rid of 2-word BP option.

1656	DAW	2-Sep-81
	Get rid of magic numbers.

1720	JLC	16-Sep-81
	Added test in DIVERT to make sure unit is open for FORMATTED I/O.

1747	DAW	28-Sep-81
	Got rid of FORPRM dependency in DIVERT.

1767	DAW	8-Oct-81
	Explain "magic" numbers in OVERFL.

2020	DAW	21-Oct-81
	Change DATE to return SPACE as last character instead of NULL,
	so it will match a literal generated by the compiler.

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

\


	PRGEND
	TITLE	ADJ1.	



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION

	SEARCH	FORPRM

;AC ASSIGNMENTS
ARG==L		;ARG POINTER
TEMOFF==T0	;HOLDS OFFSET COMPUTATION
;T1==1	;HOLDS LOOP DOUNTER (DIMENSIONALITY)
;T2==2		;HOLDS MULTIPLIER COMPUTED
TABREG==T3	;HOLDS DESTROYED ARG POINTER


	;THE FOLLOWING ALGORITHM IS IMPLEMENTED TO
	;COMPUTE ARRAY FACTORS, OFFSET AND SIZE FOR THE
	;SPECIAL CASE WHEN ALL LOWER BOUNDS ARE A
	;CONSTANT 1 AND ALL DIMENSIONS ARE ADJUSTABLE.
	;MULT(I) ARE MULTIPLIERS
	;U(I) ARE UPPER BOUNDS (EQUIVALENT TO RANGE)

	;OFFSET=MULT(1)
	;ARRAYSIZ=MULT(1)
	;DO 10 I=2,NUMBER OF DIMENSIONS-1
	;ARRAYSIZ=ARRAYSIZ*U(I-1)
	;MULT(I)=MULT(I-1)*U(I-1)
	;OFFSET=OFFSET+MULT(I)
;10	CONTINUE
	;OFFSET=-OFFSET+BASE ADDRESS OF ARRAY

	;THE PARAMTERS PASSED ARE (INORDER):
	;POINTER TO NUMBER OF DIMENSIONS
	;POINTER TO TEMP FOR ARRAYSIZ
	;BASE ADDRESS OF ARRAY
	;POINTER TO TEMP FOR OFFSET
	;MULT(1)
	;U(1)
	;MULT(2)
	;U(2)
	;	.
	;	.
	;	.
	;MULT(N)
	;U(N)

	;**NOTE THAT THE DOUBLE PRECISION/SINGLE PRECISION
	;IS HANDLED BY PASSING A 2/1 AS MULT(1).

	TWOSEG	400000

	HELLO	(ADJ1.)
	PUSH	P,T2		;SAVE REGISTERS USED
	PUSH	P,TABREG	;

	MOVE	T1,@0(ARG)	;FETCH DIMENSIONALITY
	MOVE	TABREG,ARG	;COPY ARG REGISTER
	MOVE	TEMOFF,@4(ARG)	;GET OFFSET WITH MULT(1)
	MOVE	T2,TEMOFF	;GET MULT(1) WITH MULT(1)
	MOVEM	T2,@1(ARG)	;INITIALIZE ARRAYSIZ
LOOP1:	SOJLE	T1,LUPDUN	;QUIT IF DONE
	MOVE	T2,@5(TABREG)	;FETCH U(I-1)
	IMULM	T2,@1(ARG)	;MULTIPLY INTO ARRAYSIZ
	IMUL	T2,@4(TABREG)	;MULT BY MULT(I-1)
	MOVEM	T2,@6(TABREG)	;FORMING MULT(I)
	ADDI	TEMOFF,0(T2)	;KEEP SUM OF OFFSET FACTORS
	ADDI	TABREG,2	;ADVANCE POINTER
	JRST	LOOP1		;GO AROUND AGAIN

LUPDUN:	MOVN	TEMOFF,TEMOFF	;NEGATE OFFSET
	ADDI	TEMOFF,@2(ARG)	;ADD ARRAY BASE ADDRESS
	MOVEM	TEMOFF,@3(ARG)	;STORE VALUE OF OFFSET
	MOVE	T2,@5(TABREG)	;FETCH U(I) FOR LAST ARRAYSIZE MULTIPLY
	IMULM	T2,@1(ARG)	;MULTIPLY TO MEM IT IN

	POP	P,TABREG	;RESTORE REGISTERS
	POP	P,T2
	GOODBY
	PRGEND
	TITLE	ADJG.	



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION

	SEARCH	FORPRM

;AC ASSIGNMENTS
ARG==L		;ARGUMENT LIST

TEMOFF==T0	;USED TO COMPUTE OFFSET
;T1==1		;USED TO HOLD LOOP COUNT (DIMENSIONALITY)
;T2==2		;USED TO HOLD MULTIPLIERS
TABREG==T3	;USED TO HOLD DESTROYED ARG PTR


	;THE FOLLOWING ALGORITHM IS IMPLEMENTED TO COMPUTE
	;ARRAY FACTORS AND OFFSET AND SIZE FOR THE
	;GENERAL CASE.

	;A PARTIALLY COMPUTED OFFSET MAY BE INPUT
	;THE ALGORITHM MAY START IN AN ARBITRARY PLACE AND MULT(1)
	;MAY BE 1 (STARTING FROM SCRATCH) OR ANOTHER VALUE.
	;THE ABILITY TO START ANYWHERE IS NECESSARY SINCE
	;FACTOR AND OFFSET INFO MAY ALREADY HAVE BEEN
	;COMPUTED FOR CONSTANT ARRAY BOUNDS APPEARING IN THE
	;LIST FIRST.
	;MULT(I) ARE THE FACTORS
	;U(I) ARE THE UPPER BOUNDS
	;L(I) ARE THE LOWER BOUNDS

	;OFFSET=MULT(1)*L(1)
	;ARRAYSIZ=MULT(1)
	;DO 10 I=2,NUMBER OF DIMENSIONS-1
	;TEMP=U(I-1)-L(I-1)+1
	;MULT(I)=MULT(I-1)*TEMP
	;OFFSET=OFFSET+MULT(I)
	;ARRAYSIZ=ARRAYSIZ*TEMP
;10	CONTINUE
	;OFFSET=-OFFSET+BASE ADDRESS OF ARRAY
	;TEMP=U(I)-L(I)+1
	;ARRAYSIZ=ARRAYSIZ*TEMP

	;THE PARAMTERS ARE (IN ORDER OF APPEARANCE)
	;POINTER TO NUMBER OF DIMENSIONS
	;POINTER TO ARRAY SIZE
	;BASE ADDRESS OF ARRAY
	;POINTER TO TEMP CONTAINING OFFSET
	;MULT(1)
	;U(1)
	;L(1)
	;MULT(2)
	;U(2)
	;L(2)
	;	.
	;	.
	;	.
	;MULT(N)

	TWOSEG	400000

	HELLO	(ADJG.)
	PUSH	P,T2		;SAVE REGISTERS USED
	PUSH	P,TABREG	;

	MOVE	T1,@0(ARG)	;FETCH DIMENSIONALITY
	MOVE	TABREG,ARG	;COPY ARG REGISTER
	SETZ	TEMOFF,		;[324] CLEAR OFFSET
	MOVE	T2,@4(ARG)	;MULT(1) - (PASSED IN)
	MOVEM	T2,@1(ARG)	;INITIALIZE ARRAYSIZ
LOOP1:	IMUL	T2,@6(TABREG)	;MULT(1)*L(1)
	ADDI	TEMOFF,0(T2)	;ADD TO INITIAL OFFSET
	SOJLE	T1,LUPDUN	;QUIT IF DONE
	MOVE	T2,@5(TABREG)	;U(I-1)
	SUB	T2,@6(TABREG)	;MINUS L(I-1)
	ADDI	T2,1		;PLUS 1
	IMULM	T2,@1(ARG)	;MULTIPLY INTO ARRAYSIZ
	IMUL	T2,@4(TABREG)	;TIMES MULT(I-1)
	MOVEM	T2,@7(TABREG)	;EQUALS MULT(I)
	ADDI	TABREG,3	;INCREMENT TO NEXT BUNCH
	JRST	LOOP1		;GO AROUND AGAIN

LUPDUN:	MOVN	TEMOFF,TEMOFF	;NEGATE OFFSET
	ADDI	TEMOFF,@2(ARG)	;ADD BASE ADDRESS OF ARRAY
	MOVEM	TEMOFF,@3(ARG)	;STOR OFFSET
	MOVE	T2,@5(TABREG)	;GET U(I) FOR LAST ARRAYSIZ MULT
	SUB	T2,@6(TABREG)	;-L(I)
	ADDI	T2,1		;ADD ONE OF COURSE
	IMULM	T2,@1(ARG)	;MULT AND STACH IN ARRAY SIZE

	POP	P,TABREG	;RESTORE REGISTERS USED
	POP	P,T2
	GOODBY

	PRGEND
	TITLE	ADJ.	VARIABLE DIMENSION SUBSCRIPT CALCULATOR 
SUBTTL	D. TODD /DRT 15-FEB-1973	TOM OSTEN/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION

;FROM LIB40 VERSION V.032(323)
;ADJ. IS A PROGRAM CALLED AT RUN-TIME BY A FORTRAN PROGRAM
;TO CALCULATE THE MULTIPLIERS AND OFFSET FOR SUBSCRIPT CALCULATIONS
;FOR DIMENSIONS DECLARED AS SUBROUTINE ARGUMENTS. THE COMPILER
;GENERATES THE FOLLOWING SEQUENCE:
;	JSA	16, ADJ.
;	EXP	N		;DIMENSIONALITY OF ARRAY
;	ARG	X, TEMP+N+1	;ARG IS A NO-OP, X IS THE TYPE
				;OF THE ARGUMENT,TEMP IS A PNTR
				;TYPE,TEMP+N+1 POINTS TO END OF
				;MULTIPLIER TABLE
;	EXP	U1		;ADDRESS OF NUMBER WHICH IS THE
;				;UPPER BOUND FOR FIRST SUBSCRIPT
;	EXP	L1		;ADDRESS OF NUMBER WHICH IS THE
;				;LOWER BOUND FOR FIRST SUBSCRIPT
;	.
;	.
;	.
;	EXP	LN		;LAST LOWER BOUND ADDRESS
;THE TEMP BLOCK IS CONSTRUCTED AS FOLLOWS:

;TEMP:	SIZE OF ARRAY (EQUAL TO MULTIPLIER N)
;	OFFSET
;	MULTIPLIER N-1
;	.
;	.
;	.
;	MULTIPLIER 1
;	MULTIPLIER 0

;THE I-TH MULTIPLIER, P(I), IS DESCRIBED BY:
;	P(0) = 1
;	P(I) = P(I-1) * (U(I) - L(I) + 1)

;THE OFFSET IS DESCRIBED BY
;	OFFSET = SUM FROM 1 TO N OF P(I-1)*L(I)

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	TWOSEG	400000

	HELLO	(ADJ.)		;ENTRY TO ADJ. ROUTINE
	MOVEM	2,SAV2		;SAVE AC 2
	LDB	C,[POINT 3,1(Q),11]	;GET HI 3 BITS OF ARG TYPE
	SUBI	C,3		;0 RESULT MEANS D.P. OR COMPLEX
	MOVEM	C,ACFLD		;SAVE THE RESULT
	MOVNI	C, @(Q)		;GET MINUS COUNT OF DIMENSIONS
	MOVEI	B, @1(Q)	;GET TOP ADDRESS OF TEMP BLOCK
	ADDI	B, -1(C)	;SET B BACK TO BEGINNING OF TEMP BLOCK
	HRL	B, C		;AOBJN WORD IS (-CNT)ADDR
	MOVEI	A, 1		;INITIALIZE P(0) = 1
	SETZM	OFFSET		;INITIALIZE OFFSET=0

ADJ.1:	MOVEM	A, (B)		;STORE P(N)
	ADDI	Q, 2		;SET FOR NEXT PAIR OF DIMENSIONS
	MOVE	C, A		;COPY P(N)
	IMUL	C, @1(Q)	;P(N-1)*L(N)
	ADDM	C,OFFSET	;ADD INTO OFFSET
	MOVE	C, @(Q)		;GET U(N)
	SUB	C, @1(Q)	;U(N) - L(N)
	IMULI	A, 1(C)		;P(N-1)*(U(N) -L(N) +1)
	AOBJN	B, ADJ.1	;N=N+1, GO AROUND LOOP

	MOVE	C,OFFSET	;GET OFFSET BACK
	SKIPN	ACFLD		;WAS TYPE D.P. OR COMPLEX?
	ASH	C,1		;YES, MULTIPLY OFFSET BY 2 FOR
				;COMPLEX OR DOUBLE PRECISION ARG.
	MOVEM	C, (B)		;OFFSET TO NEXT TO LAST ENTRY
	MOVEM	A, 1(B)		;SIZE TO LAST ENTRY
	MOVE	2,SAV2		;RESTORE AC 2
	GOODBY	(2)	;RETURN

	RELOC		;DATA
OFFSET:	BLOCK	1
ACFLD:	BLOCK	1	;HOLD 0 IF DOUBLE PRECISION OR COMPLEX
SAV2:	BLOCK	1	;TEMP STORAGE FOR AC 2
	RELOC
	PRGEND
	TITLE	PROAR.	ARRAY BOUNDS CHECKING ROUTINE 
	SUBTTL	SARA MURPHY	30-JAN-74



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

VERNO==3	;MAJOR VERSION NUMBER
VEDIT==21	;MAJOR EDIT NUMBER
VWHO==0		;EDITOR
VMINOR==0	;MINOR VERSION NUMBER

PROAV==BYTE(3)VWHO(9)VERNO(6)VMINOR(18)VEDIT

PURGE	VWHO,VERNO,VMINOR,VEDIT

	SEARCH	FORPRM		;DEFINE GLOBAL SYMBOLS

;ROUTINE TO PERFORM FORTRAN ARRAY BOUNDS CHECKING AT RUN TIME
;CALLED WITH AN ARGUMENT BLOCK OF THE FORM:
;	-------------------------------------------------
;	!			! PTR TO SEQ NUMB OF ST	!
;	-------------------------------------------------
;	!			! PTR TO DIMENSION INF	!
;	-------------------------------------------------
;	!			! PTR TO 1ST SUBSCRIPT	!
;	-------------------------------------------------
;	!			! PTR TO 2ND SUBSCRIPT	!
;
;			     ETC
; WHERE DIMENSION INFORMATION IS REPRESENTED BY A BLOCK OF THE FORM:
;	-------------------------------------------------
;	!  		ARRAY NAME (IN SIXBIT)		!
;	-------------------------------------------------
;	! DIM CT    !     !I!	! BASE ADDRESS		!
;	-------------------------------------------------
;	!A!F!			! PTR TO OFFSET		!
;	-------------------------------------------------
;	!			! PTR TO 1ST LOWER BND	!
;	-------------------------------------------------
;	!			! PTR TO 1ST UPPER BND	!
;	-------------------------------------------------
;	!			! PTR TO 1ST FACTOR	!
;	-------------------------------------------------
;	!			! PTR TO 2ND UPPER BND	!
;
;			     ETC
;   WHERE A IS A FLAG FOR "ADJUSTABLY DIMENSIONED ARRAY"
;	F IS A FLAG FOR "FORMAL ARRAY"
;
;COMPUTES THE ADDRESS OF THE SPECIFIED ARRAY ELEMENT AND
; RETURNS THAT ADDRESS IN AC 0. IF ANY OF THE BOUNDS ARE
; EXCEEDED, AN ERROR MESSAGE IS GIVEN BEFORE PROCEEDING
;THE ADDRESS OF THE ARRAY ELEMENT IS COMPUTED BY THE
; FORMULA:
;	BASE ADDR + OFFSET + (1ST SS)*(1ST FACTOR) +
;		(2ND SS)*(2ND FACTOR) + .....
;IF AN ARRAY IS NOT A FORMAL, THE BASE ADDR+OFFSET WILL BE ADDED
; IN TO THE RESULT OF THIS ROUTINE BY THE FORTRAN PROGRAM CALLING
; THIS ROUTINE - THEREFORE THESE 2 TERMS ARE NOT INCLUDED IN THE RESULT
; UNLESS THE ARRAY IS FORMAL.
;IF AN ARRAY IS ADJUSTABLY DIMENSIONED, THE "OFFSET" CALCULATED UPON
; ENTRY TO THE SUBROUTINE IN WHICH THE ARRAY IS DECLARED ALREADY
; INCLUDES THE BASE ADDRESS - THEREFORE FOR ADJUSTABLY DIMENSIONED
; ARRAYS NEED NOT HAVE THE BASE ADDRESS ADDED IN SEPARATELY.
;

	VREG=0		;REG IN WHICH THE RESULT IS RETURNED

	DP=15		;PTR INTO THE BLOCK OF DIMENSION INFORMATION. POINTS
			; TO THE SUB-BLOCK OF INFORMATION FOR A GIVEN DIMENSION
	SSP=14		;AOBJN POINTER INTO THE LIST OF SUBSCRIPTS - LEFT
			; HALF IS CT OF SUBSCRIPTS, RH IS PTR TO THE ENTRY
			; FOR A GIVEN SUBSCRIPT
	SS=13		;THE SUBSCRIPT BEING PROCESSED
	SUM=12		;COMPUTED SUM OF SUBSCRIPTS WITH FACTORS USED TO
			; COMPUTE THE ADDRESS

;DEFINE FIELDS IN THE ARG-BLOCK FOR THIS ROUTINE

	ISNWD=0		;WD 0 CONTAINS THE SEQ NUMBER OF THE STMNT
			; CONTAINING THIS ARRAY REF
	DBLKP=1		;WD 1 CONTAINS PTR TO THE DIMENSION BLOCK
			; FOR THIS ARRAY
	ARNAMP=1	;SINCE 1ST WD OF DIMENSION BLOCK IS THE ARRAY
			; NAME, WD 1 OF ARG BLOCK PTS TO THE ARRAY NAME
	SS1WD=2		;WD 2 CONTAINS PTR TO THE 1ST SS

;DEFINE FIELDS IN THE DIMENSION BLOCK

	DCTSIZ=9	;NUMBER OF BITS IN THE DIMENSION CT FIELD IN
			; THE DIMENSION DESCRIPTOR BLOCK
	DCTPOS=8	;LAST BIT IN THE DIMENSION CT FIELD IS BIT 8
	DCTWD=1		;DIMENSION CT FIELD IS IN WD 1 OF THE BLOCK

	DFLGWD=2	;DIMENSION BLOCK FLAGS ARE IN WD 2 OF DIM BLO
	DFLSIZ=2	;DIMENSION BLOCK FLAGS ARE 2 BITS
	DFLPOS=1	; BITS 0-1

	DNAMWD=0	;ARRAY NAME IS IN WD 0 OF THE DIMENS BLOCK
	DBASWD=1	;BASE ADDR IS IN WD 1 OF THE BLOCK
	DOFFWD=2	;OFFSET IS IN WD 2 OF THE BLOCK
	D1WD=3		;SUB-BLOCK FOR THE 1ST DIMENSION STARTS
			; IN WD 3

;DEFINE FIELDS IN THE SUB-BLOCKS FOR EACH DIMENSION

	DLBWD=0		;PTR TO LOWER BOUND IS IN WD 0 OF A SUB-BLOCK
			; FOR A GIVEN DIMENSION
	DUBWD=1		;PTR TO UPPER BOUND IS IN WD 1 OF A SUB-BLOCK
	DFACWD=2	;PTR TO FACTOR IS IN WD 2 OF A SUB-BLOCK
	DSBSIZ=3	;NUMBER OF WDS IN THE SUB-BLOCK FOR EACH DIMEN

	TWOSEG	400000

	HELLO	(PROAR.)
	PUSH	P,DP		;SAVE AC'S
	PUSH	P,SSP
	PUSH	P,SS
	PUSH	P,SUM
	MOVE	DP,DBLKP(L)	;PTR TO START OF DIMENSION BLOCK

	HRRI	SSP,SS1WD(L)	;SET UP AOBJN PTR TO THE SS LIST
				;LOAD DIMENSION COUNT
	LDB	T1,[POINT DCTSIZ,DCTWD(DP),DCTPOS]
	MOVN	T1,T1		; NEGATED GOES IN
	HRL	SSP,T1		; LEFT HALF

	LDB	T1,[POINT DFLSIZ,DFLGWD(DP),DFLPOS]	;FLAGS FOR
				; ADJ-DIM AND FOR FORMAL
	XCT	[			;INIT ADDR COMPUTED TO:
			MOVEI	SUM,0		; 0 FOR A NON-FORMAL
			MOVEI	SUM,@DBASWD(DP)	; THE ARRAY BASE FOR A FORMAL NOT
						; ADJUSTABLY DIMENSIONED
			PUSHJ	P,ERR1		; (ADJ BUT NOT FORMAL SHOULD
						; NEVER OCCUR)
			MOVE	SUM,@DOFFWD(DP)	; THE COMPUTED OFFSET FOR AN
						; ADJUSTABLY DIMENSIONED ARRAY
			](T1)

	MOVEI	DP,D1WD(DP)	;PTR TO INFO ON 1ST DIMENSION

LP:	MOVE	SS,@0(SSP)	;1ST SUBSCRIPT
	CAML	SS,@DLBWD(DP)	;IF LESS THAN LOWER BOUND
	CAMLE	SS,@DUBWD(DP)	; OR GTR THAN UPPER BOUND
	PUSHJ	P,PERR		; GIVE A MESSAGE
	IMUL	SS,@DFACWD(DP)	;MULTIPLY BY FACTOR
	ADD	SUM,SS		;ADD INTO THE ADDRESS BEING COMPUTED
	ADDI	DP,DSBSIZ	;GO ON TO NEXT DIMENSION
	AOBJN	SSP,LP		;GO ON TO NEXT SS AND LOOP


	MOVE	VREG,SUM	;RESULT
	POP	P,SUM		;RESTORE ACS
	POP	P,SS
	POP	P,SSP
	POP	P,DP
	POPJ	P,		;RETURN





;ROUTINE CALLED WHEN A BOUNDS VIOLATION HAS BEEN DETECTED

PERR:	PUSH	P,T2		;USE T1,T2,T3 FOR PASSING ARGS TO FORER
	PUSH	P,T3		; MUST PRESERVE T2,T3 BECAUSE THE FORTRAN
	PUSH	P,T4		; PROGRAM CALLING "PROAR." ASSUMES REGS
				; 2-15 ARE PRESERVED

	MOVEI	T3,-SS1WD+1(SSP) ;SET T3 TO THE DIMENSION BEING PROCESSED
	SUB	T3,L

	MOVE	T1,@ARNAMP(L)	;ARRAY NAME IN SIXBIT
	MOVE	T2,@ISNWD(L)	;ISN OF STMNT CONTAINING THIS ARRAY REF
	MOVE	T4,SS		;VALUE OF ILLEGAL SUBSCRIPT

	LERR	(SRE,%,<Subscript range error on line $D at $1L
	Subscript $D of array $S = $D>,<T2,-12(P),T3,T1,T4>)

	POP	P,T4
	POP	P,T3
	POP	P,T2
	POPJ	P,


;ADJUSTABLY DIMENSIONED FORMAL ARRAY ERROR DETETCTED

ERR1:	LERR	(VDM,?,Variably dimensioned array not formal - internal bug - abort)
	JRST	EXIT.##
				; ADJUSTABLY DIMENSIONED ARRAY THAT WAS
				; NOT FORMAL - HAVE AN INTERNAL BUG - ABORT

	PRGEND
	TITLE	FORDMP	DUMP AND PDUMP
	SUBTTL	/DMN/SWG 21-AUG-79



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
;FROM	1 MAY 1966 ED YOURDON, 2/12/68 NSR

	;THE PROGRAMS DUMP AND PDUMP MAY BE CALLED BY A FORTRAN PROGRAM
	;IN THE FOLLOWING MANNER:
	;	CALL DUMP(A(1),B(1),F(1),. . .,A(N),B(N),F(N))
	;	CALL PDUMP(A(1),B(1),F(1),.. .,A(N),B(N),F(N))
	;BOTH PROGRAMS CAUSE CORE TO BE DUMPED BETWEEN THE LIMITS A(I)
	;AND B(I), AS SPECIFIED BY THE MODE PARAMETER F(I). EITHER
	;A(I) OR B(I) MAY BE UPPER OR LOWER CORE LIMITS. DUMP CALLS
	;[SIXBIT /EXIT/] WHEN DONE, WHILE PDUMP RESTORES THE STATE
	;OF THE MACHINE AND RETURNS TO THE USERS PROGRAM. BOTH
	;PROGRAMS INDICATE THE CONTNETS OF THE ACCUMULATORS AND THE
	;FOLLOWING FLAGS BEFORE BEGINNING THE ACTUAL CORE DUMP:
	;	AR OV FLAG
	;	AR CRY0 FLAG
	;	AR CRY1 FLAG
	;	PC CHANGE FLAG - FLOATING OVERFLOW
	;	BIS FLAG
	;THE MODE OF THE DUMP IS CONTROLLED BY THE PARAMETER F(I), WHICH
	;MAY BE ONE OF THE FOLLOWING NUMBERS:
	;	0	OCTAL		(O12 FORMAT)
	;	1	FLOATING POINT	(G12.5 FORMAT)
	;	2	INTEGER		(I12 FORMAT)
	;	3	ASCII		(A12 FORMAT)
	;	4	DOUBLE PRECISION (G25.16)
	;THE FOLLOWING CONVENTIONS HAVE BEEN ADOPTED FOR UNUSUAL
	;ARGUMENT LISTS:
	;	1. IF NO ARGUMENTS ARE GIVEN, THE ENTIRE USER AREA
	;	   IS DUMPED IN OCTAL.
	;	2. IF THE LAST MODE ASSIGNMENT, F(N), IS MISSING,
	;	   THAT SECTION OF CORE IS DUMPED IN OCTAL.
	;	3. IF THE LAST TWO ARGUMENTS, B(N) AND F(N), ARE MISSING
	;	   AN OCTAL DUMP IS MADE FROM A(N) TO THE END OF USER AREA
	;	4. AN ILLEGAL MODE ASSIGNMENT CAUSES THE DUMP TO BE
	;	   MADE IN OCTAL.
	;IF A GROUP OF REGISTERS HAVE THE SAME CONTENTS, DUMP AND
	;PDUMP WILL FINISH PRINTING THE CURRENT LINE, THEN INDICATE THE NUMBER OF
	;OF REPEATED LINES WITH A COMMENT
	;LOCATION XXXXXX THROUGH XXXXXX CONTAIN XXXXXXXXXXXX

	;ACCUMULATOR ASSIGNMENTS AND PARAMETER ASSIGNMENTS

		P=	17	;PUSHDOWN POINTER
		B=	3	;SCRATCH
		C=	4	;...
		S=	5	;ADDRESS OF LOCATION CURRENTLY DUMPED
		F=	6	;ADDRESS OF HIGH LOCATION TO BE DUMPED
		I=	7	;ARGUMENT INDICATOR
		LL=	10	;LOOP COUNTER
		FRMT=	11	;HOLDS FORMAT FOR REPEATED LINES
		PP=	15	;BLT AC, ALSO HOLDS A FORMAT ADDRESS
		ARC=	12	;-Number of args left

		N==12		;SIZE OF AC BLOCK TO BE SAVED ON PD LIST
		DEVICE==-3	;DEVICE ASSIGNMENT FOR PRINT
		NLIST= 5	;NO. OF DIFFERENT FORMAT DUMPS AVAILABLE
	SEARCH	FORPRM
	FSRCH
	TWOSEG	400000

	HELLO	(DUMP)		;BEGINNING OF DUMP ROUTINE
	SETOM	ENTFLG		;FLAG DUMP ENTRY = -1
	JRST	DUMPA		;HOP DOWN TO COMMON CODE

	HELLO	(PDUMP)		;BEGINNING OF PDUMP ROUTINE
	SETZM	ENTFLG		;FLAG PDUMP ENTRY = 0

;Note: The following "POP" is used to get the PC flags. This
; does not work if the program is running in a non-zero section.
; But we will check for that case a couple instructions later.
DUMPA:	POP	P,FLGLOC	;NEED FLAGS OUT OF PC WORD
	PUSH	P,FLGLOC	;RESTORE TO TOP OF STACK
IF20,<				;Get PC flags differently?
	PUSH	P,T1		;Save an AC
	XMOVEI	T1,.		;What section are we running in?
	TLNE	T1,-1		;Non-zero?
	 XSFM	FLGLOC		;Yes, save PC flags the extended way.
	POP	P,T1		;Restore T1
>;end IF20
	PUSH	P,P
	PUSH	P, PP		;SAVE BLT AC
	HRRZI	PP, 1(P)	;SET UP BLT POINTER IN AC PP
	ADD	P, NUMBER	;MAKE ROOM ON PUSHDOWN LIST
	BLT	PP, (P)		;BLT ACS ONTO PUSHDOWN LIST
	PUSH	P,L		;SAVE THE LINK OVER THE I/O CALLS
	FUNCT	OUT.##,<<XWD 0,DEVICE>,0,0,<IFIW MESS1>,25>
	MOVE	C, BYTEP	;GET BYTE POINTER FOR FLAGS
	MOVEI	F, 5		;LOOP FOR FIVE FLAGS
FLAGS:	ILDB	B, C		;GET FLAG BIT STORED BY JSR
	MOVE	S, OFFON(B)	;GET EITHER "OFF" OR "ON"
	FUNCT	IOLST.##,<<XWD 001100,S>,0>
	SOJG	F, FLAGS	;LOOP BACK FOR MORE FLAGS
	  FUNCT	FIN.##
	FUNCT	OUT.##,<<XWD 0,DEVICE>,0,0,<IFIW MESS2>,6>
	CLEARB	S, I		;AC0-AC7, SET INDICATOR TO ZERO
	XMOVEI	L,1+[XWD -2,0	;2 args
		XWD 001100,S
		XWD 0,0]	;OUTPUT IT
D1:	PUSHJ	P,IOLST.##
	CAIGE	S, 7		;WHICH CONTAINS 0,1,2,3,4,5,6,7
	  AOJA	S, D1		;LOOP BACK UNTIL DONE

	XMOVEI	F, -N(P)	;GET CONTENTS OF AC0-AC7 OFF PD
	XMOVEI	L,1+[XWD -2,0	;2 args
		XWD 001100,(F)
		XWD 0,0]	;OUTPUT IT
	MOVEI	S,^D8		;# of accumulators
D2:	PUSHJ	P,IOLST.##
	SOJLE	S,D2A		;Loop for 8 accumulators
	  AOJA	F, D2

D2A:	MOVEI	S, 10		;PRINT AC10 - AC17
	XMOVEI	L,1+[XWD -2,0	;2 args
		XWD 001100,S
		XWD 0,0]	;OUTPUT IT
D3:	PUSHJ	P,IOLST.##
	CAIGE	S, 17		;LOOP FOR 8 ACS
	  AOJA	S, D3

	XMOVEI	S,-N-1(P)	;GET BLT AC ADDR
	XMOVEI	F,(P)		;GET L ADDR
	XMOVEI	C,-N-2(P)	;GET P ADDR ON ENTRY TO THIS ROUTINE
	XMOVEI	L,1+[XWD -7,0	;7 args
		XWD 002000,5
		XWD 0,1
		XWD 100,10
		XWD 001100,(S)
		XWD 001100,(F)
		XWD 001100,(C)
		XWD 004000,0]
	PUSHJ	P,IOLST.##
	POP	P,L		;RESTORE THE LINK FOR ARGUMENT PROCESSING
;ARGUMENT PROCESSOR
	HLRE	ARC,-1(L)	;Get -arg count
	JUMPE	ARC,ENDCHK	;No args: go dump all of core

;Come here to process a set of 3 args.
;L points to arg list
;ARC is -number of args left
SGET:	SETZ	I,		;Set to 1 if whole group of 3 args present
	FUNCT	OUT.##,<<XWD 0,DEVICE>,0,0,<IFIW MESS3>,1>
	FUNCT	FIN.##
	AOJG	ARC,SDOUT	;If no more args, quit
	XMOVEI	S,@0(L)		;Yes, pick up the address
	AOJG	ARC,ENDCK2	;End of arg list

	XMOVEI	F,@1(L)		;No, F:= end address
	AOJG	ARC,ENDCK3	;Jump if end of arg list

	MOVE	C,@2(L)		;No, C:= format type code
	AOJ	I,		;INDICATE THAT ALL 3 ARGUMENTS HAVE BEEN SEEN
	CAIL	C,NLIST		;IS THIS A LEGAL ARGUMENT?
	  JRST	ENDCK3		;No, DUMP IN OCTAL MODE

;Come here with:
;C = type of dump (0= Octal, 1= floating, etc.)
;S = Lowest location to be dumped
;F = Highest location to be dumped
;I = 0 if we defaulted any args because they were missing,
;  = 1 if all three args were present.
SCHEK:	CAML	S, F		;ARE ARGUMENTS IN ORDER?
	  EXCH	S, F		;NO, SWITCH THEM
	MOVE	PP,C		;COPY ARG TO PP FOR USE IN ARG BLOCKS
	MOVE	B,TABLE(C)	;V6 SET UP FORTRAN DATA UUO
	DPB	B,[POINT 4,IOLSTC,12]	;V6 DEPOSIT POINTER
	DPB	B,[POINT 4,IOLSTS,12]	;V6 ....
;MAIN DUMP PROCESSOR

DPROC:	PUSH	P,L		;SAVE THE LINK AFTER ARGUMENT PROCESSING
DPROC1:	MOVE	B, S		;GET CURRENT ADDRESS IN B
	MOVE	LL, S		;POINTER IN REPETITION CHECK

;** Be careful here with indexing when GLOBAL addresses are allowed.
;  If LH of index word is zero, effective address is "current section".
	MOVE	C,@S		;MEMORY WORD FOR REPETITION CHECK
LOOK:	CAMN	C,@LL		;DO WORDS MATCH?
	  CAMGE	F,LL		;Yes, Finished this section of code?
	    JRST	DIFF	;GO COMPUTE REPEATED LINES
	XMOVEI	T1,@S		;"end of a line"
	ADDI	T1,7		; . .
	CAML	LL,T1		;Finished checking a line?
	  ADDI	S, 10		;YES, INCREMENT S TO NEXT LINE
	CAMG	S,F		;STILL IN RANGE
	  AOJA	LL, LOOK	;INCREMENT POINTER, CHECK MORE
DIFF:	CAMN	B, S		;WERE ANY LINES REPEATED?
	  JRST	OLOOP0		;NO, DUMP THIS LINE INDIVIDUALLY

;"Locations n thru m contain "
	PUSH	P,C		;Save the contents of the word to print
	MOVE	C,S		;Last loc
	SUBI	C,1		; Off by one
	FUNCT	OUT.##,<<XWD 0,DEVICE>,0,0,<IFIW MESS4>,12>
	XMOVEI	L,1+[XWD -3,0	;3 args
		XWD 001100,B	;PRINT PART ABOUT ADDRESSES
		XWD 001100,C	;FIRST LOCATION THAT REPEATED
		XWD 004000,0]	;LAST LOCATION, S WAS ONE OFF
	PUSHJ	P,IOLST.##	;END OF REPETITION MESSAGE
	POP	P,C		;Get back contents

;..contain . <output the word>.
	XMOVEI	L,ARG1		;YES GET FORMAT FOR MESSAGE
	PUSHJ	P,OUT.##
	XMOVEI	L,IOLSTC	;OUTPUT REPEATED WORD
	PUSHJ	P,IOLST.##

				;LOOP FOR OUTPUTTING WORDS
OLOOP0:	MOVE	C,LIST2(PP)	;PICK UP FORMAT TYPE
OLOOP1:	CAMLE	S, F		;ALL DONE DUMPING?
	  JRST	NEXT1		;YES, CHECK ARGUMENTS
	XMOVEI	L,ARG2		;NO, OUTPUT FOR 8 WORDS/LINE
	PUSHJ	P,OUT.##	
	MOVEI	B,^D8		;LOOP COUNTER
	XMOVEI	L,1+[XWD -2,0	;2 args
		XWD 001100,S
		XWD 0,0]
	PUSHJ	P,IOLST.##
OLOOP2:	XMOVEI	L,IOLSTS	;ADDRESS FOR THIS LINE
	PUSHJ	P,IOLST.##	;MEMORY WORD
	CAML	S, F		;ALL DONE DUMPING
	  JRST	NEXT		;YES, CHECK ARGUMENTS
	CAIE	PP,DFMNM	;Double precision?
	  AOJA	S,OLOOP3	;NO, MOVE POINTER TO NEXT WORD
	ADDI	S,2		;YES, ADVANCE POINTER ONE WORD
	SOJ	B,		;OUTPUTS ONLY 4 WORDS
OLOOP3:	SOJG	B,OLOOP2	;DONE WITH THIS LINE?
	  PUSHJ	P,FIN.##	;YES, FINISH OFF FORMAT STATEMENT
	JRST	DPROC1		;SCAN NEXT LINE


;ARGUMENT BLOCKS
	XWD	-5,0
ARG1:	XWD	0,DEVICE
	XWD	0
	XWD	0
	XWD	410035,LIST1	;IFIW, INDIRECT BIT ON AND PP(R15) AS INDEX REG
	XWD	4

	XWD	-2,0
IOLSTC:	XWD	001100,C
	XWD	004000,0

	XWD	-5,0
ARG2:	XWD	0,DEVICE
	XWD	0
	XWD	0
	XWD	410035,LIST2	;IFIW, INDIRECT BIT ON AND PP(R15) AS INDEX REG
	XWD	4

	XWD	-2,0
IOLSTS:	XWD	001120,S	;INDIRECT BIT ON
	XWD	0,0
;ROUTINES THAT ARE CALLED AT TERMINATION OF ARGUMENT STRINGS,
;AND END OF CORE SECTION DUMPS

;** Note: Upper, lower limits for "all of core" must be changed
;	when extended addressing is implemented:
;   these are GLOBAL addresses, not LOCAL section addresses!
ENDCHK:	HRRZI	S, 20		;DUMP FROM 20
ENDCK2:	HRRZ	F, .JBFF	;TO END OF USER AREA
	SUBI	F,1		;DO NOT DUMP FIRST FREE
ENDCK3:	SETZ	C,		;Set OCTAL mode
	JRST	SCHEK		;FIX EXIT, CHECK CORE LIMITS

;Here when done dumping all args
SDOUT:
	MOVEM	L, L+1-N(P)	;SAVE EXIT ACCUMULATOR
	HRLZI	PP, 1-N(P)	;FIX BLT POINT AC
	BLT	PP, N-1		;GET ACS BACK FROM PD LIST
	SUB	P, NUMBER	;FIX UP PUSHDOWN POINTER
	POP	P, PP		;RESTORE BLT AC
	POP	P,(P)		;DECREMENT STACK POINTER BY ONE
	SKIPE	ENTFLG		;IS IT THE PDUMP ENTRY?
	  JRST	SDOUT1		;NO - DUMP
	GOODBY			;PDUMP - RETURN TO USER
SDOUT1:	FUNCT	(EXIT.)		;DUMP - EXIT

;Here when this dump is finished.
NEXT:	PUSHJ	P,FIN.##	;FINISH FORMAT
NEXT1:	POP	P,L		;RESTORE THE LINK
	JUMPE	I, SDOUT	;MORE ARGUMENTS TO COME?
	ADDI	L,3		;Yes, saw 3 args last time, Bump arg ptr.
	JRST	SGET		;GO GET SOME MORE ARGUMENTS

;FORMAT STATEMENTS FOR OUTPUT

MESS1:	ASCII	"(1H148X9HCORE DUMP/1H 7HOv flag17X9HCry0"
	ASCII	" flag15X9HCry1 flag15x12HFlt ov flag 13X"
	ASCII	"8HFPD flag/1H 5(A9,15X))"
MESS2:	ASCII	"(2(1H-8(9X3HAC O2)/7X8O14/))"
MESS3:	ASCII	"(1H-)"
MESS4:	ASCII	"(11H+Locations O10,9H through O10,9H contain /1H )"

;MORE FORMAT STATEMENTS AND SOME CONSTANTS, TOO
OFRMT:	ASCII	"(1H0,O10,8O14)"
EFRMT:	ASCII	"(1H0,O10,8G14.5)"
IFRMT:	ASCII	"(1H0,O10,8I14)"
AFRMT:	ASCII	"(1H0,O10,8A14)"
DFRMT:	ASCII	"(1H0,O10,4G25.16)"

OFRMT2:	ASCII   "(1H0,40X,O14)"
EFRMT2:	ASCII	"(1H0,40X,G14.5)"
IFRMT2:	ASCII	"(1H0,40X,I14)"
AFRMT2:	ASCII	"(1H0,40X,A14)"
DFRMT2:	ASCII	"(1H0,40X,G25.16)"

LIST1:	IFIW	OFRMT2
	IFIW	EFRMT2
	IFIW	IFRMT2
	IFIW	AFRMT2
	IFIW	DFRMT2
LIST2:	IFIW	OFRMT
	IFIW	EFRMT
	IFIW	IFRMT
	IFIW	AFRMT
	IFIW	DFRMT
DFMNM==.-LIST2-1		;D format index

OFFON:	ASCII	"OFF  "
	ASCII	"ON   "

TABLE:	EXP	TP%SPO,TP%SPR,TP%INT,TP%LIT,TP%DPR
BYTEP:		POINT 1,FLGLOC
NUMBER:	XWD	N, N

	RELOC			;DATA
FLGLOC:	BLOCK	1		;TO STORE PC WORD FROM TOP OF STACK
ENTFLG:	BLOCK 	1		;FLAG FOR WHICH ENTRY
	RELOC
	PRGEND
	TITLE	ILL	ZERO INPUT WORD ON ILLEG. CHARACTERS 
SUBTTL	D. TODD /DRT/DMN/TWE/SWG	20-Aug-79



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION

;FROM LIB40 VERSION V.032(323)
;WHEN THE FLAG ILLEG. IS SET (BY CALLING ILL),
;FLOATING POINT INPUT WORDS WILL BE CLEARED IF
;ANY ILLEGAL CHARACTERS ARE SCANNED FOR THAT WORD.
;THE ILLEG. FLAG IS CLEARED BY FOROTS. AT THE END
;OF EACH FORMAT STATEMENT.

;THE CALLING SEQUENCE IS PUSHJ P,ILL

;THE ROUTINE 'LEGAL' ALLOWS ONE TO CLEAR THE
;ILLEG. FLAG SO THAT ILLEGAL CHARACTERS WILL
;RESULT IN THE NORMAL ILLEGAL CHARACTER RETURN.

;THE CALLING SEQUENCE IS PUSHJ P,LEGAL

	SEARCH FORPRM
	EXTERNAL FOROP.
	TWOSEG	400000

	HELLO	(ILL)
	MOVEI	T0,FO$ILL		;Function code in T0
	XMOVEI	T1,ILLEG		;FOROP. returns addr. here
	PUSHJ	P,FOROP.		;FOROP RETURNS ADDRESS
	SETOM	@ILLEG			;SET ILL CH FLAG
	GOODBY

	HELLO	(LEGAL)
	MOVEI	T0,FO$ILL		;T0:= function code
	XMOVEI	T1,ILLEG		;T1:= Address to return adr in
	PUSHJ	P,FOROP.		;GET ADDRESS OF ILLEGAL FLAG
	SETZM	@ILLEG			;CLEAR ILL CH FLAG
	GOODBY

	RELOC	0			;SEPARATE DATA
ILLEG:	BLOCK	1

	PRGEND
	TITLE	SAVFMT	

;CODE TO ENCODE THE FORMAT IN AN ARRAY
;CALLS FOROP TO CALL %FMTSV IN FOROTS


	SEARCH	FORPRM
	EXTERN	FOROP.
	TWOSEG	400000

	HELLO	(SAVFMT)
	MOVEI	T0,FO$FSV	;Function code
				;No arg used
	PUSHJ	P,FOROP.
	GOODBY

	PRGEND
	TITLE	CLRFMT	

;CODE TO THROW AWAY THE ENCODING OF A FORMAT IN AN ARRAY
;CALLS FOROP TO CALL %FMTCL IN FOROTS


	SEARCH	FORPRM
	EXTERN	FOROP.
	TWOSEG	400000

	HELLO	(CLRFMT)
	MOVEI	T0,FO$FCL	;SETUP FOR FOROP
				;No arg used
	PUSHJ	P,FOROP.
	GOODBY

	PRGEND
	TITLE	LSNGET	

;FUNCTION WHICH RETURNS THE INTEGER VALUE OF THE LINE SEQUENCE NUMBER
;OF THE CURRENT LINE FOR MODE=LINED

	SEARCH	FORPRM
	EXTERN	FOROP.
	TWOSEG	400000

	HELLO	(LSNGET)
	MOVEI	T0,FO$GLN	;Return current line number
	MOVE	T1,@(L)		;GET CHANNEL #
	PUSHJ	P,FOROP.	;Returns line number in T0
	DMOVEM	T2,SAVE2	;SAVE 2 AC'S
	MOVEI	T3,5		;5 CHARS IN LSN
	SETZB	T1,T2		;CLEAR THE NUMBER
LSNLP:	ROTC	T0,7		;GET A CHAR
	JUMPE	T1,LSNENL	;SKIP NULLS
	CAIN	T1," "		;CONVERT SPACE TO "0"
	 MOVEI	T1,"0"
	CAIG	T1,"9"		;MAKE SURE IT'S LEGAL
	 CAIGE	T1,"0"
	  JRST	LSNILL		;NOT LEGAL
	IMULI	T2,^D10		;MUL PREVIOUS BY 10
	ADDI	T2,-"0"(T1)	;ACCUMULATE NUMBER
	SETZ	T1,		;AND CLEAR FOR NEW DIGIT
LSNENL:	SOJG	T3,LSNLP
	MOVE	T0,T2		;RETURN THE INTEGER
	DMOVE	T2,SAVE2	;Restore acs
	GOODBY

LSNILL:	MOVNI	T0,1		;-1=ILLEGAL CHAR IN LSN
	DMOVE	T2,SAVE2	;Restore acs
	GOODBY

	RELOC			;DATA
SAVE2:	BLOCK	2		;FOR THE AC'S

	PRGEND
	TITLE	DATE	TODAY'S DATE 
SUBTTL	D. TODD /DRT/KK/DMN/SWG	15-AUG-79



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION

;FROM LIB40 VERSION V.32(433)
;THIS SUBROUTINE PUTS TODAY'S DATE INTO A
;DIMENSIONED TWO-WORD ARRAY.

;THE DATE WILL BE IN THE FORM:
;	17-Aug-66

;THE ROUTINE IS CALLED IN THE FOLLOWING MANNER:
;	MOVEI	L,ARGBLK
;	PUSHJ	P,DATE


	SEARCH	FORPRM
	FSRCH
	TWOSEG	400000

	HELLO	(DATE)			;ENTRY TO DATE ROUTINE.
IF10,<
	MOVEI	T1,@(L)		;GET ADDRESS OF 2 WORD ARRAY
	MOVEM	T2,0(T1)		;SAVE THE CONTENTS OF AC T2.
	MOVEM	T3,1(T1)		;SAVE THE CONTENTS OF AC T3.
	CALLI	T1,14		;GET THE DATE FROM THE MONITOR.
	IDIVI	T1,^D31		;DIV. BY 31 TO OBTAIN THE DAY-1.
	ADDI	T2,1		;TO OBTAIN THE DAY.
	IDIVI	T2,^D10		;CONVERT INTO TWO DEC. DIGITS.
	SKIPN	T2		;IS THE DAY .LT. 10?
	MOVNI	T2,20		;YES, OUTPUT BLANK.
	MOVEI	T0,"0"(T2)	;GET FIRST DIGIT
	LSH	T0,7		;MAKE SPACE
	ADDI	T0,"0"(T3)	;ADD IN 2ND DIGIT
	IDIVI	T1,^D12		;TO OBTAIN THE MONTH
	EXCH	T1,T2		;SAVE YEAR IN T2
	MOVE	T1,TABLE(T1)	;GET MONTH IN T1
	LSHC	T0,3*7		;LEFT JUSTIFY 0 & 1
	LSH	T0,1		;0 = ASCII /DD-MO/
				;1 = ASCII /N-/
	MOVEI	T2,^D64(2)	;GET THE YEAR
	IDIVI	T2,^D10		;CONVERT INTO TWO DEC. DIGITS
	ADDI	T2,"0"		;MAKE ASCII
	ADDI	T3,"0"
	LSH	T2,2*7+1		;SHIFT TO CHAR 3
	LSH	T3,7+1		;SHIFT TO CHAR 4
	ADD	T3,T2		;ADD IN TO T3
	ADD	T3,T1		;SO LOW WORD IS IN T3
	ADDI	T3,40*2		;Make space for last character instead of NULL;
				; this allows compare of literal to work, since
				; FORTRAN pads the word with spaces.
	MOVE	T2,T0		;PUT HIGH ORDER RESULT IN 2
	MOVEI	T1,@(L)		;USER ADDRESS
	EXCH	T2,0(T1)		;RESTORE T2
	EXCH	T3,1(T1)		;AND T3 WHILE STORING RESULT
	POPJ	P,

TABLE:	ASCII	/-Jan-/
	ASCII	/-Feb-/
	ASCII	/-Mar-/
	ASCII	/-Apr-/
	ASCII	/-May-/
	ASCII	/-Jun-/
	ASCII	/-Jul-/
	ASCII	/-Aug-/
	ASCII	/-Sep-/
	ASCII	/-Oct-/
	ASCII	/-Nov-/
	ASCII	/-Dec-/
>				;END IF10

IF20,<				;BEGIN -20 ONLY CODE
	HRROI	T1,SVDT		;Point to address for result
	SETO	T2,		;ASK FOR TODAY'S DATE
	MOVX	T3,OT%NTM	;DO NOT WANT TIME
	ODTIM%			;DO THE JSYS
	DMOVE	T1,SVDT		;Get returned date
	ADDI	T2,40*2		;Change NULL to SPACE
				; This allows compare of literal to work, since
				; FORTRAN pads the word with spaces.
	DMOVEM	T1,@0(L)	; Store in user's array.
	POPJ	P,		;AND RETURN

	RELOC			;DATA
SVDT:	BLOCK	2		;Place to store ODTIM% results
>				;END IF20

	PRGEND
	TITLE	TIM2GO	RETURN TIME LIMIT IN SECONDS 
	SUBTTL	H. P. WEISS/SWG		20-AUG-79




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

	SEARCH	FORPRM
	FSRCH
	TWOSEG	400000

IF10,<				;BEGIN TOPS-10 CODE
	HELLO	(TIM2GO)	;DEFINE ENTRY POINT
	PUSH	P,T1		;GRAB A REGISTER
	MOVE	T1,[44,,11]	;DETERMINE JIFFIES PER SECOND
	GETTAB	T1,		;VIA GETTAB
	JRST	NEVER		;UNIMPLEMENTED
	FSC	T1,233		;CONVERT TO FLOATING POINT
	MOVE	T0,[-1,,40]	;DETERMINE TIME LIMIT
	GETTAB	T0,		;VIA GETTAB
	JRST	NEVER		;UNIMPLEMENTED
	TLZ	T0,777700	;CLEAR EXTRA BITS
	JUMPE	T0,NEVER	;RETURN INFINITY IF 0
	FSC	T0,233		;CONVERT TO FLOATING POINT
	FDVR	T0,T1		;COMPUTE SECONDS TILL EXPIRATION
DONE:	POP	P,T1		;RESTORE REGISTER USED
	GOODBY	(0)		;RETURN

NEVER:	HRLOI	T0,377777	;SET LIMIT TO INFINITY
	JRST	DONE
>				;END IF10

IF20,<				;TOPS-20 CODE
	ENTRY TIM2GO
TIM2GO:	PUSH	P,T1		;SAVE ACS
	PUSH	P,T2
	PUSH	P,T3
	SETO	T1,		;SET T1 TO -1 TO GET THIS JOB'S TIME
	MOVE	T2,[-3,,TBLK]	;SET UP POINTER TO BLOCK FOR RETURN VALS
	MOVX	T3,.JIRT	;START AT RUNTIME FIELD IN STRUCTURE
	GETJI%			;DO THE JSYS
	  JRST	NEVER
	SKIPN	T1,TBLK+2	;PICK UP TIME LIMIT
	  JRST	NEVER		;LIMIT IS 0 THEREFORE INFINITY
	MOVE	T2,TBLK		;PICK UP RUNTIME
	SUB	T1,T2		;GET DIFFERENCE BETWEEN RUNTIME AND TIME LIMIT
	FLTR	T0,T1		;AND FLOAT IT
	FDVRI	T0,(1000.0)	;CONVERT MILLISECONDS TO SECONDS
DONE:	POP	P,T3		;RESTORE ACS
	POP	P,T2
	POP	P,T1
	POPJ	P,

NEVER:	HRLOI	T0,377777
	JRST	DONE

	RELOC			;DATA
TBLK:	BLOCK	3
	RELOC
>				;END IF20
	PRGEND			;END OF TIM2GO
	TITLE	TIME	TIME OF DAY
	SUBTTL	/KK/SWG/EDS/EGM

;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION

;FROM LIB40 %2.(120)
;THIS SUBROUTINE PUTS THE TIME OF DAY INTO TWO WORDS.
;
;THE WORDS CONTAIN THE HOUR, THE MINUTE, THE SECOND, AND THE
;TENTH OF A SECOND.

;THE FIRST WORD IS OF THE FORM:
;	02:15 (FOR A.M. TIME)
;	14:15 (FOR P.M. TIME)

;THE SECOND WORD IS OF THE FORM:
;	37.4
;
;THE ROUTINE IS CALLED IN THE FOLLOWING MANNER:
;	XMOVEI	L,ARGBLK
;	PUSHJ	P,TIME

;ON THE -10, TIME OBTAINS THE TIME FROM THE MONITOR IN THE FORM:
;	TIME=THE NUMBER OF MILLISECONDS SINCE MIDNIGHT.
;ON THE -20, TIME OBTAINS THE INTERNAL TIME FROM THE MONITOR AND
;CONVERTS IT INTO MILLISECONDS SINCE MIDNIGHT, DOES THE SAME CONVERSION
;FROM THERE AS ON THE -10, BUT ALSO HAS TO CORRECT FOR GREENWICH MEAN TIME
;WHICH IS THE TIME THE -20 INTERNAL TIME IS STORED IN.

	SEARCH	FORPRM

	TWOSEG	400000

	SALL			;FOR HELLO MACRO - SEE BELOW
	HELLO	(TIME)
	FSRCH			;MUST FOLLOW HELLO MACRO TO AVOID OLD TIME JSYS

	PUSH	P,T2		;SAVE AC 2
	PUSH	P,T3		;SAVE AC 3
IF10,<
	MSTIME	T1,		;GET TIME IN MILLISECS FROM THE MONITOR.
>				;END IF10
IF20,<
	GTAD%			;GET INTERNAL TIME
	HRLZ	T1,T1		;Put into left half
	LSH	T1,-1		;
	MUL	T1,[^D86400000]	;COMPUTE NO OF MS SINCE MIDNIGHT
				;INTO AC1 -
>				;END IF20
	IDIVI	T1,^D60000	;TOTAL MINS. IN 1, LEFTOVER MSECS. IN 2.
	MOVEM	T2,TEMP1	;SAVE THE LEFTOVER MS
	IDIVI	T1,^D60		;HOURS IN 1, MINUTES IN 2.

IF20,<				;CORRECT FOR TIME ZONE ON -20
	SKIPE	T3,TZCOR	;PICK UP TIME ZONE CORRECTION IF IT'S SET
	  JRST	TIME01		;YES - IT'S SET - KEEP ON TRUCKIN
	PUSH	P,T4		;NEED ANOTHER AC FOR THIS JSYS
	PUSH	P,T2		;SAVE T2 WHICH IS USED FOR JSYS
	SETO	T2,		;T2 gets -1
	SETZ	T4,		;ZERO T4 FOR JSYS TO SAY LOCAL TIME
	ODCNV%			;USE THIS JSYS TO FIND TIME ZONE
	HLRZ	T3,T4		;PICK UP LEFT HALF WHICH HAS INTERESTING INFO
	TRZ	T3,<^-<(IC%TMZ)>> ;ZERO EVERYTHING EXCEPT TIME ZONE (B12-B17)
	TRZE	T3,40		;IS TIME ZONE NEGATIVE? (RANGE IS -12 to +12)
	  MOVN	T3,T3		;YES - NEGATE IT
	TXNE	T4,IC%ADS	;IS DAYLIGHT SAVINGS IN EFFECT?
	  SUBI	T3,1		;YES - SUBTRACT ONE HOUR
	MOVEM	T3,TZCOR	;STORE TIME ZONE CORRECTION FACTOR FOR NEXT TIME
	POP	P,T2		;RESTORE T2 WHICH HOLDS MINUTES
	POP	P,T4		;RESTORE T4
TIME01:	SUB	T1,T3		;CORRECT FOR TIMEZONE AND DAYLIGHT SAVINGS
	SKIPGE	T1		;DID TIME GO NEGATIVE?
	  ADDI	T1,^D24		;YES, GET IT MOD 24 HOURS
>				;END IF20
	MOVEM	T2,TEMP2	;SAVE THE MINUTES.

	XMOVEI	T0,@0(L)	;Get address of first argument
	$BLDBP	T0		;Build a byte pointer
	MOVEM	T0,HLDBP	;Save it away
	JSP	T3,SUB1		;GO TO SUBR. TO SET UP HR. IN ASCII.
	MOVEI	T1,":"		;SET UP ":".
	IDPB	T1,HLDBP	;Deposit ":" in the word.
	MOVE	T1,TEMP2	;PICK UP THE MINUTES.
	JSP	T3,SUB1		;GO TO SUBR. TO SET UP MIN. IN ASCII.
	HLRZ	T3,-1(L)	;FORTRAN-10 - GET ARGUMENT COUNT
	CAIE	T3,-2		;TWO ARGUMENTS?
	JRST	OUT1		;NO - RETURN NOW
TIME02:
	XMOVEI	T0,@1(L)	;Get address of second argument
	$BLDBP	T0		;Build a byte pointer
	MOVEM	T0,HLDBP	;Save it away
	MOVEI	T1," "		;PUT IN A BLANK AS THE FIRST
	IDPB	T1,HLDBP	;CHARACTER IN THE 2ND WORD.
	MOVE	T1,TEMP1	;PICK UP THE MSECONDS.
	IDIVI	T1,^D1000	;SECONDS IN 1, LEFTOVER MSECS. IN 2.
	MOVEM	T2,TEMP1	;SAVE THE MSECS.
	JSP	T3,SUB1		;GO TO SUBR. TO SET UP THE SECS. IN ASCII.
	MOVEI	T1,"."		;SET UP "."
	IDPB	T1,HLDBP	;IN THE WORD.
	MOVE	T2,TEMP1	;PICK UP THE MSECS.
	IDIVI	T2,^D100	;GET THE TENTH OF A SECOND.
	MOVEI	T2,"0"(2)	;MAKE IT ASCII
	IDPB	T2,HLDBP	;PUT IT IN THE SECOND WORD.
OUT1:	POP	P,T2		;RESTORE AC 2.
	POP	P,T3		;RESTORE AC 3.
	POPJ	P,		;RETURN
SUB1:	IDIVI	T1,^D10		;SUBROUTINE ENTRY POINT.
	MOVEI	T1,"0"(T1)	;MAKE IT ASCII
	IDPB	T1,HLDBP	;DEPOSIT IT IN THE WORD.
	MOVEI	T2,"0"(T2)	;MAKE IT ASCII
	IDPB	T2,HLDBP	;DEPOSIT IT IN THE WORD.
	JRST	(T3)		;RETURN TO MAIN SEQUENCE.

	RELOC			;DATA
TZCOR:	BLOCK	1		;SAVE TIME ZONE CORRECTION HERE
TEMP1:	0
TEMP2:	0
HLDBP:	BLOCK	1		;Saved byte ptr
	RELOC
	PRGEND
	TITLE	SLITE	SENSE LITE SETTING AND TESTING FUNCTION 
SUBTTL	D. TODD /DRT/TWE/SWG	 20-AUG-1979



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION

;FROM LIB40 VERSION V.032(323)
;SENSE LIGHT SETTING AND TESTING PROGRAM
;THIS PROGRAM CAN BE ENTERED AT TWO PLACES. THE SENSE LIGHT
;TESTING PROGRAM IS CALLED IN THE FOLLOWING MANNER:
;	MOVEI	L,ARGBLK
;	PUSHJ	P,SLITET
;IT TAKES TWO ARGUMENTS I AND J.
;I IS THE ADDRESS OF AN INTEGER ARGUMENT, AND J IS THE ADDRESS
;OF THE ANSWER. IF SENSE LIGHT I IS ON, THE ANSWER IS ONE, AND
;IF IT IS OFF, THE ANSWER IS 2.

;THE SENSE LIGHT SETTING PROGRAM IS CALLED IN THE FOLLOWING
;MANNER:
;	MOVEI	L,ARGBLK
;	PUSHJ	P,SLITE
;SLITE TAKES ONE ARGUMENT I.
;I IS THE ADDRESS OF AN INTEGER ARGUMENT WHOSE VALUE IS
;BETWEEN 0 AND 36. IF I=0, ALL SENSE LIGHTS ARE TURNED OFF.
;OTHERWISE, SENSE LIGHT I IS TURNED ON.

	SEARCH	FORPRM
	TWOSEG	400000

	HELLO	(SLITE)			;ENTRY TO SLITE PROGRAM
	MOVN	T1, @(L)		;GET ARGUMENT
	JUMPE	T1, SLITE2		;IS IT ZERO?
	MOVSI	T0, 400000		;NO, PUT A ONE IN BIT 0
	ROT	T0, 1(T1)		;ROTATE IT INTO POSITION
	MOVE	T1, LITES		;GET THE SENSE LIGHTS
	TDO	T1, T0			;TURN ON PROPER LIGHT
SLITE2:	MOVEM	T1, LITES		;SAVE NEW SENSE LIGHTS
	GOODBY	(1)			;RETURN

	HELLO	(SLITET)		;ENTRY TO SENSE TESTING PROGRAM
	MOVN	T1, @(L)		;PICK UP ARGUMENT
	MOVSI	T0, 400000		;PUT A ONE IN BIT 0
	ROT	T0, 1(T1)		;ROTATE IT INTO POSITION
	MOVEI	T1, 1			;SET ANSWER TO ONE FOR NOW
	MOVEM	T1, @1(L)		;...
	MOVE	T1, LITES		;PICK UP SENSE LIGHTS
	TDZN	T1,T0			;IS THE PROPER LIGHT ON?
	AOS	@1(L)			;NO, CHANGE ANSWER TO 2
	MOVEM	T1,LITES		;RESTORE WITH TESTED LIGHT OFF
	GOODBY	(2)			;RETURN

	RELOC				;DATA
LITES:	0
	RELOC
	PRGEND
	TITLE	SSWTCH	DATA SWITCH TESTING FUNCTION
SUBTTL	D. TODD /DRT/TWE/SWG/EDS	16-Mar-81



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION

;FROM LIB40 VERSION V.032(323)
; DATA SWITCH TESTING PROGRAM
;THIS PROGRAM IS CALLED IN THE FOLLOWING MANNER:
;	MOVEI	L, ARGBLK
;	PUSHJ	P,SSWTCH
;I IS THE ADDRESS OF AN INTEGER ARGUMENT AND J IS THE ADDRESS
; OF THE ANSWER . IF DATA SWITCH I IS UP,THE ANSWER IS 2 , AND
; IF IT IS DOWN, THE ANSWER IS 1.
;ON TOPS-20, THE SWITCHES ARE NOT AVAILABLE, THEREFORE SSWTCH WILL
; ALWAYS RETURN AN ANSWER OF 1.  WE ARE KEEPING THE ROUTINE AROUND
;FOR COMPATIBILITY

	SEARCH	FORPRM
	FSRCH
	TWOSEG	400000

	HELLO	(SSWTCH)	;ENTRY TO SSWTCH PROGRAM
IF10,<				;ONLY MAKES SENSE ON A -10
	MOVN	T1, @(L)	;PICK UP ARGUMENT
	MOVSI	T0, 400000	;PUT A ONE IN BIT 0
	ROT	T0,(T1)		; ROTATE BIT INTO POSITION
	MOVEI	T1,2		; SET ANSWER TO 2 FOR NOW
	MOVEM	T1, @1(L)	;...
	SWITCH	T1,		;GET DATA SWITCHES FROM MONITOR
	MOVEI	T1,2		; SET ANSWER TO 2 FOR NOW
	SOS	@1(L)		; NO, CHANGE ANSWER TO ONE
>				;END IF10

IF20,<
	MOVEI	T1,1		;ALWAYS SAY NO
	MOVEM	T1,@1(L)	;STORE IN USER'S VARIABLE
>				;END IF20
	GOODBY	(2)	;RETURN

	PRGEND
	TITLE	ERRSET	SET APR TRAP PARAMETERS 
	SUBTTL	CHRIS SMITH/CKS

;Call:
;	CALL ERRSET (N)
;or	CALL ERRSET (N, I)
;or 	CALL ERRSET (N, I, SUBR)
;
;where	N = max number of error messages to type
;
;	I = which error this call applies to.  One of:
;	       -1 any of the following
;		0 integer overflow
;		1 integer divide check
;		4 floating overflow
;		5 floating divide check
;		6 floating underflow
;	        8 library routine error	
;		9 output field width too small
;	    if I is not specified, -1 is assumed
;
;	SUBR = routine to call on the trap
;	       The effect is as if
;		   CALL SUBR (I, IPC)
;	       were placed in the program just after the instruction causing
;	       the trap.
;			I = error number of trap, same as above
;			IPC = PC of trap instruction
;			  (or if error number= 9, IPC = PC of PUSHJ 17,IOLST.)
;	       if SUBR is not specified, no routine is called on the APR trap.
	SEARCH	FORPRM
	EXTERN	FOROP.
	TWOSEG	400000

	HELLO	(ERRSET)
	MOVEI	T0,FO$APR	;T0:= function code
	XMOVEI	T1,APRCT	;Read apr table addresses to here
	PUSHJ	P,FOROP.	;READ THEM

	MOVSI	T1,(IFIW (T2))	;MAKE INDIRECT WORDS INDEXED BY T2
	HLLM	T1,APRCT	;POINTING TO ERROR COUNT TABLE
	HLLM	T1,APRLM	;AND ERROR MESSAGE LIMIT TABLE
	HLLM	T1,APRSB	;AND SUBROUTINE ADDRESS TABLE

	HLL	L,-1(L)		;GET ARG COUNT
	SETO	T2,		;DEFAULT IS ALL ERRORS
	SETZ	T3,		;DEFAULT SUBROUTINE IS NONE

	MOVE	T1,@(L)		;GET ERR MESSAGE LIMIT
	AOBJP	L,ERSET1	;IF OUT OF ARGS, GO STORE THEM
	MOVE	T2,@(L)		;GET ERROR NUMBER
	AOBJP	L,ERSET1	;IF OUT OF ARGS, GO STORE THEM
	MOVEI	T3,@(L)		;GET ROUTINE TO CALL

ERSET1:	CAILE	T2,.ETLST	;REASONABLE ERROR NUMBER?
	  SETO	T2,		;NO, SET TO DEFAULT

	CAIGE	T2,0		;DID USER SPECIFY ALL ERRORS?
	  MOVSI	T2,-<.ETNUM>	;YES, GET AOBJN POINTER
ERSETL:	MOVE	T4,T1		;GET ERR MESSAGE LIMIT
	ADD	T4,@APRCT	;ADD TO NUMBER THAT ALREADY HAPPENED
	MOVEM	T4,@APRLM	;STORE ERR MESSAGE LIMIT
	MOVEM	T3,@APRSB	;STORE SUBROUTINE ADDRESS OR 0
	AOBJN	T2,ERSETL	;SET ALL ERRORS IF THAT'S WHAT HE WANTS

	POPJ	P,		;DONE

	RELOC			;DATA
APRCT:	BLOCK	1		;ADDRESS OF APR ERROR COUNTS
APRLM:	BLOCK	1		;ADDRESS OF APR ERROR LIMITS
APRSB:	BLOCK	1		;ADDRESS OF APR ERROR SUBROUTINES
	RELOC
	PRGEND
	TITLE	ERRSNS	READ LAST IO ERROR 
	SUBTTL	CHRIS SMITH/CKS

;Call:
;	CALL ERRSNS (I,J)
;or	CALL ERRSNS (I,J,MSG)
;
;I and J are returned with the First number and the Second number
;for the last error
;
;MSG, if present, is a 16-word array returned holding the text
;of the message for the last error

	SEARCH	FORPRM
	EXTERN	FOROP.
	TWOSEG	400000

	HELLO	(ERRSNS)
	MOVEI	T0,FO$ERR	;Read error numbers
	XMOVEI	T1,ERRNUM	;To block beginning here
	PUSHJ	P,FOROP.	;READ THEM

	HLRE	T1,-1(L)	;GET ARG COUNT
	MOVN	T1,T1		;MAKE POSITIVE
	MOVE	T2,ERRNUM	;STORE ERR NUMBERS
	CAIL	T1,1
	  HLRZM	T2,@0(L)
	CAIL	T1,2
	 JRST	[HRRZ T2,T2	;Get RH only
		CAIN T2,-1	;-1?
		  SETO T2,	;Yes, make full word
		MOVEM T2,@1(L)	;Store 2nd ERR number
		JRST .+1]

	CAIGE	T1,3		;STRING SPECIFIED?
	  POPJ	P,		;NO, DONE

	MOVE	T1,ERRMSA	;GET MSG ADDRESS
	HRLI	T1,(POINT 7,)
	MOVEI	T2,@2(L)	;GET STRING ADDRESS
	HRLI	T2,(POINT 7,)
	MOVEI	T3,^D80		;COUNT 80 CHARS
ERRLP:	ILDB	T4,T1		;GET CHAR
	JUMPE	T4,ERREND	;NULL IS END
	IDPB	T4,T2		;STORE CHAR
	SOJG	T3,ERRLP

ERREND:	JUMPLE	T3,ERRRET	;IF 80 CHARS, DONE
	MOVEI	T1," "		;PAD WITH TRAILING SPACES
	IDPB	T1,T2
	SOJG	T3,.-1

ERRRET:	POPJ	P,		;DONE

	RELOC			;DATA
ERRNUM:	BLOCK	1		;ERR NUMBERS
ERRMSA:	BLOCK	1		;ERR MSG ADDRESS
	RELOC
	PRGEND
	TITLE	DIVERT	DIVERT ERROR MESSAGE OUTPUT 
	SUBTTL	CHRIS SMITH/CKS

;Call:
;
;	CALL DIVERT (U)
;where U is the unit number of an open unit, sends error messages
;to U instead of to the TTY.  If U is -1, the diversion is ended.
;
;	CALL CHKDIV (U)
;sets U to the unit number where errors are diverted, or -1 if none

	SEARCH	FORPRM
	EXTERN	FOROP.
	TWOSEG	400000

	HELLO	(CLRDIV)
	SETO	T1,		;Same as saying "UNIT=-1"
	JRST	DIV01		; (Should always return status 0)

	HELLO	(DIVERT)
	MOVE	T1,@(L)		;Get unit number
DIV01:	MOVEI	T0,FO$DIV	;Do diversion
	PUSHJ	P,FOROP.

;Status is returned in T1.
;T1:	= 0 means ok.
;	= 1 means ?Illegal unit number.
;	= 2 means ?unit not open
;	= 3 means ?Not open for FORMATTED IO
;	= 4 means ?Can't write to unit.

	PJRST	@DIVRT(T1)

;Indexed by status value

DIVRT:	IFIW	DIVRET		;(0) OK, return
	IFIW	ILLDV		;(1) Illegal unit
	IFIW	UNO		;(2) Unit not open
	IFIW	NOF		;(3) Not open for FORMATTED IO
	IFIW	CWU		;(4) Can't write to unit

ILLDV:	LERR	(LIB,?,DIVERT: illegal to divert to unit $D,<@(L)>,DIVRET)

UNO:	LERR	(LIB,?,DIVERT: unit $D is not open,<@(L)>,DIVRET)

NOF:	LERR	(LIB,?,DIVERT: unit $D is not open for FORMATTED I/O,<@(L)>,DIVRET)

CWU:	LERR	(LIB,?,DIVERT: Can't write to unit $D,<@(L)>,DIVRET)

DIVRET:	POPJ	P,		;DONE

	HELLO	(CHKDIV)
	MOVEI	T0,FO$GDV	;Get divert unit
	PUSHJ	P,FOROP.
	MOVEM	T1,@(L)		;Return unit number
	POPJ	P,		;Done

	PRGEND
	TITLE	OVERFL	RETURN OVERFLOW INFO
	SUBTTL	CHRIS SMITH/CKS/EGM

;Call:
;
;	CALL OVERFL (IANS)
;
;If any overflow, underflow, or divide check has occurred since the last
;call to OVERFL, IANS is set to 1 and T0 is set to -1; if not, IANS is
;set to 2 and T0 is set to 0.
;
; Note to maintainers: The "magic" number 8 that appears in this routine
;is because APR counts 0 thru 7 are various arithmetic traps.
;The entry number is determined by 3 PC flag bits in combination.

	SEARCH	FORPRM
	EXTERN	FOROP.
	TWOSEG	400000

	HELLO	(OVERFL)
	PUSH	P,T2		;SAVE
	PUSH	P,T3		; REGS
	MOVEI	T0,FO$APR	;Read APR table addresses
	XMOVEI	T1,APRCT	;Into here
	PUSHJ	P,FOROP.	;READ THEM
	MOVSI	T1,(IFIW (T1))	;MAKE INDIRECT WORD INDEXED BY T1
	HLLM	T1,APRCT	;POINTING TO COUNT TABLE
	MOVSI	T1,-8		;MAKE AOBJN POINTER TO TABLES
	MOVEI	T2,2		;INIT ANSWER TO 2 (NO OVERFLOWS)
OVLP:	MOVE	T3,@APRCT	;GET CURRENT COUNT
	CAMLE	T3,OLDCT	;GREATER THAN OLD COUNT?
	  MOVEI	T2,1		;YES, SET ANSWER TO 1 (OVERFLOW OCCURRED)
	AOBJN	T1,OVLP		;LOOK THROUGH WHOLE TABLE
	MOVEM	T2,@0(L)	;STORE ANSWER FOR CALLER
	HRLZ	T1,APRCT	;BLT TABLE VALUES FOR NEXT CALL
	HRRI	T1,OLDCT
	BLT	T1,OLDCT+7

	SETZM	T0		;ASSUME NO OVERFLOW, T0=FALSE
	CAIN	T2,1		;WAS THERE?
	SETOM	T0		; YES, SET T0=TRUE
	POP	P,T3		;RESTORE
	POP	P,T2		; REGS
	POPJ	P,		;DONE

	RELOC			;DATA
OLDCT:	BLOCK	8		;PREVIOUS APR COUNTS
APRCT:	BLOCK	1		;ADDRESS OF CURRENT APR COUNTS
APRLM:	BLOCK	1		;ADDRESS OF LIMITS
APRSB:	BLOCK	1		;ADDRESS OF SUBROUTINES
	RELOC
	PRGEND
	TITLE	TRACE	DUMMY ROUTINE DEFINES TRACE ENTRY IN FOROTS (FORERR) 
SUBTTL	D. TODD	/DRT		05-APR-1973



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1973,1981 BY DIGITAL EQUIPMENT CORPORATION

	SEARCH	FORPRM
	NOSYM
	ENTRY	TRACE		;HELLO MACRO CAN NOT BE USED
				;SIXBIT NAME DEFINED IN TRACE (FORERR)
TRACE=TRACE.##			;DEFINE THE EXTERNAL TRACE NAME
				;TRACE.=TRACE% IN (FORINI)
	PRGEND
	TITLE	INIOVL	SUBROUTINE TO SET PRINCIPAL OVERLAY FILE 
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	INIOVL

INIOVL=INIOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
	TITLE	GETOVL	SUBROUTINE TO GET LINKS INTO CORE 
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	GETOVL

GETOVL=GETOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
	TITLE	REMOVL	SUBROUTINE TO REMOVE LINKS FROM CORE 
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	REMOVL

REMOVL=REMOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
	TITLE	RUNOVL	SUBROUTINE TO JUMP TO START ADDRESS OF LINK 
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	RUNOVL

RUNOVL=RUNOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
	TITLE	LOGOVL	SUBROUTINE TO SET LOG OVERLAY FILE 
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	LOGOVL

LOGOVL=LOGOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
	TITLE	TMPOVL	SUBROUTINE TO SET WRITABLE OVERLAY FILE 
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	TMPOVL

TMPOVL=TMPOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
	TITLE	SAVOVL	SUBROUTINE TO MARK LINK AS WRITABLE 
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	SAVOVL

SAVOVL=SAVOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
	TITLE	CLROVL	SUBROUTINE TO MARK LINK AS NOT WRITABLE
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1981 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	CLROVL

CLROVL=CLROV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
	TITLE	FDDT	- DUMMY FORDDT 
SUBTTL	D. M. NIXON/DNM/CKS	10-Jan-80


	SEARCH	FORPRM
	FSRCH

IF20,<
  DEFINE OUTSTR (X) <
	HRROI	T1,X
	PSOUT%
  >
>

	HELLO	(FDDT.)
	PUSHJ	P,.+1		;FIRST TIME IN
	OUTSTR	[ASCIZ	/%FORDDT not loaded
/]
	PUSH	P,[CAI]		;REPLACE WITH NO-OP
	POP	P,FDDT.		;SO WE ONLY SEE MESSAGE ONCE
	POPJ	P,		;RETURN

	PRGEND
	TITLE	RELEAS	

;CALL:
;	CALL RELEAS (U)
;ACTION IS SAME AS
;	CLOSE (UNIT=U)
;WHICH SHOULE BE USED INSTEAD

	NOSYM
	ENTRY	RELEAS
	RELEAS==RELEA.##
	PRGEND
	TITLE	EXIT	

;LINK 4A(1120) has bug wherein SYMBOL=:VALUE## in overlays can lose

	NOSYM
	ENTRY EXIT
EXIT:	JRST	EXIT.##		;GO EXIT

	END