Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

	SEARCH	FORPRM
	TV	FORMSC	Miscellaneous routines ,7(3257)
	SUBTTL	Sue Godsell/SRM/EDS/EGM/CDM/AHM/RVM	14-Jan-83


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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1977, 1983


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.

***** Begin Version 6A *****

2077	RJD	31-Aug-82
	In OVERFL, index OLDCT for a correct comparison between the tables
	containing the current APR counts and the old counts.

2103	MRB	13-Sep-82	20-18016
	Time function will return incorrect results for european time 
	zones. Use the TOPS-20 JSYS ODTIM to get correct time.

***** Begin Version 7 *****

3000	CDM	19-Oct-81
	Added character routines ADJC1., ADJCG.

3001	AHM	2-Oct-81
	Make ADJ1.  and  ADJG.  work under  extended addressing.   Also,
	redefine array dimension field from 777B8 to 177B8 so that array
	bounds checking blocks  in section  0 will  hopefully look  more
	like the final version to be redefined for extended  addressing.
	Finally, create a PROTA. entry point which is the same as PROAR.
	for now to match the symbol that FORTRA 7(1250) requests.

3025	AHM	18-Nov-81
	Fix a bug in the trailing space edit to DATE (2020) that I  introduced
	when merging it into the V7 sources, and change two MOVEIs to  XMOVEIs
	for extended addressing support for good measure.

3052	AHM	1-Mar-82
	Make PROAR. work for extended addressing by widening the  flag
	field in  the dimension  block to  the upper  4 bits.   Delete
	PROTA. entry  point  since  it  is  not  needed  for  extended
	addressing after all.

3066	RVM	27-Mar-82
	Fix ADJ1., ADJG., ADJC1., and ADJCG. to not calculate the size
	of assumed-size arrays.

3073	JLC	31-Mar-82
	Remove RELEAS routine; it was for F40.

3122	JLC	28-May-82
	Segment FORMSC. Changed LERRs to $FCALLs, and move error msgs
	to a separate module FORMSL in FORMSC.

3124	AHM	6-Jun-82
	Added a SEGMENT  macro to  FDDT so that  everything goes  into
	.CODE. and .DATA.  under FTXLIB.  Also, preserve T1 around the
	PSOUT for "%FORDDT not loaded" under Tops-20.

3125	JLC	3-Jun-82
	Moved the error character to the beginning of the error macro
	calls.

3131	JLC	11-Jun-82
	Allow character string argument for ERRSNS error string return.

3132	CKS	11-Jun-82
	Add PROSB. to do substring bounds checking.

3140	JLC	2-Jul-82
	Fix ERRSET so that -1 for error number gets the entire table
	instead of just the V6-defined traps.

3141	JLC	2-Jul-82
	Install FFUNIT.

3142	AHM	3-Jul-82
	Install PRGEND in FFUNIT.

3161	JLC	16-Aug-82
	Fixed ERRSNS for extended addressing multi-sections.

3165	JLC	28-Aug-82
	Separate bounds check errors from others.

3205	AHM	18-Nov-82
	Insert error message texts for  TMA, CGP, CRP, NSS, CFS,  CGS.
	Change VDM and ICF to "Should not happen" errors.  Reword AQS.

3206	CDM	5-Nov-82/17-Jan-83
	Allow character arguments for DATE and TIME.

3257	AHM	14-Jan-83
	Fix DUMP  and PDUMP  -  FUNCT macro  made OTSZERWRD  I/O  list
	elements non-zero, FIN word was in wrong half of an I/O  list,
	change positional OUT. argument lists to keyword form, correct
	change in carriage control semantics between V6 and V7.

***** 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) DIGITAL EQUIPMENT CORPORATION 1972, 1983

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

	SEGMENT	CODE

	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)
	ADD	TEMOFF,T2	;[3001] Keep (30 bit) sum of offset factors
	ADDI	TABREG,2	;ADVANCE POINTER
	JRST	LOOP1		;GO AROUND AGAIN

LUPDUN:	MOVN	TEMOFF,TEMOFF	;NEGATE OFFSET
	XMOVEI	T2,@2(ARG)	;[3001] Get 30 bit array base address
	ADD	TEMOFF,T2	;[3001] Add it in
	MOVEM	TEMOFF,@3(ARG)	;STORE VALUE OF OFFSET
	MOVE	T2,@5(TABREG)	;FETCH U(I) FOR LAST ARRAYSIZE MULTIPLY
	CAME	T2,[1B0-1]	;[3066] Don't multiply for assumed-size array
	 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) DIGITAL EQUIPMENT CORPORATION 1972, 1983

	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 PARAMETERS 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)

	SEGMENT	CODE

	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)
	ADD	TEMOFF,T2	;[3001] Add (30 bits) 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
	XMOVEI	T2,@2(ARG)	;[3001] Get 30 bit array base address
	ADD	TEMOFF,T2	;[3001] Add it in
	MOVEM	TEMOFF,@3(ARG)	;STORE OFFSET
	MOVE	T2,@5(TABREG)	;GET U(I) FOR LAST ARRAYSIZ MULT
	CAMN	T2,[1B0-1]	;[3066] Assumed-size array case?
	 JRST	BYE		;[3066] Yes, don't calculate size
	SUB	T2,@6(TABREG)	;-L(I)
	ADDI	T2,1		;ADD ONE OF COURSE
	IMULM	T2,@1(ARG)	;MULT AND STACH IN ARRAY SIZE

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

	PRGEND

	TITLE	ADJC1.	 Adjustable dimension with start of 1

	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. Modeled from ADJ1.
