Google
 

Trailing-Edge - PDP-10 Archives - BB-4157D-BM - sources/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,1977 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: T.E. OSTEN/FJI/MD/SJW/JNG/DCE
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 = 5^24 + 1^18 + 113;		!VERSION DATE: 4-AUG-77

%(
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

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

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

*** BEGIN VERSION 5
104	VER5	-----	SHARE .I OFFSET IN DIMENTRY FOR ARRAYS
			WITH VARIABLE UPPER BOUND (LINK DIM ENTRIES)
105	410	-----	MAKE DTABPTR GLOBAL SO WILL BE INITIALIZED TO 0
106	414	QA625	FIX SHARING .I OFFSET SO ONLY SHARES DIM2 .I
			  IF DIM1 SAME
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
109	460	19477	TEST FOR OVERSIZED DIMENSIONING CORRECTLY

***** 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
112	572	21825	CHECK IMPLIED DO INDEX FOR ALREADY ACTIVE (FROM
			  AN ENCLOSING IMPLIED OR REAL DO)
113	601	Q20-26	FIX EDIT 572 TO CHECK IMPLIED DO INDEX IN DATA
			  STATEMENT FOR ALREADY ACTIVE FROM AN ENCLOSING
			  IMPLIED DO

)%	!END REVISION HISTORY

	FORWARD
		FUNCGEN,	!
		TYPEGEN,	!
		TMPGEN,		!
		BLDDIM,		!
		BLDARRAY,	!
		BLKSRCH,	!
		BLDVAR,		!
		DATALIST,	!
		BLDFORMAT,	!
		BLDUNIT,	!
		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  (

	R18 NAMES R23 NAMES  'IN EXTERNAL  STATEMENT?0',
	R22 NAMES  'AS DUMMY PARAMETER?0',
	R19 NAMES 'IN TYPE STATEMENT?0',
	R24 NAMES 'IN DATA STATEMENT?0',
	R26 NAMES 'IN COMMON?0',
	R27 NAMES 'IN EQUIVALENCE?0',
	R28 NAMES 'AS AN ENTRY POINT NAME?0',
	R33 NAMES 'AS STATEMENT FUNCTION?0',
	R34 NAMES 'AS COMMON BLOCK?0',
	R35 NAMES 'AS NAMELIST?0',

	AYORFN NAMES ' AS AN ARRAY OR FUNCTION?0',
	AY NAMES 'AS AN ARRAY?0',
	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,
%**;[235], ROUTINE NAMDEF , REPLACE @ LINE 3511, DT/MD ,11/18/74 %
%[235]%		%PARADEF%	NAMLST + CMNBLK + STFN + ENTPNT + EXTBTH + TYPED + EQVIN + COMIN + DATAIN + DUMIEE,
%[235]%		%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
%**;[235], ROUTINE NAMDEF , REPLACE @ LINE 3621 , DT/MD ,11/18/74 %
%[235]%			END;
%[235]%	%NMLSTITM%	BEGIN
%[235]%				IF .ID[OPRSP1] EQL FNNAME1 THEN FNN
%[235]%			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;
!**;[415] Change in routine FUNCGEN @ 3859	JNG	3-Aug-76
%[415]%				IF .R2[IDDIM] EQL 0 THEN
!**;[567], FUNCGEN @3885, DCE, 5-MAY-77
!**;[567], ADD ONE MORE TEST SO THAT EXTERNAL DECLARATION WILL CARRY OVER
!**;[567], TO ALL ENTRY POINT PARAMETERS
%[567]%				  (IF .R2[OPERSP] NEQ FORMLFN
%[567]%				AND .R2[OPERSP] NEQ FNNAME THEN
%[415]%				   R2[OPERSP]_FORMLVAR)
%[415]%				  !IF NOT DIMENSIONED THEN VARIABLE
%[415]%				  !UNLESS WE KNOW BETTER (ALREADY SAW
%[415]%				  !IT AS A FORMAL THAT HAS BEEN USED)
%[415]%				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;

!**[410] BLDDIM @4029 SJW 1-JUL-76
%[410]%	EXTERNAL  DTABPTR;		! HEAD OF DIM ENTRY LIST

%[V5]%	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;

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

!**[571] BLDDIM @4076  SJW  11-MAY-77
![571]  REMOVE DEFINITION OF ARALINK; IT IS NOW IN TABLES.BLI

	!----------------------------------------------------------------------------------------------------------
	!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;


	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
	!**;[460], ACT1 @4125, DCE, 24-SEP-76
	!**;[460], THE FOLLOWING PATCHES TO BLDDIM CURE A WHOLE
	!**;[460], HOST OF PROBLEMS CONCERNING ERROR DETECTION
	!**;[460], AND RECOVERY DURING DIMENSION PROCESSING, ESPECIALLY
	!**;[460], REGARDING ARRAYS WHICH ARE TOO LARGE TO HANDLE.
	%[460]%			IF .R1[CONST2] EQL 0
	%[460]%			THEN FATLEX(FARRY[IDSYMBOL],E74<0,0>);
	!**;[460], DO NOT TEST FOR TOO LARGE A SUBSCRIPT HERE -
	!**;[460], 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;
%**;[230],ROUTINE BLDDIM, REPLACE @ 4111,MD,11/17/74 %
%[230]%				IF .R1[OPERSP] NEQ FORMLVAR AND NOT .R1[IDATTRIBUT(INCOM)] THEN
%[230]%				(
%[230]%				AJDIMSTK(.R1);	! CREATE AN ENTRY
%[230]%				R1[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
%[230]%				);
				T2[DVARUBFLG(0)]_1;T2[DIMENU(0)]_@R1;ADJUSTABLE_-1;
			END;
			IF .ADJUSTABLE EQL 0 THEN
			BEGIN
	!**;[460], BLDDIM @4145, DCE, 24-SEP-76
	!**;[460], NEW VARIABLES TO TEST AND REPORT ARRAY SIZE PROBLEM
	%[460]%			LOCAL SAV; ! NEED FULL WORD TO TEST OVERFLOW
	!**;[460], ERROR 141 GIVES ARRAY NAME TOO LARGE
	%[460]%			EXTERNAL E141; ! NEW ERROR MESSAGE
				NAME_CONTAB;ENTRY[0]_0;ENTRY[1]_.ASIZE;SYMTYPE_INTEGER;
				T2[DFACTOR(0)]_TBLSEARCH();
	!**;[460], BLDDIM @4148, DCE, 24-SEP-76
	!**;[460], AS THE COMPLETE ARRAY SIZE IS COMPUTED, DO NOT LET
	!**;[460], IT GET TOO LARGE WITHOUT REPORTING THE ERROR
	%[460]%			AOFF_.AOFF-.ASIZE;
	%[460]%			SAV_.ASIZE*.R1[CONST2]; !FULL WORD SIZE
	%[460]%			IF .SAV GEQ 1^18 THEN FATLEX(.FARRY[IDSYMBOL],E141<0,0>);
	!**;[460], NOW IT IS SAFE TO PUT THIS INTO A HALF WORD WHETHER
	!**;[460], OR NOT THERE IS A TRUNCATION!
	%[460]%			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;
%**;[230],ROUTINE BLDDIM, DELETE @ 4134 , MD ,11/17/74 %
%**;[230],ROUTINE BLDDIM, REPLACE @ 4135,MD,11/17/74 %
%[230]%				IF .R1[OPERSP] NEQ FORMLVAR AND NOT .R1[IDATTRIBUT(INCOM)] THEN
%[230]%				(
%[230]%				AJDIMSTK(.R1);	! CREATE AN ENTRY
%[230]%				R1[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
%[230]%				);
				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
	!**;[460], BLDDIM @4217, DCE, 24-SEP-76
	!**;[460], DO NOT NEED TO CHECK HERE FOR ARRAY BOUND SIZE
	%[460]%			IF .HISIGN NEQ 0
	%[460]%			   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;
%**;[230],ROUTINE BLDDIM, REPLACE @ 4164,MD,11/17/74 %
%[230]%				SAV _ .R2[IDATTRIBUT(NOALLOC)];	!SAVE IN CASE ITS NOT DUMMY YET
				IF NAMREF(VARIABL1,.R2) THEN RETURN .VREG;
%**;[230],ROUTINE BLDDIM, DELETE @ 4166 , MD, 11/17/74 %
%**;[230],ROUTINE BLDDIM, REPLACE @ 4167,MD,11/17/74 %
%[230]%				IF .R2[OPERSP] NEQ FORMLVAR AND NOT .R2[IDATTRIBUT(INCOM)] THEN
%[230]%				(
%[230]%				AJDIMSTK(.R2);	! CREATE AN ENTRY
%[230]%				R2[IDATTRIBUT(NOALLOC)] _ .SAV; !RESTORE
%[230]%				);
				T2[DVARUBFLG(0)]_1;ADJUSTABLE_-1;
			END;
			IF .R2[OPERSP] EQL CONSTANT
			THEN
	!**;[460], BLDDIM @4253, DCE, 24-SEP-76
	!**;[460], DO NOT TEST ON INDIVIDUAL ELEMENTS HERE!
	%[460]%			IF .HISIGN NEQ 0
	%[460]%			  THEN R2 _ MAKECNST(INTEGER,0,-.R2[CONST2]);
			T2[DIMENU(0)]_.R2;
			IF .ADJUSTABLE EQL 0 THEN
			BEGIN
	!**;[460], BLDDIM @4263, DCE, 24-SEP-76
	!**;[460], ALSO NEED TO CHECK THE CASE WITH UPPER AND
	!**;[460], LOWER BOUNDS.
	%[460]%			LOCAL SAV;
	%[460]%			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];
	!**;[460], BLDDIM @4271, DCE, 24-SEP-76
	!**;[460], CHECK FOR TOTAL SPACE NEEDED FOR THIS ARRAY
	%[460]%			SAV_.ASIZE*(.R2[CONST2]-.R1[CONST2]+1);
	%[460]%			IF .SAV GEQ 1^18 THEN FATLEX(.FARRY[IDSYMBOL],E141<0,0>);
	%[460]%			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;

!**[571] BLDDIM @4326  SJW  11-MAY-77
%[571]%	  LOCAL BASE  PTR;
%[V5]%	  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);

%[V5]%		A0F_ IF .FARRY [DBLFLG]	! SET ELEMENT SIZE
%[V5]%		       THEN MAKECNST (INTEGER, 0, 2)
%[V5]%		       ELSE .ONEPLIT;
%[V5]%		DECR  I  FROM .DNUM - 1  TO 1  DO
LDECR:		  BEGIN		%[V5]%
%[V5]%		    T2 _ .T2 - 2;	! DIMSUBENTRY (I)
%[V5]%		    IF .T2 [DFACTOR (0)] NEQ 0
%[V5]%		      THEN LEAVE LDECR;
%[V5]%		    IF NOT .T2 [DVARUBFLG (0)] OR
%[414]%		       .T2 [DIMENL (0)] NEQ .ONEPLIT  OR
%[414]%		       .I NEQ 1
%[V5]%		      THEN BEGIN
%[V5]%			T2 [DFACTOR (0)] _ INITLTEMP (INTEGER);
%[V5]%			LEAVE LDECR;
%[V5]%		      END;
%[414]%!			I == 1 => T2 [...(0)] IS FOR 2ND DIM
%[V5]%		    PTR _ .DTABPTR <RIGHT>;
%[V5]%		    WHILE  .PTR NEQ 0
%[V5]%		      DO BEGIN
%[V5]%			E _ .PTR;
CHECKTHIS:		BEGIN		%[V5]%
!**[423] BLDDIM @4328 SJW 13-AUG-76  DIMNUM IS 1 RELATIVE NOT 0
%[423]%			  IF .E [DIMNUM] LSS 2
%[V5]%			    THEN LEAVE CHECKTHIS;
%[V5]%			  IF NOT .E [ADJDIMFLG]
%[V5]%			    THEN LEAVE CHECKTHIS;
%[V5]%			  IF .E [DFACTOR (0)] NEQ .A0F	! SAME ELEMENT SIZE
%[V5]%			    THEN LEAVE CHECKTHIS;
%[414]%!	IF DIM1 SAME THEN SHARE FACTOR FOR DIM2
%[414]%			  IF .E [DIMENU (0)] EQL .T2 [DIMENU (-1)]  AND
%[414]%			     .E [DIMENL (0)] EQL .ONEPLIT
%[V5]%			    THEN BEGIN
!**[571] BLDDIM @4371  SJW  11-MAY-77
%[571]%			      PTR _ .E [DFACTOR (1)];
%[571]%			      T2 [DFACTOR (0)] _ .PTR;
%[571]%			      PTR [IDUSECNT] _ .PTR [IDUSECNT] + 1;	! UPDATE SHARING COUNT
%[V5]%			      LEAVE LDECR;
%[V5]%			    END;
%[V5]%			END;	! OF CHECKTHIS
%[V5]%		        PTR _ .E [ARALINK];	! NEXT ENTRY
%[V5]%		      END;	! OF WHILE .PTR NEQ 0
!**[571] BLDDIM @4377  SJW  11-MAY-77
%[571]%		    PTR _ INITLTEMP (INTEGER);		! NO MATCH FOUND
%[571]%		    T2 [DFACTOR (0)] _ .PTR;
%[571]%		    PTR [IDUSECNT] _ 1;			! 1ST USAGE: NO SHARING
%[V5]%		  END;	! OF LDECR
%[V5]%		T2 _ .T2 - 2;		! SUBENTRY (0)
%[V5]%		T2 [DVARFACTFLG (0)] _ 0;
%[V5]%		T2 [ADJDIMFLG] _ 1;
%[V5]%
	   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)

