.MCALL	.MODULE
.MODULE	CMPLT,VERSION=06,COMMENT=<CMPLT/SYSLIB>,IDENT=NO,LIB=YES

; Copyright (c) 1998 by Mentec, Inc., Nashua, NH.
; All rights reserved
;
; This software is furnished under a license for use only on a
; single computer system and  may  be  copied  only  with  the
; inclusion of the above copyright notice.  This software,  or
; any other copies thereof, may not be provided  or  otherwise
; made available to any other person except for  use  on  such
; system and to one who agrees to these license  terms.  Title
; to  and  ownership of the software shall at all times remain
; in Mentec, Inc.
;
; The information in this document is subject to change without
; notice and should not be construed as a commitment by Digital
; Equipment Corporation, or Mentec, Inc.
;
; Digital and Mentec  assume  no  responsibility for the use or
; reliability of its software on equipment which is not supplied
; by Digital  or Mentec,  and listed  in the  Software  Product
; Description.
;++
;
;	Edit	Who	Date		Description of modification
;	----	---	----		---------------------------
;	001	WLD	01-OCT-90	Use SOB instruction if EIS.
;
;	002	WLD	08-OCT-90	Define ASECT to set .SAV file
;					word at SV.NID so that any
;					module linked with CMPLT will
;					not load in separated I&D space.
;
;	003	WLD	15-OCT-90	Standardize PSECT names.
;--
.SBTTL	CMPLT - FORTRAN CALLABLE SUBROUTINE
;
;	SETS UP AREA FOR FORTRAN COMPLETION ROUTINE.
;
; INPUT:R1 -> IAREA (3 WORDS) TO BE USED FOR LINKAGE CODE.
;	R5 -> WORD CONTAINING ADDRESS OF FORTRAN ROUTINE.
; OUTPUT:R0,R4,R5,SP UNCHANGED,  IAREA INITIALIZED
;
;	DESTROYS: R1,R2,R3
;
; MAS

	.LIBRARY "SRC:SYSTEM.MLB"

.IIF NDF EIS$I	EIS$I=0
.IIF NDF SLIB$M	SLIB$M=0
.IIF NE  SLIB$M	EIS$I=1

.IIF EQ  EIS$I	.MCALL	SOB

	.MCALL	.SAVDF
	.SAVDF	E=<=:>
	.ASECT			;Set I&D not allowed in
	. = SV.NID		;any .SAV file linked
	.WORD	000001		;to CMPLT.

	.PSECT	SYS$I,I

.GLOBL	$SYSLB,	$LOCK,	$CRASH,	$AOTS,	$LRECL,	$WASIZ,	$HRDWR

USERRB	=  53			;User error byte
 SUCCS$	=   1			 ;Success
 WARN$	=   2			 ;Warning
 ERROR$	=   4			 ;Error
 FATAL$	=  10			 ;Fatal
 UNCON$	=  20			 ;Unconditional

	ENMLNK=14.		;RT-11 OTSWA TRACEBACK CHAIN POINTER
	DEVHDR=10.		;TOP OF FREE SPACE POINTER
	FREESP=12.		;BOTTOM OF FREE SPACE POINTER
	LNBUF=2.		;RECORD BUFFER POINTER

$CMPLT::MOV	#004437,(R1)+	;JSR R4,@#COMPLT   TO IAREA
	MOV	#COMPLT,(R1)+
	MOV	@R5,(R1)+	;FORTRAN SUBROUTINE ADDRESS
	TSTB	$LOCK		;IS THIS FIRST CALL?
	BLE	2$		;1 MEANS YES
	MOV	$AOTS,R3	;GET ADDRESS OF CURRENT WORK AREA
	MOV	#$WASIZ,R2	;GET ITS SIZE
	MOV	DEVHDR(R3),R1	;GET TOP OF FREE SPACE POINTER
	SUB	R2,R1		;HUNK OUT NEW WORK AREA
	SUB	R2,R1		;COUNT WAS IN WORDS
	MOV	R1,$SYSLB	;SAVE ITS ADDRESS FOR COMPLETION ENTRY
	MOV	R1,-(SP)	;MAKE COPY
	SUB	#$LRECL,@SP	;ALLOCATE NEW LINE BUFFER
	BIC	#1,@SP		;MAKE SURE # OF WORDS
	MOV	@SP,DEVHDR(R3)	;RESET NEW FREE SPACE POINTER
	CMP	FREESP(R3),@SP	;MAKE SURE THIS WILL WORK
	BLO	1$		;TIS O.K.
	TRAP	0		;GIVE THE 'NON-FORTRAN ERROR CALL'
1$:	MOV	(R3)+,(R1)+	;COPY THE WORK AREA
	SOB	R2,1$		;BR IF MORE TO COPY.
	MOV	$SYSLB,R3	;NOW POINT TO IT TO SET NEW LINE BUFFER
	MOV	(SP)+,LNBUF(R3)	;GIVES US NEW LINE BUFFER
	NEGB	$LOCK		;ENABLE OTSWA SWAPPING
2$:	RTS	PC
	.PSECT	SYS$O		;USR CAN NOT SWAP OVER THIS CODE