; MULT(I) are multipliers.

; U(I) are upper bounds (equivalent to range).

;	MULT(1)=<size of array from descriptor>
;	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

; The parameters passed are (inorder):
;	Pointer to number of dimensions
;	Pointer to temp for ARRAYSIZ
;	Descriptor of array
;	Pointer to temp for OFFSET
;	MULT(1)
;	U(1)
;	MULT(2)
;	U(2)
;		.
;		.
;		.
;	MULT(N)
;	U(N)

; **Note that MULT1(1) is assigned from the descriptor's size
;   unlike for numeric arrays (ADJ1) which has a constant passed.

	SEGMENT	CODE

	HELLO	(ADJC1.)
	PUSH	P,T2		;Save registers used
	PUSH	P,TABREG	;

	DMOVE	T1,@2(ARG)	;Get array descriptor, t2=size of array
	MOVEM	T2,@4(ARG)	;Assign MULT(1)
	MOVEM	T2,@1(ARG)	;Initialize ARRAYSIZ
	MOVE	TEMOFF,T2	;Get offset with MULT(1)
	MOVE	T1,@0(ARG)	;Fetch dimensionality 
	MOVE	TABREG,ARG	;Copy arg register
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)
	ADD	TEMOFF,T2	;Keep sum of OFFSET factors
	ADDI	TABREG,2	;Advance pointer
	JRST	LOOP1		;Go around again

LUPDUN:	MOVNM	TEMOFF,@3(ARG)	;Negate OFFSET and store it
	MOVE	T2,@5(TABREG)	;Fetch U(I) for last arraysize multiply
	CAME	T2,[1B0-1]	;[3066] Don't multiply for assumed-size array
	 IMULM	T2,@1(ARG)	;Multiply to mem it in

	POP	P,TABREG	;Restore registers
	POP	P,T2
	GOODBY
	PRGEND

	TITLE	ADJCG.   General adjustable dimension array

	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.  It is modeled after ADJG.

; 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

;	MULT(1)=<size from descriptor passed>
;	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
;	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
;	Descriptor for array
;	Pointer to temp containing offset
;	MULT(1)
;	U(1)
;	L(1)
;	MULT(2)
;	U(2)
;	L(2)
;		.
;		.
;		.
;	MULT(N)

	SEGMENT	CODE

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

	DMOVE	T1,@2(ARG)	;Descriptor, T2 is size of array
	MOVEM	T2,@4(ARG)	;Assign MULT(1)
	MOVEM	T2,@1(ARG)	;INITIALIZE ARRAYSIZ
	MOVE	T1,@0(ARG)	;FETCH DIMENSIONALITY
	MOVE	TABREG,ARG	;COPY ARG REGISTER
	SETZ	TEMOFF,		;CLEAR OFFSET
LOOP1:	IMUL	T2,@6(TABREG)	;MULT(1)*L(1)
	ADD	TEMOFF,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:	MOVNM	TEMOFF,@3(ARG)	;NEGATE OFFSET and store it
	MOVE	T2,@5(TABREG)	;GET U(I) FOR LAST ARRAYSIZ MULT
	CAMN	T2,[1B0-1]	;[3066] Assumed-size array case?
	 JRST	BYE		;[3066] Yes, don't calculate size
	SUB	T2,@6(TABREG)	;-L(I)
	ADDI	T2,1		;ADD ONE OF COURSE
	IMULM	T2,@1(ARG)	;MULT AND STACH IN ARRAY SIZE

BYE:	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) DIGITAL EQUIPMENT CORPORATION 1972, 1983

;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

	SEGMENT	CODE

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

	SEGMENT	DATA

OFFSET:	BLOCK	1
ACFLD:	BLOCK	1	;HOLD 0 IF DOUBLE PRECISION OR COMPLEX
SAV2:	BLOCK	1	;TEMP STORAGE FOR AC 2

	PRGEND

	TITLE	PROAR.	ARRAY BOUNDS CHECKING ROUTINE
	SUBTTL	SARA MURPHY/AHM	1-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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

	SEARCH	FORPRM		;DEFINE GLOBAL SYMBOLS
	FSRCH			;[3052] Search MACTEN or MACSYM

; Routine to perform FORTRAN array bounds checking at run time.