%[V5]%	DLBL _ 0;			! FOR SAFETY
%[V5]%	ALINK _ .DTABPTR <RIGHT>;	! LINK THIS ENTRY INTO LIST
%[V5]%	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;

!**[571] BLDARRAY @4441  SJW  11-MAY-77
%[571]%	LABEL  OUT, CHECKTHIS;
%[571]%	EXTERNAL  DTABPTR, ONEPLIT, INITLTEMP;
%[571]%	LOCAL BASE  PTR;		! TO MARCH DOWN DIM ENTRY LIST
%[571]%	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
!**[571] BLDARRAY @4539  SJW  11-MAY-77
						T2 _ .R2[DFACTOR(0)];
						R2[DFACTOR(0)] _ MAKECNST(INTEGER,0, ( .T2[CONST2] * .DUB ) / 2 );
%[571]%	OUT:					BEGIN
%[571]%						  IF .R2 [DIMNUM] LSS 2	
%[571]%						    THEN LEAVE OUT;
%[571]%						  IF NOT .R2 [DVARUBFLG (1)]
%[571]%						    THEN LEAVE OUT;
%[571]%						  IF .R2 [DIMENL (1)] NEQ .ONEPLIT
%[571]%						    THEN LEAVE OUT;
%[571]%						  T2 _ .R2 [DFACTOR (1)];
%[571]%						  T2 [IDUSECNT] _ .T2 [IDUSECNT] - 1;
%[571]%						  IF .T2 [IDUSECNT] EQL 0
%[571]%						    THEN T2 [IDATTRIBUT (NOALLOC)] _ 1;	! NOT SHARED NOW: DON'T ALLOC
%[571]%						  PTR _ .DTABPTR<RIGHT>;
%[571]%						  WHILE .PTR NEQ 0
%[571]%						    DO BEGIN
%[571]%						      E _ .PTR;
%[571]%	CHECKTHIS:				      BEGIN
%[571]%							IF .E EQL .R2		! DON'T SHARE WITH YOURSELF
%[571]%							  THEN LEAVE CHECKTHIS;
%[571]%							IF .E [DIMNUM] LSS 2
%[571]%							  THEN LEAVE CHECKTHIS;
%[571]%							IF NOT .E [ADJDIMFLG]
%[571]%							  THEN LEAVE CHECKTHIS;
%[571]%							IF .E [DFACTOR (0)] NEQ .R2 [DFACTOR (0)]	! SAME ELEMENT SIZE ?
%[571]%							  THEN LEAVE CHECKTHIS;
%[571]%							IF .E [DIMENU (0)] NEQ .R2 [DIMENU (0)]
%[571]%							  THEN LEAVE CHECKTHIS;
%[571]%							IF .E [DIMENL (0)] NEQ .ONEPLIT
%[571]%							  THEN LEAVE CHECKTHIS;
%[571]%	!		DIM 1 SAME: SHARE FACTOR FOR DIM2
%[571]%							PTR _ .E [DFACTOR (1)];
%[571]%							R2 [DFACTOR (1)] _ .PTR;
%[571]%							PTR [IDUSECNT] _ .PTR [IDUSECNT] + 1;	! UPDATE SHARING COUNT
%[571]%							LEAVE OUT;
%[571]%						      END;	! OF CHECKTHIS
%[571]%						      PTR _ .E [ARALINK];	! NEXT ENTRY
%[571]%						    END;	! OF WHILE .PTR NEQ 0
%[571]%						  IF .T2 [IDUSECNT] EQL 0	! NO MATCH FOUND
%[571]%						    THEN T2 [IDATTRIBUT (NOALLOC)] _ 0	! USE OLD .I WHICH WAS DEALLOCED
%[571]%						    ELSE T2 _ INITLTEMP (INTEGER);	! GET NEW .I TEMP
%[571]%						  R2 [DFACTOR (1)] _ .T2;
%[571]%						  T2 [IDUSECNT] _ 1;		! 1ST USAGE: NO SHARING
%[571]%						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;

