Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
driver.bli
There are 13 other files named driver.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: D. B. TOLMAN/MD/JNG/SJW/DCE/RDH/TFV/EGM/CKS/CDM/AHM/PLB/PY/RVM/AlB
MODULE DRIVER(START,RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
GLOBAL BIND DRIVEV = #10^24 + 0^18 + #2500; ! Version Date: 16-Nov-84
%(
***** Begin Revision History *****
2 ----- ----- ADD CODE TO EXECUTE "SYNTAX" FOR SELECTED STATEMENTS
BEFORE CALLING THEIR SEMANTICS ROUTINES
3 ----- ----- ADD THE CODE TO RECOGNIZE END OF FILE IN AN INCLUDED
FILE AND THEN RESTORE THE ORIGIONAL SOURCE FILE
AND CONTINUE PROCESSING IT
4 ----- ----- MOVE ZZOUTMSG TO UNEND SO THAT IT CAN BE CALLED BY MAIN
WHILE IN ANY PHASE
5 ---- ----- MOVE THE END OF PROGRAM UNIT AND END OF
COMPILATION CODE TO ROUTINES ENDUNIT AND
FINALCHAR RESPECTIVELY IN MODULE UNEND.
THIS WILL ALLOW THEM TO BE ACCESSED BY MAIN
6 ----- ----- ADD ERROR DETECTION OF PROGRAM UNIT TERMINATION IN
INCLUDE
7 ----- ----- REDUCE THE END OF THE STACK BY POOLSIZ FOR
PHAZE1 AND THEN RESTORE FOR LATER PASSES
8 ----- ----- FINAL CHAR HAS GONE AWAY
9 ----- ----- ADD PROCESSING TO GLOBINIT TO INITIALIZE
THE FLGREG FOR THE NEW DEBUG SWITCH MODIFIERS
10 ----- ----- FIX DOCHECK TO HANDLE THE NEW ACTIVVE DO STACK
WHICH NOW CONTAINS THE ACTIVE INDEX FOR EACH LOOP
ADD ROUTINE CKDOINDEX() WHICH WILL SEARCH THE
ACTIVE LIST FOR SOME GIVEN VARIABLE
11 ----- ----- ADD ROUTINE CKAJDIM TO CHECK THE LIST OF
VARIABLE DIMENSIONS WHICH WERE NOT LEGAL
AT THE TIME TO SEE IF THEY HAVE BECOME LEGAL
12 ----- ----- MOVE DOCHECK CALL TO UNLINK LOOP LIST DOWN
AFTER SEMANTICS SO THE LAST STAATEMENT WILL
BE PART OF THE LOOP FOR INDEX MODIFICATION
CHECKING PURPOSES
13 ----- ----- FIX DOCHECK SO IT POPS INDEX PROPERLY
14 230 ----- LEGAL VARIABLE DIMENSIONS MUST BE ALLOCATED, (MD)
15 303 16369 CLEAR FLGREG OF ARGUMENT LIST FLAG BETWEEN STATEMENTS,
(JNT)
16 307 16611 CLEAR BUFFERS AFTER FINISHING ERROR MESSAGES, (JNT)
17 343 17636 FIX END OF STA. SO THAT THE LINE NUMBER IS CORRECT.,
(MD)
18 462 19960 FIX MRP1 TO ALWAYS LEAVE SREG<LEFT> THE WAY
IT FOUND IT (FIX PDL OV'S IN LATER PHAZES), (JNG)
***** Begin Version 5A *****
19 571 22378 DEFINE AND CALL CLERIDUSECNTS AT END OF MRP1
TO CLEAR IDUSECNTS OF .I TEMPS SHARED IN
DIM TABLE, (SJW)
20 573 ----- REQUIRE DBUGIT.REQ, (SJW)
***** Begin Version 5B *****
21 657 11554 IF /OPT/DEB ON -20, FIX PROBLEM WITH LISTING FILE, (DCE)
22 673 25984 SOME ILLEGAL DO NESTING REPORTED INCORRECTLY
REWRITE ROUTINE UNDOLABEL, (DCE)
23 677 25573 MOVE PARAMETER-DEBUG BIT INTO FLGREG.
24 710 12299 FIX EDIT 657 TO INITIALIZE DEBOPT, (DCE)
25 712 26490 ILLEGAL DO NESTING CAN GIVE ICE - FIX IT, (DCE)
***** Begin Version 6 *****
26 750 TFV 1-Jan-80 ------
Remove Debug:parameters (edit 677)
27 767 DCE 20-May-80 -----
Remove test for GFL microcode - put into COMMAN instead
28 1044 EGM 20-Jan-81 20-15467
Add new illegal statement ordering case and error call.
29 1047 EGM 22-Jan-81 Q10-05325
Add support for TOPS-10 execute only.
30 1066 EGM 12-May-81 Q10-05202
Do not use ISN in error messages if not pertinent.
***** Begin Version 6A *****
36 1147 EGM 5-Jan-82
Make LINELINE agree with ISN during call to produce NED warning.
Prevents ICE introduced by 1066 for RETURN^Z.
1162 PY 29-Jun-82
Zero the freelist pointers. Prevents problem with error during
first call to LEXICAL. Zero between .JBFF and .JBREL, which
may be allocated for TOPS-20 TTY buffers.
***** Begin Version 7 *****
31 1213 TFV 20-May-81 ------
TYPTABle now has two word entries. Second word is character count
for character data. Rewrite initialization code.
32 1214 CKS 27-May-81
Use DOIFSTK to handle nested DOs instead of LASDOLABEL<LEFT>.
Catches crossed-up nesting of DO and IF. Rename UNDOLABEL to
UNTERMDOIF. Rewrite DOCHECK and CKDOINDEX to use new stack format.
33 1402 CKS 23-Oct-81
Remove checks for labels on declaration statements; code is now in
LABDEF and LABREF since declarations can be labeled, it's just that
the label may not be referenced.
34 1405 DCE 27-Oct-81 -----
Fix up edit 1402. Only process the label when appropriate (not twice!)
35 1437 CDM 16-Dec-81
Added code for /DEBUG:ARGUMENTS and allowed this to be optimized.
1504 AHM 9-Mar-82
Add an assignment statement in GLOBINIT to set the BIGARY
variable to its default value. This will have to be moved if
a Tops-20 native mode command scanner is added.
1563 PLB 18-Jun-82
Native compiler; REQUIRE FTTENX, No CORE UUO needed.
1573 CKS 9-Jul-82
Call ENDWHILE for statements which terminate DO <n> WHILE loops.
1600 PLB 9-Jul-82
Nativization; Use CORUUO routine for cutback. Removes edit 1563.
1613 CDM 13-Aug-82
Change /DEBUG:PARAMETERS to /DEBUG:ARGUMENTS
***** End V7 Development *****
1754 CDM 26-May-83
Remove incorrect error message saying that the use of a variable
in an adjustably dimensioned array declaration is illegal before
defining it as a dummy in an ENTRY statement later in the
program. Also start giving error messages (again) for using
variables in these declarations that are not later declared to
be dummys or in common. Set INADJDIM flag.
2013 TJK 18-Oct-83
Remove CLERIDUSECNTS and the call to it from MRP1. It
formerly cleared the IDUSECNT field of shared .I dimension
offsets, because it overlapped the IDTARGET field. IDUSECNT
is now a separate field. The routine failed to properly check
for .I variables, and sometimes cleared things it shouldn't.
***** Begin Version 10 *****
2224 RVM 3-Oct-83
Remove the assignment to BIGARY from GLOBINIT. The TOPS-20
command scanner now controls setting this variable. This edit
in effect removes edit 1504 in this module.
2412 TFV 1-Jul-84
Split LEXICA into two modules. The classifier is in the new
module LEXCLA. The lexeme scanner is in LEXICA. LEXCLA is
called to initialize each program unit, to classify each
statement, to classify the consequent statement of a logical IF,
and to do the standard end of program and missing end of program
actions.
2437 PLB 31-Jul-84
Fixed spelling of external FFBUFSAV (was spelled FFBUFSV,
and caused XSEARCH lossage.)
2456 AHM 30-Aug-84
Clear all saved INCLUDE file buffer pointers between program
units. Otherwise, the remembered buffer addresses tend to
point into the active heap after it is recycled. This will
hopefully keep nested INCLUDE statements working on Tops-20
until PB comes back from vacation.
2474 TFV 21-Sep-84
Fix continuation processing to handle unlimited numbers of blank
and comment lines between continuation lines. The lines are
recorded in a linked list of four word entries, defined in
LEXAID.BLI. If there are too many blank and comment lines, the
buffer will get an overflow. When this happens, the buffer is
compacted using the information in the linked list. The info is
also used to speed up continuation processing in the lexeme
scan. MRP1 will reset the pointer to the current entry on the
linked list to the head for use by LEXICA.
2500 AlB 14-Nov-84
Change the list of entries for source lines from a linked list
in dynamic memory to a fixed-length list in static memory.
***** End V10 Development *****
***** End Revision History *****
)%
REQUIRE DBUGIT.REQ;
REQUIRE FTTENX.REQ; ![1563]
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
EXTERNAL
ADJCALL,
BUGOUT,
CCLSW,
CGERR,
%1600% CORUUO, !SIMULATED CORE UUO
CURPOOLEND,
DECODELINE,
DIGITS,
%1754% DIMESTA, ! DIMENSION statement processing routine.
DOIFSTK,
E29,
E61,
E67,
E69,
E107,
E108,
E110,
E123,
E149,
ENDOFILE,
ENDUNIT,
ENDWHILE,
ENTRY,
EOPRESTORE,
EOPSVPOOL,
ERLSTR,
ERRMSG,
FATLERR,
GSTSTMNT,
GSTLEXEME,
GSTNOEND,
GSTEOP,
%1754% GTYPCOD, ! Global bind for parsing a type specification sttmnt.
%1754% INADJDIM, ! Tells whether we're parsing a statement that an
%1754% ! adjustably dimensioned array is defined on.
ISN,
JOBERR,
JOBFFSAV,
LABDEF,
LABREF,
%2474% LASTCODELINE, ! Pointer to last pool source entry containing code
%2474% LINLLAST, ! Pointer to last non-deleted entry in linked list
%2412% LEXCLA, ! Classifier entry
LEXICA,
LEXLINE,
LINENO,
%2474% LINLCURR, ! Current entry in linked list
LOOK4LABEL,
LSAVE,
NUMFATL,
NUMWARN,
ONEPLIT,
PAGEHEADING,
POOL,
%1754% PSTATE, ! Indicates what kind of statement is being parsed.
PSTEND,
%1754% PSTEXE, ! Value in PSTATE, indicates
%1754% ! that an executeable statement is being parsed.
SP,
STALABL,
STMNDESC,
STRNGOUT,
SYMTYPE,
SYNTAX,
TBLSEARCH,
WARNERR,
WARNOUT,
ZZOUTMSG;
GLOBAL ROUTINE ENDSTA =
BEGIN
EXTERNAL ERLSTR;
EXTERNAL PSTATE,LEXICAL,GSTLEXEME,GSTNOEND,GSTEOP,ISN,WARNERR,PSTEND,ENDCODE,NEWENTRY,LABLOFSTATEMENT,CONTSTA;
EXTERNAL PSTBKIMP,PSTEXEC;
%CHECK FOR UNIT TERMINATION IN INCLUDE%
IF .FLGREG<ININCLUD>
THEN
BEGIN %ITS A NO O %
PSTATE _ IF .FLGREG<PROGTYP> EQL BKPROG
THEN PSTBKIMP<0,0>
ELSE PSTEXEC<0,0>;
RETURN FATLERR(.ISN, E123<0,0>)
END;
IF .PSTATE NEQ PSTEND<0,0>
THEN
BEGIN
% MISSING END STATEMENT %
%[1147]% LOCAL SAVELINELINE;
%[1147]% EXTERNAL LINELINE;
%[1147]% SAVELINELINE _ .LINELINE; ! Save LEXICA's line number
%[1147]% LINELINE _ 0; ! Line no. must = ISN of 0
%[1066]% WARNERR (0, E69<0,0> );
%[1147]% LINELINE _ .SAVELINELINE; ! Restore actual line number
PSTATE _ PSTEND<0,0>;
NAME _ IDOFSTATEMENT _ ENDDATA;!CREATE ENTRY BEFORE CALL TO LEXICAL
NAME<RIGHT> _ SORTAB;
NEWENTRY();
%2412% LEXCLA (.GSTNOEND ); ! RESTORE LEXCLA TO BEGINNING OF LAST
! STATEMENT AND PERFORM END OF PROGRAM
! UNIT PROCESSING
END
ELSE
BEGIN % WE HAVE AN "END" STATEMENT %
% MAKE DUMMY CONTINUE LABEL HERE IF LABELELD %
IF .LABLOFSTATEMENT NEQ 0
THEN
BEGIN % LABELED END %
CONTSTA();
LABLOFSTATEMENT _ 0
END
ELSE LEXICAL ( .GSTLEXEME ) ; ! PICK UP EOS
NAME _ IDOFSTATEMENT _ ENDDATA;!CREATE ENTRY BEFORE CALL TO LEXICAL
NAME<RIGHT> _ SORTAB;
NEWENTRY();
%2412% LEXCLA ( .GSTEOP ) ! END OF PROGRAM UNIT PROCESSING
END;
%CLEAR OUT THE ERROR MESSAGE QUEUE %
ERLSTR( NOT .FLGREG<TTYDEV> AND NOT .FLGREG<NOERRORS> );
END; % ROUTINE ENDSTA %
GLOBAL ROUTINE CKAJDIM =
BEGIN
! Scan the stack of variables in DIMSTK to see if they have been
! defined as dummies or in common yet.
EXTERNAL DIMSTK,SAVSPAC,E126,FATLERR,E15;
REGISTER BASE LINK:PTR;
LINK = .DIMSTK<RIGHT>;
WHILE ( .LINK ) NEQ 0
DO
BEGIN ! Check each queued up symbol
PTR = .(.LINK+1)<RIGHT>; ! Variable or array pointer
IF .PTR[OPRSP1] EQL ARRAYNM1
THEN
BEGIN ! Its an array. Check to make sure that some
! ENTRY made it a dummy. Must assume that it is
! an array definition, even though we allow
! array ref's in the adjustable expressions
! (this is non standard).
IF NOT .PTR[IDATTRIBUT(DUMMY)]
THEN FATLERR(UPLIT'a dummy array?0', PTR[IDSYMBOL],
.(.LINK+1)<LEFT>,E15<0,0>);
END
ELSE
BEGIN ! Its a variable. If it is not a formal/dummy
! variable or in COMMON, or equivalenced
! (possibly to something in common, but we can't
! check for this until in later processing, then
! give an error.
IF .PTR[OPERSP] NEQ FORMLVAR
AND NOT .PTR[IDATTRIBUT(INCOM)]
%1754% AND NOT .PTR[IDATTRIBUT(INEQV)]
THEN FATLERR ( .PTR[IDSYMBOL],.(.LINK+1)<LEFT>,E126<0,0>);
PTR[IDATTRIBUT(NOALLOC)]_0; !MUST ALLOCATE
END;
LINK _ @( VREG _ .LINK );
SAVSPAC ( 1,.VREG ) ! Free up the space not needed
END ! Check each queued up symbol
END; ! of CKAJDIM
GLOBAL ROUTINE LABLCHECK=
BEGIN
%
ROUTINE SCANS THE LABEL TABLE AND OUTPUTS A LIST OF UNDEFINED
LABELS IT ENCOUNTERS.
%
EXTERNAL LABTBL,LSTOUT,DECODELINE,LINENO,ZZOUTMSG,HEADCHK;
LOCAL BASE PTR, UNDEFLABEL,COUNT;
COUNT _ 0;
UNDEFLABEL _ 0;
DECR I FROM LASIZ-1 TO 0 DO
BEGIN
IF (PTR _ .LABTBL[.I]) NEQ 0
THEN
BEGIN
DO BEGIN
IF .PTR[SNHDR] EQL 0
THEN IF .PTR[SNUMBER] LEQ 99999
%1402% THEN IF NOT .PTR[SNDECL]
THEN
BEGIN
!ERROR UNDEFINED LABEL
IF .UNDEFLABEL EQL 0 THEN( HEADCHK(); ZZOUTMSG(UPLIT '?M?J?M?JUndefined labels?M?J?M?J?0'));
UNDEFLABEL _ .PTR[SNUMBER];
DECODELINE( .UNDEFLABEL );
ZZOUTMSG( LINENO<0,0> );
IF (COUNT _.COUNT+1) GTR 3
THEN (COUNT _ 0; ZZOUTMSG( UPLIT'?M?J?0' ); HEADCHK());
NUMFATL _ .NUMFATL+1; !INCREMENT # OF ERRORS
END;
END WHILE (PTR _ .PTR[CLINK]) NEQ 0;
END
END;
IF .UNDEFLABEL NEQ 0
THEN
BEGIN
ZZOUTMSG(UPLIT'?M?J?0');
FLGREG<ERRSW> _ 1; !SET FLAG FOR FATAL ERRORS
END
END; !OF LABLCHECK
GLOBAL ROUTINE UNTERMDOIF = ! UNTERMINATED DO AND IF STATEMENTS
![1214] REWRITE TO USE DOIFSTK INSTEAD OF LASDOLABEL<LEFT>. LIST
![1214] BOTH DOS AND IFS BY ISN.
BEGIN
!Here from MRP1 when an END stmt is seen and there are still things on
!DOIFSTK. Go through the stack and list the line numbers of the statements,
!which are the unterminated DOs and IFs.
EXTERNAL DECODELINE,LINENO,ZZOUTMSG,HEADCHK;
EXTERNAL DINODE DOIFSTK;
LOCAL BASE PTR;
LOCAL ERRSEEN; ! FLAG SET AFTER HEADING PRINTED
ERRSEEN_0;
DO
BEGIN
PTR _ .DOIFSTK[DISTMT]; ! GET POINTER TO STMT NODE OF TOP DO/IF
IF NOT .ERRSEEN THEN
BEGIN !FIRST PROBLEM SEEN
FLGREG<ERRSW>_1;
ERRSEEN_1;
HEADCHK();
ZZOUTMSG (UPLIT'?M?J?JUnterminated DO and IF statements?M?J?J?0');
END;
HEADCHK();
ZZOUTMSG (UPLIT'Line: '); !TYPE LINE NUMBER OF DO/IF STMT
DECODELINE (.PTR[SRCISN]);
ZZOUTMSG (LINENO<0,0>);
ZZOUTMSG (UPLIT '?M?J?0');
NUMFATL = .NUMFATL + 1; !BUMP FATAL ERROR COUNT
END
UNTIL (DOIFSTK _ .DOIFSTK[DILINK]) EQL 0; ! REPEAT FOR ALL NODES ON STACK
END; %UNTERMDOIF%
GLOBAL ROUTINE DOCHECK ( LABNODE ) =
BEGIN
!Here when a stmt label is defined and the label has appeared as the target
!of one or more DO statements. The DOs will have been pushed on DOIFSTK by
!DOLOOP. Remove all DO nodes from DOIFSTK which have LABNODE as their target.
!For nesting to be legal, the top of DOIFSTK must be a DO LABNODE node.
!There can be more than one DO LABNODE, but they must all be together on the
!top. To check this condition, look through DOIFSTK from bottom to top; when
!the first DO LABNODE is seen, all following entries must be DO LABNODE.
MAP BASE LABNODE;
EXTERNAL DONESTLEVEL,DOINDEX,FATLEX;
EXTERNAL GENLAB,CONTGEN;
EXTERNAL DINODE DOIFSTK;
EXTERNAL E152,E153;
REGISTER BASE T1;
REGISTER DINODE P:Q;
LOCAL CHKNEST,DOSPLIT;
LOCAL BASE OLDLAB:NEWLAB;
! Adjust DO nesting level
DONESTLEVEL = .DONESTLEVEL - .LABNODE[SNDOLVL];
! Subtract the nest level of the label
! Check for legal nesting of DO, IF, and DO WHILE
P = .DOIFSTK; ! Point to top (innermost) entry of
! DOIFSTK
IF .P NEQ 0 THEN ! search until a node with zero DILINK
WHILE .P[DILINK] NEQ 0 DO ! is found
P = .P[DILINK];
! now have P pointing to bottom
! (outermost) entry of DOIFSTK
CHKNEST = 0; ! CHKNEST is 1 after we find a
! DO LABNODE
WHILE .P NEQ 0 ! P goes from outermost dinode to
DO ! innermost
BEGIN
IF (IF .P[DITYPE] EQL DIDOTYPE
THEN .LABNODE EQL .P[LASTDOLBL]
ELSE IF .P[DITYPE] EQL DIWHILETYPE
THEN .LABNODE EQL .P[BOTSTMT])
THEN ! if we have a DO LABNODE,
BEGIN
CHKNEST = 1; ! all following entries must also be
! DO LABNODE
END
ELSE ! found a node that isn't DO LABNODE
BEGIN
IF .CHKNEST NEQ 0 ! if we've seen a DO LABNODE,
THEN ! improper nesting
BEGIN
T1 = .P[DISTMT]; ! get pointer to stmt node
IF .P[DITYPE] EQL DIIFTYPE
THEN FATLEX(.T1[SRCISN],E153<0,0>)
! "ILL DO NESTING"
ELSE FATLEX(.T1[SRCISN],E152<0,0>);
! "ILL IF NESTING"
END
END;
P = .P[DIBLINK]; ! go on to next inner DO or IF
END;
! Now remove all DO <LABNODE>s from the stack
P = .DOIFSTK; ! P goes from innermost to outermost
DOSPLIT = 0; ! DOSPLIT is 1 for DOs which contain
! an inner WHILE ending at the same
! label
WHILE .P NEQ 0 DO
BEGIN
IF .P[DITYPE] EQL DIDOTYPE
THEN IF .P[LASTDOLBL] EQL .LABNODE
THEN
BEGIN
! If there are WHILEs inner to this DO, change
! the terminal statement of the DO to a new CONTINUE
IF .DOSPLIT
THEN
BEGIN ! split DOs ending on same label
MAP BASE Q;
T1 = .P[DISTMT]; ! get pointer to DO stmt
OLDLAB = .T1[DOLBL];
T1[DOLBL] = NEWLAB = GENLAB();
CONTGEN(.NEWLAB);
OLDLAB[SNDOLVL] = .OLDLAB[SNDOLVL] - 1;
OLDLAB[SNREF] = .OLDLAB[SNREF] - 1;
Q = .OLDLAB[SNDOLNK];
IF .Q[LEFTP] EQL .T1
THEN (T1 = .OLDLAB[SNDOLNK];
OLDLAB[SNDOLNK] = .T1[RIGHTP])
ELSE
BEGIN
WHILE .(.Q[RIGHTP])<LEFT> NEQ .T1
DO Q = .Q[RIGHTP];
T1 = .Q[RIGHTP];
Q[RIGHTP] = .T1[RIGHTP];
END;
NEWLAB[SNDOLVL] = .NEWLAB[SNDOLVL] + 1;
NEWLAB[SNREF] = .NEWLAB[SNREF] + 1;
NEWLAB[SNDOLNK] = .T1;
T1[RIGHTP] = 0;
END; ! split DOs ending on same label
! Unlink this node from the stack
IF (Q = .P[DIBLINK]) NEQ 0
THEN Q[DILINK] = .P[DILINK]
ELSE DOIFSTK = .P[DILINK];
IF (Q = .P[DILINK]) NEQ 0
THEN Q[DIBLINK] = .P[DIBLINK];
END;
IF .P[DITYPE] EQL DIWHILETYPE
THEN IF .P[BOTSTMT] EQL .LABNODE
THEN
BEGIN
ENDWHILE(.P);
DOSPLIT = 1;
END;
P = .P[DILINK]; ! step to next outer DO or IF
END;
END;
GLOBAL ROUTINE CKDOINDEX ( ID ) =
BEGIN
%SEARCH BACK UP THE CURRENTLY ACTIVE DO LOOP LIST AND SEE
IF ID ( A POINTER TO A VARIABLE ) IS AN ACTIVE INDEX %
![1214] CHANGE TO SEARCH DOIFSTK INSTEAD OF LASDOLABEL<LEFT>
MAP BASE ID;
REGISTER LAB,IDX;
REGISTER DINODE DIPTR;
EXTERNAL LASDOLABEL,CURDOINDEX;
EXTERNAL DOIFSTK;
DIPTR _ .DOIFSTK; ! LOOK THROUGH DOIFSTK
WHILE .DIPTR NEQ 0 ! FOR EACH DO/IF STATEMENT ON STACK
DO
BEGIN
IF .DIPTR[DITYPE] EQL DIDOTYPE
THEN ! IF IT'S A DO STATEMENT
BEGIN
IDX _ .(DIPTR[CURDONDX])<RIGHT>; ! SEE IF INDEX MATCHES
IF .ID<RIGHT> EQL .IDX
THEN RETURN -1; !YES, ITS A MATCH, RETURN TRUE
END;
DIPTR _ .DIPTR[DILINK]; ! LINK TO NEXT OUTER DO/IF
END;
RETURN 0 ! NOT FOUND, INDEX IS NOT ACTIVE, RETURN FALSE
END;
MACHOP POPJ=#263;
MACRO CORE(X) = BEGIN
CALLI(X,#11);
END$;
EXTERNAL LOWLOC,SEGINCORE,ILABIX,PHAZCONTROL %()%,ERRLINK,SP,TMPCNT[4],FREELIST,LSAVE,LEXL,LEXEMEGEN %()%;
GLOBAL ROUTINE GLOBINIT= !INITIALIZE ALL GLOBALS
BEGIN
!FILE GLOBL.BLI HAS ALL THE GLOBALS DEFINED
EXTERNAL GLOBEND;
% FIRST ZERO EVERYTHING UP TO GLOBEND - THERE ARE A FEW AFTER
GLOBEND WHICH SHOULD NOT BE ZEROED FOR EVERY COMPILATION UNIT %
SYMTBL[0]_ 0; !THE FIRST GLOBAL IN GLOBL.BLI
VREG<LEFT>_ SYMTBL<0,0>; VREG<RIGHT> _ SYMTBL[1]<0,0>; !SET BLT POINTER
BLT(VREG,GLOBEND); !ZERO THE GLOBAL AREA
IF .JOBREL GEQ .JOBFF THEN
BEGIN
(.JOBFF)<FULL> _ 0;
IF .JOBREL GTR .JOBFF THEN
BEGIN
VREG<LEFT> _ .JOBFF; VREG<RIGHT> _ .JOBFF+1;
BLT(VREG,.JOBREL)
END
END;
!INITIALIZE GLOBAL AREA
BEGIN
EXTERNAL ENTRY,SYMTYPE,TBLSEARCH,NAME,ONEPLIT,PROGNAME;
EXTERNAL GINTEGER,GREAL,PAGE,PAGELINE,NONIOINIO;
%1504% EXTERNAL BIGARY; ! Large array lower size limit
REGISTER T1,T2;
ILABIX _ 100000; !INITIAL TEMPORTRY LABEL VALUE
%[1213]% ! Initialize TYPTABle; first word is default type; second is
%[1213]% ! character count for character data
%[1213]% ! I thru N are integers, rest are real
%[1213]% INCR IDX FROM 2 * ("A" - "A") TO 2 * ("H" - "A") BY 2 DO
%[1213]% BEGIN
%[1213]% TYPTAB[ .IDX ] _ GREAL<0,0>;
%[1213]% TYPTAB[ .IDX + 1 ] _ 0
%[1213]% END;
%[1213]% INCR IDX FROM 2 * ("I" - "A") TO 2 * ("N" - "A") BY 2 DO
%[1213]% BEGIN
%[1213]% TYPTAB[ .IDX ] _ GINTEGER<0,0>;
%[1213]% TYPTAB[ .IDX + 1 ] _ 0
%[1213]% END;
%[1213]% INCR IDX FROM 2 * ("O" - "A") TO 2 * ("Z" - "A") BY 2 DO
%[1213]% BEGIN
%[1213]% TYPTAB[ .IDX ] _ GREAL<0,0>;
%[1213]% TYPTAB[ .IDX + 1 ] _ 0
%[1213]% END;
PROGNAME _ SIXBIT'MAIN.';
PAGE _ 1^18;
PAGELINE _ -1;
NONIOINIO _ 0;
FLGREG<ERRSW> _ 0;
SPACEFREE_@JOBREL-@JOBFF;
SEGINCORE_1;
FLGREG<BLKDATA> _ 0; ! CLEAR THE BLKDATA BIT
FLGREG<LABLDUM> _ 0; ! LABEL FORMALS PARAMETERS
FLGREG<PROGTYP> _ MAPROG; ! MAIN PROGRAM
FLGREG<MULTENT> _ 0; ! MULTIPLE ENTRIES FLAG
FLGREG<ENDFILE> _ 0; !CLEAR END OF FILE FLAG
FLGREG<BTTMSTFL> _ 1; !BOTTOMMOST SUBROUTINE FLAG
LOWLOC _ 1;
END !OF GLOBI1
!
END; !Of GLOBINIT
%[1047]% PORTAL ROUTINE MRP1 =
BEGIN
REGISTER T1,T2;
LABEL COMPILATION;
LOCAL DEBOPT; ![657] SET IF BOTH DEBUG AND OPT REQUESTED
BIND EOF =#200;
BIND EOSLEX = 5;
%[710]% DEBOPT_FALSE;
%REDUCE THE STACK BY POOLSIZ BECAUSE POOL CANNOT
BE DESTROYED LIKE THE OLD DAYS%
SREG _ .SREG + POOLSIZ^18;
% FIRST PROGRAM UNIT INITIALIZATION %
CURPOOLEND _ POOL[0]<0,0>;
LINENO[1] _ ' '; ! TAB FOLLOWING LINE NUMBERS
!**;[1162] Routine: MRP1, @ line 3896, PY, 29-Jun-82
![1162] CLEAR FROM JOBFF THROUGH JOBREL
%[1162]%
%[1162]% IF .JOBREL GEQ .JOBFF THEN
%[1162]% BEGIN
%[1162]% (.JOBFF)<FULL> _ 0;
%[1162]% IF .JOBREL GTR .JOBFF THEN
%[1162]% BEGIN
%[1162]% T2<LEFT> _ .JOBFF; T2<RIGHT> _ .JOBFF+1;
%[1162]% BLT(T2,.JOBREL)
%[1162]% END
%[1162]% END;
%[1162]%
![1162] ZERO THE FREE LIST, IN CASE OF ERROR DURING FIRST LEXICA CALL
%[1162]%
%[1162]% FREELIST[0] _ 0;
%[1162]% T2 _ FREELIST[0]<0,0>^18+FREELIST[1]<0,0>;
%[1162]% BLT (T2,FREELIST[FLSIZ]);
BEGIN ! Check and set appropriate flags for debug switch
! Define bit positions as set by scan for the
! various debug modifiers. These are set in
! DEBGSW. The left half indicates which
! modifiers have been specifically excluded and
! the right half indicates those which have been
! included.
MACRO
DBSDIMN = 0,1$,
DBSLABL = 1,1$,
DBSINDX = 2,1$,
DBSTRAC = 3,1$,
%[750]% DBSBOUN = 4,1$,
%1613% DBSARGM = 5,1$; ! /DEBUG:ARGUMENTS
%1437% BIND NUMSWITCHES = 6; ! Change this count for any
! change in the number of
! switches above
BIND DEBUGFLGS =
! FLGREG bit positions for the various
! DEBUG modifiers
1^DBGDIMNBR +
1^DBGINDXBR +
1^DBGLABLBR +
1^DBGTRACBR +
1^DBGBOUNBR +
%1613% 1^DBGARGMBR; ! /DEBUG:ARGUMENTS
EXTERNAL DEBGSW; !SWITCH VALUE VARIABLE - SET BY SCAN
REGISTER R;
! First check for specific exclusions. If only
! exclusions are specified it implies a request
! for the rest
IF .DEBGSW<LEFT> LSS 1^NUMSWITCHES
AND .DEBGSW<LEFT> NEQ 0
AND .DEBGSW<RIGHT> EQL 0
THEN
%ONLY EXCLUSIONS - INCLUDE THE REST %
R _ NOT .DEBGSW<LEFT>
ELSE
% RIGHT SIDE IS GOOD %
R _ .DEBGSW<RIGHT>;
! Clear /DEBUG switches in FLGREG
FLGREG<FULL> _ .FLGREG<FULL> AND ( NOT DEBUGFLGS );
! Now set the specific /DEBUG switches for later
! compiler processing.
IF .R NEQ 0
THEN
BEGIN
IF .R<DBSDIMN> THEN FLGREG<DBGDIMN> _ -1;
IF .R<DBSINDX> THEN FLGREG<DBGINDX> _ -1;
IF .R<DBSLABL> THEN FLGREG<DBGLABL> _ -1;
IF .R<DBSTRAC> THEN ( FLGREG<DBGTRAC> _ -1;
FLGREG<DBGLABL> _ -1 );
IF .R<DBSBOUN> THEN FLGREG<BOUNDS> _ -1;
%1613% IF .R<DBSARGM> THEN FLGREG<DBGARGMNTS> _ -1;
! No global optimization if any other /DEBUG
! other than /DEBUG:ARGUMENTS is specified.
%1437% IF (.FLGREG<FULL> AND
%1613% (DEBUGFLGS AND (NOT 1^DBGARGMBR))) NEQ 0
%1437% THEN ! Discontinue /OPT if specified
%1437% BEGIN
! [657] Cannot print the error
! message yet but set flag for
! later.
%[657]% DEBOPT _ .FLGREG<OPTIMIZE>;
%[657]% FLGREG<OPTIMIZE> _ 0;
%1437% END;
END
END; %DEBUG MODIFER PROCESSING%
PAGEHEADING(); ! BUILD THE PAGE HEADING SKELITION
FLGREG<FATALERR> _ FLGREG<WARNGERR> _ 0;
IF EOPRESTORE() EQL EOF
THEN
BEGIN
SREG _ .SREG - POOLSIZ^18; !RESTORE THE STACK
RETURN 0
END;
![657] NOW IT IS OK TO PRINT THE ERROR MESSAGE SINCE THE BUFFER
![657] POINTERS HAVE BEEN SET UP CORRECTLY.
%[657]% IF .DEBOPT
%[657]% THEN (EXTERNAL LINELINE,FATLERR,E133;
%[657]% LINELINE_-1;
%[657]% FATLERR(-2,E133<0,0>);
%[657]% LINELINE_1);
COMPILATION:
WHILE 1
DO
BEGIN ! Compilation loop
LABEL STATEMENT;
EXTERNAL PSTATE,GINTEGER;
GLOBINIT(); ! INITIALIZE THE GLOBAL AREA
%2474% ! Reset linked list pointers
%2500% LASTCODELINE = LINLCURR = LINLLAST = 0;
JOBFFSAV _ .JOBFF; !SAVING THE STATE OF THE LOW SEG
% CREATE A CONSTANT NODE FOR 1 %
NAME _ CONTAB; SYMTYPE _ GINTEGER<0,0>; ENTRY[1] _ 1;
ONEPLIT _ TBLSEARCH();
DO
STATEMENT: BEGIN ! Program unit loop
LABLOFSTATEMENT _ 0;
FLGREG<FELFLG>_0; !CLEAR ARG LIST FLAG
% CLASSIFY THE NEXT STATEMENT %
WHILE 1 DO
BEGIN
%2412% IF LEXCLA(.GSTSTMNT) NEQ ENDOFILE<0,0>
THEN EXITLOOP
ELSE
BEGIN % MISSING END STATEMENT %
EXTERNAL POSTINCL;
IF .FLGREG<ININCLUD> THEN POSTINCL()
ELSE
IF .PSTATE EQL 0
THEN
BEGIN
%2412% LEXCLA(.GSTEOP);
LEAVE COMPILATION
END
ELSE
BEGIN
ENDSTA();
LEAVE STATEMENT !SKIP REST OF STATEMENT PROCESSING
END
END
END;
BEGIN % CLASSIFIED STATEMENT %
EXTERNAL CREFIT;
BIND LINNE = 2;
IF .FLGREG<CROSSREF> THEN CREFIT(.ISN,LINNE); !LINE NUMBER OF STATEMENT
IF DBUGIT THEN
BEGIN
EXTERNAL STRNGOUT,LINENO;
REGISTER T;
IF ( T_.BUGOUT AND 4) NEQ 0
THEN
BEGIN
STRNGOUT(KEYWRD(.STMNDESC));
DECODELINE(.ISN);
STRNGOUT(UPLIT(' CLASSIFICATION - STATEMENT '));
STRNGOUT (LINENO);
STRNGOUT(UPLIT'?M?J');
END
END;
% CHECK STATEMENT ORDERING %
% STRUCTURE FOR THE STATMENT ORDER CHECKING STATE TABLE %
BEGIN
STRUCTURE ORDERTAB[ST,CD] =
.ORDERTAB+(.CD*(PSTEND<0,0>+1))+.ST;
EXTERNAL STMNSTATE,STMNDESC,PSTATE;
MAP ORDERTAB STMNSTATE;
REGISTER CODE;
IF ( CODE _ .STMNSTATE[ .PSTATE, .ORDERCODE( @STMNDESC) ] ) LEQ PSTEND<0,0>
THEN
BEGIN % VALID ORDERING %
PSTATE _ .CODE
END
ELSE
BEGIN % ILLEGAL ORDERING %
EXTERNAL ISN,FATLERR,WARNERR;
CASE (.CODE-PSTEND<0,0>-1) OF SET
%OW - ORDER WARNING %
BEGIN
WARNERR ( KEYWRD(@STMNDESC)<0,0>, .ISN, E107<0,0> )
END;
% ED - MISSING END %
BEGIN
ENDSTA();
LEAVE STATEMENT ! END OF PROGRAM UNIT
END;
% BD - ILLEGAL STATEMENT IN BLOCK DATA %
BEGIN
FATLERR ( .ISN, E108<0,0> );
LEAVE STATEMENT ! SKIP THE STATEMENT
END;
% IE - INTERNAL COMPILER ERROR %
BEGIN
EXTERNAL FATLERR;
FATLERR (UPLIT'STORDER',.ISN,E61<0,0>)
%[1044]% END;
%[1044]%
%[1044]% %FO - ORDER FATALITY %
%[1044]% BEGIN
%[1044]% FATLERR( KEYWRD(@STMNDESC)<0,0>, .ISN, E149<0,0> )
%[1044]% END
TES
END
END
END;
!**;[1405], MRP1, DCE, 27-Oct-81
![1405] Process labels here (unless deferred/delayed)
![1405] Deferred label processing is necessary for
![1405] statement function/array assignment statements.
![1405] It is not yet known whether such a statement is allowed
![1405] to have a label on it or not. So wait until the statement
![1405] is further classified, then call LABDEF at that point.
%1405% IF .STALABL NEQ 0
%1405% THEN
%1405% BEGIN
%1405% EXTERNAL DELAYED; ! Delayed label processing
%1405% IF .LABOK(@STMNDESC) NEQ DELAYED<0,0>
%1405% THEN LABDEF(); ! Process the label now.
%1405% END;
%1754% ! Set INADJDIM if we are parsing a type decl or
%1754% ! DIMENSION statement that could have an
%1754% ! adjustably dimensioned array defined in them.
%1754% ! Checking here is more economical than checking
%1754% ! for every variable reference!
%1754% IF (.ORDERCODE(@STMNDESC) EQL GTYPCOD<0,0>)
%1754% OR (.STMNROUTINE(@STMNDESC) EQL DIMESTA<0,0>)
%1754% THEN INADJDIM = TRUE
%1754% ELSE INADJDIM = FALSE;
! Execute the statement routine
SP _ -1;
LSAVE _ 0;
LOOK4LABEL_0; ! STACK AND LEXEME INITIALIZATION
% EXECUTE SYNTAX FOR THOSE STATEMENTS WHICH DO IT FIRST %
IF ( T1_.SYNOW(@STMNDESC)) NEQ 0
THEN IF SYNTAX (.T1) LSS 0 THEN LEAVE STATEMENT;
% NOW THE SEMANTICS ROUTINE %
( .STMNROUTINE( @STMNDESC )) () ;
%UNLINK LOOP LIST IF NECESSARRY%
IF .LABLOFSTATEMENT NEQ 0
THEN
BEGIN
MAP BASE LABLOFSTATEMENT;
IF .LABLOFSTATEMENT[SNDOLVL] NEQ 0
%1573% OR .LABLOFSTATEMENT[SNWHILE]
THEN DOCHECK(.LABLOFSTATEMENT);
END;
END ! Program unit loop
UNTIL .PSTATE EQL PSTEND<0,0>;
CKAJDIM(); !CHECK FOR BAD VARIABLE DIMENSIONS
LABLCHECK(); !CHECK FOR UNDEFINED LABELS
%2013% ! Removed call to CLERIDUSECNTS, which no longer exists
EOPSVPOOL(); !SAVE BUFFERS BETWEEN PROGRAM UNITS
IF .DOIFSTK NEQ 0 THEN UNTERMDOIF(); !OUTPUT LIST OF UNTERMINATED DO AND IFS
IF .NUMFATL EQL 0
THEN IF NOT .FLGREG<SYNONLY>
THEN
BEGIN
%[1047]% EXTERNAL ADJCALL,XPHAZCONTROL;
%2437% EXTERNAL FFBUFSAV;
LOCAL REG0SAV,LFFBUFSV;
%2437% LFFBUFSV _ .FFBUFSAV; !JOBFF FOR PROPER REALLOCATION OF BUFFERS
REG0SAV_.FLGREG;
ADJCALL(); !INSERT CALLS FOR ADJUSTABLE DIMENSIONS
%ADD POOLSIZ BACK TO THE STACK%
SREG _ .SREG - POOLSIZ^18;
%[1047]% XPHAZCONTROL();
FLGREG_.REG0SAV;
%2437% FFBUFSAV _ .LFFBUFSV;
% REMOVE POOLSIZ FROM THE STACK AGAIN%
SREG _ .SREG + POOLSIZ^18;
END;
ENDUNIT(); !END OF PROGRAM UNIT MESSAGES
IF .FLGREG<ENDFILE> THEN LEAVE COMPILATION;
EOPRESTORE(); ! RESTORE THE STATEMENT BUFFER
%1563% IF NOT FTTENEX !RESET SIZE OF LOWSEG
%1563% THEN !TOPS-10 ONLY
BEGIN ! TOPS-10
MACHOP JFCL=#255;
JOBFF _ VREG _ .JOBFFSAV<RIGHT>;
CORE(VREG);
JFCL(0,0);
END ! TOPS-10
ELSE
BEGIN ! TOPS-20
%1600% CORUUO(JOBFF _ .JOBFFSAV<RIGHT>);
%2456% INCR I FROM 0 TO INCLMAX-1 ! Clear out the saved
%2456% DO BUFFERS(ICL+.I) = 0; ! buffer pointers -
! the heap was reset
END; ! TOPS-20
END; ! Compilation loop
SREG _ .SREG - POOLSIZ^18; !RESTORE THE STACK
END; !END OF MRP1
MRP1();
POPJ(SREG,0)
END ELUDOM