; Called with an argument block of the form:
;	-------------------------------------------------
;	!1!0!			! PTR TO SEQ NUMB OF ST	!
;	-------------------------------------------------
;	!1!0!			! PTR TO DIMENSION INF	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 1ST SUBSCRIPT	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 2ND SUBSCRIPT	!
;			     Etc.
;
; Where dimension information is represented by a block of the form:
;	-------------------------------------------------
;	!  		ARRAY NAME (IN SIXBIT)		!
;	-------------------------------------------------
;	!1!0! DIM CT !     !I!	! BASE ADDRESS		!
;	-------------------------------------------------
; V6	!A!F!0!0!		! PTR TO OFFSET		!
; V7	!1!0!A!F!		! PTR TO OFFSET		!
;	-------------------------------------------------
;	!1!0!			! PTR TO 1ST LOWER BND	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 1ST UPPER BND	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 1ST FACTOR	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 2ND UPPER BND	!
;
;			     ETC
;   WHERE A IS A FLAG FOR "ADJUSTABLY DIMENSIONED ARRAY"
;	F IS A FLAG FOR "FORMAL ARRAY"
;
; Note that  the argument  list  is created  in the  compiler  routine
; PROARRXPN in the file ARRXPN.BLI and the dimension block is  created
; and written in CGDIMBLK in DEBUG.BLI.
;
;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.

; Note that there are two formats for the adjustably dimensioned array
; and formal array flags.  The old format used for V6 and before  used
; the two high  order bits  of the flag  word.  The  pattern "10"  was
; illegal for  V6 because  it means  "adjustably dimensioned  but  not
; formal" -  a  non-sequitur for  Fortran.   Which is  just  as  well,
; because the two high order bits of the flag word had to be forced to
; "10" for V7  in order to  make the  flag word an  IFIW for  extended
; addressing.  The definitions of the bits were just shifted over by 2
; places for extended addressing.

	DP=P4		;PTR INTO THE BLOCK OF DIMENSION INFORMATION. POINTS
			; TO THE SUB-BLOCK OF INFORMATION FOR A GIVEN DIMENSION
	SSP=P1		;[3052] Pointer to the arg block entry for a subscript
	SS=P2		;Value of the subscript being processed
	COUNT=P3	;[3052] The number of subscripts left to go
	SUM=0		;[3052] Computed sum of subscripts with factors
			;[3052]  (Used to compute the element 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

	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

	DCTSIZ=7	;[3001] Number of bits in the dimension count
			;[3001]  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

	TYPWRD==1	;[3052] Dim block word that contains the array type
	TYPMSK==<Z 17,0>	;[3052] Type field is the AC field

	DFLGWD=2	;DIMENSION BLOCK FLAGS ARE IN WD 2 OF DIM BLO
	DFLSIZ=4	;[3052] Dimension block flags are 4 bits
	DFLPOS=3	;[3052] Bits 0-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

	SEGMENT	CODE
	EXTERN	ABORT.		;[3205] FOROTS fatal error entry point

	HELLO	(PROAR.)
	PUSH	P,DP		;SAVE ACs
	PUSH	P,SSP
	PUSH	P,SS
	PUSH	P,COUNT		;[3052] Save the count AC


	XMOVEI	DP,@DBLKP(L) 	;[3052] Pointer to dimension block

	XMOVEI	SSP,SS1WD(L)	;[3052] Set up pointer to the SS list
	LDB	COUNT,[POINT DCTSIZ,DCTWD(DP),DCTPOS] ;Load dimension count

; Get flags to see how to compute the base address of the array.

	LDB	T1,[POINT DFLSIZ,DFLGWD(DP),DFLPOS] ; Adj-dim and formal flags

	LDB	SUM,[POINTR (TYPWRD(DP),TYPMSK)] ;[3052] Get the array type
	CAIN	SUM,TP%CHR 	;[3052] Is it a character variable ?
	 MOVEI	T1,^B1011	;[3052] Yes, they act like an adjustable formal
				;[3052]  (The main program "adds in" the array
				;[3052]  base with an ADJBP, but we are
				;[3052]  responsible for starting off with the
				;[3052]  offset pointed to by DOFFWD(DP))


	XCT	PXCTAB(T1)	;Execute table entry (indexed by T1)
	XMOVEI	DP,D1WD(DP)	;[3052] Pointer 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
	ADDI	SSP,1		;[3052] Go on to next SS
	SOJG	COUNT,LP	;[3052] Loop back for more

	POP	P,COUNT		;[3052] Restore ACs
	POP	P,SS
	POP	P,SSP
	POP	P,DP
	POPJ	P,		;RETURN


;EXECUTE TABLE
; There are presently 4 bits - this implies a 16 word table.

PXCTAB:	MOVEI	SUM,0		;[3052] |0000| V6 Non-formal
	$FCALL	SNH,ABORT.	;[3052] |0001| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |0010| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |0011| Flags for V7 set by V6
	XMOVEI SUM,@DBASWD(DP)	;[3052] |0100| V6 Non-adj formal
	$FCALL	SNH,ABORT.	;[3052] |0101| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |0110| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |0111| Flags for V7 set by V6
	MOVEI	SUM,0		;[3052] |1000| V7 Non-formal
	XMOVEI SUM,@DBASWD(DP)	;[3052] |1001| V7 Non-adj formal
	$FCALL	SNH,ABORT.	;[3052] |1010| V7 Adj but not formal
				;[3052]           should never occur
	MOVE	SUM,@DOFFWD(DP)	;[3052] |1011| V7 Computed offset for
				;[3052]           an adjustable array
	MOVE	SUM,@DOFFWD(DP)	;[3052] |1100| V6 Computed offset for
				;[3052]           an adjustable array
	$FCALL	SNH,ABORT.	;[3052] |1101| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |1110| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |1111| Flags for V7 set by V6

;END OF EXECUTE TABLE

;ROUTINE CALLED WHEN A BOUNDS VIOLATION HAS BEEN DETECTED

PERR:	XMOVEI	T1,1-SS1WD(SSP) ;[3052] Set T1 to the dimension
	SUB	T1,L		;[3052] being processed
	PUSH	P,T2		;SAVE T2,T3
	PUSH	P,T3
	MOVE	T2,@ARNAMP(L)	;GET THE ARRAY NAME
	MOVE	T3,@ISNWD(L)	;GET THE ISN

;(SRE,21,101,%,<Subscript range error - subscript $D of array $S = $D
;	on line $D>,<T1,T2,P2,T3>)

	$FCALL	SRE		;ISSUE MESSAGE, CONTINUE

	POP	P,T3		;RESTORE T2,T3
	POP	P,T2
	POPJ	P,

;@ISNWD(L)[T3]/	ISN of statement containing this array ref
;T1/			Dimension number being processed
;@ARNAMP(L)[T2]/	Array name in SIXBIT
;SS[P2]/		Value of illegal subscript


	PRGEND

	TITLE	FORDMP	DUMP AND PDUMP
	SUBTTL	/DMN/SWG/DAW/AHM



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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
;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
	SEGMENT	CODE

	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
	XMOVEI	L,1+[XWD -2,0	;[3257] Arg count
		401100,,[DEVICE] ;[3257] UNIT=
		402340,,MESS1]	;[3257] FMT=
	PUSHJ	P,OUT.##	;[3257] Set up for output
	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"
	XMOVEI	L,1+[XWD -2,0	;[3257] Arg count
		XWD 001100,S	;[3257] DATACALL
		0]		;[3257] OTSZERWRD
	PUSHJ	P,IOLST.##	;[3257] Do the output
	SOJG	F, FLAGS	;LOOP BACK FOR MORE FLAGS
	  FUNCT	FIN.##
	XMOVEI	L,1+[XWD -2,0	;[3257] Arg count
		401100,,[DEVICE] ;[3257] UNIT=
		402340,,MESS2]	;[3257] FMT=
	PUSHJ	P,OUT.##	;[3257] Set up for more output
	CLEARB	S, I		;AC0-AC7, SET INDICATOR TO ZERO
D1:	XMOVEI	L,1+[XWD -2,0	;2 args
		XWD 001100,S
		XWD 0,0]	;OUTPUT IT
	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
D3:	XMOVEI	L,1+[XWD -2,0	;2 args
		XWD 001100,S
		XWD 0,0]	;OUTPUT IT
	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]	;[3257] OTSFINWRD
	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
	PUSH	P,L		;[3257] Save arg pointer
	XMOVEI	L,1+[XWD -2,0	;[3257] Arg count
		401100,,[DEVICE] ;[3257] UNIT=
		402340,,MESS3]	;[3257] FMT=
	PUSHJ	P,OUT.##	;[3257] Go set up for output and do it
	FUNCT	FIN.##		;[3257] All done!
	POP	P,L		;[3257] Restore arg pointer
	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
	XMOVEI	L,1+[XWD -2,0	;[3257] Arg count
		401100,,[DEVICE] ;[3257] UNIT=
		402340,,MESS4]	;[3257] FMT=
	PUSHJ	P,OUT.##	;[3257] Set up for output
	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	-2,0