!**[572] DATALIST @4676  SJW  13-MAY-77
%[572]%	EXTERNAL  CKDOINDEX;		! CHECK DO INDEX ALREADY ACTIVE
%[572]%	EXTERNAL  DOCHECK;		! REMOVE DO LABEL FROM ACTIVE DO LIST
%[572]%	EXTERNAL  E21;			! DO INDEX ALREADY ACTIVE MESSAGE

%[572]%	MACRO  ADDOLAB (X,Y) =		! PUT INDEX ON ACTIVE DO LIST
%[572]%		BEGIN
%[572]%		EXTERNAL  LASDOLABEL;	! PTR TO END LABEL,,INDEX OF MOST RECENT DO
%[572]%		EXTERNAL  CURDOINDEX;	! PTR TO CURRENT DO INDEX VARIABLE
%[572]%		LOCAL BASE  TEMP;
%[572]%			NAME<LEFT> _ 2;			! LINK IN NEW LABEL
%[572]%			TEMP _ CORMAN ();
%[572]%			TEMP [ELMNT] _ .LASDOLABEL;	! SAVE LAST
%[572]%			TEMP [ELMNT1] _ .CURDOINDEX;	! SAVE INDEX
%[572]%			LASDOLABEL<LEFT> _ .TEMP;
%[572]%			LASDOLABEL<RIGHT> _ X;
%[572]%			CURDOINDEX _ Y;			! INDEX PTR
%[572]%		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>)$;
	LABEL IO1;
	!
	!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)=
	IO1: 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;