COMPLT:	INCB	$LOCK		;SIGNAL COMPLETION ROUTINE IN PROGRESS
	BEQ	RUNIT		;MUST BE A SJ MONITOR NON-SYNCHRONIZE
				;COMPLETION ROUTINE DISASTER
BOMB:	TRAP	0		;MIGHT AS WELL CRASH
	MOV	SP,R0		;MAKE SURE R0 ISN'T 0
	EMT	350		;.EXIT

RUNIT:	MOV	R5,-(SP)	;SAVE REGISTERS
	MOV	R3,-(SP)
	MOV	R2,-(SP)
	MOV	#$HRDWR,R3	;PERFORM A PSEUDO HARDWARE TASK SWITCH
	JMP	@SAVH(R3)	;GO TO CORRECT SAVER ROUTINE

SAVED:	MOV	$AOTS,R2	;SWITCH TO NEW WORK AREA
	MOV	$SYSLB,R3
	MOV	R3,$AOTS
	MOV	R2,-(SP)	;SAVE FOR MAINLINE
	MOV	DEVHDR(R2),DEVHDR(R3)	;SAFETY PLAY
	MOV	FREESP(R2),FREESP(R3)	;OBJECT TIME FORMAT ALLOWER
				;EVEN THOUGH THIS IS DONE IT IS
				;IMPERATIVE THAT THE COMPLETION ROUTINE
				;NOT CAUSE MODIFICATION TO THESE
	MOV	ENMLNK(R2),ENMLNK(R3)	;HANDLE TRACEBACK AND RETURN
	MOV	R1,-(SP)
	MOV	SP,R2		;SAVE ITS ADDRESS SO WE CAN PASS IT
	MOV	R0,-(SP)
	MOV	SP,R0		;R0 -> SAVEAREA
	MOV	R2,-(SP)	;BUILD FORTRAN ARGUMENT LIST
	MOV	R0,-(SP)	;BUILD FORTRAN ARG LIST
	MOV	#2,-(SP)	;WITH ONE ARG
	MOV	SP,R5		;R5 -> ARG LIST
	JSR	PC,@(R4)+	;CALL FORTRAN ROUTINE
	ADD	#10.,SP		;POP ARG BLOCK AND R0,R1
	MOV	(SP)+,$AOTS	;RESTORE REAL WORKAREA POINTER
	MOV	#$HRDWR,R3	;UN-TASK SWITCH HARDWARE
	JMP	@RESTH(R3)	;GO TO PROPER ROUTINE

RESTRD:	MOV	(SP)+,R2	;RESTORE REGS
	MOV	(SP)+,R3
	MOV	(SP)+,R5
	MOV	(SP)+,R4
	TSTB	$CRASH		;DID INTERRUPT OVERRUN OCCUR??
	BEQ	1$		;BRANCH IF ALL O.K.
	EMT	355		;.RCTRLO
	MOVB	#<FATAL$>,@#USERRB ;SET UP FATAL ERROR IN USER ERROR BYTE
	MOV	#MSG,R0		;SET UP FOR .PRINT
	EMT	351		;.PRINT
	BR	BOMB		;TERMINATE PROGRAM

1$:	DECB	$LOCK		;FREE UP THIS COPY OF WORK AREA
	RTS	PC		;AND RETURN TO THE MONITOR

	.ENABL	LC

EAESV:	MOV	@#177302,-(SP)	;MUST BE SAVE IN THIS ORDER!!!
	MOV	@#177304,-(SP)
	MOV	@#177310,-(SP)
	BR	SAVED

EAERE:	MOV	(SP)+,@#177310	;MUST BE RESTORED IN THIS ORDER
	MOV	(SP)+,@#177304
	MOV	(SP)+,@#177302
	BR	RESTRD

FPUSV:	STFPS	-(SP)		;THE STACK BETTER BE BIG!!!
	SETD			;HERE IT COMES
	STD	R0,-(SP)
	STD	R1,-(SP)
	STD	R2,-(SP)
	STD	R3,-(SP)
	LDD	R4,R0
	STD	R0,-(SP)
	LDD	R5,R0
	STD	R0,-(SP)
	SETF			;SIMULATE OTI INIT FOR SUBR'S
	BR	SAVED

FPURE:	SETD			;JUST IN CASE DOUBLE MODE
	LDD	(SP)+,R0
	STD	R0,R5
	LDD	(SP)+,R0
	STD	R0,R4
	LDD	(SP)+,R3
	LDD	(SP)+,R2
	LDD	(SP)+,R1
	LDD	(SP)+,R0
	LDFPS	(SP)+
	BR	RESTRD		;WHEW

	.PSECT	SYS$S,D

MSG:	.ASCIZ	/?SYSLIB-F-Interrupt overrun/
	.EVEN
SAVH:	.WORD	SAVED		;BARE 11
	.WORD	EAESV		;EAE
	.WORD	SAVED		;EIS
	.WORD	SAVED		;FIS
	.WORD	FPUSV		;IT'S AN FPU!
RESTH:	.WORD	RESTRD		;BARE 11
	.WORD	EAERE		;EAE
	.WORD	RESTRD		;EIS
	.WORD	RESTRD		;FIS
	.WORD	FPURE		;FPU

.END