ARG1:	401100,,[DEVICE]	;[3257] UNIT=
	402375,,LIST1		;[3257] IFIW, @LIST1(PP)

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

	XWD	-2,0
ARG2:	401100,,[DEVICE]	;[3257] UNIT=
	402375,,LIST2		;[3257] IFIW, @LIST2(PP)

	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

	EXP	MESS1L		;[3257] FMTSIZ=
MESS1:	ASCII	"(1H148X9HCORE DUMP/1H 7HOv flag17X9HCry0"
	ASCII	" flag15X9HCry1 flag15x12HFlt ov flag 13X"
	ASCII	"8HFPD flag/1H 5(A9,15X))"
	MESS1L==.-MESS1		;[3257] Compute size of FORMAT statement

	EXP	MESS2L		;[3257] FMTSIZ=
MESS2:	ASCII	"(2(1H-8(9X3HAC O2)/7X8O14/))"
	MESS2L==.-MESS2		;[3257] Compute size of FORMAT statement

	EXP	MESS3L		;[3257] FMTSIZ=
MESS3:	ASCII	"(1H-)"
	MESS3L==.-MESS3		;[3257] Compute size of FORMAT statement

	EXP	MESS4L		;[3257] FMTSIZ=
MESS4:	ASCII	"(11H-Locations O10,9H through O10,9H contain /1H )"
	MESS4L==.-MESS4		;[3257] Compute size of FORMAT statement

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

	EXP	4		;[3257]
