Google
 

Trailing-Edge - PDP-10 Archives - BB-4157E-BM - fortran-compiler/inout.bli
There are 12 other files named inout.bli in the archive. Click here to see a list.
!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
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/MD/SJW/DCE/EGM

MODULE INOUT(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN

GLOBAL BIND INOUTV = 6^24 + 0^18 + 52;		! Version Date:	30-Jul-81

%(

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

29	-----	-----	ADD HEADCHK TO CHECK FOR HEADINGS WHEN OUTPUTING
			INFORMATION AT THE END OF PROGRAM AND FOR MACRO LISTNG

30	-----	-----	OUTPUT CRLF FOR ERROR MESSAGES AFTER PHASE 1
			BEFORE THE MESSAGE

31	-----	-----	ROUTINE ERROR - DELETE ALL MESSAGES THAT ARE
			NOT USED ( LEAVING 4 ) 

			CHANGE THEM TO ?FTN FORMAT

			CHANGE ALL CALLS TO NEW NUMBERS

32	-----	-----	SET ERRFLAG IN FATLERR WHEN THE MESSAGE
			IS NOT PUT IN THE QUEUE.  BACKTYPE DOES THIS
			BUT SOMETIMES IT DOESNT GET CALLED, MAKING
			FOR SOME APPARRENT INCONSISTANCY

			CHANGE OUTUUO TO USE SKIP MACRO

33	-----	-----	CHANGE RELOUT TO USE OUUOBIN  FOR MORE MODULARITY
	
34	-----	-----	PUT FTTENEX I/O IN

35	-----	-----	FIXUP SOUTPUT A BIT
36	335	17377	FIX FATLERR SO THAT IT PRESERVES NAME
			AS SET BY LEXICAL., (MD)
37	467	VER5	REQUIRE FTTENX.REQ, (SJW)

***** Begin Version 5A *****

40	573	-----	REQUIRE DBUGIT.REQ, (SJW)

***** Begin Version 5B *****

41	657	11554	FIX /OPT/DEB FOR -20 TO GET LISTING FILE, (DCE)
42	723	-----	ADD /NOWARN: SELECTIVITY IN FATLER HANDLING, (DCE)
43	741	-----	ADD E145 WARNING MSG HANDLING, (DCE)
44	752	13736	Discard .REL file if fatal errors., (EGM)
45	766	-----	ADD E147 WARNING MSG HANDLING, (DCE)

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

46	1013	-----	If end-of-line is unexpected, get error msg right.

47	1043	EGM	19-Jan-81	20-15466
	Add mnuemonic CAO (Consec. arit ops illegal) for NOWARN selectivity

50	1061	DCE	9-Apr-81	-----
	Add PSR (Pound Sign in Random access illegal) for NOWARN selectivity

51	1066	EGM	12-May-81	Q10-05202
	Handle LINE:xxxx in error messages with just one special character (?E).
	And do not print the error line number if less than 1.

52	1115	EGM	30-Jul-81	--------
	Rewrite /NOWARN selectivity test for simplification of error addition.

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

)%


EXTERNAL ENTRY;
REQUIRE  FTTENX.REQ;
REQUIRE  DBUGIT.REQ;
REQUIRE  LEXAID.BLI;
REQUIRE IOFLG.BLI;

BIND	BMODE=	#14,AMODE=	0,
	BINARYOUTP=	1^18+1^BMODE,
	ASCIIOUTP=	1^18+1^AMODE,
	ASCIIINP=	1^19+1^AMODE;
EXTERNAL	FLGWRD;
MACRO	ADVANCEN=	30,6$,
	BACKSPACEN=	24,6$,
	FULL=		0,36$;
EXTERNAL JOBREL,JOBSA,JOBFF;
EXTERNAL CCLSW,INDEX;
EXTERNAL	JOBFFSAVE;

MACRO SKIP(OP)=
BEGIN
	VREG_1;
	OP;
	VREG_0;
	.VREG
END$,
	NOSKIP(OP)=
BEGIN
	VREG_0;
	OP;
	VREG_1;
	.VREG
END$;
MACHOP  IDIVI = #231, MOVEI = #201, ROTC = #245;

EXTERNAL  ERRLINK,SAVSPACE;
FORWARD STRNGOUT,LINEOUT,CHAROUT,FATLERR,WARNERR,CLOSUP,SOUTPUT;
EXTERNAL NAME,CORMAN,MSGNOTYPD,ERRMSG,NUMFATL,NUMWARN,WARNOPT;
EXTERNAL NOCR,PAGE;
EXTERNAL BASENO,HEADPTR,BACKTYPE;
FORWARD BLDMSG;


%(-----------------------------------------------------------------------------------------------------------------

ROUTINE ERROR(N,CHNL)=		TYPE ERROR NUMBER N USING CHNL TO SPECIFY WHICH FIELD,
			 	DEVICE, FILE, OR PROJECT PROGRAMMER NUMBER TO TYPE.
				RETURNS TO JOB STARTING ADDRESS (.JOBSA) SO THAT
				ANOTHER COMMAND STRING MAY BE TYPED. CALLED BY I/O ROUTINES TO
				TYPE FATAL I/O ERRORS ONLY.

GLOBAL ROUTINE GETBUF=		RETURNS NEXT CHARACTER FROM SOURCE IN VREG AND AS ITS VALUE,
				IF AND END OF FILE OCCURS THEN IT RETURNS EOF AS ITS VALUE
				IF ANY OTHER ERROR CONDITION OCCURS THE ERROR ROUTINE IS CALLED
				TO TYPE OUT THE APPROPRIATE ERROR MESSAGE.

GLOBAL ROUTINE LSTOUT=		OUTPUTS THE CONTENTS OF REGISTER C AS THE NEXT LISTING CHARACTER.
				THE ERROR ROUTINE IS CALLED IF AN ERROR OCCURS.

GLOBAL ROUTINE RELOUT=		OUTPUTS THE CONTENTS OF REGISTER C AS THE NEXT WORD OF THE
				OBJECT FILE. THE ERROR ROUTINE IS CALLED IF AN ERROR OCCURS.

-----------------------------------------------------------------------------------------------------------------)%


	MACRO  NXT(C) =  REPLACEI ( HEADPTR, C ) $;

	GLOBAL ROUTINE 
DIGITS(NUM)=
	BEGIN
		LOCAL N;
		GLOBAL NUMODIG;	!USED TO COUNT UP THE DIGITS IF THE CALLER ZEROS IT
		N_.NUM MOD @BASENO;
		IF (NUM_.NUM/@BASENO) NEQ 0 THEN DIGITS(@NUM);
		NUMODIG _ .NUMODIG + 1;	!COUNT UP THE NUMBER OF DIGITS
		NXT ( .N + "0" );
		.VREG
	END;
	GLOBAL ROUTINE 
STRNG6 ( ST ) =
	BEGIN
		REGISTER T[2];
		T[0] _ .ST;
		VREG_0;	!COUNT THE LETTERS
		DO (MOVEI(T[1],0);ROTC(T[0],6);MOVEI(T[1]," ",T[1]);NXT( .T[1] ); VREG_.VREG+1) UNTIL .T[0] EQL 0;
		.VREG
	END;


	GLOBAL ROUTINE 
STRNG7 ( ST ) =
	BEGIN
		REGISTER T[2];
		T[0] _ .ST;
		DO (MOVEI(T[1],0);ROTC(T[0],7);NXT( .T[1] )) UNTIL .T[0] EQL 0;
		.VREG
	END;
	GLOBAL ROUTINE
HEADCHK  =
BEGIN	% WHEN CALLED WILL CHECK TO SEE IF THE END OF PAGE HAS
	  BEEN REACHED AND IF SO PUT OUT A HEADING %
	EXTERNAL  PAGELINE,HEADING;
	
	IF NOT .FLGREG<LISTING>  THEN  RETURN;
	IF .PAGELINE  LEQ  0
	THEN	HEADING();
	PAGELINE _ .PAGELINE -1;

END;	%HEADCHK%


	GLOBAL ROUTINE 
HEADING  =

BEGIN
	% PUT THE ROUTINE NAME AND PAGE NUMBER IN THE HEADING AND PRINT IT %
	EXTERNAL  FNDFF,HEADSTR,HEADPTR,BASENO,PAGEPTR,PROGNAME;

	% PUT BLANKS IN WHERE THE NAME WILL GO %
	HEADSTR[0] _ '     ';
	HEADSTR[1]<29,7> _ " ";
	HEADPTR _ HEADSTR<36,7>;
	STRNG6( .PROGNAME );
	HEADPTR _ .PAGEPTR;
	IF .FNDFF  EQL  0
	THEN 	CHAROUT ( FF )	! OUTPUT FF IF USER DIDN'T PUT ONE IN
	ELSE	( FNDFF _ 0; PAGE<LEFT> _ .PAGE<LEFT> + 1;  PAGE<RIGHT> _ 0);	! RESET PAGE

	BASENO _ 10;
	DIGITS ( .PAGE<LEFT> );
	IF .PAGE<RIGHT>  NEQ  0
	THEN	( NXT("-");  DIGITS( .PAGE<RIGHT> ) );
	NXT("?0");

	PAGE _ .PAGE + 1;
	PAGELINE _ LINESPERPAGE - 3;

	STRNGOUT ( HEADSTR<ADRS> );	STRNGOUT( PLIT'?M?J?M?J?M?J?0');

END;	% HEADING %
	GLOBAL ROUTINE  
FATLERR (ENT2,ENT1,LINE,ERRNUM ) =

	% THIS ROUTINE WILL QUEUE OR PRINT THE ERROR MESSAGE DEPENDING ON THE
	  CURRENT LINE NUMBER AND THE ONE ASSOCIATED WITH THE MESSAGE.  IF THE TWO
	  NUMBERS ARE NOT EQUAL THEN THE MESSAGE IS PRINTED BECAUSE IT RELATES
	  TO SOME PREVIOUSLY UNPRINTED LINE.  IF THEY ARE EQUAL THEN IT  RELATES
	  TO THE CURRENT AND UNPRINTED LINE AND SO WILL BE QUEUED UNTIL THE LINE
	  IS PRINTED.  %
	
	% PARAMETERS:
		ENT1 - FIRST MESSAGE PARAMETER( 7BIT,6BIT , OR NUMBER)
		ENT2 - SECOND MESSAGE PARAMETER
			THE PARAMETER INDICATOR IN THE MESSAGE SKELETON
			SPECIFIES THE TYPE OF PARAMETER.
		LINE - LINE NUMBER ASSOCIATED WITH THE MESSAGE
		ERRNUM - ERROR NUMBER
		WARNFATL - IF 1 INDICATES A FATAL ERROR, 0 A WARNING
	
		NOTE THAT ONLY THE LAST THREE PARAMETERS ARE REQUIRED
	%

BEGIN

	REGISTER T1,
%[1115]%		T2,		!ANOTHER SCRATCH REGISTER
		 ENODE;
	EXTERNAL SEGINCORE;
	OWN  ERRNODE [4];	! TEMPORARY ERRNODE AREA

	EXTERNAL  WARMSG,WOPTMSG;

%[1115]%	EXTERNAL
%[1115]%		NWKTB,		!NOWARN KEYWORD TABLE (SIXBIT)
%[1115]%		NWKTBC,		!NOWARN KEYWORD COUNT
%[1115]%		NWBITS;		!NOWARN OPTIONS SELECTED
%[1115]%	LOCAL	ERRABREV;	!SIXBIT ERROR MNUEMONIC


	%DETERMINE IF WARNING OR FATAL ERROR %
	IF .ERRNUM<RIGHT>  LSS  WARMSG<0,0>
	THEN
	BEGIN	%WARNING%
		NUMWARN _ .NUMWARN + 1;
		IF .ERRNUM<RIGHT>  GEQ  WOPTMSG<0,0>
		THEN	WARNOPT _ -1;	!WARNING MAY AFFECT OPTIMIZED CODE
%[1115]%		!If user specified /NOWARN, may need to
%[1115]%		! suppress printing this message.
%[1115]%		IF .FLGREG<NOWARNING> THEN
%[1115]%		BEGIN
%[1115]%			!Grab first 3 characters of the
%[1115]%			! error message (mnuemonic) and
%[1115]%			! convert them to sixbit.
%[1115]%			T1 _ (ERRMSG[.ERRNUM<RIGHT>]-1)<1,7>;
%[1115]%			T2 _ (ERRABREV-1)<0,6>;
%[1115]%			ERRABREV _ 0;
%[1115]%			REPLACEI(T2,SCANI(T1)-" ");
%[1115]%			REPLACEI(T2,SCANI(T1)-" ");
%[1115]%			REPLACEI(T2,SCANI(T1)-" ");
%[1115]%
%[1115]%			!Step through the /NOWARN keyword table
%[1115]%			! starting with keyword 3 (offset 2).
%[1115]%			!If the mnuemonic for this warning matchs
%[1115]%			! a keyword, and that keyword was selected
%[1115]%			! via a /NOWARN switch, suppress the warning.
%[1115]%			!Also decrement the warn count, since
%[1115]%			! the user does not care about this situation.
%[1115]%			INCR T1 FROM 2 TO (NWKTBC-1)<0,0> DO
%[1115]%				IF .NWKTB[.T1] EQL .ERRABREV THEN
%[1115]%				IF .(NWBITS + .T1/36)<(.T1 MOD 36),1> NEQ 0
%[1115]%				THEN
%[1115]%				BEGIN
%[1115]%					NUMWARN _ .NUMWARN-1;
%[1115]%					RETURN -1
%[1115]%				END
%[1115]%		END
	END
	ELSE
	BEGIN	%FATAL%
		NUMFATL _ .NUMFATL + 1;
		FLGREG<ERRSW> _ -1
	END;

	IF .LINE EQL .LINELINE  AND .SEGINCORE EQL  1 % ALWAYS PRINT MESSAGES FOR LATER PASSES  %
	THEN	% ASSOCIATED WITH CURRENT LINE SO QUEUE IT %
	BEGIN
		LOCAL SAVNAME;	!TO SAVE NAME AS SET BY LEXICAL
		SAVNAME_.NAME;
		MSGNOTYPD _ 1;	! SET MESSAGE TO BE TYPED FLAG
		NAME<LEFT> _ ENODSIZ;
		ENODE _ CORMAN();	! GET A BLOCK OF FREE STORAGE FOR THE NODE
		NAME_.SAVNAME;	!RESTORE NAME
		% ERRLINK<RIGHT> CONTAINS A POINTER TO THE BEGINNING 
		  OF THE LIST AND .ERRLINK<LEFT> A POINTER TO THE END OF THE LIST %
		IF .ERRLINK<RIGHT>  EQL  0
		THEN	( ERRLINK<LEFT> _ .ENODE;
			  ERRLINK<RIGHT> _ .ENODE
			)
		ELSE	( ENODLINK(ERRLINK<LEFT>)  _ .ENODE;
			  ERRLINK<LEFT> _ .ENODE
			)
	END
	ELSE	% THE MESSAGE WILL BE PRINTED NOW SO JUST BUILD THE BLOCK IN TEMPORARY STORAGE%
		ENODE _ ERRNODE  ;

	%BUILD THE NODE  %
	
	EMSGNUM(ENODE) _ .ERRNUM;
	ERRTYPD(ENODE) _ 0;
	ERRLINE (ENODE) _ .LINE;
	ERRENT1(ENODE)  _ .ENT1;
	ERRENT2(ENODE)  _ .ENT2;


	IF .LINE NEQ .LINELINE  OR .SEGINCORE  NEQ  1
	THEN	% PRINT MESSAGE NOW , IT RELATES TO PREVIOUS LINE %
	BEGIN
		% BUILD THE MESSAGE  %
		ENODE _  BLDMSG (ERRNODE);


		% PRINT MESSAGE ON LISTING  %
		IF .FLGREG<LISTING>
		THEN
		BEGIN
			%PUT OUT CRLF IF AFTER PHASE1%
			IF .SEGINCORE  NEQ  1
			THEN	(  STRNGOUT(PLIT'?M?J');
				   PAGELINE _ .PAGELINE - 1
				);
![657] NO HEADING IF WE ARE HERE TO PRINT OPTIMIZE SWITCH IGNORED
%[657]%			IF .PAGELINE LEQ 0 AND .LINE NEQ -2
			THEN HEADING();
			PAGELINE _ .PAGELINE -1;
			STRNGOUT(.ENODE)
		END;

		IF NOT .FLGREG<TTYDEV> AND NOT .FLGREG<NOERRORS>
		THEN	% THE MESSAGE CAN BE OUTPUT TO TTY AS WELL AS THE LISTING %
		BEGIN
			IF  NOT   .ERRFLAG  AND  .SEGINCORE EQL  1
![657] BE CAREFUL IF NO LINES HAVE BEEN SCANNED YET!
%[657]%				AND .LINE NEQ -2
			THEN	(%THIS IS THE FIRST ERROR IN THIS
				  STATEMENT SO TYPE ALL LINES TO THIS POINT%
				 BACKTYPE(LINESONLY)
				);
			 % OUTPUT THE MESSAGE TO TTY  %
			 OUTTYX (ENODE)
		END;

	%NOTE THAT A MESSAGE IS GOING OUT THAT WILL
	  NOT SHOW UP IN THE QUEUE %
	ERRFLAG _ -1;

	END;
	RETURN -1
END;  % ROUTINE FATLERR %



	GLOBAL ROUTINE 
WARNERR  ( ENT2,ENT1,LINE,ERRNUM )   =
	% PROCESS WARNING ERROR MESSAGE REQUESTS %
BEGIN
	FATLERR (.ENT2,.ENT1,.LINE,.ERRNUM )

END;


EXTERNAL  LEXLINE;


	GLOBAL ROUTINE
FATLEX  ( ENT2, ENT1, ERRNUM )  =
BEGIN
	% FOR ERRORS ASSOCIATED WITH LEXEMES  %
	RETURN  FATLERR( .ENT2,.ENT1,.LEXLINE,.ERRNUM )
END;


	GLOBAL ROUTINE
WARNLEX ( ENT2,ENT1,ERRNUM )   =
BEGIN
	% FOR WARNING ERRORS ASSOCIATIED WITH LEXEMES %
	RETURN  FATLERR  ( .ENT2, .ENT1, .LEXLINE, .ERRNUM )
END;




	GLOBAL ROUTINE 
BLDMSG(ENODE)=
BEGIN	!BUILDS MSG POINTED TO BY EPTR AND RETURNS A POINTER TO IT

	EXTERNAL  WARMSG;
	REGISTER T[3];
	MACRO  T1=T[0]$,  T2=T[1]$,  T3=T[2]$,   C=T[2]$;
	LABEL PARAM;
	LOCAL N,EPTR;
	OWN TTYMSG[20];
	 BIND TTYPTR= TTYMSG;



	EPTR _ ERRMSG[C_.EMSGNUM(ENODE)]<36,7>;	! FORM THE BYTE POINTER
	TTYPTR _ (TTYMSG+1)<8,7>;
	N _ 0;
	IF .C  LSS  WARMSG<0,0>
	THEN	TTYMSG[1] _ '%FTN'
	ELSE	TTYMSG[1] _ '??FTN';	!FATAL

	WHILE 1 DO
	PARAM:	IF (C_SCANI(EPTR)) LSS " " THEN CASE .C OF SET
	%0:%	EXITLOOP;	!UNDEFINED CHARACTERS IN LAST WORD OF PLIT ARE NULLS
	%"?A":%	BEGIN	!INSERT THE RIGHTMOST FIVE DECIMAL DIGITS SUPPLIED BY THE NEXT PARAMETER
			T1_.(.ENODE<RIGHT>)[N_.N+1];T2_T3_0;
			DECR J FROM 4 TO 0 DO
			BEGIN
				MACHOP IDIVI=#231,ADDI=#271,LSHC=#246;
				IDIVI(T1,10);	!REMAINDER IN T2
				ADDI(T2,"0");	!ASCII-DIGIT_REMAINDER+"0"
				LSHC(T2,-7);	!T3<29,7>_ASCII-DIGIT
			END;
			T1_T3<36,7>;
			DECR J FROM 4 TO 0 DO COPYII (T1,TTYPTR ) ;
		END;
	%"?B":%	BEGIN	!INSERT THE ASCII STRING POINTED TO BY THE NEXT PARAMETER
			% CHECK TO SEE IF ITS A CHARACTER OR BYTE POINTER%
			IF (T2 _ ( T1 _ .(.ENODE<RIGHT>)[N_.N+1]) AND NOT #377) EQL  0
			THEN
			BEGIN	% ITS A CHARACTER %
%[1013]%			BIND  EOSLEX = 5;
				EXTERNAL  LEXNAME;
				IF  .T1  LSS #200
				THEN
				BEGIN
					REPLACEI(TTYPTR,.T1);	! ITS ONLY A CHARACTER
					LEAVE PARAM
				END
				ELSE	T1 _ .LEXNAME[EOSLEX];
			END;
			 T1 _ (.T1)<36,7>;
			  UNTIL(C_SCANI(T1)) EQL 0 DO  REPLACEI(TTYPTR,.C)
			END;
	%"?C":%	BEGIN	!INSERT THE SIXBIT NAME POINTED TO BY THE NEXT PARAMETER
			T1_(.(.ENODE<RIGHT>)[N_.N+1])<36,6>;
			DECR X FROM 5 TO 0 DO (C _ SCANI(T1)+" "; REPLACEI(TTYPTR,.C))
		END;
	%"?D":% BEGIN	! INSERT THE SIXBIT NAME IN THE NEXT PARAMETER
			T1 _ (.ENODE<RIGHT>)[N_.N+1]<36,6>;
			DECR X FROM 5 TO 0 DO (C _ SCANI(T1)+" "; REPLACEI(TTYPTR,.C))
		END;
%[1066]% %"?E"%	BEGIN	! INSERT "Line:nnnnn" if required
%[1066]%		IF (T2_.(.ENODE<RIGHT>)[N_.N+1]) GTR 0 THEN
%[1066]%		BEGIN
%[1066]%			T1 _ (PLIT' Line:')<36,7>;
%[1066]%			UNTIL (C_SCANI(T1)) EQL 0 DO
%[1066]%				REPLACEI(TTYPTR,.C);
%[1066]%			T1_.T2;T2_T3_0;
%[1066]%			DECR J FROM 4 TO 0 DO
%[1066]%			BEGIN
%[1066]%				MACHOP IDIVI=#231,ADDI=#271,LSHC=#246;
%[1066]%				IDIVI(T1,10);	!REMAINDER IN T2
%[1066]%				ADDI(T2,"0");	!MAKE IT ASCII
%[1066]%				LSHC(T2,-7)	!T3<29,7>_ASCII-DIGIT
%[1066]%			END;
%[1066]%			T1_T3<36,7>;
%[1066]%			DECR J FROM 4 TO 0 DO COPYII (T1,TTYPTR )
%[1066]%		END;
		END
		TES ELSE  REPLACEI(TTYPTR,.C);
	   REPLACEI(TTYPTR,CR);
	 REPLACEI(TTYPTR,LF);
	REPLACEI(TTYPTR,0);

	RETURN  (TTYMSG+1)<ADRS>
END; !OF BLDMSG

GLOBAL ROUTINE ERROR (N,CHNL) =
BEGIN
IF NOT FTTENEX THEN
BEGIN
	REGISTER T1=1,T2=2,C=3;
	BIND	DEVMODE=PLIT(PLIT('BINARY OUTPUT'),PLIT('ASCII OUTPUT'),PLIT('ASCII INPUT'))-1;
	BIND	FIELD=PLIT(PLIT('OBJECT'),PLIT('LISTING'),PLIT('SOURCE'))-1;
%ERROR% BIND	ERRORS=PLIT(
!%0%		PLIT('I/O#0 1 FILE 2 COULD NOT BE FOUND'),
!%1%		PLIT('I/O#1 3 UFD DOES NOT EXITS'),
!%2%		PLIT('I/O#2 PROTECTION FAILUTE OR DIRECTORY FULL ON 1 DEVICE 4'),
!%3%		PLIT('I/O#3 1 FILE 2 IS BEING MODIFIED'),
!%4%		PLIT('I/O#4 ENTER FOLLOWS LOOKUP OF 1 FILE 2'),
!%5%		PLIT('I/O#5 LOOKUP FOLLOWS ENTER OF 1 FILE 2'),
!%6%		PLIT('I/O#6 DEVICE ERROR, DATA ERROR, OR DATA INCONSISTENCY IN 1 UFD'),
!%7%		PLIT('I/O#7 DSK ERROR NUMBER SEVEN'),
!%8%		PLIT('I/O#8 DSK ERROR NUMBER TEN'),	%OCTAL DISK ERRORS %
!%9%		PLIT('I/O#9 DSK ERROR NUMBER ELEVEN'),
!%10%		PLIT('I/O#10 DSK ERROR NUMBER TWELVE'),
!%11%		PLIT('I/O#11 DSK ERROR NUMBER THIRTEEN'),
!%12%		PLIT('I/O#12 1 FILE STRUCTURE 4 HAS NO ROOM OR HAS EXCEEDED ITS QUOTA'),
!%13%		PLIT('I/O#13 1 DEVICE 4 IS WRITE LOCKED'),
!%14%		PLIT('I/O#14 NOT ENOUGH TABLE SPACE IN MONITOR FREE CORE FOR 1 DEVICE 4'),
!%15%		PLIT('I/O#15 1 FILE 2 ONLY PARTIALLY ALLOCATED'),
!%16%		PLIT('I/O#16 1 FILE 2 BLOCK NOT FREE ON ALLOCATED POSITION'),
!%17%		PLIT('I/O#17 1 DEVICE 4 NOT AVAILABLE'),
%0%		PLIT('?FTNDWL 1 DEVICE 4 WRITE LOCKED'),
%1%		PLIT('?FTNHDE HARDWARE DEVICE ERROR ON 1 DEVICE 4'),
%2%		PLIT('?FTNCPE CHECKSUM OR PARITY ERROR IN 1 FILE 2'),
%3%		PLIT('?FTNQEX BLOCK TOO LARGE OR QUOTA EXCEEDED FOR 1 FILE 2'),
!%22%		PLIT('I/O#22 NOT ENOUGH ROOM IN CORE FOR COMMAND STRING'),
!%23%		PLIT('I/O#23 WILD CHARACTERS IN OUTPUT SPECIFICATION ARE NOT SUPPORTED'),
!%24%		PLIT('I/O#24 SUBFILE OUTPUT IS NOT SUPPORTED'),
!%25%		PLIT('I/O#25 1 DEVICE 4 CANNOT DO 5'),
!%26%		PLIT('I/O#26 NON-EXISTANT INPUT FILE'),
!%27%		PLIT('I/O#27 WILD CARD FEATURE FOR DECTAPE NOT SUPPORTED'),
!%28%		PLIT('I/O#28 ONLY TWO OUTPUT FILES ARE SUPPORTED'),
!%29%		PLIT('I/O#29 1 DEVICE 4 ALREADY IN USE OR DOESN''T EXIST'),
!%30%		PLIT('I/O#30 WILD EXTENSIONS IN OUTPUT SPECIFICATION ARE NOT SUPPORTED'),
!%31%		PLIT('COR#31 NOT ENOUGH CORE FOR EXPANSION, COMPILATION TERMINATED')
		);
MACHOP	CLOSE=#070,JRST=#254;
%(-----------------------------------------------------------------------------------------------------------------
	COPY THE "N"TH PLIT OF THE ERRORS PLIT INTO LINE BUFFER T, TRANSLATING
	THE DIGITS 1-5 INTO THE APPROPRIATE INFORMATION.  USE THE CHANNEL
	NUMBER TO INDICATE IN WHICH FIELD oF THE COMMAND STRING THE
	ERROR OCCURRED AND TO PICK UP THE APPROPRIATE DEVICE, FILENAME,
	ETC. FOR THIS CHANNEL.
-----------------------------------------------------------------------------------------------------------------)%
LOCAL	P1,P2,T[20]% 100 CHARACTER LINE %;
P1_(@(ERRORS+.N)-1)<1,7>;P2_T[0]<36,7>;
INCR I FROM 1 TO @P1*5 DO	!P1 POINTS INITIALLY TO THE PLIT WORD COUNT
		SELECT C_SCANI(P1) OF NSET
0:		EXITLOOP;	!UNDEFINED CHARACTERS IN LAST WORD OF PLIT ARE SET TO ZERO
"#":		(DO REPLACEI(P2,.C) UNTIL ( C_SCANI(P1)) EQL " ";REPLACEI(P2," "));
"1":		BEGIN
%SOURCE,%
%LISTING OR%		T1_(@(FIELD+.CHNL))<36,7>;
%OBJECT%		UNTIL (C_SCANI (T1)) EQL 0 DO REPLACEI(P2,.C)
		END;
"2":		BEGIN
			T1_(FILENAME(.CHNL))<36,6>;T2_6;
%FILENAME.EXTENSION%	UNTIL (T2_.T2-1) LSS 0 DO IF (C_SCANI(T1)) NEQ 0 THEN REPLACEI(P2,.C+" ");
			REPLACEI(P2,".");T2_3;
			UNTIL (T2_.T2-1) LSS 0 DO IF (C_SCANI(T1)) NEQ 0 THEN REPLACEI(P2,.C+" ")
		END;
"3":		BEGIN
			T1_(DIRECTORY(.CHNL))<36,3>;
			REPLACEI(P2,"[");T2_6;
			UNTIL (T2_.T2-1) LSS 0
%[PROJECT,PROGRAMMER]%	DO (REPLACEI(P2,SCANI(T1)+"0"));
			REPLACEI(P2,",");T2_6;
			UNTIL (T2_.T2-1) LSS 0
			DO (REPLACEI(P2,SCANI(T1)+"0"));
			REPLACEI(P2,"]")
		END;
"4":		BEGIN
			T1_(DEVICE(.CHNL))<36,6>;T2_6;
			UNTIL (T2_.T2-1) LSS 0
%DEVICE%		DO (IF (C_SCANI(T1)) EQL 0 THEN EXITLOOP ELSE REPLACEI(P2,.C+" "));
			REPLACEI(P2,":")
		END;
"5":		BEGIN
%BINARY OUTPUT,%
%ASCII OUTPUT,OR%	T1_(@(DEVMODE+.CHNL))<36,7>;
%ASCII INPUT%		UNTIL (C_SCANI(T1)) EQL 0 DO REPLACEI(P2,.C)
		END;
OTHERWISE:	REPLACEI(P2,.C)
		TESN;
		REPLACEI(P2,0);
		T1_T[0];
		OUTTYX(T1);
%[752]%		CLOSE(BIN,40);	! DISCARD .REL FILE
%[752]%		CLOSE(LST,0);CLOSE(SRC,0);
		JRST(0,.JOBSA<0,18>);
		.VREG
END
END;


	MACRO IOIMPM=17,1$,IODERR=16,1$,IODTER=15,1$,IOBKTL=14,1$,IODEND=13,1$;
FORWARD OUTSTAT;

GLOBAL ROUTINE OUUOLST  =
BEGIN
% THE INDIRECT PARAMETER PASSING SIMPLIFIES THE CALL IN ITS LOOP %
	IF NOT FTTENEX
	THEN
	BEGIN
		REGISTER T1;
		MACHOP OUTUUO = #057,GETSTS = #062;

		IF SKIP(OUTUUO ( LST,0))
		THEN
		BEGIN
			GETSTS ( LST,T1 );
			OUTSTAT(LST,.T1)
		END
	END
	ELSE
	BEGIN	
		SOUTPUT( LST )
	END

END;  %OUUOLST%


GLOBAL ROUTINE  OUTSTAT(DEV,STAT)   =
BEGIN
IF NOT FTTENEX THEN
BEGIN
% THIS ROUTINE WILL  CHECK
  THE STATUS.  IF EVERYTHING IS ALRIGHT IT WILL RETURN  %
	% THERE ARE ERRORS SO CHECK THE STATUS %
			BEGIN
				IF .STAT<IOBKTL> THEN ERROR(3,.DEV)
					ELSE
					IF .STAT<IODTER> THEN ERROR(2,.DEV)
						ELSE
						IF .STAT<IODERR> THEN ERROR(1,.DEV)
							ELSE
							IF .STAT<IOIMPM> THEN ERROR(0,.DEV);
			END

END
END ;  % OUTSTAT  %


GLOBAL ROUTINE  LINEOUT ( BEGPTR, ENDPTR )  =
BEGIN
% THIS ROUTINE WILL TRANSFER THE ASCII STRING FROM
  BEGPTR + 1  TO ENDPTR TO THE LST OUTPUT DEVICE   %

MACRO  P = 30,6  $;

DECR I FROM (.ENDPTR<RIGHT> - .BEGPTR<RIGHT> ) * 5
		+ ((.BEGPTR<P> - .ENDPTR<P>) / 7 ) -1
	TO 0  BY  1
DO  BEGIN
	% CHECK TO SEE IF THE BUFFER IS FULL %
	IF (BUFCNT(LST) _ .BUFCNT(LST) -1 ) LEQ  0  THEN  OUUOLST()  ;
	% COPY THE NEXT CHARACTER %
	COPYII ( BEGPTR, BUFPNT(LST) );
END;
		% DEBUGGING CODE %
		IF DBUGIT
		THEN
		BEGIN	% OUTPUT THE BUFFER IMMEDIATELY SO
				  YOU CAN SEE EXACTLY WHAT IS HAPPENTING
				  ON THE TTY  %
			REGISTER T1;
			IF ( T1 _ .BUGOUT AND 1 ) NEQ 0
			THEN
			BEGIN
				OUUOLST();
				BUFCNT(LST)_.BUFCNT(LST)+1
			END;
			% NOTE IF A LINE IS TERMINATED BY FF THIS WILL CAUSE
			  AN EXTRA FF IN LISTING %
		END;


END; % LINEOUT %

GLOBAL ROUTINE  CHAROUT (CHAR)  =
BEGIN
% OUTPUT ONE CHARACTER TO DEVICE LST  %
IF (BUFCNT(LST) _ .BUFCNT(LST) -1 )  LEQ  0  THEN  OUUOLST();
REPLACEI ( BUFPNT(LST),.CHAR)
;

		% DEBUGGING CODE %
		IF DBUGIT
		THEN
		BEGIN	% OUTPUT THE BUFFER IMMEDIATELY SO
				  YOU CAN SEE EXACTLY WHAT IS HAPPENTING
				  ON THE TTY  %
			REGISTER T1;
			IF ( T1 _ .BUGOUT AND 1 ) NEQ 0
			THEN
			BEGIN
				OUUOLST();
				BUFCNT(LST)_.BUFCNT(LST)+1
			END;
			% NOTE IF A LINE IS TERMINATED BY FF THIS WILL CAUSE
			  AN EXTRA FF IN LISTING %
		END;


END;



GLOBAL ROUTINE STRNGOUT (PTR)    =
BEGIN
% THIS ROUTINE WILL OUTPUT A STRING OF CHARACTERS OF THE BYTE
  SIZE SPECIFIED IN PTR<P> UNTIL A 0 CHARACTER IS ENCOUNTERED   %

	MACRO  S = 24,6  $;
	REGISTER T1;

	IF .PTR<S>  NEQ  7
	THEN	PTR<LEFT> _ #440700;	! FORM BYTE POINTER

	UNTIL ( T1 _ SCANI(PTR) )  EQL  0
	DO
	BEGIN
		IF (BUFCNT(LST) _ .BUFCNT(LST)-1)  LEQ 0
		THEN  OUUOLST ();
		REPLACEI (BUFPNT(LST),.T1)
	END;

		% DEBUGGING CODE %
		IF DBUGIT
		THEN
		BEGIN	% OUTPUT THE BUFFER IMMEDIATELY SO
				  YOU CAN SEE EXACTLY WHAT IS HAPPENTING
				  ON THE TTY  %
			REGISTER T1;
			IF ( T1 _ .BUGOUT AND 1 ) NEQ 0
			THEN
			BEGIN
				OUUOLST();
				BUFCNT(LST)_.BUFCNT(LST)+1
			END;
			% NOTE IF A LINE IS TERMINATED BY FF THIS WILL CAUSE
			  AN EXTRA FF IN LISTING %
		END;


END;  % STRNGOUT %

GLOBAL	ROUTINE	LSTOUT =
BEGIN
	REGISTER C=3;
	RETURN  CHAROUT(.C)
END;


GLOBAL ROUTINE OUUOBIN  =
BEGIN
% THE INDIRECT PARAMETER PASSING SIMPLIFIES THE CALL IN ITS LOOP %
	IF NOT FTTENEX
	THEN
	BEGIN
		REGISTER T1;
		MACHOP OUTUUO = #057,GETSTS = #062;
		
		IF SKIP(OUTUUO ( BIN,0))
		THEN
		BEGIN
			GETSTS ( BIN,T1 );
			OUTSTAT(BIN,.T1)
		END
	END
	ELSE
	BEGIN
		SOUTPUT( BIN )
	END

END;


GLOBAL	ROUTINE	RELOUT =
BEGIN
	REGISTER C=3;
	MACHOP	OUTUUO=#057;
	IF (BUFCNT(BIN)_.BUFCNT(BIN)-1) LEQ 0 THEN OUUOBIN();
	 REPLACEI(BUFPNT(BIN),.C);
	.VREG
END;
	GLOBAL ROUTINE  
SOUTPUT ( DEV ) =
BEGIN

IF  FTTENEX  
THEN
BEGIN

	LOCAL RSV[3];
	REGISTER R1=1,R2=2,R3=3;
	MACHOP  JSYS = #104;
	MACRO	SOUT = JSYS(0,#53) $;

	RSV[0] _ .R1; RSV[1] _ .R2; RSV[2] _ .R3;	!SAVE REGS

	R1 _ .XDEVJFN( .DEV );	!JFN

	IF .DEV EQL BIN
	THEN
	BEGIN	%SET UP FOR BINARY%
		R3 _ - ( .BUFPNT(BIN)<RIGHT>  - .BUFFERS(BIN)<RIGHT> + 1 );	!SIZE
		BUFPNT(BIN) _ R2 _ (.BUFFERS(BIN)<RIGHT>)<36,36>;	!INITIAL POINTER
		BUFCNT(BIN) _ XSOUTSIZ;	!RESTORE COUNT
	END
	ELSE
	BEGIN	%SET UP FOR LISTING%
		%NULL FILL%
		(.BUFPNT(LST)<RIGHT>)<0,.BUFPNT(LST)<30,6>> _ 0;
		R3 _ - ( .BUFPNT(LST)<RIGHT>  - .BUFFERS(LST)<RIGHT> + 1 ) * 5 ;	!SIZE
		BUFPNT(LST) _ R2 _ (.BUFFERS(LST)<RIGHT>)<36,7>;	!INITIAL POINTER
		BUFCNT(LST) _ XSOUTSIZ * 5 ;	!RESTORE COUNT
	END;
	SOUT;
	R1_.RSV[0];R2_.RSV[1];R3_.RSV[2];
END
END;

	GLOBAL ROUTINE 
CLOSUP  =
BEGIN

IF FTTENEX 
THEN
BEGIN

	REGISTER R1 =1;
	MACHOP  JSYS = #104, JFCL =#255 ;
	MACRO  CLOSF = JSYS(0,#22)  $;
	LOCAL RSAV;

	RSAV _ .R1;

	IF .FLGREG<LISTING>
	THEN
	BEGIN
		SOUTPUT( LST );
		R1 _ .XDEVJFN(LST);
		CLOSF;
		JFCL (0,0);
	END;

	IF .FLGREG<OBJECT>
	THEN
	BEGIN
%[752]%		BIND CLOSEABORT = #4000000000;	! CZ%ABT CLOSE ABORT
%[752]%		IF .FLGREG<ERRSW> EQL 0		! FATAL ERRORS?
%[752]%		THEN
%[752]%		BEGIN				! NONE
%[752]%			SOUTPUT (BIN);
%[752]%			R1 _ 0			! NO CLOSF BITS
%[752]%		END
%[752]%		ELSE				! ERRORS
%[752]%			R1 _ CLOSEABORT;	! SET ABORT BIT
%[752]%		R1<RIGHT> _ .XDEVJFN(BIN);	! SET JFN
		CLOSF;
		JFCL(0,0);
	END;

	IF .FLGREG<ININCLUD>
	THEN
	BEGIN
		R1 _ .XDEVJFN(ICL);
		CLOSF;
		JFCL(0,0);
	END;

	R1 _ .XDEVJFN(SRC);
	CLOSF;
	JFCL(0,0);

	R1 _ .RSAV;
END
END;

END ELUDOM