Trailing-Edge
-
PDP-10 Archives
-
bb-4157h-bm_fortran20_v10_16mt9
-
fortran-compiler/inout.bli
There are 12 other files named inout.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1985
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/MD/SJW/DCE/EGM/CKS/CDM/PLB/TFV/TJK/AlB/MEM
MODULE INOUT(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND INOUTV = #10^24 + 0^18 + #2501; ! Version Date: 20-Nov-84
%(
***** 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.
***** Begin Version 6A *****
1160 EGM 14-Jun-82
If fatal errors, turn on global fatal errors this compile command flag
(make edit 752 work properly).
***** Begin Version 7 *****
53 1463 CKS 22-Jan-82
Modify FATLERR's sixbit printer to not output trailing spaces
54 1466 CDM 1-Feb-82
Addition of ?F to BLDMSG to type out integers without leading zeroes.
1563 PLB 18-Jun-82
Remove REQUIRE of FTTENX since LEXAID does it for us.
1646 TFV 18-Oct-82
Fix BLDMSG to output negative decimal numbers correctly.
***** End V7 Development *****
2010 TJK 10-Oct-83 10-34235
Have BLDMSG substitute printable characters for control
characters and DEL.
***** Begin Version 10 *********
2247 AlB 22-Dec-83
Add routines CFLAGB and CFLEXB to aid in compatibility flagging
2420 TFV 9-Jul-84
Fix flagger warnings so that each gets printed once instead of
twice. Fix the line numbers for the warnings, they were wrong
and could ICE the compiler.
2455 MEM 30-Aug-84
Replace all occurrences of VAX with VMS.
2473 CDM 29-Oct-84
Add IMPLICIT NONE for the Military Standard MIL-STD-1753.
Make ANSIPLIT, VMSPLIT, BOTHPLIT into GLOBAL symbols.
2474 TFV 21-Sep-84
Removed definition of FULL macro, which has been moved to LEXAID.
2501 AlB 20-Nov-84
Special handling of errors found in comment lines. Since these
errors can be detected while scanning unprinted comment lines, they
cannot go through the normal error queueing process.
Added routines WARNCOMT and ERRPRINT.
***** End V10 Development *****
***** End Revision History *****
)%
REQUIRE DBUGIT.REQ;
REQUIRE LEXAID.BLI;
REQUIRE IOFLG.BLI;
FORWARD
DIGITS(1),
STRNG6(1),
STRNG7(1),
HEADCHK,
HEADING,
FATLERR(4),
WARNERR(4),
FATLEX(3) ,
WARNLEX(3),
%2501% WARNCOMT(1),
BLDMSG(1),
%2501% ERRPRINT,
ERROR(2),
OUUOLST,
OUTSTAT(2),
LINEOUT(2),
CHAROUT(1),
STRNGOUT(1),
LSTOUT,
OUUOBIN ,
RELOUT,
SOUTPUT(1),
%2247% CLOSUP,
%2247% CFLAGB,
%2247% CFLEXB,
%2420% CFLINB;
EXTERNAL
BACKTYPE,
BASENO,
CCLSW,
CORMAN,
ENTRY,
%2501% E222,
%2501% E225,
%2501% E265,
ERRLINK,
ERRMSG,
FLGWRD,
FNDFF,
HEADPTR,
HEADSTR,
INDEX,
JOBFF,
JOBFFSAVE,
JOBREL,
JOBSA,
LEXLINE, ! Line number for first line being classified
LEXNAME,
%2420% LINELINE, ! Line number for line with error
MSGNOTYPD,
NAME,
NOCR,
NUMFATL,
NUMWARN,
%1115% NWKTB, !NOWARN KEYWORD TABLE (SIXBIT)
%1115% NWKTBC, !NOWARN KEYWORD COUNT
%1115% NWBITS, !NOWARN OPTIONS SELECTED
PAGE,
PAGELINE,
PAGEPTR,
PROGNAME,
SAVSPACE,
SEGINCORE,
WARMSG,
WARNOPT,
WOPTMSG;
OWN
%2501% ERRNODE [ENODSIZ]; ! Temporary error node
BIND
%2501% PLITFLG=UPLIT(
%2473% ANSIPLIT GLOBALLY NAMES ' Extension to Fortran-77: ?0',
%2473% VMSPLIT GLOBALLY NAMES ' VMS incompatibility: ?0',
%2473% BOTHPLIT GLOBALLY NAMES ' Fortran-77 and VMS: ?0'
);
BIND
BMODE= #14,
AMODE= 0,
BINARYOUTP= 1^18+1^BMODE,
ASCIIOUTP= 1^18+1^AMODE,
ASCIIINP= 1^19+1^AMODE;
MACRO ADVANCEN= 30,6$,
BACKSPACEN= 24,6$,
! FULL= 0,36$, Removed in edit 2474
NXT(C) = REPLACEI ( HEADPTR, C ) $;
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;
!------------------------------------------------------------------------------
!
! 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.
!
! 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.
!
! LSTOUT= OUTPUTS THE CONTENTS OF REGISTER C AS THE NEXT LISTING
! CHARACTER. THE ERROR ROUTINE IS CALLED IF AN ERROR
! OCCURS.
!
! RELOUT= OUTPUTS THE CONTENTS OF REGISTER C AS THE NEXT WORD OF
! THE OBJECT FILE. THE ERROR ROUTINE IS CALLED IF AN
! ERROR OCCURS.
!
!------------------------------------------------------------------------------
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; ! of DIGITS
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; ! of STRNG6
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; ! of STRNG7
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 %
IF NOT .FLGREG<LISTING> THEN RETURN;
IF .PAGELINE LEQ 0
THEN HEADING();
PAGELINE _ .PAGELINE -1;
END; ! of HEADCHK
GLOBAL ROUTINE HEADING=
BEGIN
% PUT THE ROUTINE NAME AND PAGE NUMBER IN THE HEADING AND PRINT IT %
% 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; ! of HEADING
GLOBAL ROUTINE FATLERR(ENT2,ENT1,LINE,ERRNUM)=
BEGIN
% 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
%
REGISTER T1,
%[1115]% T2, !ANOTHER SCRATCH REGISTER
ENODE;
%[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 %
%2501% ERRPRINT(.LINE);
RETURN -1
END; ! of FATLERR
GLOBAL ROUTINE WARNERR(ENT2,ENT1,LINE,ERRNUM)=
BEGIN
% PROCESS WARNING ERROR MESSAGE REQUESTS %
FATLERR (.ENT2,.ENT1,.LINE,.ERRNUM )
END; ! of WARNERR
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 WARNCOMT(SRCENT)=
!++
! FUNCTIONAL DESCRIPTION:
!
! Produce a warning message for a comment line.
! The message to be listed is encoded in the source line entry
! for the line.
!
! FORMAL PARAMETERS:
!
! SRCENT - The address of the source list entry for the line
! containing the error.
!
! IMPLICIT INPUTS:
!
! The source list entry.
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! An error message may be printed and/or typed.
!
!--
%2501% !Written by AlB on 20-Nov-84
BEGIN
REGISTER ENODE; ! Points to error node
NUMWARN = .NUMWARN+1; ! Count it
ENODE = ERRNODE;
EMSGNUM(ENODE) = E265<0,0>; ! Assume this for now
ERRTYPD(ENODE) = 0;
ERRLINE(ENODE) = .LINENUM(SRCENT);
CASE .ERRCOMNT(SRCENT)-1 OF ! Code for error message
SET
! 1 - ANSI Improper character in column 1
ERRENT1(ENODE) = ANSIPLIT;
! 2 - VMS Improper character in column 1
ERRENT1(ENODE) = VMSPLIT;
! 3 - BOTH Improper character in column 1
ERRENT1(ENODE) = BOTHPLIT;
! 4 - ANSI Comment on statement
EMSGNUM(ENODE) = E222<0,0>;
! 5 - ANSI Debug line
EMSGNUM(ENODE) = E225<0,0>;
TES;
ERRPRINT(.LINENUM(SRCENT)); ! Print the message
END; ! of WARNCOMT
GLOBAL ROUTINE BLDMSG(ENODE)=
BEGIN
!BUILDS MSG POINTED TO BY EPTR AND RETURNS A POINTER TO IT
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;
%1466% ROUTINE DECOUT(NUM)= ![1466] New
%1466% BEGIN
%1466% REGISTER DIGIT;
%1646% IF .NUM LSS 0
%1646% THEN
%1646% BEGIN ! Handle negative numbers correctly
%1646% REPLACEI(TTYPTR,"-");
%1646% NUM = -.NUM;
%1646% END;
%1466% DIGIT = .NUM MOD 10;
%1466% IF .NUM/10 NEQ 0 THEN DECOUT(.NUM/10);
%1466% REPLACEI(TTYPTR,.DIGIT+"0");
%1466% END;
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 WITH LEADING ZEROES
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;
IF .T1 LSS #200 ! Is it a character?
THEN
BEGIN ! It is
%2010% IF .T1 EQL #177 ! Is it DEL?
%2010% THEN
%2010% BEGIN ! Yes, use ^?
%2010% REPLACEI(TTYPTR,"^");
%2010% REPLACEI(TTYPTR,"??")
%2010% END
%2010% ELSE IF .T1 LSS #40 ! Is it a CTRL?
%2010% THEN
%2010% BEGIN ! Yes, use ^ representation
%2010% REPLACEI(TTYPTR,"^");
%2010% REPLACEI(TTYPTR,.T1 OR #100)
%2010% END
%2010% ELSE REPLACEI(TTYPTR,.T1); ! normal chr
%2010%
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
BEGIN
%1463% C _ SCANI(T1)+" ";
%1463% IF .C NEQ " " THEN REPLACEI(TTYPTR,.C);
END
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
BEGIN
%1463% C _ SCANI(T1)+" ";
%1463% IF .C NEQ " " THEN REPLACEI(TTYPTR,.C);
END
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;
%1466% %"?F":% BEGIN
%1466% ! Insert the rightmost decimal digits supplied by
%1466% ! the next parameter with no leading zeroes.
%1466% DECOUT( .(.ENODE<RIGHT>)[N_.N+1] );
%1466% END
TES ELSE REPLACEI(TTYPTR,.C);
REPLACEI(TTYPTR,CR);
REPLACEI(TTYPTR,LF);
REPLACEI(TTYPTR,0);
RETURN (TTYMSG+1)<ADRS>;
END; ! of BLDMSG
ROUTINE ERRPRINT(LINE)=
!++
! FUNCTIONAL DESCRIPTION:
!
! Print and/or type an error message
!
! FORMAL PARAMETERS:
!
! LINE - The line number for the line in error
!
! IMPLICIT INPUTS:
!
! ERRNODE - An error node containing info about the message to be emitted
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! An error message may be printed and/or typed.
!
!--
%2501% ! Taken from FATLERR by AlB on 20-Nov-84
BEGIN
REGISTER ENODE; ! Points to error node
ENODE = BLDMSG(ERRNODE); ! Build the message
IF .FLGREG<LISTING>
THEN
BEGIN ! Print message on listing
IF .SEGINCORE NEQ 1
THEN ! Put out CRLF after Phase 1
BEGIN
STRNGOUT(PLIT'?M?J');
PAGELINE _ .PAGELINE - 1
END;
! NO HEADING IF WE ARE HERE TO PRINT OPTIMIZE SWITCH IGNORED
IF .PAGELINE LEQ 0 AND .LINE NEQ -2
THEN HEADING();
PAGELINE _ .PAGELINE -1;
STRNGOUT(.ENODE)
END; ! Print message on listing
IF NOT .FLGREG<TTYDEV> AND NOT .FLGREG<NOERRORS>
THEN
BEGIN ! Message to TTY
! BE CAREFUL IF NO LINES HAVE BEEN SCANNED YET!
IF NOT .ERRFLAG AND .SEGINCORE EQL 1
AND .LINE NEQ -2
THEN ! THIS IS THE FIRST ERROR IN THIS
! STATEMENT SO TYPE ALL LINES TO THIS POINT
BACKTYPE(LINESONLY);
OUTTYX (ENODE) ! Message sent to TTY
END; ! Message to TTY
! NOTE THAT A MESSAGE IS GOING OUT THAT WILL NOT SHOW UP IN THE QUEUE
ERRFLAG _ -1;
END; ! of ERRPRINT
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; ! of ERROR
MACRO IOIMPM=17,1$,IODERR=16,1$,IODTER=15,1$,IOBKTL=14,1$,IODEND=13,1$;
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; ! of 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.
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; ! of 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; ! of 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; ! of CHAROUT
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; ! of 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; ! of OUUOBIN
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; ! of RELOUT
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; ! of SOUTPUT
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
%[1160]% IF .FLAGS2<FTLCOM> EQL 0 ! Fatal compile 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; ! of CLOSUP
!******************************************************************************
! Routines for putting out flagger warning messages [2247]
!
! CFLAGB, CFLEXB and CFLINB put out Flagger warning for either or both of
! /FLAG:VMS and /FLAG:STANDARD
! It is expected that either FLAGANSI or FLAGVMS is on.
!
! If both flags are on, the prefix will be BOTHPLIT
! If only VMS is on, the prefix will be VMSPLIT
! If VMS is off (i.e. STANDARD is on), the prefix will be ANSIPLIT
! The parameters are:
! X -- An optional argument to be inserted into error message
! ERRNUM -- The address of the error message
!Used outside of syntax phase
GLOBAL ROUTINE CFLAGB (X, ERRNUM) =
BEGIN
EXTERNAL ISN; !The line number to which we attach the message
%2455% IF FLAGVMS
THEN
IF FLAGANSI
THEN FATLERR(.X,BOTHPLIT<0,0>,.ISN,.ERRNUM)
ELSE FATLERR(.X,VMSPLIT<0,0>,.ISN,.ERRNUM)
ELSE
FATLERR(.X,ANSIPLIT<0,0>,.ISN,.ERRNUM)
END; ! of CFLAGB
! Either or both for syntax
GLOBAL ROUTINE CFLEXB (X, ERRNUM) =
BEGIN
EXTERNAL LEXLINE; !The line number to which we attach the message
%2455% IF FLAGVMS
THEN
IF FLAGANSI
THEN FATLERR(.X,BOTHPLIT<0,0>,.LEXLINE,.ERRNUM)
%2455% ELSE FATLERR(.X,VMSPLIT<0,0>,.LEXLINE,.ERRNUM)
ELSE
FATLERR(.X,ANSIPLIT<0,0>,.LEXLINE,.ERRNUM)
END; ! of CFLEXB
! Either or both for syntax
GLOBAL ROUTINE CFLINB(X, ERRNUM)=
!++
! FUNCTIONAL DESCRIPTION:
!
! Puts out Flagger warning for either or both of:
! /FLAG:VMS and /FLAG:STANDARD
! It is expected that either FLAGANSI or FLAGVMS is on.
!
! If both flags are on, the prefix will be BOTHPLIT
! If only VMS is on, the prefix will be VMSPLIT
! If only STANDARD is on, the prefix will be ANSIPLIT
!
! FORMAL PARAMETERS:
!
! X optional argument to be inserted into error message
! ERRNUM address of the error message
!
! IMPLICIT INPUTS:
!
! LINELINE line number for the line containing the error
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Outputs a warning message to the terminal and listing.
!
!--
![2420] New
BEGIN
EXTERNAL LINELINE; !The line number to which we attach the message
%2455% IF FLAGVMS
THEN
IF FLAGANSI
THEN FATLERR(.X,BOTHPLIT<0,0>,.LINELINE,.ERRNUM)
ELSE FATLERR(.X,VMSPLIT<0,0>,.LINELINE,.ERRNUM)
ELSE
FATLERR(.X,ANSIPLIT<0,0>,.LINELINE,.ERRNUM)
END; ! of CFLINB
END
ELUDOM