OFRMT2:	ASCII   "(1H0,40X,O14)"
	EXP	4		;[3257]
EFRMT2:	ASCII	"(1H0,40X,G14.5)"
	EXP	4		;[3257]
IFRMT2:	ASCII	"(1H0,40X,I14)"
	EXP	4		;[3257]
AFRMT2:	ASCII	"(1H0,40X,A14)"
	EXP	4		;[3257]
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

	SEGMENT	DATA

FLGLOC:	BLOCK	1		;TO STORE PC WORD FROM TOP OF STACK
ENTFLG:	BLOCK 	1		;FLAG FOR WHICH ENTRY

	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) DIGITAL EQUIPMENT CORPORATION 1972, 1983

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

	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

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

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

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

	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

	SEGMENT	DATA

SAVE2:	BLOCK	2		;FOR THE AC'S

	PRGEND

	TITLE	DATE	TODAY'S DATE 
SUBTTL	D. TODD /DRT/KK/DMN/SWG/AHM/CDM		5-Nov-82



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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983

;FROM LIB40 VERSION V.32(433)

;This subroutine puts today's date  into a numeric dimensioned  two-word
;array or a character variable.

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

	HELLO	(DATE)			;ENTRY TO DATE ROUTINE.

	PUSH	P,T2		;[3206] Save ac's
	PUSH	P,T3		;[3206]

	; Put time into SVDT

IF10,<
	XMOVEI	T1,@0(L)	;[3025] Get address of 2 word array
	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(T2)	;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	T1,T3		;[3206] So low word is in T1
	ADDI	T1," "_1	;[3206] Make space for last character instead
				;[2020]  of NULL; this allows compare of
				;[2020]  literal to work, since FORTRAN pads
				;[2020]  the word with spaces.
	DMOVEM	T0,SVDT		;[3206] Store away date to return

>				;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
	MOVEI	T1," "_1	;[3206] Change NULL to SPACE
				;[2020]  This allows compare of literal to
				;[2020]  work, since FORTRAN pads the word
				;[2020]  with spaces.
	IORM	T1,SVDT+1	;[3206] Store away date to return

>				;END IF20

	; Return date to caller

	LDB	T0,[POINTR (0(L),ARGTYP)] ;[3206] Type of argument
	CAIE	T0,TP%CHR	;[3206] Is it character?
	 JRST	NOTCHR		;[3206] No

	; Argument is character.  Rather than worrying how to handle the
	; length of  the  character  descriptor, and  how  to  pad  with
	; blanks, let the move sludge handle this.

	MOVEI	T0,^D10		;[3206] Move 2 words of source
	MOVE	T1,[POINT 7,SVDT] ;[3206] Make a byte pointer for source
	DMOVE	T3,@0(L)	;[3206] Arg's BP and length
	EXCH	T3,T4		;[3206] Reverse order
	EXTEND	T0,[MOVSLJ
			" "]	;[3206] Put the date in the argument
	 JFCL			;[3206] NOP

	JRST	EXDATE		;[3206] Return

NOTCHR:	; Argument is numeric

	DMOVE	T0,SVDT		;[3206] Get date
	DMOVEM	T0,@0(L)	;[3206] Return date calculated above

EXDATE:	POP	P,T3		;[3206] Return ac's
	POP	P,T2		;[3206]
	POPJ	P,		;[3206] Return to caller

IF10,<
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-/
>

	SEGMENT	DATA

SVDT:	BLOCK	2		;Place to store results from monitor call

	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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

	SEARCH	FORPRM
	FSRCH
	SEGMENT	CODE

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

	SEGMENT	DATA

TBLK:	BLOCK	3
>				;END IF20

	PRGEND			;END OF TIM2GO

	TITLE	TIME	TIME OF DAY
	SUBTTL	/KK/SWG/EDS/EGM/CDM

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983

;FROM LIB40 %2.(120)

;This subroutine returns the time of day in two single word arguments or
;a character variable.
;
;The first argument gets  the hour and minute,  and the optional  second
;argument gets the second and tenth of a second.

;The first argument is given in military time:
;	02:15	(for a.m. time)
;	14:15	(for p.m. time)
;
;The optional second argument 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

	SEGMENT	CODE

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

	PUSH	P,T2		;[3206] Save ac's
	PUSH	P,T3		;[3206]

	;Process the first argument.  Put it into TTIME.

IF10,<				;TOPS10-only code
	MSTIME	T1,		;Get time in millisecs from the monitor.
	IDIVI	T1,^D60000	;[2103]Total mins. in 1, leftover msecs. in 2.
	MOVEM	T2,TEMP1	;Save the leftover ms
	IDIVI	T1,^D60		;Hours in 1, minutes in 2.
	MOVEM	T2,TEMP2	;[2103]Save the minutes.
	MOVE	T0,[POINT 7,TTIME] ;[3206] Build a BP for answer
	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.

>				;[2103]End IF10

