Google
 

Trailing-Edge - PDP-10 Archives - BB-4157E-BM - fortran-compiler/act1.bli
There are 26 other files named act1.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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: T.E. OSTEN/FJI/MD/SJW/JNG/DCE/TFV/AHM

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

!		REQUIRES LEXNAM, FIRST, TABLES, ASHELP

SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
SWITCHES NOSPEC;

REQUIRE ASHELP.BLI;

GLOBAL BIND ACT1V = 6^24 + 0^18 + 128;		! Version Date:	19-Oct-81

%(

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

69	-----	-----	MAKE USE COUNT FOR IMPLIESD DO LOOP LABELS
			2 INSTEAD OF 1
70	-----	-----	GENERATE LABELS FOR DIMENSION BLOCKS FOR ARRAYS
			THAT ARE PROTECTED (ALSO - COMMENT OUT CODE IN
			"BLDARRAY" THAT APPEARS TO PROCESS MULTIPLE
			ARRAYS SPECIFIED BY THE SAME DIMENSION SPECIFICATION)
71	-----	-----	FIX OPERSP FIELD OF SLIST CALLS

72	-----	-----	MODIFY "BLDARRAY" TO GENERATE DIMENSION LABELS
			FOR ALL ARRAYS IF THE "BOUNDS" SWITCH WAS SPECIFIED.
			(WE HAVE DONE AWAY WITH THE "ISPROT" FLAG ON INDIVIDUAL
			ARRAYS)
76	-----	-----	DETECT UNDETECTED SUBSCRIPTED IMPLICIT DO INDICES

77	-----	-----	PUT PARAMETER STUFF IN NAMCHK AND NAMDEF.
			PUT *N OVERRIDE IN BLDARRAY.
			CHANGE NO PARAMETERS IN FUNCTION TO WARNING

78	-----	-----	IN FUNCGEN - NO LONGER SET FNNAME ON FUNCTIONS.
				  - PROGNAME IS NOW SET IN ACTION PNAMSET

79	-----	-----	MAKE A LINKED LIST OF ENTRY POINT NAMES IN FUNCGEN

80	-----	-----	ALLOW DIMENSION A(1:3)

81	-----	-----	DUMMIES CAN BE IN EXTERNAL STATEMENTS

82	-----	-----	CLEAR THE NOALOC BIT IN THE OTHER PLACE
			WHERE THE SPECIAL FORMAL ARRAY PSEUDOSYMBOL TABLE
			ENTRY IS GENERATED - FUNCGEN

83	-----	-----	CHANGE NAMDEF AND NAMCHK TO INTERPRET THE &/* EXTERNAL
			STATEMENT PROPERLY

84	-----	-----	FIX BLDARRAY SO THAT IT ACCEPTS THE TYPE INFORMATION
			FOR TYPE STATEMENTS BEFORE THE DIMENSION INFORMATION
			RATHER THAN AFTER

85	-----	-----	CHECK FOR DUPLICATE DUMMY ARGS IN FUNCTIONS,
			SUBROUTINES AND ENTRYS

86	----	-----	HAVE BLDDIM USE  DVARFLGS TO CLEAR THE FLAGS IN
			THE DIMENSION TABLE ENTRY.

87	-----	-----	DETECT THE CASE OF AN IMPLIED DO SPEC WITHOUT
			PRECEEDING VARIABLE LIST OF SOME SORT - DATALIST

88	-----	-----	ISSUE A WARNING MESSAGE WHEN LABEL INDICATORS 
			APPEAR IN THE FORMAL ARGUMENT LIST OF A FUNCTION
			FUNCGEN

89	-----	-----	FIX BLDARRAY SO THAT IT WILL REVERSE
			THE CALCULATED DIMENSIONS OF AN ARRAY WHICH
			HAS GONE TO DOUBLE PRECISION DUE TO
			AN IMPLICIT STATEMENT AND IS THEN EXPLICITLY TYPED
			TO SINGLE PRECISION

90	-----	-----	CHECK IN BLDDIM TO BE SURE THAT DIMENSIONS
			ARE WITHIN A RESPECTABLE RANGE

91	-----	-----	IN BLDDIM, CHANGE REFERENCE TO "DEBUG" FLAG
			TO "DBGDIMN" FLAG 

92	-----	-----	FUNCGEN - FIX DUPLICATE DUMMY PARAMETER CHECK SO
			IT REALLY WORKS

93	-----	-----	MAKE A CHECK FOR DO INDEX MODIFICATION IN NAMSET
			SO THAT ALL CASES ARE CHECKED

94	-----	-----	NAMSET WAS NOT CALLED FOR IMPLICIT DO INDICES

95	-----	-----	BLDDIM - CHECK FOR ZERO SINGLE DIMENSION

96	-----	-----	WITH THE ADVENT OF SIGNED PARAMETERS  - BULDDIM
			MUST BE PREPARED TO CHECK THE SIGN OF THE NUMBER
			NOT JUST WHETHER OR NOT A - WAS
			PRESENT

97	-----	-----	EXTEND NAMDEF TO DETECT REFERENCE TO DUMMY PARAMETERS
			BEFORE THEY HAVE BEEN DEFINED

***** Begin Version 4A *****

99	 230	-----	RESTORE NOALLOC BIT WHEN ADJUSTABLE DIMENSION
			IS NOT YET DEFINED, (MD)

100	232	-----	FIX BLDUNIT - IT NEEDED ONE MORE LEVEL OF
			INDIRECTION IN THE RECORD NUMBER PROCESSING., (MD)

101	235	-----	FIX NAMELIST PROBLEMS
			USING NEW PARAMETER NMLSTITM, (DT/MD)
102	265	15946	ADD CHECK FOR VARIABLE IN DATA STATEMENT TWICE, (JNT)
103	272	-----	CHANGE 102 TO ONLY CHECK SIMPLE VARIABLES, NOT ARRAYS,
			(JNT)

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

104	VER5	-----	SHARE .I OFFSET IN DIMENTRY FOR ARRAYS
			WITH VARIABLE UPPER BOUND (LINK DIM ENTRIES), (SJW)
105	410	-----	MAKE DTABPTR GLOBAL SO WILL BE INITIALIZED TO 0, (SJW)
106	414	QA625	FIX SHARING .I OFFSET SO ONLY SHARES DIM2 .I
			  IF DIM1 SAME, (SJW)
107	415	18964	DON'T DESTROY SYMBOL TABLE ENTRY FOR A FORMAL
			  FUNCTION IF A LATER ENTRY STATEMENT SEEN WITH
			  THE FUNCTION AS A PARAMETER.
108	423	QA709	FIX PATCH 414: DIMNUM=1 => ARRAY HAS 1 DIM NOT 2, (SJW)
109	460	19477	TEST FOR OVERSIZED DIMENSIONING CORRECTLY, (DCE)

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

110	567	22284	MAKE EXTERNAL STMNT APPLY TO ALL ENTRY POINT PARAMS
111	571	22378	FIX V5 OPTIMIZATION THAT SHARES 2ND OFFSET OF
			  FORMAL ARRAYS IF 1ST DIMENSIONS = SO ALL WILL
			  WORK IF ARRAY SUBSEQUENTLY TYPED DIFFERENTLY
			  (DIFFERENT # WORDS) THAN WHEN SHARING 1ST DONE, (SJW)
112	572	21825	CHECK IMPLIED DO INDEX FOR ALREADY ACTIVE (FROM
			  AN ENCLOSING IMPLIED OR REAL DO), (SJW)
113	601	Q20-26	FIX EDIT 572 TO CHECK IMPLIED DO INDEX IN DATA
			  STATEMENT FOR ALREADY ACTIVE FROM AN ENCLOSING
			  IMPLIED DO, (SJW)

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

114	627	23755	FIX EDIT 571 TO CORRECTLY ADJUST ALL DIMENSION
			TABLE MULTIPLICATIVE FACTORS BY THE RIGHT
			CONSTANT IF AN ARRAY IS LATER DISCOVERED TO
			REQUIRE A DIFFERENT NUMBER OF WORDS PER ENTRY
			THAN ORIGINALLY THOUGHT. EDIT 571 ONLY FIXED
			THE FIRST SUBSCRIPT., (JNG)
115	635	24868	FIX DATALIST TO RETURN -1 IF IT GETS E66
			(CANNOT INIT DUMMY PARAMETER IN DATA), (JNG)
116	663	25643	FIX TYPING OF FORMAL FUNCTIONS (EXTERNAL STMNTS), (DCE)
117	717	26560	GIVE REASONABLE ERROR MESSAGE FOR
			REPEATED PARAMETER STATEMENT, (DCE)
118	741	-----	ADD SLASHWARN ROUTINE, (DCE)

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

119	760	TFV	1-Jan-80	-----
	Add routines to handle keywords in I/O control lists

127	1132	AHM	22-Sep-81	Q10-06347
	Fix casing of some error message fragments.

128	1136	AHM	19-Oct-81	Q20-01652,Q20-01656
	Delete code that unjustifiably decremented SNREF for labels
	in BLDKEY, since it screwed up optimizations.

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

)%

	FORWARD
		FUNCGEN,	!
		TYPEGEN,	!
		TMPGEN,		!
		BLDDIM,		!
		BLDARRAY,	!
		BLKSRCH,	!
		BLDVAR,		!
		DATALIST,	!
		BLDFORMAT,	!
		BLDUNIT,	!
%[760]%		BLDKEY,
%[760]%		BLDKLIST,
%[760]%		KORFBLD,
		NAMSET,
		NAMREF,
		NAMDEF,
		NAMCHK;

	
	% THE FOLLOWING TABLE IS USED TO PRODUCE THE ERROR MESSAGES 
	  IT IS BASED UPON THE BIT POSITION OF THE CONFLICTING IDATTRIBUT
	  FIELD BIT %
	BIND DUMDUM  =  PLIT  (

%1132%	R18 NAMES R23 NAMES  'in EXTERNAL statement?0',
%1132%	R22 NAMES  'as dummy parameter?0',
%1132%	R19 NAMES 'in type statement?0',
%1132%	R24 NAMES 'in DATA statement?0',
%1132%	R26 NAMES 'in COMMON?0',
%1132%	R27 NAMES 'in EQUIVALENCE?0',
%1132%	R28 NAMES 'as an entry point name?0',
%1132%	R33 NAMES 'as statement function?0',
%1132%	R34 NAMES 'as COMMON block?0',
%1132%	R35 NAMES 'as NAMELIST?0',

%1132%	AYORFN NAMES ' as an array or FUNCTION?0',
%1132%	AY NAMES 'as an array?0',
%1132%	FNN NAMES 'as a FUNCTION?0'
);


	GLOBAL ROUTINE
NAMDEF (  TYPE, ID )   =
BEGIN

	EXTERNAL E136;
	MAP BASE ID;

	% ID - POINTER TO SYMBOL TABLE ENTRY %
	% TYPE - CODE FOR WHAT YOU THINK YOU HAVE  %

	% THE FOLLOWING BINDS ARE USED TO MAKE THE SYMBOL TABLE ATTRIBUTE
	  FIELD MASKS  %
	
	BIND
		NAMLST = 1^35,
		CMNBLK = 1^34,
		STFN = 1^33,
		ENTPNT = 1^28,
		EXTERN = 1^23,
		EXTRSGN = 1^18,
		TYPED = 1^19,
		EXTBTH = 1^18 + 1^23,
		EQVIN = 1^27,
		COMIN = 1^26,
		DATAIN = 1^24,
		DUMIEE = 1^22;
	
	% THE FOLLOWING ARE MASKS ( INDEXED BY .TYPE ) OF THE SYMBOLTABLE
	  IDATRIBU FIELD.  IF THE AND IS NON-ZERO THEN THERE IS A CONFLICT %
	
	BIND	DEFMASK = PLIT (
	
		%ARRYDEF%	NAMLST + STFN + ENTPNT + EXTBTH,
		%ARRYDEFT%	NAMLST + STFN + ENTPNT + EXTBTH + TYPED,
		%STFNDEF%	NAMLST + STFN + ENTPNT + EXTBTH + EQVIN + COMIN + DATAIN + DUMIEE,
		%EXTDEF%	NAMLST + STFN + ENTPNT + EXTBTH  + DATAIN + COMIN + EQVIN,
		%NMLSTDEF%	NAMLST + STFN + ENTPNT + EXTBTH + DUMIEE + DATAIN + COMIN + EQVIN,
		%VARARY%	NAMLST + STFN + EXTBTH + COMIN + DUMIEE,
		%IDDEFT%	NAMLST + TYPED,
		%IDDEFINE%	NAMLST + STFN + ENTPNT + EQVIN + COMIN + DATAIN,	%DUMMY PARAMETERS%
		%ENTRYDEF%	NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK + DUMIEE,
		%EXTDEFS%	NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK  + DATAIN + COMIN + EQVIN,
		%CMNBLK%	ENTPNT + EXTRSGN,
		%PARADEF%	NAMLST + CMNBLK + STFN + ENTPNT + EXTBTH + TYPED + EQVIN + COMIN + DATAIN + DUMIEE,
		%NMLSTITM%	NAMLST + STFN + EXTBTH + DUMIEE
	);
	
	
	% NAMDEF IS REFERENCED FROM THE FOLLOWING ROUTINES WITH THE  FOLLOWING TYPES:
	
		SEMANTIC ROUTINE     -   TYPES
	
		TYPE STATEMENTS 		ARRYDEFT, IDDEFT
		FUNCTION			ENTRYDEF, IDDEF
		SUBROUTINE			ENTRYDEF, IDDEF
		ENTRY				ENTRYDEF, IDDEF
		PROGRAM				ENTRYDEF
		BLOCKDATA			ENTRYDEF
		DIMENSION			ARRYDEF
		COMMON				VARARY, CMNBLK, ARYDEF
		EXTERNAL			EXTDEF, EXTDEFS(LIB FUNCTION)
		NAMELIST			NMLSTDEF, VARARY
		STMNT FUNCTION			STFNDEF
		PARAMETER			PARADEF
	
		NOTE THAT EQUIVALENCE AND DATA STATEMENTS REFERENCE NAMSET RATHER
	 THAN NAMDEF.  THIS IS DONE MAINLY FOR CONVIENCE.  IF THEY COULD BE
	CHANGED TO REFERENCE NAMREF IT MIGHT BE POSSIBLE, WITH A LITTLE THOUGHT, TO DETECT
	INSTANCES OF DEFINITION AFTER REFERENCE.
	
	%


	%THIS MASK DEFINES WHICH TYPES CAN BE THE SAME AS AN ENTRY POINT
	  NAME AS LONG AS ITS NOT IN A FUNCTION %

	BIND	OKSAMEASENTRY  = 1^ARRYDEF + 1^ARRYDEFT + 1^STFNDEF +
				1^EXTDEF + 1^NMLSTDEF + 1^IDDEFINE  ;


	BIND  PDEFAS  =  PLIT  (
	R18,R19,0,0,R22,R23,R24,0,R26,R27,R28,0,0,0,0,R33,R34,R35  );

	REGISTER R;
	EXTERNAL CREFIT;

	IF .FLGREG<CROSSREF>   THEN  CREFIT(  .ID, SETT );

	% CHECK THE ATTRIBUTES  %
	IF  ( R _ .DEFMASK[.TYPE]<LEFT> AND .ID[IDATTRIBUT(ALLOFTHEM)] )  NEQ  0
	THEN
		%ALLOW STATEMENT FUNCTIONS , ARRAYS , NAMELISTS , AND POSSIBLE LIBRARY
		  FUNCTIONS TO BE THE SAME AS ENTRY POINT NAMES PROVIDING
		  THAT THIS IS NOT A FUNCTION  %

		IF (1^(.TYPE) AND OKSAMEASENTRY )  EQL  0
			OR  .FLGREG < PROGTYP>  EQL  FNPROG
			OR    .R NEQ   ENTPNT^(-18)
		THEN
			% ALLOW ENTRY POINT DEFINITIONS TO BE THE
			  SAME AS NAMELIST, STATEMENT FUNCTIONS, AND 
			  POSSIBLE LIBRARY FUNCTIONS AS LONG AS ITS NOT A FUNCTION%

			IF .TYPE NEQ  ENTRYDEF
			  OR  .FLGREG<PROGTYP>  EQL  FNPROG
			  OR ( .R NEQ  NAMLST^(-18)
				AND  .R  NEQ  STFN^(-18)
				AND  .R  NEQ  EXTERN^(-18)  )
			THEN
				% ITS A CONFLICTING DEFINITION %
				RETURN  FATLEX  (  .PDEFAS[35-FIRSTONE(.R)], ID[IDSYMBOL], E34 );

	% WE MUST DO JUST A BIT MORE CHECKING %

	VREG _ 0;
	VREG _  CASE  .TYPE  OF   SET

	%ARRYDEF%	BEGIN
				IF .ID[OPRSP1]  NEQ  VARIABL1 THEN  AYORFN
			END;
	%ARRYDEFT%	BEGIN
				IF .ID[OPRSP1]  NEQ  VARIABL1  THEN  AYORFN
			END;
	%STFNDEF%	BEGIN
				IF .ID[OPRSP1]  NEQ  VARIABL1  THEN  AYORFN
			END;
	%EXTDEFS%	BEGIN
				IF  .ID[OPRSP1]  EQL  ARRAYNM1  THEN  AY
			END;
	%NMLSTDEF%	BEGIN
				IF .ID[OPRSP1]  NEQ  VARIABL1  THEN  AYORFN
			END;
	%VARARY%	BEGIN
				IF .ID[OPRSP1]  EQL  FNNAME1 THEN  FNN
			END;
	%IDDEFT%		BEGIN END;
	%IDDEF%	BEGIN
				%CHECK HERE TO SEE THAT DUMMY PARAMETERS
				 HAVE NEVER BEEN REFERENCED %
				IF NOT .ID[IDATTRIBUT(NOALLOC)]
				  AND NOT  .ID[IDATTRIBUT(DUMMY)]
				THEN	RETURN FATLEX(.ID[IDSYMBOL],E136<0,0>)
			 END;
	%ENTRYDEF%	BEGIN
				IF .ID[OPRSP1]  EQL FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)]  THEN  FNN
			END;
	%EXTDEF%	BEGIN
				IF .ID[OPRSP1]  EQL  ARRAYNM1  THEN  AY
			END;
	%CMNBLK%	BEGIN
				IF .ID[OPRSP1]  EQL  FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)]  THEN FNN
			END;
	%PARADEF%	BEGIN
				IF NOT .ID[IDATTRIBUT(NOALLOC)]  THEN  IDENPLIT
![717] IF ALREADY DEFINED AS PARAMETER (IF THIS IS A REDUNDENT
![717] PARAMETER DEFINITION OR REDEFINITION) GIVE FATAL ERROR
%[717]%			ELSE IF .ID[IDATTRIBUT(PARAMT)] THEN .LEXNAM[CONSTLEX]
			END;
	%NMLSTITM%	BEGIN
				IF .ID[OPRSP1] EQL FNNAME1 THEN FNN
			END
	
	TES;

	IF .VREG  NEQ  0
	THEN  RETURN  FATLEX ( .VREG, ID[IDSYMBOL], E34 );

END;	%NAMDEF%



	GLOBAL ROUTINE
NAMSET ( TYPE , ID  )   =
	
BEGIN	% THE SYMBOL POINTED TO BY ID AND DEFINED BY TYPE IS 
	  BEING SET  %

	EXTERNAL CREFIT;
	MAP BASE  ID;
	EXTERNAL CKDOINDEX,STMNDESC;

	%CHECK FOR DO INDEX MODIFICATION%
	IF CKDOINDEX ( .ID )
	THEN	IF .LABOK(@STMNDESC)  EQL  0	!FORGET DATA AND EQUIV
		THEN	FATLEX(E77<0,0>);	!MODIFICATION WARNING

	ID[IDATTRIBUT(STORD)] _ 1;
	IF  .FLGREG<CROSSREF>  THEN  CREFIT( .ID, SETT );
	RETURN  NAMCHK  ( .TYPE , .ID )

END;	%NAMSET%


	GLOBAL ROUTINE
NAMREF ( TYPE , ID )   =

BEGIN	% THE SYMBOL POINTED TO BY ID AND DEFINED BY TYPE IS BEING 
	  REFERENCED  %
	EXTERNAL CREFIT;

	IF  .FLGREG<CROSSREF>  THEN CREFIT( .ID, USE );
	RETURN  NAMCHK ( .TYPE, .ID )

END;	%NAMREF%




	GLOBAL ROUTINE
NAMCHK  (  TYPE, ID  )  =

BEGIN	% CHECK TO SEE IF WE HAVE WHAT WE THINK WE HAVE AND IF NOT
	  OUTPUT AN ERROR MESSAGE  %

	% THE FOLLOWING BINDS ARE USED TO MAKE THE SYMBOL TABLE ATTRIBUTE
	  FIELD MASKS  %
	
	BIND
		NAMLST = 1^35,
		CMNBLK = 1^34,
		STFN = 1^33,
		ENTPNT = 1^28,
		EXTERN = 1^23,
		EXTRSGN = 1^18,
		TYPED = 1^19,
		EXTBTH = 1^18 + 1^23,
		EQVIN = 1^27,
		COMIN = 1^26,
		DATAIN = 1^24,
		DUMIEE = 1^22;

	BIND DUMO  =  PLIT (

	VAORAY NAMES 'A VARIABLE OR ARRAY?0',
	VARIB NAMES  'A SCALAR VARIABLE?0',
	AAY   NAMES  'AN ARRAY?0',
	AFN   NAMES  'A SUBPROGRAM NAME?0'	);
	MAP BASE ID;


	VREG _ 0;
	VREG _ CASE .TYPE OF SET

	%VARYREF%	BEGIN
		IF .ID[OPRSP1]  EQL FNNAME1
		  OR  .ID[IDATTRIBUT(NAMNAM)]
		THEN	VAORAY
		END;

	%VARIABL1%	BEGIN
		IF .ID[OPRSP1]  NEQ  VARIABL1
		  OR  .ID[IDATTRIBUT(NAMNAM)]
		THEN  VARIB
		END;

	%ARRAYNM1%	BEGIN
		IF  .ID[OPRSP1]  NEQ  ARRAYNM1
		THEN     AAY
		END;

	%FNNAME1%	BEGIN
		IF  .ID[OPRSP1]  EQL  FNNAME1
		THEN   
		BEGIN
			%CHECK TO SEE THAT POSSIBLE LIBRARY FUNCTIONS
			WHICH TURNED OUT NOT TO BE LIBRARY FUNCTIONS
			ARE NOT CONFLICTING WITH ANY GLOBAL NAMES %

			IF ( VREG _ .ID[IDATTRIBUT(ALLOFTHEM)] AND
				( CMNBLK^(-18) + ENTPNT^(-18)) ) NEQ  0
			THEN	IF	.ID[IDATTRIBUT(COMBL)]
				THEN	FATLEX( R34, ID[IDSYMBOL], E34<0,0> )
				ELSE	FATLEX(R28,ID[IDSYMBOL],E34<0,0>);
			0
		END
		ELSE
		BEGIN
			IF .ID[OPRSP1]  EQL ARRAYNM1 OR NOT .ID[IDATTRIBUT(NOALLOC)] OR  ISDEFIND(ID)
				OR .ID[IDATTRIBUT(COMBL)]
			THEN	AFN	!ITS A VARIABLE OR ARRAY
			ELSE
			BEGIN
			 ID[OPERSP] _ IF .ID[IDATTRIBUT(DUMMY)] 
						THEN FORMLFN ELSE FNNAME;
			0
			END
		END
		END;

	%NMLSTREF%	BEGIN
		%NO CONFLICTS HERE%
		0
		END;
	%PARAREF%	BEGIN
		RETURN  .ID[IDPARAVAL]
		END


	TES;

	IF  .VREG  NEQ   0
	THEN	RETURN  FATLEX (.VREG, ID[IDSYMBOL],E15<0,0> );

	%  INDICATE THAT WE ARE USING THIS NAME %
	ID[IDATTRIBUT(NOALLOC)] _ 0;

END;	%ROUTINE  NAMCHK  %




GLOBAL ROUTINE FUNCGEN (FPNT)=
BEGIN
	LOCAL BASE R1;
	REGISTER BASE T2; MAP BASE FPNT;REGISTER BASE T1:R2;
	EXTERNAL MULENTRY;	!POINTER TO FIRST ENTRY POINT NAME
	EXTERNAL SAVSPACE %(SIZE,LOC)%,TYPE,IDTYPE,PROGNAME,CORMAN %()%,
		NEWENTRY %()%,STK,NAME;
	MACRO
	FCTN = 4$, ENT=1$,
	ERR40=RETURN FATLEX(R1[IDSYMBOL], E40<0,0>)$;

	!------------------------------------------------------------------------
	!THIS ROUTINE IS CALLED WITH THE PARAMETER FPNT POINTING TO
	!THE LIST:
	!
	!IDENTIFIER (20^18+LOC) - SUBPROGRAM NAME
	!OPTION 0 - NO ARGUMENTS, ILLEGAL IF THIS IS A FUNCTION
	! OR
	!OPTION 1 - ARGUMENT LIST POINTER FOLLOWS
	!	COUNT^18+LOC - POINTS TO LIST POINTER
	!		1^18+LOC - POINTS TO LIST OF
	!		CHOICE 1 - DUMMY ARGUMENT
	!			IDENTIFIER (20^18+LOC)
	!		CHOICE 2 - DUMMY LABEL
	!
	!THE LOCATION TYPE IS NON-ZERO (4) FOR A FUNCTION STATEMENT
	!AND ZERO FOR A SUBROUTINE OR ENTRY STATEMENT.  AN ARGUMENT
	!LIST MUST BE PRESENT IF TYPE IS NON-ZERO.  IF THE FUNCTION
	!WAS TYPED, IDTYPE WILL CONTAIN THE TYPE OTHERWISE IT CONTAINS -1
	!------------------------------------------------------------------------
	R1_.FPNT[ELMNT];!R1_LOC (SUBPROGRAM NAME)
	IF NAMDEF( ENTRYDEF, .R1) LSS 0 THEN RETURN .VREG;
	IF .FPNT[ELMNT1]EQL 0 THEN ! NO ARGUMENTS
	BEGIN
		IF .FLGREG<PROGTYP> EQL  FNPROG  THEN WARNLEX ( E28<0,0> ); !FUNCTION SUBPROGRAM
		R2_0
	END
	ELSE
	BEGIN
		!--------------------------------------------------------------------
		!CREATE AN ARGUMENT LIST ON THE UNUSED PORTION OF THE
		!LEXEME STACK (STK[2] THRU STK[100]).  THIS IS NECESSARY
		!BECAUSE THE EXACT NUMBER OF ARGUMENTS IS NOT KNOWN.
		!THE ARGUMENT LIST PRODUCED BY SYNTAX CONTAINS 2 WORDS
		!(CHOICE 1) FOR EACH DUMMY ARGUMENT BUT ONLY 1 WORD
		!FOR ACH DUMMY LABEL (CHOICE 2).  THE PROPORTION OF
		!EACH ARGUMENT TYPE IS NOT KNOWN UNTIL THE LIST IS SCANNED.
		!--------------------------------------------------------------------
		T2_.FPNT[ELMNT2];T1_.T2[ELMNT];SAVSPACE(0,@T2);
		T2_STK[3]<0,0>;!T1_LOC(GENERATED ARG LIST),SET COUNT T2 TO LOC OF ARGLIST
		INCR ALST FROM @T1 TO @T1+.T1<LEFT>DO
		BEGIN
			MAP BASE ALST;
			T2_.T2+1;
			IF .ALST[ELMNT] EQL 1 THEN !DUMMY ARGUMENT
			BEGIN
				T2[ELMNT]_R2<RIGHT>_.ALST[ELMNT1];
				IF NAMDEF(IDDEFINE, .R2 ) LSS 0 THEN RETURN .VREG;
				IF .R2[OPRCLS] EQL DATAOPR THEN T2[P1AVALFLG] _ 1;
![663] WE ARE TRYING TO ASSIGN TYPE INFORMATION TO PARAMETERS OF
![663] SUBROUTINE AND ENTRY STATEMENTS.  THERE MAY BE INFORMATION
![663] ALREADY PRESENT REGARDING THESE VARIABLES, SO WE NEED TO BE
![663] VERY CAREFUL.  IF THE VARIABLE HAS ALREADY BEEN DIMENSIONED,
![663] THEN WE KNOW THAT IT IS A FORMLARRAY.  OTHERWISE, WE MIGHT
![663] HAVE SEEN IT PREVIOUSLY IN AN EARLIER SUBROUTINE OR ENTRY
![663] STATEMENT IN WHICH CASE WE NEED TO RETAIN THE SAME TYPE.
![663] SO IF IT IS EITHER A FORMLFN OR A FORMLVAR, RETAIN THAT TYPE
![663] INFORMATION.  FINALLY, IT MIGHT HAVE OCCURRED AS A FUNCTION
![663] NAME (AS IN AN EXTERNAL DECLARATION) - IN THIS CASE CHANGE
![663] THE TYPE TO FORMLFN SO THAT SPACE WILL BE ALLOCATED FOR THE
![663] VARIABLE NAME.  IF NONE OF THE ABOVE, THEN THE VARIABLE
![663] IS A SIMPLE ONE - FORMLVAR.
%[663]%				IF .R2[IDDIM] EQL 0 THEN
%[663]%				  (IF .R2[OPERSP] NEQ FORMLFN THEN
%[663]%					IF .R2[OPERSP] EQL FNNAME 
%[663]%					THEN R2[OPERSP]_FORMLFN
%[663]%					ELSE R2[OPERSP]_FORMLVAR)
%[663]%				ELSE
				   BEGIN
				     LOCAL BASE DIMPTR;
				     R2[OPERSP] _ FORMLARRAY;
				      DIMPTR _ .R2[IDDIM];
				     IF .DIMPTR[ARADDRVAR] EQL 0
					THEN IF NOT  .DIMPTR[ADJDIMFLG]
					  THEN BEGIN
						LOCAL BASE PTRVAR;
						ENTRY[0] _ .R2[IDSYMBOL];
						NAME _ IDTAB;
						PTRVAR _ NEWENTRY();
						PTRVAR[VALTYPE] _ INTEGER;
						PTRVAR[OPERSP] _ FORMLVAR;
						PTRVAR[IDATTRIBUT(NOALLOC)] _ 0;	!LET THIS BE ALLOCATED
						DIMPTR[ARADDRVAR] _ .PTRVAR;
						END;
				   END;
				R2[IDATTRIBUT(DUMMY)]_-1;  !DUMMY ARGUMENT
				IF .FLGREG<PROGTYP> EQL FNPROG  THEN IF .R2<RIGHT> EQL .R1<RIGHT>
				THEN ! ARGUMENT IS SAME AS FUNCTION
				  FATLEX( R2[IDSYMBOL], E71<0,0>);
			END
			ELSE( EXTERNAL  E129;
				  FLGREG<LABLDUM> _ 1;	!SET DUMMY LABLES FLAG
				 IF .FLGREG<PROGTYP>  EQL  FNPROG
				 THEN	WARNLEX (E129<0,0>);
					!ISSUE WARNING BECAUSE FUNCTIONS WITH
					! MULTIPLE RETURNS CANNOT BE REFERENCED
					! AS FUNCTIONS
				 T2[ELMNT]_0 !DUMMY LABEL
				);
			IF .ALST[ELMNT] LEQ 2 THEN ALST_.ALST+1; !IF ARG IS NOT A $ THE SKIP BY 1
		END;SAVSPACE(.T1<LEFT>,@T1);
		!------------------------------------------------------------------------
		!THE FOLLOWING CODE SETS UP T1 AS THE BLT POINTER
		!(SOURCE ADDRESS ^18+ DESTINATION ADDRESS AND T2 AS THE FINAL
		!ADDRESS.  R2 POINTS TO THE BEGINNING OF THE ARG BLOCK CREATED.
		!ITS FIRST WORD CONTAINS THE ARG COUNT.
		!------------------------------------------------------------------------
		STK[2]_0;	!LINK WORD
		T2_.T2-STK[3]<0,0>; !NUMBER OF ARGUMENTS

		% CHECK FOR DUPLICATE ARGUMENTS %
		INCR PRM FROM STK[4]<0,0> TO STK[4]<0,0>+.T2-2
		DO
		BEGIN
			MAP BASE PRM;
			LOCAL BASE PLST:ID1:ID2;
			IF ( ID1 _ @@PRM )  NEQ  0	!IE AN IDENTIFIER
			THEN
			BEGIN
				PLST _ .PRM+1;
				DO
				BEGIN
					IF ( ID2 _ @@PLST ) NEQ 0	!IDENTIFIER
					THEN
					BEGIN
						IF .ID1[IDSYMBOL] EQL  .ID2[IDSYMBOL]
						THEN	RETURN FATLEX(.ID1[IDSYMBOL],E87<0,0>)
					END
				END
				UNTIL	(PLST _ .PLST+1) EQL  STK[3]<0,0>+.T2+1;
			END;
		END;

		STK[3] _ .T2;
		NAME<LEFT> _ T2_ .T2+2; !ARG BLOCK CONTAINS 2+ NUM OF ARGS
		T2_.T2-1+(T1<RIGHT>_R2_CORMAN());
		T1<LEFT>_STK[2]<0,0>; BLT(T1,0,T2);!COPY ARG LIST FROM STACK
	END;
	NAME_IDOFSTATEMENT_ENTRDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
	IF @IDTYPE GEQ 0 THEN( R1[IDATTRIBUT(INTYPE)] _ -1;  R1[VALTYPE]_@IDTYPE);
	IF .TYPE EQL ENT THEN
	BEGIN
		T1[ENTNUM] _ -1;
		%LINK UP THE ENTRY POINTS FOR REL OUTPUT%
		R1[IDENTLNK] _ .MULENTRY;
		MULENTRY _ .R1;
	END;
	R1[IDATTRIBUT(FENTRYNAME)] _ 1; !SET ENTRY NAME BIT

	T1[ENTSYM]_@R1;T1[ENTLIST]_@R2;
	SAVSPACE(.FPNT<LEFT>,@FPNT);
END;
GLOBAL ROUTINE TYPEGEN(TLST) =
BEGIN
	LOCAL BASE T1;
	REGISTER BASE T2; REGISTER BASE R1:R2;
	EXTERNAL SAVSPACE %(SIZE,LOC)%,STK,BLDARRAY %(ONEARRAY LIST POINTER)%;
!-----------------------------------------------------------------------
!	THIS ROUTINE IS CALLED WITH THE PARAMETER TLST
!	POINTING TO A LIST OF ELEMTNTS. EACH
!	ELEMENT POINTS TO A LIST OF SCALAR OR ARRAY DEFINITIONS
!	(ONEARRAY) FOLLOWED BY AN OPTIONAL LIST OF VALUES. UNTIL
!	THE ROUTINES TO HANDLE DATA SPECIFICATIONS HAVE BEEN
!	WRITTEN THESE VALUE LISTS WILL BE IGNORED.
!-----------------------------------------------------------------------
	INCR DLST FROM @TLST TO @TLST+.TLST<LEFT> DO
	BEGIN
		MAP BASE DLST;
		R1_.DLST[ELMNT];
		!IF A VALUELIST IS PRESENT THEN BLDARRAY
		!MUST SAVE ALL THE SCALAR AND ARRAY NAMES IT FINDS, PROBABLY ON THE STACK
		IF BLDARRAY(.R1[ELMNT]) LSS 0 THEN RETURN .VREG;
		IF.R1[ELMNT1] NEQ 0 THEN				!OPTIONAL VALUELIST IS PRESENT
		BEGIN
			FATLEX(E84<0,0>);	!OPTIONAL VALUE LIST NOT SUPPORTED
			T1_.R1[ELMNT2];					!T1_LOC(VALUELIST)
!			T2_.T1[ELMNT1];					!T2_LOC(LIST OF CONSTANTS)
!			INCR CLST FROM @T2 TO @T2+.T2<LEFT> BY 2 DO
!			BEGIN
!				MAP BASE CLST;
!				IF .CLST[ELMNT] EQL 1 THEN		!CONSTANT POSSIBLY A REPEAT COUNT
!				BEGIN
!					R1_.CLST[ELMNT1];
!					IF .R1[ELMNT1] NEQ 0 THEN
!					BEGIN				!SAVE REPEATED CONSTANT SPACE
!						R2_.R1[ELMNT2];SAVSPACE(.R2<LEFT>,@R2)
!					END;
!					SAVSPACE(.R1<LEFT>,@R1);	!SAVE CONSTANT SPACE
!				END;
!			END; SAVSPACE(.T2<LEFT>,@T2);			!SAVE CONSTANT LIST SPACE
			SAVSPACE(.T1<LEFT>,.T1);			!SAVE VALUE LIST SPACE
		END
	END;
END;
GLOBAL ROUTINE TMPGEN (TYPE) =
BEGIN
	EXTERNAL TMPCNT[4],TBLSEARCH %()%;
	BIND TMPNAM=PLIT(
	%0%	SIXBIT 'TM.000',
	%1%	SIXBIT 'MF.000',
	%2%	SIXBIT 'OF.000',
	%3%	SIXBIT 'SZ.000');
	REGISTER BASE R3,R2,R1;MACHOP IDIVI=#231,LSHC=#246;
	R1_.TMPCNT[.TYPE]_.TMPCNT[.TYPE]+1;
	DECR I FROM 2 TO 0 DO (IDIVI(R1,10);LSHC(R2,-6));
	ENTRY[0]_.TMPNAM[.TYPE]+.R3<LEFT>;
	NAME_IDTAB;R3_TBLSEARCH();
	IF .TYPE EQL 0 THEN R3[OPR1]_VARFL;
	RETURN .R3
END;
GLOBAL ROUTINE BLDDIM (SSLST) =
BEGIN
	REGISTER BASE R1:R2:T1;
	LOCAL HISIGN,LOSIGN;
	EXTERNAL NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,IDTYPE,STK,CORMAN %()%,TBLSEARCH %()%,ONEPLIT,FARRY;
	EXTERNAL GENLAB;	!ROUTINE TO ADD A LABEL TABLE ENTRY FOR A COMPILER GENERATED LABEL
	REGISTER T2=2;  MAP BASE T2;
	MAP BASE FARRY;
	EXTERNAL E125,E126;

	EXTERNAL  DTABPTR;		! HEAD OF DIM ENTRY LIST

	LABEL  LDECR, CHECKTHIS;

	MACRO ERR46 = FATLEX(.FARRY[IDSYMBOL], E125<0,0>)$;
	MACHOP BLT=#251;
	!----------------------------------------------------------------------------------------------------------
	!SSLST POINTS TO A LIST OF SUBSCRIPTS OF THE FORM:
	!
	!CHOICE 1 - SUBSCRIPT IS A CONSTANT
	!	CONSTANT (21^18+LOC)
	!CHOICE 2 - SUBSCRIPT IS AN IDENTIFIER
	!	IDENTIFIER (20^18+LOC)
	!OPTION 0 - SUBSCRIPT IS UPPER BOUND, LOWER BOUND IS ONE
	!OPTION 1 - SUBSCRIPT IS LOWER BOUND
	!	COUNT^18+LOC - POINTER TO UPPER BOUND
	!		DIVIDE
	!		CHOICE 1 - SUBSCRIPT IS A CONSTANT
	!			CONSTANT (21^18+LOC)
	!		CHOICE 2 - SUBSCRIPT IS AN IDENTIFIER
	!			IDENTIFIER (20^18+LOC)
	!
	!SINCE THE KNOWLEDGE OF WETHER OR NOT THE DIMENSIONS ARE ADJUSTABLE OR IN ERROR IS NOT KNOWN UNTIL THE
	!LIST HAS BEEN SCANNED, A PSEUDO DIMENSION NODE IS CREATED ON THE UNUSED PORTION OF THE STACK
	! (STK[2] - STK[100]).
	!----------------------------------------------------------------------------------------------------------
	BIND ADJUSTABLE=STK[2],DNUM=STK[3]<LEFT>,ASIZE=STK[3]<RIGHT>,AOFF=STK[4],MF=1,OS=2,SZ=3;

	BIND  DLBL   =  STK [5] <LEFT>,		! TEMP ARADLBL
	      ALINK  =  STK [5] <RIGHT>,	! TEMP ARALINK
	      A0F    =  STK [7] <RIGHT>;	! TEMP DFACTOR (0)


	!----------------------------------------------------------------------------------------------------------
	!OMITTING THE EXTRA CODE TO FETCH CONSTANTS AND STORE VALUES, THE ARRAY SIZE, ARRAY OFFSET, AND
	!SUBSCRIPT MULTIPLICATION FACTOR ARE CALCULATED IN THE FOLLOWING MANNER:
	!
	!IF .IDTYPE GEQ DOUBLPREC THEN WORDSIZE_2 ELSE WORDSIZE_1;
	!ARRAYSIZE_.WORDSIZE;ARRAYOFFSET_0;
	!INCR I FROM 1 TO NUMBEROF DIMENSIONS DO
	!BEGIN
	!	FACTOR(.I)_.ARRAYSIZE;
	!	ARRAYOFFSET_.ARRAYOFFSET+.FACTOR(.I)*.LOWERLIMIT(.I);
	!	SUBSCRIPTSIZE_.UPPERLIMIT(.I)-.LOWERLIMIT(.I)+1;
	!	ARRAYSIZE_.ARRAYSIZE*.SUBSCRIPTSIZE;
	!END;
	!
	!FOR EXAMPLE:
	!
	!DOUBLE PRECISION A(2/5,3/5,4/5)
	!
	!WOULD PRODUCE
	!
	!FACTOR=		2	8	24
	!ARRAYOFFSET=		4	28	124
	!SUBSCRIPTSIZE=		4	3	2
	!ARRAYSIZE=		8	24	48
	!
	!THUS USING BLISS NOTATION, THE SECOND ELEMENT OF A, A(3,3,4) IS
	!.(A+2*3+8*3+24*4-124) WHICH EQUALS .(A+2) . THE ARRAY SIZE SPECIFIES THE
	!NUMBER OF WORDS OCCUPIED BY THE ARRAY, THUS IN THE ABOVE EXAMPLE ARRAY A OCCUPIES LOCATIONS A THRU A+47.
	!----------------------------------------------------------------------------------------------------------

	EXTERNAL INITLTEMP;
	ROUTINE ERRA =
	BEGIN
		RETURN FATLEX(FARRY[IDSYMBOL], E31<0,0>)
	END;
	ROUTINE ERRB (X)=
	BEGIN
		MAP BASE X;
		RETURN FATLEX(.X[IDSYMBOL],E126<0,0>)
	END;

![741] ROUTINE TO GIVE WARNING WHEN / ENCOUNTERED IN
![741] ANY BOUNDS FOR AN ARRAY DECLARATOR

%[741]%	GLOBAL ROUTINE SLASHWARN=
%[741]%	BEGIN
%[741]%		EXTERNAL E145;
%[741]%		WARNERR(.ISN,E145<0,0>); ! USE :, NOT /
%[741]%		RETURN 0
%[741]%	END;

	ROUTINE AJDIMSTK( PTR ) =
	BEGIN
		%SAVE THIS VARIABLE NAME ON A STACK BECAUSE IT IS
		 CURRENTLY NOT IN COMMON OR A DUMMY  BUT IT
		  MIGHT BE AFTER SOME ENTRY
		 STATEMENTS  %
		EXTERNAL	DIMSTK,NAME,CORMAN,LEXLINE;
		REGISTER R1;
	
		NAME<LEFT> _ 2;	!2 WORD ENTRIES
		R1 _ CORMAN();

		IF .DIMSTK  EQL  0
		THEN
		BEGIN
			DIMSTK<LEFT> _ .R1
		END;
		(.R1)<RIGHT> _ .DIMSTK<RIGHT>;
		DIMSTK<RIGHT> _ .R1;
		(.R1+1)<RIGHT> _ .PTR;
		(.R1+1)<LEFT>_ .LEXLINE
	END;

	T2_STK[3]<0,0>;
	IF .IDTYPE GEQ DOUBLPREC THEN ASIZE_2 ELSE ASIZE_1;
	ADJUSTABLE_AOFF_DNUM_0;
	INCR SS FROM @SSLST TO @SSLST+.SSLST<LEFT> DO
	BEGIN
		MAP BASE SS;
		HISIGN_LOSIGN_0;
		T2[DVARFLGS(0)]_0;T1_.SS[ELMNT];
		IF .T1[ELMNT] NEQ 0
		  THEN(IF .T1[ELMNT] EQL 2 THEN HISIGN_-1;
			T1_.T1+2;
		      )
		  ELSE T1_.T1+1;
		R1_.T1[ELMNT1];
		IF .R1[VALTYPE] NEQ INTEGER THEN RETURN ERRA();
		CASE .T1[ELMNT2] OF SET
		BEGIN	!OPTION 0 - LOWER LIMIT IS 1 BY DEFAULT
			T2[DIMENL(0)]_.ONEPLIT;
			IF .T1[ELMNT] EQL 1 THEN
			BEGIN	!CHOICE 1 - R1 = CONSTANT POINTER
				%DO THIS BUSINESS IN CASE OF NEGITIVE PARAMETER VALUES%
				IF .HISIGN NEQ 0
				   THEN R1 _ MAKECNST(INTEGER,0,-.R1[CONST2]); !MAKE NEG CONST NODE
				IF .R1[CONST2] LSS 0 THEN ERR46;!NO NEGATIVE DIMENSION
				!THE FOLLOWING CODE CURES A WHOLE
				! HOST OF PROBLEMS CONCERNING ERROR DETECTION
				! AND RECOVERY DURING DIMENSION PROCESSING, ESPECIALLY
				! REGARDING ARRAYS WHICH ARE TOO LARGE TO HANDLE.
				IF .R1[CONST2] EQL 0
				THEN FATLEX(FARRY[IDSYMBOL],E74<0,0>);
				!DO NOT TEST FOR TOO LARGE A SUBSCRIPT HERE -
				! WILL CATCH THIS LATER ON
				T2[DIMENU(0)]_.R1;
			END
			ELSE
			BEGIN	!CHOICE 2 - R1 = IDENTIFIER POINTER
				LOCAL SAV;
				IF .HISIGN NEQ 0 THEN ERR46;
				SAV _ .R1[IDATTRIBUT(NOALLOC)];	!SAVE IN CASE ITS NOT DUMMY YET
				IF NAMREF(VARIABL1,.R1) LSS 0 THEN RETURN .VREG;
				IF .R1[OPERSP] NEQ FORMLVAR AND NOT .R1[IDATTRIBUT(INCOM)] THEN
				(
				AJDIMSTK(.R1);	! CREATE AN ENTRY
				R1[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
				);
				T2[DVARUBFLG(0)]_1;T2[DIMENU(0)]_@R1;ADJUSTABLE_-1;
			END;
			IF .ADJUSTABLE EQL 0 THEN
			BEGIN
				LOCAL SAV; ! NEED FULL WORD TO TEST OVERFLOW
				EXTERNAL E141; ! NEW ERROR MESSAGE
				NAME_CONTAB;ENTRY[0]_0;ENTRY[1]_.ASIZE;SYMTYPE_INTEGER;
				T2[DFACTOR(0)]_TBLSEARCH();
				!AS THE COMPLETE ARRAY SIZE IS COMPUTED, DO NOT LET
				! IT GET TOO LARGE WITHOUT REPORTING THE ERROR
				AOFF_.AOFF-.ASIZE;
				SAV_.ASIZE*.R1[CONST2]; !FULL WORD SIZE
				IF .SAV GEQ 1^18 THEN FATLEX(.FARRY[IDSYMBOL],E141<0,0>);
				!NOW IT IS SAFE TO PUT THIS INTO A HALF WORD WHETHER
				! OR NOT THERE IS A TRUNCATION!
				ASIZE_.SAV;
			END
			ELSE
			BEGIN
				T2[DVARFACTFLG(0)]_1;T2[DFACTOR(0)]_0;
			END;
		END;
		BEGIN	!OPTION 1 - BOTH LOWER AND UPPER LIMITS ARE SPECIFIED
			LOCAL SAVPTR;	!FOR SAVING PTR FOR CALL TO SAVSPACE
			IF .T1[ELMNT] EQL 2 THEN
			BEGIN	!CHOICE 2 - R1=IDENTIFIER POINTER
				LOCAL SAV;
				IF .HISIGN NEQ 0 THEN ERR46;
				SAV _ .R1[IDATTRIBUT(NOALLOC)];	!SAVE IN CASE ITS NOT DUMMY YET
				IF NAMREF(VARIABL1,.R1) LSS 0 THEN RETURN .VREG;
				IF .R1[OPERSP] NEQ FORMLVAR AND NOT .R1[IDATTRIBUT(INCOM)] THEN
				(
				AJDIMSTK(.R1);	! CREATE AN ENTRY
				R1[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
				);
				T2[DVARLBFLG(0)]_1;ADJUSTABLE_-1;
			END;
			T1_.T1[ELMNT3]; !GET PTR TO UPPER BOUND BLOCK
			SAVPTR _ .T1;	!SAVING PTR FOR SAVSPACE CALL LATER
			IF .R1[OPERSP] EQL  CONSTANT
			THEN
				!DO NOT NEED TO CHECK HERE FOR ARRAY BOUND SIZE
				IF .HISIGN NEQ 0
				   THEN R1 _ MAKECNST(INTEGER,0,-.R1[CONST2]); !MAKE NEG CONST NODE
			T2[DIMENL(0)] _ .R1; !LOWER BOUND
			!T1 NOW POINTS TO UPPER BOUND PART
			!SEE IF IT IS SIGNED 
			!
			IF .T1[ELMNT2] NEQ 0 !ELMNT0-1 IS THE SLASH OR COLON
			  THEN(IF .T1[ELMNT2] EQL 2 THEN HISIGN _ -1 ELSE HISIGN _ 0;
				T1 _ .T1+3;
			      )
			  ELSE (HISIGN_0; T1 _ .T1+2;);
			R2_.T1[ELMNT2];
			IF .R2[VALTYPE] NEQ INTEGER THEN RETURN ERRA();
			IF .T1[ELMNT1] EQL 2 THEN
			BEGIN	!CHOICE 2 - R2 = IDENTIFIER POINTER
				LOCAL SAV;
				IF .HISIGN NEQ 0 THEN ERR46;
				SAV _ .R2[IDATTRIBUT(NOALLOC)];	!SAVE IN CASE ITS NOT DUMMY YET
				IF NAMREF(VARIABL1,.R2) THEN RETURN .VREG;
				IF .R2[OPERSP] NEQ FORMLVAR AND NOT .R2[IDATTRIBUT(INCOM)] THEN
				(
				AJDIMSTK(.R2);	! CREATE AN ENTRY
				R2[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
				);
				T2[DVARUBFLG(0)]_1;ADJUSTABLE_-1;
			END;
			IF .R2[OPERSP] EQL CONSTANT
			THEN
				!DO NOT TEST ON INDIVIDUAL ELEMENTS HERE!
				IF .HISIGN NEQ 0
				  THEN R2 _ MAKECNST(INTEGER,0,-.R2[CONST2]);
			T2[DIMENU(0)]_.R2;
			IF .ADJUSTABLE EQL 0 THEN
			BEGIN
				!ALSO NEED TO CHECK THE CASE WITH UPPER AND
				! LOWER BOUNDS.
				LOCAL SAV;
				EXTERNAL E141; ! ARRAY TOO LARGE
				IF .R1[CONST2] %LOWER BOUND%
					GTR .R2[CONST2] %UPPER BOUND%
					  THEN FATLEX( FARRY[IDSYMBOL],E74<0,0>);

					!ERROR IF LOWER GTR UPPER BOUND
				NAME_CONTAB;ENTRY[0]_0;ENTRY[1]_.ASIZE;SYMTYPE_INTEGER;
				T2[DFACTOR(0)]_TBLSEARCH();
				AOFF_.AOFF-.ASIZE*.R1[CONST2];
				!CHECK FOR TOTAL SPACE NEEDED FOR THIS ARRAY
				SAV_.ASIZE*(.R2[CONST2]-.R1[CONST2]+1);
				IF .SAV GEQ 1^18 THEN FATLEX(.FARRY[IDSYMBOL],E141<0,0>);
				ASIZE_.SAV; !SAFE NOW TO SET UP ASIZE
			END
			ELSE
			BEGIN
				T2[DVARFACTFLG(0)]_1;T2[DFACTOR(0)]_0;
			END;
			SAVSPACE(.SAVPTR<LEFT>,.SAVPTR);
		END
		TES;
		T1_.SS[ELMNT]; !FOR SAVSPACE CALL
		SAVSPACE(.T1<LEFT>,.T1);DNUM_.DNUM+1;T2_.T2+2;
	END;
	!----------------------------------------------------------------------------------------------------------
	!STK[2] THRU STK[(.DNUM+1)*2] NOW CONTAINS A DIMENSION NODE. USE THE CORMAN ROUTINE TO CREATE
	!A REAL DIMENSION NODE AND COPY THE NODE FROM THE STACK.
	!----------------------------------------------------------------------------------------------------------
	IF .ADJUSTABLE NEQ 0 THEN
	   BEGIN
		!--------------------------------------------------------------------------------------------------
		!IF THE DIMENSIONS ARE ADJUSTABLE CREATE A SPECIAL SET OF TEMPS TO BE USED BY ADJ. TO
		!CALCULATE THE MULTIPLICATIVE FACTORS. ALSO SET ADJDIMFLG
		!--------------------------------------------------------------------------------------------------
		!FOR ADJ. THEY MUST BE IN A SPECIAL ORDER
		!ASIZE
		!OFFSET
		!FACTOR N-1
		! .
		! .
		! .
		!FACTOR 1
		EXTERNAL  FATLEX,E137;

	  LOCAL BASE  PTR;
	  LOCAL DIMENTRY  E;

		%CHECK TO SEE IF ADJUSTABLES ARE LEGAL %
		IF .FLGREG<PROGTYP>  NEQ  SUPROG
		  AND  .FLGREG<PROGTYP>  NEQ  FNPROG
		THEN	RETURN FATLEX(E137<0,0>);

		!CHECK FOR ADJUSTABLE ARRAY NOT A DUMMY
		IF NOT .FARRY[IDATTRIBUT(DUMMY)] THEN AJDIMSTK(.FARRY);
		ASIZE_INITLTEMP(INTEGER);
		AOFF<LEFT>_INITLTEMP(INTEGER);

		A0F_ IF .FARRY [DBLFLG]	! SET ELEMENT SIZE
		       THEN MAKECNST (INTEGER, 0, 2)
		       ELSE .ONEPLIT;
		DECR  I  FROM .DNUM - 1  TO 1  DO
LDECR:		  BEGIN
		    T2 _ .T2 - 2;	! DIMSUBENTRY (I)
		    IF .T2 [DFACTOR (0)] NEQ 0
		      THEN LEAVE LDECR;
		    IF NOT .T2 [DVARUBFLG (0)] OR
		       .T2 [DIMENL (0)] NEQ .ONEPLIT  OR
		       .I NEQ 1
		      THEN BEGIN
			T2 [DFACTOR (0)] _ INITLTEMP (INTEGER);
			LEAVE LDECR;
		      END;
		!I == 1 => T2 [...(0)] IS FOR 2ND DIM
		    PTR _ .DTABPTR <RIGHT>;
		    WHILE  .PTR NEQ 0
		      DO BEGIN
			E _ .PTR;
CHECKTHIS:		BEGIN
			  IF .E [DIMNUM] LSS 2
			    THEN LEAVE CHECKTHIS;
			  IF NOT .E [ADJDIMFLG]
			    THEN LEAVE CHECKTHIS;
			  IF .E [DFACTOR (0)] NEQ .A0F	! SAME ELEMENT SIZE
			    THEN LEAVE CHECKTHIS;
			!IF DIM1 SAME THEN SHARE FACTOR FOR DIM2
			  IF .E [DIMENU (0)] EQL .T2 [DIMENU (-1)]  AND
			     .E [DIMENL (0)] EQL .ONEPLIT
			    THEN BEGIN
			      PTR _ .E [DFACTOR (1)];
			      T2 [DFACTOR (0)] _ .PTR;
			      PTR [IDUSECNT] _ .PTR [IDUSECNT] + 1;	! UPDATE SHARING COUNT
			      LEAVE LDECR;
			    END;
			END;	! OF CHECKTHIS
		        PTR _ .E [ARALINK];	! NEXT ENTRY
		      END;	! OF WHILE .PTR NEQ 0
		    PTR _ INITLTEMP (INTEGER);		! NO MATCH FOUND
		    T2 [DFACTOR (0)] _ .PTR;
		    PTR [IDUSECNT] _ 1;			! 1ST USAGE: NO SHARING
		  END;	! OF LDECR
		T2 _ .T2 - 2;		! SUBENTRY (0)
		T2 [DVARFACTFLG (0)] _ 0;
		T2 [ADJDIMFLG] _ 1;

	   END
	   ELSE AOFF<LEFT> _ MAKECNST(INTEGER,0,.AOFF); !MAKE CONST NODE FOR OFFSET VALUE
		SAVSPACE(.SSLST<LEFT>,@SSLST);
!
!NOW MAKE A REAL DIMENSION NODE TRANSFERING THE INFORMATION ON THE
!TEMPORARY STACK (STK) TO THE DIMENSION NODE OF SIZE (.DNUM+1)*2
!
	NAME<LEFT>_T2_DIMSIZ+.DNUM*DIMSUBSIZE;
	T2 _ .T2-1; !ONE LESS FOR UPCOMING BLT
	T2_.T2+(T1_(NAME<RIGHT>_DIMTAB; NEWENTRY()));
	 !ADD THE PTR TO THE NEW DIMENSION NODE TO T2 (THE NUMBER OF WORDS IN THE BLOCK MINUS 1)

	DLBL _ 0;			! FOR SAFETY
	ALINK _ .DTABPTR <RIGHT>;	! LINK THIS ENTRY INTO LIST
	DTABPTR <RIGHT> _ .T1;			! NEW LIST HEAD

	BEGIN LOCAL SAVT1;
		T1<LEFT>_STK[3]<0,0>;
		SAVT1 _.T1; !SAVING T1 INCASE OF BLT INTERRUPT
		BLT(T1,0,T2); !MOVE THE BLOCK TO NEW LOCATION
		T1 _ .SAVT1;
	END;
	IF .FARRY[OPERSP] EQL FORMLARRAY
	THEN
	(  IF .ADJUSTABLE EQL 0
	   THEN BEGIN
		!MAKE A POINTER VARIABLE TO BE A COPY OF ARRAY'S SYMBOL TABLE NODE
		!AND PUT IT IN THE DIMENSON NODE
		LOCAL BASE PTRVAR;
		ENTRY[0] _ .FARRY[IDSYMBOL]; NAME _ IDTAB;
		PTRVAR _ NEWENTRY();
		PTRVAR[IDATTRIBUT(NOALLOC)] _ 0;	!LET THIS BE ALLOCATED
		PTRVAR[VALTYPE] _ INTEGER;
		PTRVAR[OPERSP]  _ FORMLVAR;	!MAKE IT A FORMAL DUMMY
		T1[ARADDRVAR] _ .PTRVAR; !PTR VARIABLE TO DIMENSION NODE
	       END;
	) ELSE T1[ARADDRVAR] _ 0;

	RETURN .T1	!PTR TO DIMENSION NODE
END;
GLOBAL ROUTINE BLDARRAY (LPNT) =
BEGIN
	REGISTER T2=2;  MAP BASE  T2;
	REGISTER BASE T1;REGISTER BASE R2;  LOCAL BASE R1;
	EXTERNAL GENLAB;	!ROUTINE TO ADD A COMPILER GEBERATED LABEL
	EXTERNAL SAVSPACE %(SIZE,LOC)%,IDTYPE,FARRY,TYPE,STK,NAMDEF;
	MACRO ERR4=
	BEGIN
		RETURN  FATLEX( T1[IDSYMBOL],PLIT'VARIABLE',E4<0,0> )
	END$;
	MACRO ERR41=
	BEGIN
		RETURN FATLEX (T1[IDSYMBOL],FARRY[IDSYMBOL],E41<0,0>)
	END$;
	MACRO
	ERR42=RETURN FATLEX(T1[IDSYMBOL], E42<0,0>)$,
	ERR34(X)= RETURN FATLEX ( PLIT'X?0', T1[IDSYMBOL], E34<0,0>)$;
	BIND BASE CBLOCK=STK[2];
	LOCAL POINTER;

	LABEL  OUT, CHECKTHIS;
	EXTERNAL  DTABPTR, ONEPLIT, INITLTEMP;
	LOCAL BASE  PTR;		! TO MARCH DOWN DIM ENTRY LIST
	LOCAL DIMENTRY  E;		! ONE ELEMENT ON THAT LIST

ROUTINE CHKCOMMON ( T1 ) =	!CHECKS COMMON DECLARATIONS
BEGIN
		MAP BASE T1;
			BEGIN	!COMMON STATEMENT
				IF .T1[IDATTRIBUT(INCOM)] THEN ERR42
					ELSE IF .T1[IDATTRIBUT(DUMMY)] THEN ERR34(DUMMY);
				T1[IDATTRIBUT(INCOM)]_1;
				IF .CBLOCK<LEFT> EQL 0 THEN
				BEGIN
					CBLOCK<LEFT>_CBLOCK<RIGHT>_@T1;
				END
				ELSE
				BEGIN
					CBLOCK[IDCOLINK]_@T1;CBLOCK<RIGHT>_@T1;
				END;
			END
END;	!OF CHKCOMMON
	!----------------------------------------------------------------------------------------------------------
	!THE PARAMETER LPNT POINTS TO A LIST OF ONEARRAY'S, THAT IS TO SAY EACH ELEMENT OF THE LIST POINTED TO
	!BY LPNT IS A POINTER TO A LIST OF THE FORM:
	!
	!IDENTIFIER (20^18+LOC) - FIRST ARRAY NAME
	!OPTION 0 OR OPTION 1 - ADDITIONAL ARRAY NAMES AND SUBSCRIPTS FOLLOW
	!	COUNT^18+LOC - LIST POINTER
	!VARIABLE TYPE - ONLY IF THIS IS A TYPE STATEMENT
	!
	!THE LOCATION IDTYPE CONTAINS THE VARIABLE TYPE TO BE SET IN EACH ARRAY NAME. IF IDTYPE IS LESS THAN ZERO,
	!NO TYPE IS SPECIFIED AND AN OPTION 0 (NO SUBSCRIPTS) IS ILLEGAL. IDTYPE IS SET LESS THAN ZERO FOR
	!DIMENSION, AND GLOBAL STATEMENTS.
	!IDTYPE FOR TYPE STATEMENTS IS NOW IN THE TREE IN ORDER TO IMPLIMENT THE *N TYPE OVERRIDE FEATURE
	!----------------------------------------------------------------------------------------------------------
	INCR OA FROM .LPNT TO .LPNT+.LPNT<LEFT> DO
	BEGIN
		MAP BASE OA;	!OA STANDS FOR ONEARRAY
		R1_.OA[ELMNT];
		FARRY_T1_.R1[ELMNT];
		IF .TYPE EQL  4 %TYPE STATEMENT%
		THEN
		BEGIN
			IDTYPE _ .R1[ELMNT1];	!GET TYPE FROM TREE - POSSIBLE *N CONSTRUCT
			R1 _ .R1 + 1;	!SKIP TYPE
		END
		ELSE
			IDTYPE_.T1[VALTYPE];
		IF .R1[ELMNT1] EQL 0 THEN
		BEGIN	!OPTION 0 - NO SUBSCRIPTS
			CASE .TYPE OF SET
			ERR4;	!DIMENSION
			BEGIN	!GLOBAL
				!IF .T1[IDATTRIBUT(INCOM)]THEN ERR34(COMMON)
				!	ELSE IF .T1[IDATTRIBUT(INEXTERN)]THEN ERR34(EXTERNAL);
				!T1[IDATTRIBUT(INGLOB)]_1
			END;
			BEGIN	!EXTERNAL
				!GONE
			END;
			BEGIN	!PROTECT
				!GONE
			END;
			BEGIN	!TYPE STATEMENT
				LOCAL DUB;	!SET TO 4 FOR CONVERSION TO
						! DOUBLE PRECISION AND
						!TO 1 FOR CONVERSION TO
						!SINGLE PECISION
				LABEL ADJ;
				IF .T1[IDDIM] NEQ 0
				THEN
				ADJ:BEGIN
					IF .IDTYPE GEQ DOUBLPREC
					THEN 
					BEGIN
						IF .T1[VALTYPE] LSS DOUBLPREC
						THEN 	DUB _ 4
						ELSE	LEAVE ADJ
					END
					ELSE
					BEGIN
						IF .T1[VALTYPE] GEQ DOUBLPREC
						THEN	DUB _ 1	!CONVERT TO SINGLE PRECISION
						ELSE	LEAVE ADJ
					END;
					R2 _ .T1[IDDIM];
					IF NOT .R2[ADJDIMFLG]
					THEN
					BEGIN
					       R2[ARASIZ] _ (.R2[ARASIZ]*.DUB ) / 2;
						T2 _ .R2[ARAOFFSET];
						R2[ARAOFFSET] _ MAKECNST(INTEGER,0,( .T2[CONST2] * .DUB ) / 2 );
						DECR I FROM .R2[DIMNUM]-1 TO 0 DO
						BEGIN
						   T2 _ .R2[DFACTOR(.I)];
						   R2[DFACTOR(.I)] _ MAKECNST(INTEGER,0, ( .T2[CONST2] * .DUB ) / 2 );
						END
					END
					ELSE
					BEGIN !DO ONLY FOR FIRST FACTOR IF ADJUSTABLE
%[627]%						DECR I FROM .R2[DIMNUM]-1 TO 0 DO
%[627]%							IF NOT .R2[DVARFACTFLG(.I)] THEN
%[627]%							BEGIN
%[627]%								T2 _ .R2[DFACTOR(.I)];
%[627]%								R2[DFACTOR(.I)] _ MAKECNST(INTEGER,0, ( .T2[CONST2] * .DUB ) / 2 );
%[627]%							END;
	OUT:					BEGIN
						  IF .R2 [DIMNUM] LSS 2	
						    THEN LEAVE OUT;
						  IF NOT .R2 [DVARUBFLG (1)]
						    THEN LEAVE OUT;
						  IF .R2 [DIMENL (1)] NEQ .ONEPLIT
						    THEN LEAVE OUT;
						  T2 _ .R2 [DFACTOR (1)];
						  T2 [IDUSECNT] _ .T2 [IDUSECNT] - 1;
						  IF .T2 [IDUSECNT] EQL 0
						    THEN T2 [IDATTRIBUT (NOALLOC)] _ 1;	! NOT SHARED NOW: DON'T ALLOC
						  PTR _ .DTABPTR<RIGHT>;
						  WHILE .PTR NEQ 0
						    DO BEGIN
						      E _ .PTR;
	CHECKTHIS:				      BEGIN
							IF .E EQL .R2		! DON'T SHARE WITH YOURSELF
							  THEN LEAVE CHECKTHIS;
							IF .E [DIMNUM] LSS 2
							  THEN LEAVE CHECKTHIS;
							IF NOT .E [ADJDIMFLG]
							  THEN LEAVE CHECKTHIS;
							IF .E [DFACTOR (0)] NEQ .R2 [DFACTOR (0)]	! SAME ELEMENT SIZE ?
							  THEN LEAVE CHECKTHIS;
							IF .E [DIMENU (0)] NEQ .R2 [DIMENU (0)]
							  THEN LEAVE CHECKTHIS;
							IF .E [DIMENL (0)] NEQ .ONEPLIT
							  THEN LEAVE CHECKTHIS;
	!		DIM 1 SAME: SHARE FACTOR FOR DIM2
							PTR _ .E [DFACTOR (1)];
							R2 [DFACTOR (1)] _ .PTR;
							PTR [IDUSECNT] _ .PTR [IDUSECNT] + 1;	! UPDATE SHARING COUNT
							LEAVE OUT;
						      END;	! OF CHECKTHIS
						      PTR _ .E [ARALINK];	! NEXT ENTRY
						    END;	! OF WHILE .PTR NEQ 0
						  IF .T2 [IDUSECNT] EQL 0	! NO MATCH FOUND
						    THEN T2 [IDATTRIBUT (NOALLOC)] _ 0	! USE OLD .I WHICH WAS DEALLOCED
						    ELSE T2 _ INITLTEMP (INTEGER);	! GET NEW .I TEMP
						  R2 [DFACTOR (1)] _ .T2;
						  T2 [IDUSECNT] _ 1;		! 1ST USAGE: NO SHARING
						END;	! OF OUT
					END
				END;	!ADJ BLOCK
				IF NAMDEF(IDDEFT, .T1) LSS 0 THEN RETURN .VREG;
				T1[IDATTRIBUT(INTYPE)] _ 1;
				T1[VALTYPE]_.IDTYPE;
				R1 _ .R1 -1	!RESTORE FOR SAVSPACE
			END;
			BEGIN	%COMMON%
				IF NAMDEF( VARARY, .T1) LSS 0 THEN RETURN .VREG;
				CHKCOMMON(.T1);	!ROUTINE TO CHECK COMMON DECLARATION
			END
			TES;
		END
		ELSE

		BEGIN	!OPTION 1 - ARRAY NAMES AND SUBSCRIPTS
			MAP BASE FARRY;
			LOCAL SAVSTK;
			MACRO IDCHECK =
			BEGIN
				CASE @TYPE OF SET
				BEGIN	%DIMENSION%
					IF NAMDEF(ARRYDEF,.T1) LSS 0 THEN RETURN .VREG
				END;
				BEGIN	!GLOBAL
					!IF .T1[IDATTRIBUT(INCOM)] THEN ERR34(COMMON)
					!	ELSE IF .T1[IDATTRIBUT(INEXTERN)] THEN ERR34(EXTERNAL);
					!T1[IDATTRIBUT(INGLOB)]_1
				END;
				BEGIN	!EXTERNAL
				END;
				BEGIN	!PROTECT
				END;
				BEGIN	!TYPE STATEMENT
					IF NAMDEF(ARRYDEFT,.T1) LSS 0 THEN RETURN .VREG;
					T1[IDATTRIBUT(INTYPE)] _ 1;
					T1[VALTYPE]_.IDTYPE;
					R1 _ .R1-1	!RESTORE FOR SAVSPACE
				END;
				BEGIN	%COMMON%
					IF NAMDEF (ARRYDEF,.T1) LSS 0 THEN RETURN .VREG;
					IF CHKCOMMON(.T1) LSS 0 THEN RETURN .VREG;	!CHECK COMMON DECLARATIONS
				END
				TES;
				IF .T1[OPERSP] EQL VARIABLE THEN T1[OPERSP]_ARRAYNAME
					ELSE T1[OPERSP]_FORMLARRAY;
			END$;
			R2 _ .R1[ELMNT2];
			IDCHECK;
			SAVSTK_.STK[2]; !SAVING COMMON LIST POINTERS IF PROCESSING COMMON LISTS

			IF (T2_BLDDIM(.R2[ELMNT])) LSS 0 THEN RETURN .VREG
				ELSE
				BEGIN
					 FARRY[IDDIM]_.T2;
					IF .FLGREG<BOUNDS>	!IF SS BOUNDS CHECKING IS TO BE PERFORMED
								! ON ALL ARRAYS (USER "BOUNDS" SWITCH)
						OR .FLGREG<DBGDIMN>	!OR THE "DEBUG" SWITCH WAS SPECIFIED
					THEN T2[ARADLBL]_GENLAB();	!GENERATE A LABEL TO GO ON THE BLOCK
							! THAT WILL BE OUTPUT DESCRIBING THE DIMENSION
							! INFORMATION FOR THIS ARRAY
				END;
			STK[2]_.SAVSTK;


		END;SAVSPACE(.R1<LEFT>,@R1);
	END;SAVSPACE(.LPNT<LEFT>,@LPNT);
END;
GLOBAL ROUTINE BLKSRCH	(BLKNAME)=
BEGIN
	REGISTER BASE R1:R2;
	EXTERNAL NEWENTRY %()%,COMBLKPTR;
	!---------------------------------------------------------------------------------
	!THIS ROUTINE FINDS OR CREATES THE COMMON BLOCK "NAME" AND
	!RETURNS A POINTER TO IT.
	!---------------------------------------------------------------------------------
	R1_.COMBLKPTR<LEFT>;
	UNTIL .R1 EQL 0 DO
	BEGIN
		IF .R1[COMNAME] EQL .BLKNAME THEN RETURN .R1;
		R1_.R1[NEXCOMBLK];
	END;
	ENTRY[0]_.BLKNAME;
	NAME_COMTAB;R2_NEWENTRY();
	RETURN .R2
END;
GLOBAL ROUTINE BLDVAR (VPNT)=
BEGIN
	LOCAL  BASE T2;
	GLOBAL SETUSE;	! SET TO SET/USE BY CALLER
	REGISTER  BASE	T1;REGISTER BASE R1:R2;
	EXTERNAL SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,ARRXPND %(NAME,SUBSCRIPTS)%;
	!--------------------------------------------------------------------------
	!THE PARAMETER VPNT POINTS TO THE LIST:
	!
	!IDENTIFIER (20^18+LOC) - THE SCALAR OR ARRAY VARIABLE
	!OPTION 0 OR OPTION 1 - SUBSCRIPTS FOLLOW
	!		1^18+LOC - POINTER TO SUBSCRIPT LIST POINTER
	!			COUNT^18+LOC - POINTER TO A LIST OF SUBSCRIPT EXPRESSIONS
	!--------------------------------------------------------------------------
	T1_.VPNT;T2_.T1[ELMNT];!T2_LOC(IDENTIFIER)
	IF .T1[ELMNT1] EQL 0 THEN
	BEGIN	%SCALAR%
		IF .SETUSE EQL  SETT
		THEN	NAMSET(VARYREF, .T2)
		ELSE	NAMREF(VARYREF,.T2);
		IF .VREG LSS 0 THEN T2 _ -1
		ELSE T2<LEFT>_IDENTIFIER	! USED BY ASSISTA AND GOTO - EVERYONE ELSE WILL
						! ACCEPT AN UNSUBSCRIPTE ARRRAY REF HERE
	END
	ELSE
	BEGIN
		IF .SETUSE EQL  SETT
		THEN	NAMSET(ARRAYNM1, .T2)
		ELSE	NAMREF(ARRAYNM1, .T2);
		IF .VREG LSS 0 THEN RETURN .VREG;
		R1_.T1[ELMNT2];R2_.R1[ELMNT];SAVSPACE(0,@R1); !CHANGED 1 TO 0
		INCR SCR FROM @R2 TO @R2+.R2<LEFT> DO
		BEGIN
			MAP BASE SCR;MACRO SCRFLGS=0,0,LEFT$,SCRPTR=0,0,RIGHT$;
			R1_.SCR[ELMNT];			SCR[SCRPTR]_@R1;SCR[SCRFLGS]_0;
		END;
		IF (T2_ARRXPND(@T2,@R2)) GTR 0
		THEN	T2<LEFT>_ARRAYREF;
	END;
	SAVSPACE(.VPNT<LEFT>,@VPNT);
	RETURN .T2!RETURN POINTER TO SCALAR OR ARRAY EXPRESSION
END;
GLOBAL ROUTINE DATALIST (LPNT)=
BEGIN
	LOCAL  BASE T2;
	REGISTER BASE T1;REGISTER BASE R1:R2;
	EXTERNAL TBLSEARCH,SP,DOXPN;
	EXTERNAL BLDVAR%(VPNT)%,SAVSPACE %(SIZE,LOC)%,TYPE,ONEPLIT,STK,CORMAN %()%;
	EXTERNAL SETUSE;
	EXTERNAL GENLAB,NEWENTRY,DATASUBCHK;

	EXTERNAL  CKDOINDEX;		! CHECK DO INDEX ALREADY ACTIVE
	EXTERNAL  DOCHECK;		! REMOVE DO LABEL FROM ACTIVE DO LIST
	EXTERNAL  E21;			! DO INDEX ALREADY ACTIVE MESSAGE

	MACRO  ADDOLAB (X,Y) =		! PUT INDEX ON ACTIVE DO LIST
		BEGIN
		EXTERNAL  LASDOLABEL;	! PTR TO END LABEL,,INDEX OF MOST RECENT DO
		EXTERNAL  CURDOINDEX;	! PTR TO CURRENT DO INDEX VARIABLE
		LOCAL BASE  TEMP;
			NAME<LEFT> _ 2;			! LINK IN NEW LABEL
			TEMP _ CORMAN ();
			TEMP [ELMNT] _ .LASDOLABEL;	! SAVE LAST
			TEMP [ELMNT1] _ .CURDOINDEX;	! SAVE INDEX
			LASDOLABEL<LEFT> _ .TEMP;
			LASDOLABEL<RIGHT> _ X;
			CURDOINDEX _ Y;			! INDEX PTR
		END$;

	LOCAL SAVEBOUNDSFLG;	! TO SAVE THE VALUE OF THE "BOUNDS"
				! SWITCH WHILE PROCESSING THE DATA
				! LIST FOR A DATA STMNT
	MACRO
	ERR38=(RETURN FATLEX(E38<0,0>))$, !INDEX VARIABLE NOT VARIABLE
	ERR44=RETURN FATLEX(TDOSYM[IDSYMBOL],E44<0,0>)$;
	!
	!MACROS FOR DATALIST NODE GENERATION FOR IOLISTS,DATA LISTS
	!
	MACRO SIZOFARRAY=
	BEGIN
	  IF NOT .SYMBL[DBLFLG]
		THEN(IF NOT .T2[ADJDIMFLG]
			THEN MAKECNST(INTEGER,0,.T2[ARASIZ])
			ELSE .T2[ARASIZ]	!PTR TO TEMP FOR ADJ DIMENSION
		    )
		ELSE(IF NOT .T2[ADJDIMFLG]
			THEN MAKECNST(INTEGER,0,.T2[ARASIZ]/2)
			ELSE(	NAME _ EXPTAB;
				T1 _ NEWENTRY();
				!MAKE A DIVIDE NODE .T2[ARASIZ]/2
				T1[ARG1PTR] _ .T2[ARASIZ];
				T1[ARG2PTR] _ MAKECNST(INTEGER,0,2);
				T1[A1VALFLG] _ T1[A2VALFLG] _ 1; !SETTING FLAGS
				T1[OPERATOR] _ INTDIVIDE;
				T1[PARENT] _ .R1;	!POINTS BACK TO DATA LIST NODE
				.T1	!PTR TO ASSIGN TO SCALLCT
			    )
		     )
	END$;
	MACRO IODATANODE(X)=
%[635]%	BEGIN
		NAME _ IOLTAB;	!IOLIST TABLE
		R1_X;
		T2 _ .R1[ELMNT];
		IF .TYPE EQL READD THEN
		SETUSE _ SETT	!BLDVAR FLAG
		ELSE
		IF .TYPE EQL DATALST THEN
		  BEGIN
			SETUSE _ SETT;
			IF .T2[IDATTRIBUT(INDATA)] EQL 1	!SEE IF IT'S
			AND .T2[IDDIM] EQL 0	!NOT AN ARRAY BUT
			THEN		!ALREADY IN A DATA STATEMENT
			FATLEX(T2[IDSYMBOL],E139<0,0>);	!WARN HIM
			T2[IDATTRIBUT(INDATA)] _ 1;
%[635]%			IF .T2[IDATTRIBUT(DUMMY)] THEN RETURN FATLEX( T2[IDSYMBOL],E66<0,0>);
		   END
		   ELSE	SETUSE _ USE;

		IDOFSTATEMENT _  IF .R1[ELMNT1] NEQ 0 THEN DATACALL
					ELSE (R1_.R1[ELMNT]; !PTR TO SYMBOL
						IF .R1[IDDIM] NEQ 0 THEN (NAME<LEFT>_ 3;SLISTCALL) ELSE DATACALL
					    );
		R1_NEWENTRY();
		R1[OPERSP] _ .IDOFSTATEMENT;  !DATACALL OR SLISTCALL
		IF .LISTLINK EQL 0
		  THEN (LISTLINK<LEFT>_LISTLINK<RIGHT>_.R1)
		  ELSE (LISTLINK[CLINK] _ .R1; LISTLINK<RIGHT>_.R1);
		R1[OPRCLS] _ IOLSCLS;	!IOLIST CLASS
		R1[DCALLELEM] _ BLDVAR(X);
		IF .VREG LSS 0 THEN (R1[DCALLELEM] _ 0; RETURN -1); !VREG IS -1 IF BLDVAR FOUND AN ERROR
		IF .R1[OPERSP] EQL SLISTCALL
		THEN BEGIN
			LOCAL BASE SYMBL;
			!FIX UP OPERSP BECAUSE NEWENTRY
			!HAS SET SRCID
			R1[SRCID]_0;
			R1[OPERSP]_SLISTCALL;
			SYMBL _ .R1[DCALLELEM];
			T2 _ .SYMBL[IDDIM]; !PTR TO DIMENSION NODE
			R1[SCALLCT] _ SIZOFARRAY;	!PTR TO NODE CONTAINING NUM OF ELEMENTS IN ARRAY
		    END;
	END$;
	MACRO IODONODE(X)=
	BEGIN
		IDOFSTATEMENT_NAME_DODATA;
		NAME<RIGHT> _ IOLTAB;
		T1_NEWENTRY();
		T1[CLINK]_ .X<LEFT>; X<LEFT>_ .T1;
		T1[OPRCLS]_STATEMENT;
		T1[DOLBL] _ .IOLBL;	!PSEUDO LABEL MADE BY IOCONTNODE
		T2_.IOLBL[SNDOLNK]; 
		IOLBL[SNDOLVL] _ .IOLBL[SNDOLVL]+1;
		NAME<LEFT> _ 1; IOLBL[SNDOLNK] _ CORMAN();
		(.VREG)<LEFT>_.T1; (.VREG)<RIGHT>_.T2; !LINKING IN ENDING LBL TO DO NODE AND LABEL TABLE
	END$;
	MACRO IOCONTNODE =
	BEGIN
		IDOFSTATEMENT_NAME_CONTDATA;	!NODE IDENTIFICATION AND SIZE
		NAME<RIGHT> _ IOLTAB;
		T1_NEWENTRY();
		T1[OPRCLS]_STATEMENT;
		IOLBL _ T1[SRCLBL]_ GENLAB();
		IOLBL[SNREFNO]_2;	!REFERENCE COUNT OF 2
		IOLBL[SNHDR] _ .T1	!PTR TO CONTINUE IN LABEL TABLE NODE
	END$;

	MACRO ADDCONTNODE (X) =
 BEGIN
		T1 _ .IOLBL [SNHDR];	! GET NODE FROM IOCONTNODE
		X [CLINK] _ .T1;	! LINK IN CONT NODE AT END OF LOOP
		X<RIGHT> _ .T1;		! POINT TO NEW END OF DATALIST
	END$;

	LOCAL BASE LISTLINK;	!PTR TO FIRST<LEFT> AND LAST<RIGHT> NODES IN DATALIST CHAIN
	!---------------------------------------------------------------------
	!THIS ROUTINE IS CALLED WITH LPNT POINTING TO A LIST OF
	!DATAITEMS.  EACH DATAITEM CONSISTS OF:
	!
	!CHOICE-1
	!	DATAITEM-(LOC)
	!CHOICE-2
	!	LIST-(COUNT^18+LOC)
	!		DATAITEM
	!	OPTION-0 OR
	!	OPTION-1
	!		LOOPPART
	!---------------------------------------------------------------------
	SAVEBOUNDSFLG_.FLGREG<BOUNDS>;	!PRESERVE THE VALUE OF THE "BOUNDS"
			! SWITCH (USED BY THE USER TO REQUEST ARRAY BOUNDS CHECKING)
	IF .TYPE EQL DATALST	!IF WE ARE PROCESSING THE DATA LIST FOR A DATA STATEMENT
				! (NOT AN IO STMNT)
	THEN
	FLGREG<BOUNDS>_0;	!TURN OFF THE BOUNDS FLAG UNTIL ARE THROUGH WITH THIS STMNT
				! (ELSE THE ARRAY SS CALC WILL BE TURNED INTO A CALL TO
				! A RUN-TIME FUNCTION)
	LISTLINK_0;	!INITIALIZING FOR LIST INPARENS
	INCR DATLST FROM @LPNT TO @ LPNT+.LPNT<LEFT> BY 2 DO
	BEGIN
		MAP BASE DATLST;
		IF .DATLST[ELMNT] EQL 1 THEN	!A DATAITEM
		BEGIN
			IODATANODE(.DATLST[ELMNT1]);
		END
		ELSE	!AN IMPLIED DO LOOP OR LIST ENCLOSED IN PARENS
		BEGIN
			LOCAL BASE LNKLST; !TEMPORARY HOLDER OF LINKLIST
			LOCAL BASE TDOSYM; !TEMPORARY HOLDER OF DO INDEX SYMBOL PTR
			EXTERNAL  E128;
			LOCAL  BASE DONOD:IOLBL;	!LABEL OF CONTINUE ENDING IMPLIED DO LOOP
			LNKLST _ 0;  !INIT LOCAL
			R1_.DATLST[ELMNT1];R2_.R1[ELMNT];  !R2_LOC(DATAITEM LIST)
			IF .R1[ELMNT1] NEQ 0
			 THEN (!IMPLIED DO LOOP COMING UP ; R2 HAS PTR  TO IMPLIED  DO LIST
				%FIRST CHECK TO SEE THAT THERE HAVE BEEN
				 SOME VARIABLES FOR THIS DO SPEC %
				IF .R2<LEFT>  EQL  1  
				THEN	RETURN FATLEX (E128<0,0>);
				T1_@R2+.R2<LEFT>;
				T2 _ .T1[ELMNT];
				IOCONTNODE ;		! GEN A CONTINUE NODE
				%DON'T LET SUBSCRIPTED IMPLICIT DO INDECES GO UNDETECTED%
				IF .T2[ELMNT1]  NEQ  0  THEN RETURN FATLEX(E115<0,0>);
				T2 _ TDOSYM _ .T2[ELMNT];
				IF .T2[OPRCLS] NEQ DATAOPR THEN ERR38
				  ELSE IF .T2[OPRSP1] NEQ VARIABL1 THEN ERR38;
				IF .T2[VALTYPE] NEQ INTEGER THEN RETURN FATLEX(E104<0,0>);
				IF .TYPE EQL DATALST
				THEN
				  BEGIN
					STK[SP_.SP+1] _.T2; !SAV PTR TO INDEX SYMBOL ON STACK
				  END
				ELSE BEGIN
				  IF NAMSET (VARIABL1,.T2) LSS 0
				    THEN RETURN .VREG;
				END;

				IF CKDOINDEX (.T2)
				  THEN RETURN FATLEX (T2 [IDSYMBOL], E21<0,0>);	! DO INDEX ALREADY ACTIVE
				ADDOLAB (.IOLBL, .T2);	! THIS INDEX IS CURRENTLY MOST ACTIVE

				R2<LEFT>_.R2<LEFT>-2; !RESET LIST PTR SO THAT LAST ITEM (INDEX PTR)
							!DOESN'T GET PROCESSED AS AN IODATANODE
				);
			IF (LNKLST _ DATALIST (.R2)) LSS 0
			  THEN BEGIN
			    T2 _ .VREG;
			    IF .R1 [ELMNT1] NEQ 0	! IMPLIED DO LOOP
			      THEN DOCHECK (.IOLBL);	! REMOVE LABEL FROM ACTIVE DO LIST
			    RETURN .T2;
			  END;
			IF .R1[ELMNT1] NEQ 0 THEN	!IMPLIED DO LOOP
			BEGIN
				DOCHECK (.IOLBL);	! REMOVE LABEL FROM ACTIVE DO LIST
				ADDCONTNODE (LNKLST);	! LINK IN CONT NODE
				IODONODE(LNKLST);	!GEN A DO LOOP NODE
				DONOD_.LNKLST<LEFT>; !SET UP BY IODONODE
				DONOD[DOSYM]_.TDOSYM;	!STK[2]_LOC(INDEX VARIABLE)
				R2_.R1[ELMNT2]; SAVSPACE(.R1<LEFT>,.R1); !R2_LOC(LOOPPART)
				R1_.R2[ELMNT];
				!R1 POINTS TO INITIAL VALUE
				IF .TYPE EQL DATALST THEN
					 IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
				IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
				DONOD[DOM1]_@R1;R1_.R2[ELMNT1];	!_LOC(INITIAL VALUE)
				!R1 POINTS TO FINAL VALUE
				IF .TYPE EQL DATALST THEN
					 IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
				IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
				DONOD[DOM2]_@R1;	!_LOC(FINAL VALUE)
				IF .R2[ELMNT2] EQL 0 THEN	!INPLIED INCREMENT OF 1
				BEGIN
					DONOD[DOM3]_.ONEPLIT;
				END
				ELSE	!INCREMENT SPECIFIED
				BEGIN
					T1_.R2[ELMNT3];R1_.T1[ELMNT];SAVSPACE(0,.T1);
					IF .TYPE EQL DATALST THEN
						IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
					IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
					DONOD[DOM3]_.R1<RIGHT>;
				END;
				IF .TYPE EQL DATALST
				THEN IF .SP GTR 0
					THEN (	DATASUBCHK(.DONOD[CLINK],.SP,STK[1]<0,0>);
						SP _ .SP-1;
					     );
				SAVSPACE(.R2<LEFT>,.R2);
			END;
			IF .LISTLINK EQL 0
			THEN LISTLINK_.LNKLST
			ELSE (LISTLINK[CLINK]_.LNKLST<LEFT>;
				LISTLINK<RIGHT> _ .LNKLST<RIGHT>
			     );
		END;
	END;
	FLGREG<BOUNDS>_.SAVEBOUNDSFLG;	!RESTORE THE "BOUNDS" FLAG TO ITS ORIGINAL VAL
	RETURN .LISTLINK	!POINTS TO FIRST ELEMENT IN LIST
END;
GLOBAL ROUTINE BLDFORMAT (FPNT)=
BEGIN
	REGISTER BASE T1:T2; MAP BASE FPNT;REGISTER BASE R1:R2;
	GLOBAL NAMLSTOK;	!SET TO 1 BY CALLER IF NAMELIST IS A VIABLE ARGUMENT
	EXTERNAL SAVSPACE %(SIZE,LOC)%,STK,BLDVAR %(VPNT)%,TBLSEARCH %()%,
		 TYPE;
	MACRO
	ERR25=(RETURN FATLEX(E25<0,0>))$,
	ERR19=(RETURN FATLEX(E19<0,0>))$,
	ERR15(X)=BEGIN
			RETURN FATLEX( X,R2[IDSYMBOL],E15<0,0>)
		END$,
	ERR34=RETURN FATLEX(PLIT'PARAMETER',R2[IDSYMBOL],E34<0,0>)$;
	ROUTINE EOE=
	BEGIN
		!--------------------------------------------------------------------------------------------------
		!R2=LOC (END OR ERR IDENTIFIER)
		!T1=LOC (LABEL CHOICE)
		!T2=LOC (LABEL )
		!--------------------------------------------------------------------------------------------------
			EXTERNAL NONIOINIO,LABREF;
			% THESE LABELS ARE PICKED UP AS CONSTANTS AND THEN
			  CONVERTED TO LABELS BECAUSE THEY ARE EXECUTABLE
			  LABEL REFERENCES IN AN IO STATEMENT  %
			IF .T2[VALTYPE] NEQ INTEGER
			THEN RETURN FATLERR(.LEXNAM[LABELEX],.LEXNAM[CONSTLEX],.ISN,E0<0,0>);
			NONIOINIO _ 1;
			ENTRY[1] _ .T2[CONST2];
			T2 _ LABREF();
			T2[SNREF] _ .T2[SNREF]-1;	!DON'T COUNT REFERENES
							!TO FORMAT LABELS IN I/O STATEMENTS
		SAVSPACE(.T1<LEFT>,@T1);
		IF .R2[IDSYMBOL] EQL SIXBIT 'END' THEN
			(IF .STK[6] EQL 0 THEN STK[6]_@T2 ELSE ERR34)
			ELSE IF .R2[IDSYMBOL] EQL SIXBIT 'ERR' THEN
				(IF .STK[5] EQL 0 THEN STK[5]_@T2 ELSE ERR34)
					ELSE ERR15 (PLIT'END OR ERR ');
	END;
	!----------------------------------------------------------------------------------------------------------
	!THIS ROUTINE IS CALLED WITH THE PARAMETER FPNT POINTING TO
	!A FORMAT SPECIFICATION.  SEE EXPANSION OF METASYMBOL IOSPEC FOR
	!DETAILS.  THE FORMAT POINTER IS RETURNED IN STK[4].  IT MAY BE
	!A LABEL (LOC), ASTERISK - STANDARD FORMAT CONVERSIONS (-1)
	!AN ARRAY NAME OR NAMELIST NAME (LOC[IDENTIFIER]) OR NOT SPECIFIED (0).
	!THE END AND ERR BRANCH LOCATIONS ARE RETURNED IN STK[6] AND STK[5]
	!RESPECITVELY.  THEY MAY BE LABELS (LOC), VARIABLES (LOC) OR NOT
	!SPECIFIED (0).
	!----------------------------------------------------------------------------------------------------------
	CASE .FPNT[ELMNT] OF SET
	0;!NEVER OCCURS,INSERTED FOR SPEED ONLY
	BEGIN!LABEL
		IF .STK[4]  NEQ  0  THEN  RETURN FATLEX(E39<0,0>);	! ALREADY FOUND ONE
		STK[4]_.FPNT[ELMNT1];
	END;
	BEGIN!ARRAY NAME NAMELIST NAME OR END/ERR
		R1_.FPNT[ELMNT1];
		%FLAG BEING SET INDICATES THAT BLDFORMAT WAS CALLED FROM
		  READ OR WRITE AND THUS HAS A SLIGHTLY DIFFERENT
		  SYNTAX TREE, POSSIBLY INCLUDING END/ERR=  %

		R2 _ IF .FLAG EQL  0 THEN .R1[ELMNT] %READ OR WRITE% ELSE .R1;
		IF (.R1[ELMNT1] EQL 0) OR (.FLAG NEQ 0)  THEN !ARRAY NAME OR NAMELIST NAME
								!OR NO END= OR ERR= EXPECTED
		BEGIN
			IF .STK[4] NEQ 0 THEN RETURN FATLEX(E39<0,0>);
			IF .R2[OPRSP1] EQL ARRAYNM1
			THEN
			BEGIN
				STK[4]_.R2;
				IF .TYPE EQL READD
				THEN	NAMSET(ARRAYNM1, .R2)
				ELSE	NAMREF(ARRAYNM1, .R2);
				IF .VREG LSS 0 THEN RETURN .VREG;
			END
			ELSE IF .NAMLSTOK NEQ 0 THEN
				IF .R2[IDATTRIBUT(NAMNAM)]
				THEN
				BEGIN
					LOCAL NAMROUT; !TO PUT ROUTINE TO CALL
					LOCAL BASE NMLST:NAMCOM;
					STK[4]_@R2;
					IF NAMREF( NMLSTREF,.R2) LSS 0 THEN RETURN .VREG;
					%NOTE REFERENCE OR SETTING OF EACH ITEM IN LIST %
					NAMROUT _ IF .TYPE EQL READD THEN NAMSET ELSE NAMREF; !DETERMINE ROUTINE TO CALL
					NAMCOM_.R2[IDCOLINK]; !GET POINTER TO NAMELIST NODE
					NMLST_.NAMCOM[NAMLIST]; !GET POINTER TO LIST OF ITEMS
					WHILE .NMLST LSS (.NAMCOM[NAMLIST] + .NAMCOM[NAMCNT]) DO
					BEGIN
					R1 _ .NMLST[ELMNT];
					(.NAMROUT)(.R1[OPRSP1],.R1); !CALL THE ROUTINE
					NMLST _ .NMLST+1; !NEXT ITEM
					END;	!OF WHILE ... DO
					R1 _ .FPNT[ELMNT1]; !RESTORE R1
				END
					ELSE ERR15(PLIT'ARRAY OR NAMELIST NAME')
				ELSE ERR15(PLIT'ARRAY NAME');
		END
		ELSE !END=/ERR=
		BEGIN
			T1_.R1[ELMNT2];T2_.T1[ELMNT]; !T1 HAS PTR TO OPTIONAL (= CONST )
			  !T2 HAS PTR TO SYMBOL NODE THAT SHOULDCONTAIN
			 !'END' OR 'ERR' 
			IF EOE() LSS 0 THEN RETURN .VREG;
		END;
		IF .FLAG  EQL  0 %READ/WRITE% THEN SAVSPACE( .R1<LEFT>,@R1);
	END;
	BEGIN!ASTERISK
		IF .STK[4]  NEQ  0  THEN  RETURN FATLEX(E39<0,0>);	! ALREADY FOUND ONE
		STK[4]_-1
	END
	TES;
END;

GLOBAL ROUTINE BLDUNIT (UPNT)=
BEGIN
	MAP BASE UPNT; LOCAL BASE T2;REGISTER BASE R1:T1:R2;
	EXTERNAL SAVSPACE %(SIZE,LOC)%,STK,BLDFORMAT %(FPNT)%,BLDVAR %(UPNT)%;
	EXTERNAL SETUSE,NAMLSTOK;
	EXTERNAL CNVNODE;
	MACRO
	ERR15(X)=RETURN FATLEX( INTGPLIT<0,0>, X, E15<0,0> )  $;
	!----------------------------------------------------------------------------------------------------------
	!THIS ROUTINE IS CALLED WITH THE PARAMETER UPNT POINTING
	!TO A UNITSPEC OPTIONALLY FOLLOWED BY A FORMATID.  SEE
	!EXPANSIONS OF THE METASYMBOLS IOSPEC, UNITSPEC AND FORMATID FOR
	!DETAILS.  A UNIT NUMBER MAY BE AN INTEGER CONSTANT OR AN INTEGER
	!VARIABLE.  IF A FORMAT IS PRESENT THE ROUTINE BLDFORMAT IS CALLED
	!TO SCAN THE FORMAT.  UPON EXIT FROM THIS ROUTINE THE FOLLOWING
	!LOCATIONS WILL BE DEFINED:
	!
	!	STK[2]=UNIT
	!	STK[3]=RECORD
	!	STK[4]=FORMAT
	!	STK[5]=ERR
	!	STK[6]=END
	!----------------------------------------------------------------------------------------------------------
	R1_.UPNT[ELMNT];R2_.R1[ELMNT1];  !R2_LOC(CONSTANT OR VARIABLE)
	IF .R1[ELMNT] EQL 1 THEN !INTEGER CONSTNAT
	BEGIN
		IF .R2[VALTYPE] NEQ INTEGER THEN ERR15 (PLIT SIXBIT 'UNIT');
		STK[2]_.R2
	END
	ELSE !VARIABLE
	BEGIN
		T2 _ .R2[ELMNT];	!PTR TO IDENTIFIER OR CONSTANT NODE
		IF .T2[VALTYPE] NEQ INTEGER THEN ERR15 (T2[IDSYMBOL]);
		SETUSE _ USE;
		IF (STK[2]_BLDVAR(.R2)) LSS 0 THEN RETURN .VREG;
		%DON'T LET UNSUBSCRIPTED ARRAYS THROUGH%
		IF .VREG<LEFT>  EQL  IDENTIFIER
		THEN	( MAP BASE VREG;
			  IF .VREG[OPRSP1]  EQL  ARRAYNM1
			  THEN	RETURN FATLEX( VREG[IDSYMBOL],ARPLIT<0,0>,E4<0,0>);
			);
	END;
	IF .R1[ELMNT2] NEQ 0 THEN !RECORD NUMBER
	BEGIN
		STK[3] _ .R1[ELMNT3];
		T1 _ @@STK[3];
		IF .T1[VALTP1] NEQ INTEG1
		  THEN  (.STK[3])<FULL> _ CNVNODE(.T1,INTEGER,0);
	END ELSE ( NAMLSTOK _ 1; STK[3]_0 ) ;
	SAVSPACE(.R1<LEFT>,@R1);
	STK[4]_STK[5]_STK[6]_0;
	IF .UPNT[ELMNT1] NEQ 0 THEN !FORMAT, END/ERR
	BEGIN
		R2_.UPNT[ELMNT2];
		T1 _ .R2[ELMNT];
		INCR FMT FROM .T1 TO .T1+.T1<LEFT> DO
		BEGIN
			MAP BASE FMT;
			FLAG _ 0; !SIGNAL BLDFORMAT FOR POSSIBLE END= OR ERR=
			IF BLDFORMAT(.FMT[ELMNT]) LSS 0 THEN ( NAMLSTOK _ 0;  RETURN .VREG);
			SAVSPACE(.FMT[ELMNT]<LEFT>,.FMT[ELMNT]);
		END;
		T1 _ .R2[ELMNT]; SAVSPACE(.T1<LEFT>,.T1);
	END;
	NAMLSTOK _ 0;
	SAVSPACE(.UPNT<LEFT>,@UPNT);
END;

%[760]%	GLOBAL ROUTINE BLDKLIST(KLPNT)=
%[760]%	BEGIN
%[760]%		MAP BASE KLPNT;
%[760]%		REGISTER BASE R1:R2:R3;
%[760]%		EXTERNAL BLDKEY,SAVSPACE;
%[760]%	
%[760]%		!--------------------------------------------------------
%[760]%		! This routine is called with KLPNT pointing to a list
%[760]%		! of keyspecs
%[760]%		!--------------------------------------------------------
%[760]%		R1_.KLPNT[ELMNT];
%[760]%		SAVSPACE(.KLPNT<LEFT>,@KLPNT);
%[760]%		R2_.R1[ELMNT];
%[760]%		SAVSPACE(.R1<LEFT>,@R1);
%[760]%	
%[760]%		INCR LIST FROM @R2 TO @R2 + .R2<LEFT> DO
%[760]%		BEGIN
%[760]%			MAP BASE LIST;
%[760]%			R3_.LIST[ELMNT];
%[760]%			IF BLDKEY(.R3[ELMNT],R3[ELMNT1]) LSS 0 THEN RETURN .VREG;
%[760]%			SAVSPACE(.R3<LEFT>,@R3);
%[760]%		END;
%[760]%		SAVSPACE(.R2<LEFT>,@R2);
%[760]%		.VREG
%[760]%	END;
%[760]%	
%[760]%	GLOBAL ROUTINE BLDKEY(KPNT,VALPNT)=
%[760]%	BEGIN
%[760]%	
%[760]%		MAP BASE KPNT;
%[760]%		MAP BASE VALPNT;
%[760]%		LOCAL SPOS,TYPE,CHOICE,VAR;
%[760]%		LABEL FINDK;
%[760]%		REGISTER BASE R1:R2:R3;
%[760]%		EXTERNAL NAMLSTOK, CGERR;
%[760]%		EXTERNAL STK, LABREF, NONIOINIO, SETUSE, BLDVAR;
%[760]%		!------------------------------------------------------------
%[760]%		! This routine is called with KPNT pointing to an identifier
%[760]%		! and VALPNT pointing to the list:
%[760]%		!	CHOICE - 1 (constant), 2 (variable), 3 (asterisk)
%[760]%		!	VALUE - pointer to symbol table entry for the choice
%[760]%		!------------------------------------------------------------
%[760]%	
%[760]%		BIND	CONOK = 1^0,	! CONSTANT OK
%[760]%			VAROK = 1^1,	! VARIABLE OR ARRAY REF OK
%[760]%			ARROK = 1^2,	! ARRAY NAME OR NAMELIST NAME OK
%[760]%			LBLOK = 1^3,	! LABEL OK
%[760]%			ASTOK = 1^4;	! ASTERISK OK
%[760]%	
%[760]%		BIND	NUMKEYS = 6;
%[760]%	
%[760]%		BIND	KEYWORDS = PLIT (
%[760]%				SIXBIT 'END'	,6^18	+LBLOK,
%[760]%				SIXBIT 'ERR'	,5^18	+LBLOK,
%[760]%				SIXBIT 'FMT'	,4^18	+LBLOK +ARROK +ASTOK,
%[760]%				SIXBIT 'IOSTAT'	,7^18	+VAROK,
%[760]%				SIXBIT 'REC'	,3^18	+VAROK +CONOK,
%[760]%				SIXBIT 'UNIT'	,2^18	+VAROK +CONOK +ASTOK);
%[760]%	
%[760]%		MACRO	STKPOS(I)=	(KEYWORDS[I]+1)<LEFT>$,
%[760]%			KTYPE(I)=	(KEYWORDS[I]+1)<RIGHT>$;
%[760]%	
%[760]%		MACRO	ERR15(X) = (RETURN FATLEX(X,KPNT[IDSYMBOL],E15<0,0>))$,
%[760]%			ERR15I(X) = (RETURN FATLEX(INTGPLIT<0,0>, X, E15<0,0>))$,
%[760]%			ERR34 = (RETURN FATLEX(PLIT' ',KPNT[IDSYMBOL],E34<0,0>))$;
%[760]%			! Try to match a keyword
%[760]%		FINDK: BEGIN
%[760]%			INCR I FROM 0 TO (NUMKEYS - 1) * 2 BY 2 DO
%[760]%			BEGIN
%[760]%				IF .KPNT[IDSYMBOL] EQL @KEYWORDS[.I]
%[760]%				THEN
%[760]%				BEGIN
%[760]%					SPOS_.STKPOS(.I);
%[760]%					TYPE_.KTYPE(.I);
%[760]%					LEAVE FINDK;
%[760]%				END
%[760]%			END;
%[760]%			! no match - invalid keyword
%[760]%			ERR15( PLIT 'A KEYWORD')
%[760]%		END;
%[760]%	
%[760]%			! check for redundant keyword
%[760]%		IF .STK[.SPOS] NEQ 0 THEN ERR34;
%[760]%		CHOICE_.VALPNT[ELMNT];
%[760]%		R1_.VALPNT[ELMNT1];
%[760]%	
%[760]%		CASE .CHOICE OF SET
%[760]%			CGERR();	! FOR SPEED
%[760]%			BEGIN	! CONSTANT
%[760]%				IF (.TYPE AND CONOK) NEQ 0
%[760]%				THEN
%[760]%				BEGIN
%[760]%					IF .R1[VALTYPE] NEQ INTEGER THEN ERR15I(R1[IDSYMBOL]);
%[760]%					STK[.SPOS]_.R1;
%[760]%				END
%[760]%				ELSE IF (.TYPE AND LBLOK) NEQ 0
%[760]%				THEN
%[760]%				BEGIN
%[760]%					IF .R1[VALTYPE] NEQ INTEGER THEN ERR15I(R1[IDSYMBOL]);
%[760]%					IF .SPOS EQL 4 THEN NONIOINIO_0 ELSE NONIOINIO_1;
%[760]%					ENTRY[1]_.R1[CONST2];
%[760]%					R2_LABREF();
%[760]%					STK[.SPOS]_@R2;
%[760]%				END
%[760]%				ELSE	ERR15(PLIT 'INTEGER OR LABEL');
%[760]%			END;
%[760]%			BEGIN	! VARIABLE
%[760]%				IF (.TYPE AND VAROK) NEQ 0
%[760]%				THEN
%[760]%				BEGIN	! VARIABLE OR ARRAY REF
%[760]%					IF .SPOS EQL 7 THEN SETUSE_SETT ELSE SETUSE_USE;
%[760]%					R2_.R1[ELMNT];
%[760]%					IF .R2[VALTYPE] NEQ INTEGER THEN ERR15I(R2[IDSYMBOL]);
%[760]%					IF (VAR_BLDVAR(.R1)) LSS 0 THEN RETURN .VREG;
%[760]%					! BLDVAR allows unsubscripted arrays
%[760]%					IF .VREG<LEFT> EQL IDENTIFIER
%[760]%					THEN
%[760]%					BEGIN
%[760]%						MAP BASE VREG;
%[760]%						IF .VREG[OPRSP1] EQL ARRAYNM1
%[760]%						THEN ERR15(PLIT'A SCALAR');
%[760]%					END;
%[760]%					STK[.SPOS]_.VAR;
%[760]%				END
%[760]%				ELSE IF (.TYPE AND ARROK) NEQ 0
%[760]%				THEN
%[760]%				BEGIN	! ARRAY OR NAMELIST NAME
%[760]%					R2_.R1[ELMNT];
%[760]%					IF .R2[OPRSP1] EQL ARRAYNM1
%[760]%					THEN
%[760]%					BEGIN
%[760]%						STK[.SPOS]_.R2;
%[760]%						IF .TYPE EQL READD
%[760]%						THEN	NAMSET(ARRAYNM1, .R2)
%[760]%						ELSE	NAMREF(ARRAYNM1, .R2);
%[760]%						IF .VREG LSS 0 THEN RETURN .VREG;
%[760]%					END
%[760]%					ELSE IF .NAMLSTOK NEQ 0 THEN
%[760]%						IF .R2[IDATTRIBUT(NAMNAM)]
%[760]%						THEN
%[760]%						BEGIN
%[760]%							LOCAL NAMROUT; !TO PUT ROUTINE TO CALL
%[760]%							LOCAL BASE NMLST:NAMCOM;
%[760]%							STK[.SPOS]_@R2;
%[760]%							IF NAMREF( NMLSTREF,.R2) LSS 0 THEN RETURN .VREG;
%[760]%							NAMROUT _ IF .TYPE EQL READD THEN NAMSET ELSE NAMREF; !DETERMINE ROUTINE TO CALL
%[760]%							NAMCOM_.R2[IDCOLINK]; !GET POINTER TO NAMELIST NODE
%[760]%							NMLST_.NAMCOM[NAMLIST]; !GET POINTER TO LIST OF ITEMS
%[760]%							WHILE .NMLST LSS (.NAMCOM[NAMLIST] + .NAMCOM[NAMCNT]) DO
%[760]%							BEGIN
%[760]%							R3 _ .NMLST[ELMNT];
%[760]%							(.NAMROUT)(.R3[OPRSP1],.R3); !CALL THE ROUTINE
%[760]%							NMLST _ .NMLST+1; !NEXT ITEM
%[760]%							END;	!OF WHILE ... DO
%[760]%						END
%[760]%							ELSE ERR15(PLIT'ARRAY OR NAMELIST NAME')
%[760]%						ELSE ERR15(PLIT'ARRAY NAME');
%[760]%				END
%[760]%				ELSE ERR15(PLIT'ALLOWED');
%[760]%			END;	! VARIABLE
%[760]%			BEGIN	! ASTERISK
%[760]%				IF (.TYPE AND ASTOK) NEQ 0
%[760]%				THEN STK[.SPOS]_-1
%[760]%				ELSE ERR15(PLIT'ALLOWED');
%[760]%			END;
%[760]%		TES;
%[760]%	
%[760]%		.VREG
%[760]%	
%[760]%	END;	! BLDKEY
%[760]%	
%[760]%	GLOBAL ROUTINE KORFBLD(FPNT)=
%[760]%	BEGIN
%[760]%		MACRO ERR15(X) = (RETURN FATLEX(X,R2[IDSYMBOL],E15<0,0>))$;
%[760]%	
%[760]%		EXTERNAL BLDKEY,SAVSPACE,SETUSE,NAMLSTOK, CGERR;
%[760]%		REGISTER BASE T1:R1:R2:R3;
%[760]%		MAP BASE FPNT;
%[760]%		!---------------------------------------------------------
%[760]%		! This routine is called with FPNT pointing to the list:
%[760]%		!	choice 1 - label
%[760]%		!	pointer to label
%[760]%		! or
%[760]%		!	choice 2 - variablespec or keyword
%[760]%		!	pointer to list:
%[760]%		!		variablespec
%[760]%		!		option if keyword
%[760]%		!		pointer to choice of constant, variable,
%[760]%		!			or asterisk
%[760]%		! or
%[760]%		!	choice 3 - asterisk
%[760]%		!----------------------------------------------------------
%[760]%	
%[760]%		SETUSE _ USE;
%[760]%		CASE .FPNT[ELMNT] OF SET
%[760]%			CGERR();	! FOR SPEED
%[760]%			BEGIN	! LABEL
%[760]%				STK[4] _ .FPNT[ELMNT1];
%[760]%			END;
%[760]%			BEGIN	! VARIABLESPEC OR KEYWORD
%[760]%				R1 _ .FPNT[ELMNT1];
%[760]%				IF .R1[ELMNT1] EQL 0
%[760]%				THEN
%[760]%				BEGIN	! ARRAY OR NAMELIST NAME
%[760]%					R3_.R1[ELMNT];
%[760]%					R2_.R3[ELMNT];
%[760]%					IF .R2[OPRSP1] EQL ARRAYNM1
%[760]%					THEN
%[760]%					BEGIN
%[760]%						STK[4]_.R2;
%[760]%						IF .TYPE EQL READD
%[760]%						THEN	NAMSET(ARRAYNM1, .R2)
%[760]%						ELSE	NAMREF(ARRAYNM1, .R2);
%[760]%						IF .VREG LSS 0 THEN RETURN .VREG;
%[760]%					END
%[760]%					ELSE IF .NAMLSTOK NEQ 0 THEN
%[760]%						IF .R2[IDATTRIBUT(NAMNAM)]
%[760]%						THEN
%[760]%						BEGIN
%[760]%							LOCAL NAMROUT; !TO PUT ROUTINE TO CALL
%[760]%							LOCAL BASE NMLST:NAMCOM;
%[760]%							STK[4]_@R2;
%[760]%							IF NAMREF( NMLSTREF,.R2) LSS 0 THEN RETURN .VREG;
%[760]%							NAMROUT _ IF .TYPE EQL READD THEN NAMSET ELSE NAMREF; !DETERMINE ROUTINE TO CALL
%[760]%							NAMCOM_.R2[IDCOLINK]; !GET POINTER TO NAMELIST NODE
%[760]%							NMLST_.NAMCOM[NAMLIST]; !GET POINTER TO LIST OF ITEMS
%[760]%							WHILE .NMLST LSS (.NAMCOM[NAMLIST] + .NAMCOM[NAMCNT]) DO
%[760]%							BEGIN
%[760]%							R3 _ .NMLST[ELMNT];
%[760]%							(.NAMROUT)(.R3[OPRSP1],.R3); !CALL THE ROUTINE
%[760]%							NMLST _ .NMLST+1; !NEXT ITEM
%[760]%							END;	!OF WHILE ... DO
%[760]%						END
%[760]%							ELSE ERR15(PLIT'ARRAY OR NAMELIST NAME')
%[760]%						ELSE ERR15(PLIT'ARRAY NAME');
%[760]%				END
%[760]%				ELSE
%[760]%				BEGIN	! KEYWORD
%[760]%					R2 _ .R1[ELMNT];
%[760]%					IF BLDKEY(.R2[ELMNT],.R1[ELMNT2]) LSS 0 THEN RETURN .VREG;
%[760]%					R3 _ .R1[ELMNT2];
%[760]%					SAVSPACE(.R3<LEFT>,@R3);
%[760]%				END;
%[760]%			END;
%[760]%			BEGIN	! ASTERISK
%[760]%				STK[4] _ -1;
%[760]%			END;
%[760]%		TES;
%[760]%		.VREG
%[760]%	END;	! KORFBLD
	
	END
ELUDOM