%**;[265],ACT1,JNT,11-APR-75%
%**;[265],IN DATALIST @ 4574%
			IF .T2[IDATTRIBUT(INDATA)] EQL 1	![265] SEE IF IT'S
%**;[272],ACT1,JNT,04-MAY-75%
%**;[272],IN DATALIST IN EDIT 265 @ 4574%
			AND .T2[IDDIM] EQL 0	![272] NOT AN ARRAY BUT
			THEN		![265] ALREADY IN A DATA STATEMENT
			FATLEX(T2[IDSYMBOL],E139<0,0>);	![265] WARN HIM
			T2[IDATTRIBUT(INDATA)] _ 1;
			IF .T2[IDATTRIBUT(DUMMY)] THEN (FATLEX( T2[IDSYMBOL],E66<0,0>); LEAVE IO1);
		   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$;
!**[572] DATALIST @4770  SJW  16-MAY-77  REMOVE FORMAL X
%[572]%	MACRO IOCONTNODE =
	BEGIN
		IDOFSTATEMENT_NAME_CONTDATA;	!NODE IDENTIFICATION AND SIZE
		NAME<RIGHT> _ IOLTAB;
		T1_NEWENTRY();
		T1[OPRCLS]_STATEMENT;
!**[572} DATALIST @4776  SJW  16-MAY-77  REMOVE REFERENCES TO X
		IOLBL _ T1[SRCLBL]_ GENLAB();
		IOLBL[SNREFNO]_2;	!REFERENCE COUNT OF 2
		IOLBL[SNHDR] _ .T1	!PTR TO CONTINUE IN LABEL TABLE NODE
	END$;