IF20,<				;TOPS-20 only code
	GTAD%			;[3206] Universal Date Time
	MOVEM	T1,TEMP1	;[3206] Save internal d & t
	MOVE	T2,T1		;[3206] For ODTIM, convert this
	HRROI	T1,TTIME	;[3206] BP for result
	MOVSI	T3,(OT%NDA!OT%NSC) ;[3206] Set flags for call
	ODTIM%			;[3206] Convert udt to hh:mm
>				;End IF20

	; Return time in 1st argument

	LDB	T0,[POINTR (0(L),ARGTYP)] ;[3206] Get type of 1st argument
	CAIE	T0,TP%CHR	;[3206] Is it character?
	 JRST	NTCHR1		;[3206] no

	; Character argument.   Use move  string, so  we don't  have  to
	; worry about the length the user specified and how to pad  with
	; spaces.

	MOVEI	T0,5		;[3206] Length of 1 numeric word
	MOVE	T1,[POINT 7,TTIME] ;[3206] Address of source (time to return)
	DMOVE	T3,@0(L)	;[3206] Arg BP and length
	EXCH	T3,T4		;[3206] Exchange positions
	EXTEND	T0,[MOVSLJ
			" "]	;[3206] Put the time in the argument
	 JFCL			;[3206] NOP
	JRST	NEXT1		;[3206]

NTCHR1:	; Numeric argument

	MOVE	T0,TTIME	;[3206] Return time in
	MOVEM	T0,@0(L)	;[3206]  the first argument

NEXT1:	HLRZ	T3,-1(L)	;[3206] Number of arguments
	CAIE	T3,-2		;[3206] Are there two?
	 JRST	EXTIME		;[3206] Exit from here

IF20,<				;TOPS20-only code - Set up to look like 10 side
	HRLZ	T1,TEMP1	;[3206] Put into left half
	LSH	T1,-1		;[2103]shift
	MUL	T1,[^D86400000]	;[2103]compute miliseconds since midnight
	IDIVI	T1,^D60000	;[2103]total mins. in 1, leftover msecs. in 2.
	MOVEM	T2,TEMP1	;[2103]save the leftover ms
	IDIVI	T1,^D60		;[2103]hours in 1, minutes in 2.
>				;[2103]End IF20

	; Process 2nd argument to return seconds

TIME02:
	MOVE	T0,[POINT 7,TTIME] ;[3206] Build BP for second argument
	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.

	LDB	T0,[POINTR (1(L),ARGTYP)] ;[3206] Type of 2nd argument
	CAIE	T0,TP%CHR	;[3206] Is it character?
	 JRST	NTCHR2		;[3206] No

	; 2nd argument is character.

	MOVEI	T0,5		;[3206] Length of source in characters
	MOVE	T1,[POINT 7,TTIME] ;[3206] Make a BP for
	DMOVE	T3,@1(L)	;[3206] 2nd arg's BP and length
	EXCH	T3,T4		;[3206] Exchange them
	EXTEND	T0,[MOVSLJ
			" "]	;[3206] Put the time in the argument
	 JFCL			;[3206] NOP
	JRST	EXTIME		;[3206] Exit from here

NTCHR2:	; 2nd argument is numeric.

	MOVE	T0,TTIME	;[3206] Return the seconds as the 2nd arg
	MOVEM	T0,@1(L)	;[3206]

EXTIME:	POP	P,T3		;[3206] Restore ac's
	POP	P,T2		;[3206]
	POPJ	P,		;[3206] 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.

	SEGMENT	DATA

TTIME:	BLOCK	1		;[3206] Temporary storage for Time
TEMP1:	BLOCK	1		;[3206]
TEMP2:	BLOCK	1		;[3206]
HLDBP:	BLOCK	1		;Saved byte ptr

	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) DIGITAL EQUIPMENT CORPORATION 1972, 1983

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

	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

	SEGMENT	DATA

LITES:	0

	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) DIGITAL EQUIPMENT CORPORATION 1972, 1983

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

	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
;		10 input floating overflow
;		11 input floating underflow
;		12 input integer overflow
;		21 FORLIB warnings
;		22 non-standard usage warnings
;
;	    If I is not specified, -1 is assumed
;
;	SUBR = routine to call on the trap
;
;	       The effect is as if
;		   CALL SUBR (I, IPC, N2, ITYPE, UNFIXED, FIXED)
;	       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 FOROTS call)
;			N2 = 2nd error number (reserved for DEC)
;			ITYPE = data type of value
;			UNFIXED = value returned by the processor
;			FIXED =  value after fixup by MTHTRP
;	       If SUBR is not specified, no routine is called on the APR trap.

	SEARCH	FORPRM
	EXTERN	MTHOP.
	SEGMENT	CODE

	HELLO	(ERRSET)
	MOVEI	T0,ML$APR	;T0:= function code
	XMOVEI	T1,APRCT	;Read apr table addresses to here
	PUSHJ	P,MTHOP.	;READ THEM
	MOVEM	T0,ERRSZ	;SAVE SIZE OF TABLE

	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 APR 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
	XMOVEI	T3,@(L)		;GET ROUTINE TO CALL

