Google
 

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