!**[572] DATALIST @4781  SJW  16-MAY-77  DEFINE NEW MACRO
%[572]%	MACRO ADDCONTNODE (X) =
%[572]% BEGIN
%[572]%		T1 _ .IOLBL [SNHDR];	! GET NODE FROM IOCONTNODE
%[572]%		X [CLINK] _ .T1;	! LINK IN CONT NODE AT END OF LOOP
%[572]%		X<RIGHT> _ .T1;		! POINT TO NEW END OF DATALIST
%[572]%	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;
!**[572] DATALIST @4815  SJW  13-MAY-77
%[572]%			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];
!**[572] DATALIST @4825  SJW  13-MAY-77
%[572]%				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
!**[572] DATALIST @4837  SJW  13-MAY-77
%[572]%				ELSE BEGIN
%[572]%				  IF NAMSET (VARIABL1,.T2) LSS 0
%[572]%				    THEN RETURN .VREG;
%[572]%				END;

!**[601] DATALIST MOVE [572] FROM @4837 TO @4840  SJW  4-AUG-77
%[601]%				IF CKDOINDEX (.T2)
%[601]%				  THEN RETURN FATLEX (T2 [IDSYMBOL], E21<0,0>);	! DO INDEX ALREADY ACTIVE
%[601]%				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
				);
!**[572] DATALIST @4843  SJW  13-MAY-77
%[572]%			IF (LNKLST _ DATALIST (.R2)) LSS 0
%[572]%			  THEN BEGIN
%[572]%			    T2 _ .VREG;
%[572]%			    IF .R1 [ELMNT1] NEQ 0	! IMPLIED DO LOOP
%[572]%			      THEN DOCHECK (.IOLBL);	! REMOVE LABEL FROM ACTIVE DO LIST
%[572]%			    RETURN .T2;
%[572]%			  END;
			IF .R1[ELMNT1] NEQ 0 THEN	!IMPLIED DO LOOP
			BEGIN
!**[572] DATALIST @4846  SJW  13-MAY-77
%[572]%				DOCHECK (.IOLBL);	! REMOVE LABEL FROM ACTIVE DO LIST
%[572]%				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 -