ERSET1:	CAML	T2,ERRSZ	;REASONABLE ERROR NUMBER?
	 $FCALL	NOR,EPOPJ	;NUMBER OUT OF RANGE

	JUMPGE	T2,ERSETL	;IF INDIVIDUAL ERROR, GO SET IT
	MOVN	T2,ERRSZ	;IF ALL ERRORS, CREATE AOBJN PNTR
	HRLZI	T2,(T2)
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

EPOPJ:	POPJ	P,		;DONE

	SEGMENT	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
ERRSZ:	BLOCK	1		;SIZE OF TABLES

	PRGEND

	TITLE	MTHOP.
	SEARCH	FORPRM
	ENTRY	MTHOP.
	EXTERN	FOROP.

MTHOP.==FOROP.

	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
	FSRCH
	EXTERN	FOROP.
	SEGMENT	CODE

	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 POINTER
	LDB	T2,[POINTR (2(L),ARGTYP)] ;GET ARG TYPE
	CAIE	T2,TP%CHR	;CHARACTER?
	 JRST	ERRNC		;NO
	DMOVE	T2,@2(L)	;YES. GET PNTR/COUNT
	JRST	ERRLP		;AND JOIN COMMON CODE
ERRNC:	XMOVEI	T2,@2(L)	;GET STRING ADDRESS
	$BLDBP	T2		;BUILD A BYTE POINTER TO IT
	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

	SEGMENT	DATA

ERRNUM:	BLOCK	1		;ERR NUMBERS
ERRMSA:	BLOCK	1		;ERR MSG ADDRESS

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

	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.

	XMOVEI	T0,DIVRT(T1)	;GET ADDR TO GO
	MOVE	T1,@(L)		;GET UNIT NUMBER
	PJRST	@T0		;GO THERE

;Indexed by status value

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


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

	HELLO	(OVERFL)
	PUSH	P,T2		;SAVE
	PUSH	P,T3		; REGS
	PUSH	P,T4		;[2077]
	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)
	SETZ	T4,		;[2077] INITIALIZE OLD COUNT TABLE INDEX
OVLP:	MOVE	T3,@APRCT	;GET CURRENT COUNT
	CAMLE	T3,OLDCT(T4)	;[2077] GREATER THAN OLD COUNT?
	  MOVEI	T2,1		;YES, SET ANSWER TO 1 (OVERFLOW OCCURRED)
	ADDI	T4,1		;[2077] INCREMENT OLD COUNT TABLE INDEX
	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,T4		;[2077]
	POP	P,T3		;RESTORE
	POP	P,T2		; REGS
	POPJ	P,		;DONE

	SEGMENT	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

	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) DIGITAL EQUIPMENT CORPORATION 1973, 1983

	SEARCH	FORPRM
	NOSYM
	ENTRY	TRACE		;HELLO MACRO CAN NOT BE USED
				;SIXBIT NAME DEFINED IN TRACE (FORERR)
TRACE=TRACE.##			;DEFINE THE EXTERNAL TRACE NAME

	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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

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) DIGITAL EQUIPMENT CORPORATION 1974, 1983

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/DMN/CKS/AHM	6-Jun-81


	SEARCH	FORPRM
	FSRCH
	SEGMENT	CODE		;[3124] Put this in the lowseg because
				;[3124]  FDDT. is impure

IF20,<
  DEFINE OUTSTR (X) <
	PUSH	P,T1		;[3124] Save T1
	HRROI	T1,X
	PSOUT%
	POP	P,T1		;[3124] Restore T1
  >
>

	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	EXIT	
	SEARCH	FORPRM


	ENTRY EXIT
	EXTERN	EXIT.

EXIT==EXIT.

	PRGEND

	TITLE	EXIT1

;ENTRY POINT TO JUST CLOSE FILES

	ENTRY	EXIT1
	EXTERN	EXIT1.

EXIT1==EXIT1.

	PRGEND

	TITLE	QUIETX
	SEARCH	FORPRM

;DOES A QUIET EXIT FROM FOROTS (NO CPU TIME MESSAGE)
;WILL STILL GIVE ERROR SUMMARIES, IF ANY

	ENTRY	QUIETX
	EXTERN	FOROP.

	SEGMENT	CODE

QUIETX:	MOVEI	T0,FO$QIT	;QUIET EXIT FUNCTION
	PJRST	FOROP.

	PRGEND
	TITLE	PROSB.	Substring bounds checking routine
	SUBTTL	CHRIS SMITH/CKS		8-Jun-82
				;[3132] New 

;Routine to perform substring bounds checking.

;The compiler transforms the substring reference
;
;	VAR(LB:UB)
;
;into
;
;	VAR(LB: PROSB.(VAR,LB-1,UB,ISN,'VAR') )
;
;where PROSB. checks the validity of LB and UB, then returns UB.  If the bounds
;are invalid, a warning message is typed.  (LB-1 is used instead of LB because
;LB-1 is conveniently available in the compiler's internal representation of
;substrings.)

;The conditions for valid substring bounds are
;
;	LB <= UB
;	LB >= 1
;	UB <= LEN(VAR)
;
;If a bound is found to be out of range, a warning message is typed.  No
;attempt at correction is made - the program will get the same results as if
;/DEBUG:BOUNDS were not specified, except for the message.

	SEARCH	FORPRM
	SEGMENT	CODE
	SALL


;Argument block offsets

VAR==0				;Variable we're taking substring of
LB==1				;Lower bound - 1
UB==2				;Upper bound
ISN==3				;Statement number of substring reference
VARNAME==4			;Sixbit variable name for error message

	HELLO	(PROSB.)

	PUSH	P,T2		;SAVE ACS
	PUSH	P,T3

	XMOVEI	T1,@VAR(L)	;GET POINTER TO DESCRIPTOR
	MOVE	T1,1(T1)	;GET CHARACTER VARIABLE LENGTH

	MOVE	T2,@LB(L)	;GET LOWER BOUND - 1
	MOVE	T3,@UB(L)	;GET UPPER BOUND

	JUMPL	T2,SERR		;CHECK LB .GE. 1 (LB-1 .GE. 0)
	CAML	T2,T3		;MUST HAVE LB .LE. UB (LB-1 .LT. UB)
	  JRST	SERR		;NO, ERROR
	CAMLE	T3,T1		;CHECK UB .LE. LENGTH
	  JRST	SERR		;NO, ERROR

;Return	UB.

RET:	MOVE	T0,@UB(L)	;RETURN UB FOR SUBSTRING CALCULATION

	POP	P,T3		;RESTORE ACS
	POP	P,T2
	POPJ	P,		;RETURN


;Here on error, type message and return normally.

SERR:	PUSH	P,T4		;SAVE SOME MORE REGISTERS FOR ERR MESSAGE
	PUSH	P,T5

	MOVE	T4,@ISN(L)	;GET ISN
	MOVE	T5,@VARNAME(L)	;GET VARIABLE NAME
	ADDI	T2,1		;CONVERT LB-1 TO LB

	$FCALL	SSE		;"%Substring range error VAR(LB:UB)
				;  on line ISN at LABEL+OFFSET"

	POP	P,T5		;RESTORE REGISTERS
	POP	P,T4
	JRST	RET		;GO RETURN UB

	PRGEND

	TITLE	FFUNIT
	SEARCH	FORPRM

	EXTERN	FOROP.

	SEGMENT	CODE

	HELLO	(FFUNIT)
	MOVEI	T0,FO$GFU	;GET # OF FIRST FREE UNIT
	PUSHJ	P,FOROP.
	MOVEM	T0,@(L)		;SAVE IN USER'S VARIABLE
	POPJ	P,

	PRGEND			;[3142] End of the routine

	TITLE	FORMSL
	SEARCH	FORPRM

	SEGMENT	CODE

	RADIX	10

	$FERR (?,IOE,98,0,$J) ;General-purpose I/O error
	$FERR (%,NOR,-1,0,ERRSET: error number out of range - ignored)
;[3205] 21,102 was VDM
;[3205] 21,103 was ICF
	$FERR (?,IDU,21,104,DIVERT: illegal to divert to unit $D,<T1>)
	$FERR (?,UNO,21,105,DIVERT: unit $D is not open,<T1>)
	$FERR (?,NOF,21,106,DIVERT: unit $D is not open for FORMATTED I/O,<T1>)
	$FERR (?,CWU,21,107,DIVERT: Can't write to unit $D,<T1>)
	$FERR (?,CLE,21,108,<Concatenation result larger than expected>)
	$FERR (?,ICE,21,109,<Illegal length character expression>)
	$FERR (?,NCS,21,110,No character stack allocated - compiler error)
	$FERR (?,NCA,21,111,No memory available for character stack)
	$FERR (?,AQS,21,112,<First argument to SORT must be a quoted string>) ;[3205]
	$FERR (%,SSE,23,113,<Substring range error $S($D:$D)
	on line $D>,<T5,T2,T3,T4>)
	$FERR (%,SRE,23,114,<Subscript range error - subscript $D of array $S = $D
	on line $D>,<T1,T2,P2,T3>)

	$FERR (?,TMA,21,115,<Too many arguments in call to SORT>) ;[3205]
	$FERR (?,CGP,21,116,<Can't get pages 600:677 for SORT>)	;[3205]

IF10,<
	$FERR (?,CRP,21,117,<Can't return pages 600:677 after call to SORT>)
> ; End of IF10
IF20,<
	$FERR (?,NSS,21,118,<No free section available for SORT>) ;[3205]
	$FERR (?,CFS,21,119,<Can't find SYS:SORT.EXE - $J>) ;[3205]
	$FERR (?,CGS,21,120,<Can't get SYS:SORT.EXE - $J>) ;[3205]
> ; End of IF20

	$FERR (?,SNH,-1,0,<Internal FOROTS error>)	;[3205]
IF20,<							;[3205]
	$FERR (?,IJE,-1,0,<Internal FOROTS JSYS error - $J>) ;[3205]
> ; End of IF20						;[3205]

	END