Google
 

Trailing-Edge - PDP-10 Archives - bb-4157h-bm_fortran20_v10_16mt9 - fortran-compiler/datast.bli
There are 12 other files named datast.bli in the archive. Click here to see a list.


!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR ANY  OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
!AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

!AUTHOR: S. MURPHY/DCE/TFV/CKS/AHM/RVM/CDM/PLB

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

GLOBAL BIND DATASV = #10^24 + 0^18 + #2457;	! Version Date:	20-Sep-84

%(

MODULE:	DATAST

	This module performs allocation for DATA statements.  The
	objective of DATA statements is to give the loader information
	about storage areas in a Fortran program which are to be
	preinitialized before execution of the program.  The loader
	must be told each location to be initialized and the
	corresponding constant to be stored there.

	A DATA statement has associated with it 2 kinds of lists:
		1.	Data item lists- these describe locations into
			which the constants are to be initialized.  A
			data item list looks like an IOLIST.  Elements
			on a data-item list may be:
				A. DO statement
				B. CONTINUE statement with a label that
				   terminates the DO
				C. DATACALL:  which may have as an arg either
				   a scalar or an ARRAYREF.  If arg is an
				   ARRAYREF then all subscripts must be of
				   the form C1*I+C2 where I is a loop index
				   and C1 and C2 are INTEGER constants.
				D. SLIST call

		2.	Data constant lists- these indicate the initial values
			to be stored.  A data constant list is a linked list of
			elements of the form:
				---------------------------------
[2202]				! DCONST	!   CLINK	!
				---------------------------------
[2202]				! DATARPT                       !
				---------------------------------

			where CLINK points to the next element on the list
			(or is 0 for the last element), DCONST points to a
			constant table entry (may be for a literal or for
			any other constant) and DATARPT is a count of the
			number of times the constant indicated is to be stored.

)%

%(
***** Begin Revision History *****

38	-----	-----	COMMENT OUT CALLS TO "ZDMPBLK" IN "DATPROC"
39	-----	-----	FIX ERROR CALLS
40	-----	-----	GIVE WARNING WHEN THERE ARE FEWER VARS THAN CONSTS
			IN A GIVEN DATA STMNT; MAKE THE WARNING WHEN THERE
			ARE TOO FEW CONSTS COME OUT ONLY ONCE;
			REMOVE THE CALLS TO ZDMPBLK IN "DATPROC" WHICH WERE
			PREVIOUSLY COMMENTED OUT
41	-----	-----	GIVE AN ERROR MESSAGE WHEN ATTEMPT TO WRITE BEYOND
			THE END OF AN ARRAY IN A DATA STATEMENT
42	-----	-----	SHOULD USE "EXTSIGN" WHEN PICKING UP TARGADDR
			FIELD FOR AN ARRAY REF
43	16361	273	SHOULD USE "EXTSIGN" WHEN PICKING UP CONSTANT IN
			CNSTEVAL, (JNT)
44	314	QAR	SHOULD USE "EXTSIGN" FOR IMPLIED DO LOOPS IN DATA, (JNT)

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

45	666	25572	NEGATIVE INCREMENT IN DATA STATEMENT NOT
			HANDLED CORRECTLY - DATA (A(I),I=10,1,-1), (DCE)
***** Begin Version 6 *****

46	761	TFV	1-Mar-80	-----
	Add KTYPCG to fold /GFLOATING type conversions

52	1131	AHM	22-Sep-81	Q20-01671
	Check for storing before the first word of an array in GETDADDR
	since we already check for storing after the last word.

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

1157	EGM	11-Jun-82
	Alter error FTNMVC to indicate whether there are more or less data
	items that constants in a DATA statement.

***** Begin Version 7 *****

47	1212	TFV	29-Apr-81	------
	Replace LITERAL with HOLLERITH, LITERALENTRY with HOLLENTRY.

50	1236	SRM	15-July-81	------
	Allow CHARACTER constants as well as HOLLERITH constants
	to be used to initialize numeric data

51      1242	CKS	29-Jul-81
	Add initialization of CHARACTER variables.

53	1416	CKS	9-Nov-81
	Add initialization of character substrings.  Allow integer
	exponentiation in subscripts and substring bounds.  Detect
	zero-trip DO loops if F77.

54	1430	CKS	3-Dec-81
	Add code to check substring bounds in when substrings occur in
	DATA statements

55	1461	CKS	20-Jan-82
	Change an error message: "DATA statement exceeds bounds of array"
	to "Illegal substring bound in DATA statement".  Also add identifier
	name to "Can't store numeric constant in character variable."

1542	RVM	25-May-82
	Always convert the REAL (GFLOATING) constants back to single
	precision, even if the REAL constant was created by a conversion
	from an OCTAL (or LOGICAL or HOLLERITH ...) constant originally.


***** Begin Version 10 *****

2202	CDM	7-Apr-83
	Remove calls to EXTSIGN for IDDATVAL fields.  This is now a full
	word, so it does not need to have the sign extended.

2216	PLB	27-Sep-83
	Add a dot to the BP in each call to BPADD; it used to be a MACRO
	now it is a routine in OUTMOD.

2423	AHM	13-Jul-84
	Add support for 1160 Ultimate Sparse Data REL blocks under
	/EXTEND.  Add a new routine named FLUSHDATA which buffers and
	outputs 1160 blocks and call it from OUTDATA and OUTCHDATA.
	Move those routines from OUTMOD and RELBUF so that they can
	share module OWNs along with FLUSHBUFFER.  Make DATAST's
	module preface conform to the new conventions.

2432	AHM	23-Jul-84
	Create an alias named RULTFLAGS for the concatenation of the
	1160 flag bits RULTRPTFLAG, RULTFILLFLAG and RULTBYTEFLAG, and
	clear it near the top of FLUSHDATA.  Cures bad REL files
	caused by assuming that the garbage left on the top of the
	stack was zero.

2435	AHM	24-Jul-84
	Invalidate DATNEXT at the start of each program unit's DATA
	statement processing by setting it to -1.  This insures that
	OUTDATA and OUTCHDATA will not append DATA statements in
	different program units to the same 1160 block.

2452	AHM	20-Aug-84
	Make OUTCHDATA return immediately when handed a NIL pointer
	for a CHARACTER constant, as GETCHCNST intends it to.  This
	prevents it from generating bad REL blocks based on the
	contents of the compiler's ACs.

2453	AHM	22-Aug-84
	Fix the 1160 box to reflect RULTSYMLEN getting narrower.
	Also, change lengthy disjunctions in OUTDATA and OUTCHDATA
	into IF/THEN/ELSE's for speed.  Finally, insert a missing dot
	and reverse the sense of a test in OUTDATA at the same time.

2457	AHM	20-Sep-84
	Changes to Ultimate Sparse Data Support for code review.
	Comment changes, except for changing access to DCON1 and DCON2
	in OUTDATA from formals to globals.

***** End V10 Development *****

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

)%

!Require: FIRST.BLI
!Require: TABLES.BLI
!Require: REQREL.BLI
SWITCHES NOLIST;
REQUIRE 'FIRST.BLI';
REQUIRE 'TABLES.BLI';
REQUIRE 'REQREL.BLI';
SWITCHES LIST;

FORWARD
	DATPROC,	! Walk all DATA statements and allocate them
	ALCDATA,	! Allocate a single DATA statement
	ADJDATPTR,	! Handle list of IOLSCLS, DO and CONTINUE nodes
	GETDADDR,	! Get address of next numeric variable
	GETCHADDR,	! Get byte pointer for next CHARACTER variable
	CNSTEVAL,	! Exaluate INTEGER CTCE for ARRAYREFs
	IPOWER,		! Calculate INTEGER**INTEGER
	GETDCNST,	! Get next numeric constant
	GETCHCNST,	! Get next CHARACTER constant
%2423%	OUTDATA,	! Output numeric data to REL file
%2423%	OUTCHDATA,	![1242] Output CHARACTER data to REL file
%2423%	FLUSHDATA;	! Flush buffered 1160 blocks to REL file

EXTERNAL
%2423%	&JBDA,		! The value of this symbol is the first location
			!  available to the user.  Used to distinguish psect
			!  indices from addresses in the compiler lowseg.
%2216%	BPADD,		! ADJBP-er; Was a MACRO until now
	C1H,		! High order
	C1L,		!  and low order arguments
	C2H,		!  for the
	C2L,		!  constant combination module
	CGERR,		! ICEs the compiler
	CNSTCMB,	! Combines arguments of CTCE's
	COPRIX,		! Operator index arguments for CMSTCMB
BASE	CSTMNT,		! Pointer to current statement
	DATASPTR,	! LH contains a pointer to the first DATA statement
	DMPMAINRLBF,	! Output the contents of the main rel buffer
	DMPRLBLOCK,	! Outputs a block of rel code to the rel file
	E135,		! "DATA statement exceeds bounds of array X"
	E160,		! "Can't store numeric constant
			!  in character variable X"
	E161,		! "Character constant split between numeric
			!  and character variables"
	E173,		! "Illegal substring bound in DATA statement"
	E175,		! "Zero-trip DO loop illegal in DATA statement"
	E57,		! "Number of variables is greater/less than the number
			!  of constants in DATA statement"
%2342%	EXTERNPSECT,	! Table of external psect indices
			!  indexed by internal psect indices
	FATLERR,	! Prints fatal messages
	ISN,		! Used to communicate current statement's ISN
	KISNGL,		! Rounds a REAL that is being represented
			! internally with 2 words of precision
	KTYPCB,		! Base in table for constant folding
			!  for type conversions
%761%	KTYPCG,		! To fold /GFLOATING type conversions
RELBUFF	MAINRLBF,	! Main rel file buffer - used for type 1 and 1010
			!  (code and data) as well as miscellaneous
			!  (hiseg, end, etc.)
	RADIX50,	! Return Radix-50 of the sixbit word in R2
	RDATWD,		! Holds the data word for ZOUTBLOCK
	WARNERR,	! Prints warning messages
	ZOUTBLOCK;	! Buffers a word to the rel file
OWN
	CHDBP, CHDLEN,	!CHAR BYTE POINTER AND CHAR STRING LENGTH TO BE
			! INITIALIZED
	CNSTCT,		!NUMBER OF TIMES THAT THE CONSTANT INDICATED BY
			! "DATACNSTPTR" HAS BEEN OUTPUT SO FAR (NOTE THAT FOR
			! A MULTI-WORD CONSTANT, THIS COUNT IS ONLY INCREMENTED
			! AFTER ALL WORDS OF THE CONSTANT HAVE BEEN OUTPUT)
	CNSTWDCT,	!NUMBER OF WORDS OF THE INDICATED CONSTANT THAT HAVE
			! BEEN OUTPUTED SO FAR (NOTE THAT WHEN THE SAME
			! CONSTANT IS OUTPUT MORE THAN ONCE, THIS COUNT IS SET
			! BACK TO 0 EACH TIME WE GO BACK TO THE FIRST WORD OF
			! THE CONSTANT)
BASE	DATACNSTPTR,	!POINTS TO THE ELEMENT ON THE DATA CONSTANT LIST
			! WHICH IS CURRENTLY BEING USED
%2423%	DATDAT[2],	!Pointer to buffered literal table entry, or 1 or 2
			! buffered words of numeric data for 1160 support
%2423%	DATFILL,	!Fill count for buffered 1160 data item
%2423%	DATNEXT,	!Byte pointer or address for next 1160 datum to
			! qualify as a repeat of the buffer contents
%2423%	BASE DATORG,	!Origin byte pointer for start of buffered 1160 data
%2423%	BASE DATPSECT,	!Psect index or pointer to COMMON block
			! for DATORG and DATNEXT
%2423%	DATRPT,		!Current repeat count of buffered 1160 data
%2423%	DATSIZE,	!Byte or word count for 1160 data
BASE	DATAITMPTR,	!POINTS TO THE ELEMENT IN THE DATA-ITEM LIST WHICH
			! IS CURRENTLY BEING FILLED IN
	DCON1, DCON2,	!CONSTANT WDS TO BE OUTPUT NEXT; IF THE SYMBOL
			! BEING INITIALIZED IS DOUBLE PREC OR COMPLEX
			! DCON1 IS HIGH ORDER PART, DCON2 LOW ORDER PART;
			! OTHERWISE (FOR INTEGER AND REAL) DCON2 IS NOT USED
	XTRAVARS;	!FLAG INDICATING THAT WE HAVE
			! TOO FEW CONSTANTS IN THE STMNT BEING PROCESSED
GLOBAL ROUTINE DATPROC =
%(***************************************************************************
	ROUTINE TO WALK THRU ALL DATA STATEMENTS PERFORMING ALLOCATION FOR THEM
	THE GLOBAL "DATASPTR" CONTAINS A PTR TO THE FIRST DATA STMNT IN ITS LEFT HALF.
***************************************************************************)%
BEGIN
%1242%	DMPMAINRLBF();		! DUMP PREVIOUS .REL BLOCK FROM MAIN BUFFER.
				! SINCE OUTCHDATA WRITES TYPE 1004 BLOCKS
				! DIRECTLY, IT WON'T CAUSE BUFFER TO GET DUMPED
				! SO DO IT NOW TO GET THINGS IN THE RIGHT ORDER

	CSTMNT = .DATASPTR<LEFT>;
%2423%	DATRPT = 0;			! Make the buffer empty
%2435%	DATNEXT = -1;			! Make sure that no one appends to the
					!  buffer.  Set it to a value which is
					!  not a valid byte pointer or address

	UNTIL .CSTMNT EQL 0
	DO
	BEGIN
		ISN = .CSTMNT[SRCISN];
		ALCDATA();
		CSTMNT = .CSTMNT[CLINK];
	END;

%2423%	IF EXTENDED AND .FLGREG<OBJECT>		! Generating 1160 blocks?
%2423%	THEN FLUSHDATA();			! Yes, flush the buffer

END;	! of DATPROC
GLOBAL ROUTINE ALCDATA=
%(***************************************************************************
	ROUTINE TO PERFORM ALLOCATION FOR DATA STATEMENTS.
	CALLED WITH CSTMNT POINTING TO A STATEMENT OF THE FORM:

		----------------------------------------
		!  DATITEMS	!  CLINK		!
		------------------------------------------
		!  DATCOUNT	!  OPERATOR		!
		-----------------------------------------
		!  ISN		!   DATCONS		!
		------------------------------------------

	WHERE:
		DATCONS - POINTS TO  A DATA-CONSTANT-LIST
		DATITEMS - POINTS TO A DATA-ITEM-LIST
***************************************************************************)%
BEGIN
	OWN BASE SYM;		!PTR TO THE SYMBOL TABLE ENTRY FOR THE VAR BEING INITIALIZED
	OWN DADDR;		!ADDRESS TO BE INITIALIZED (ADDRESS OF 1ST WD
				! IF THE VAR IS DOUBLE-PREC)
	DATAITMPTR_.CSTMNT[DATITEMS];
	ADJDATPTR();				!GET PTR TO THE FIRST ELEMENT ON THE
						! DATA ITEM LIST WHICH IS EITHER AN SLIST
						! OR  A DATACALL (AND SET UP VALS OF INDICES
						! FOR IMPLICIT DO STMNT)
	DATACNSTPTR_.CSTMNT[DATCONS];	!1ST ENTRY ON DATA CONSTANT LIST
	CNSTCT_0;				!NUMBER OF TIMES THIS CONSTANT HAS BEEN
						! OUTPUT SO FAR
	CNSTWDCT_0;				!NUMBER OF WORDS OF THIS CONSTANT THAT
						! HAVE BEEN OUTPUT SO FAR

	XTRAVARS_FALSE;	!FLAG INDICATING THAT HAVE RUN OUT OF CONSTS BEFORE
			! FILLING ALL VARS(USED TO PREVENT REPEATING ERROR MESSAGE)

	%(***WALK THRU THE DATA ITEM LIST OUTPUTING A CONSTANT FOR EACH LOCATION***)%
	UNTIL .DATAITMPTR EQL 0
	DO
	BEGIN
		%(***IF THIS DATA-ITEM IS AN SLIST (IE WANT TO FILL A WHOLE ARRAY)***)%
		IF .DATAITMPTR[OPR1] EQL SLISTCLFL
		THEN
		BEGIN	! SLIST
			OWN BASE SLSTCT;	!PTR TO CONSTANT TABLE ENTRY FOR NUMBER
						! OF ITEMS IN THE ARRAY
			OWN WORDCT;		!NUMBER OF WORDS IN THE ARRAY
			SYM_.DATAITMPTR[SCALLELEM];	!PTR TO SYMBOL TABLE ENTRY FOR THE ARRAY
			SLSTCT_.DATAITMPTR[SCALLCT];

			IF .SYM[VALTYPE] NEQ CHARACTER
			THEN
			BEGIN	! NON-CHARACTER

				%(***GET THE NUMBER OF WORDS IN THE ARRAY (THE SCALLCT FIELD
					PTS TO ENTRY FOR THE NUMBER OF ITEMS. FOR DOUBLE-WD ENTRIES
					MUST MULTIPLY BY 2)***)%
				WORDCT_(IF .SYM[DBLFLG] THEN .SLSTCT[CONST2]*2 ELSE .SLSTCT[CONST2]);


				%(***OUTPUT A CONSTANT TO BE  STORED INTO EACH ELEM OF THE ARRAY***)%
				INCR I FROM 0 TO .WORDCT-1
				DO
				BEGIN
					! Determine what constant to output
					!  and put it in DCON1 and DCON2

					GETDCNST(.SYM);

					! Now output the constant that is
					!  living in DCON1 and DCON2

%2457%					OUTDATA(.I+.SYM[IDADDR],.SYM);

					! If this is a DP or COMPLEX array,
					! must increment address again

					IF .SYM[DBLFLG]
%2423%					THEN I = .I+1;
				END;
			END	! NON-CHARACTER
			ELSE
			BEGIN	! [1242] CHARACTER
				CHDBP = .SYM[IDCHBP];
				CHDLEN = .SYM[IDCHLEN];
				DECR I FROM .SLSTCT[CONST2] TO 1 DO
				BEGIN
					GETCHCNST(.SYM);  ! GET CONST TO OUTPUT
					OUTCHDATA(.CHDBP,.CHDLEN,.DCON1,.SYM);
						! WRITE CONST TO .REL FILE
%2216%					CHDBP = BPADD(.CHDBP,.CHDLEN);
						! BUMP TO NEXT ELEMENT OF ARRAY
				END
			END	! [1242] CHARACTER
		END	! SLIST

		%(***IF THIS DATA-ITEM IS A DATACALL(EITHER AN ARRAYREF OR  A SCALAR)***)%
		ELSE
		BEGIN	! DATACALL
			%(***GET PTR TO SYMBOL TABLE ENTRY CORRESP TO THE DATA ITEM***)%
			SYM_.DATAITMPTR[DCALLELEM];

			%(***IF THE DATA-ITEM IS AN ARRAYREF, MUST GET PTR TO ENTRY FOR THE
				ARRAY-NAME***)%

%1416%			IF .SYM[OPRCLS] EQL SUBSTRING
%1416%			THEN SYM_.SYM[ARG4PTR];

			IF .SYM[OPRCLS] EQL ARRAYREF
			THEN SYM_.SYM[ARG1PTR];

			IF .SYM[VALTYPE] NEQ CHARACTER
			THEN
			BEGIN		! NON-CHARACTER

				GETDCNST(.SYM);	!SET UP DCON1 AND DCON2 TO THE 2 WDS OF THE
						! CONSTANT TO BE OUTPUT (DO NOT USE DCON2 IF
						! SYMBOL IS INTEGER OR REAL)
				DADDR_GETDADDR();	!ADDRESS INTO WHICH TO STORE

					! Output constant in DCON1 and DCON2

%2457%				OUTDATA(.DADDR,.SYM);
			END		! NON-CHARACTER
			ELSE
			BEGIN		! [1242] CHARACTER
				GETCHCNST(.SYM); ! SET UP DCON1 TO POINT TO
	 					 ! THE NEXT CHAR CONSTANT
				GETCHADDR(); 	 ! GET CHDBP, BYTE PTR TO STRING
						 ! AND CHDLEN, LENGTH
				OUTCHDATA(.CHDBP,.CHDLEN,.DCON1,.SYM);
						 ! WRITE STRING INTO .REL BLOCK
			END		! [1242] CHARACTER
		END;	! DATACALL

		DATAITMPTR_.DATAITMPTR[CLINK];
		ADJDATPTR();				!GET PTR TO NEXT ITEM ON DATA-ITEM-LIST
							! WHICH IS EITHER  A DATACALL OR
							! SLISTCALL, ADJUST ANY DO-LOOP INDICES
	END;

	IF .DATACNSTPTR NEQ 0	!IF THERE ARE STILL CONSTANTS LEFT AFTER
				! ALL VARS HAVE BEEN FILLED
%1157% THEN  WARNERR(PLIT'is less than?0',.ISN,E57<0,0>);	!GIVE WARNING
END;	! of ALCDATA
GLOBAL ROUTINE ADJDATPTR=
%(***************************************************************************
	THIS ROUTINE IS ALWAYS CALLED AFTER THE GLOBAL "DATAITMPTR" HAS
	BEEN MOVED FORWARD BY SETTING IT TO THE LINK FIELD OF THE PRECEEDING
	NODE POINTED TO. IF THE NODE  TO WHICH IT HAS BEEN ADVANCED IS
	A DATACALL NODE, NO ACTION NEED BE TAKEN. IF THE NODE TO WHICH IT
	HAS BEEN ADVANCED IS A DO STATEMENT NODE, THE DO LOOP MUST
	BE INTIALIZED AND DATAITMPTR ADVANCED TO THE NEXT STMNT.
	IF THE NODE TO WHICH IT HAS BEEN ADVANCED IS A CONTINUE STATEMENT WHICH
	TERMINATES A DO, THE DO INDEX MUST BE ADVANCED, A LOOP-TERMINATION TEST
	MADE, AND DATAITMPTR  EITHER SET BACK TO THE FIRST STMNT INSIDE THE DO,OR
	ADVANCED TO THE STMNT AFTER THE CONTINUE.
	(NOTE THAT NO MORE THAN ONE DO LOOP WILL EVER BE TERMINATED ON THE
	SAME CONTINUE; NOTE ALSO THAT DO INDICES MUST BE INTEGER AND THAT
	INITL, FINAL, AND INCR VALS ON DO LOOPS MUST BE INTEGER CONSTANTS.
***************************************************************************)%
BEGIN
	OWN PEXPRNODE DOINDEX;		!SYMBOL TABLE ENTRY FOR THE VAR USED AS
					! THE INDEX ON A DO STMNT BEING PROCESSED
	LOCAL PEXPRNODE INCRVAL:FINALVAL; !INCREMENT AND FINAL LIMIT OF DO LOOP

	%(***WALK THRU THE DATA ITEM LIST UNTIL EITHER REACH THE END OF THE
		LIST, OR REACH AN ELEMENT WHICH IS A DATACALL OR SLISTCALL***)%
	UNTIL .DATAITMPTR EQL 0
	DO
	BEGIN

		%(***IF ARE LOOKING AT A DATACALL OR AN SLIST, RETURN*****)%
		IF .DATAITMPTR[OPRCLS] NEQ STATEMENT THEN RETURN;

		%(***IF ARE LOOKING AT A DO STATEMENT, SET THE "IDDATVAL" FIELD IN
			THE SYMBOL TABLE ENTRY FOR THE DO INDEX TO ITS INITIAL VALUE***)%
		IF .DATAITMPTR[SRCID] EQL DOID
		THEN
		BEGIN
			OWN PEXPRNODE DOINITVAL;
			DOINDEX_.DATAITMPTR[DOSYM];
			DOINITVAL_.DATAITMPTR[DOM1];
			%(***CAN ASSUME INITIAL VAL IS AN INTEG CONSTANT***)%
			DOINDEX[IDDATVAL]_.DOINITVAL[CONST2];

%1416%			%(***CHECK FOR ZERO-TRIP LOOP***)%
%1416%			IF F77 THEN
%1416%			BEGIN
%1416%				INCRVAL _ .DATAITMPTR[DOM3];   ! GET INCREMENT
%1416%				FINALVAL _ .DATAITMPTR[DOM2];  ! GET FINAL VAL
%1416%
%1416%				! Check for initial value already greater than
%1416%				! final value (ie, for zero-trip loop)
%1416%				IF (.INCRVAL[CONST2] GTR 0 AND
%2202%					.DOINDEX[IDDATVAL] GTR .FINALVAL[CONST2])
%1416%				OR (.INCRVAL[CONST2] LSS 0 AND
%2202%					.DOINDEX[IDDATVAL] LSS .FINALVAL[CONST2])
%1416%				OR (.INCRVAL[CONST2] EQL 0)
%1416%				THEN
%1416%				FATLERR(.ISN,E175<0,0>); ! "zero-trip loop illegal"
%1416%			END;

			%(***GO ON TO NEXT ELEM****)%
			DATAITMPTR_.DATAITMPTR[CLINK];
		END

		ELSE

		%(***IF ARE LOOKING AT A CONTINUE WHICH TERMINATES A DO STMNT, INCREMENT
			THE DO INDEX AND TEST FOR THE DO INDEX GTR THAN ITS FINAL VAL.
			IF HAVE FINISHED ITERATING THIS LOOP, THEN GO ON TO NEXT ELEM,
			OTHERWISE GO BACK TO THE START OF THE LOOP****)%
		IF .DATAITMPTR[SRCID] EQL CONTID
		THEN
		BEGIN
			OWN PEXPRNODE LABNODE;		!LABEL TABLE ENTRY FOR LABEL ON CONTINUE
			OWN BASE DOSTNODE;		!DO STMNT NODE AT START OF LOOP
			OWN PEXPRNODE INCRVAL:FINALVAL;	!CONSTANT TABLE ENTRIES
								! FOR INCREMENT AND FINAL VAL
								! OF LOOP INDEX

			LABNODE_.DATAITMPTR[SRCLBL];
			IF .LABNODE EQL 0 THEN CGERR();	!THE CONTINUE MUST TERMINATE SOME LOOP
			DOSTNODE_.LABNODE[SNDOLNK];
			IF .DOSTNODE EQL 0 THEN CGERR();	!THE CONTINUE MUST TERMINATE A DO
			DOSTNODE_.DOSTNODE[LEFTP];	!GET PTR TO STMNT FROM THE LINKED LIST
							! OF DO STMNTS ASSOCIATED WITH THIS LABEL
							! (NOTE THATFOR A DATA STMNT THERE
							! WILL  NEVER BE MORE THAN 1)

			INCRVAL_.DOSTNODE[DOM3];
			FINALVAL_.DOSTNODE[DOM2];
			DOINDEX_.DOSTNODE[DOSYM];

			%(***INCR THE DO INDEX***)%
%2202%			DOINDEX[IDDATVAL] = .DOINDEX[IDDATVAL]+.INCRVAL[CONST2];	!GET SIGNED #

![666] NEGATIVE (AND ZERO) INCREMENTS FOR DATA STATEMENT NOT HANDLED
![666] CORRECTLY - REVERSE SENSE OF THE TEST IF NEGATIVE INCREMENT
%[666]%			IF ( .INCRVAL[CONST2] GTR 0 AND
%2202%				.DOINDEX[IDDATVAL] GTR .FINALVAL[CONST2])
%[666]%			OR ( .INCRVAL[CONST2] LSS 0 AND
%2202%				.DOINDEX[IDDATVAL] LSS .FINALVAL[CONST2])
%[666]%			OR ( .INCRVAL[CONST2] EQL 0)
			THEN
			%(***IF HAVE FINISHED LOOP ITERATION, GO ON TO STMNT AFTER LOOP***)%
			DATAITMPTR_.DATAITMPTR[CLINK]

			ELSE
			%(***IF HAVE NOT FINISHED LOOP ITERATION, GO BACK TO STMNT AFTER DO STMNT***)%
			DATAITMPTR_.DOSTNODE[CLINK];
		END

		ELSE CGERR();		!STMNT MUST BE EITHER DO OR CONTINUE
	END;

END;	! of ADJDATPTR
GLOBAL ROUTINE GETDADDR=
%(***************************************************************************
	THIS ROUTINE RETURNS THE RELOCATABLE ADDRESS CORRESPONDING TO
	A DATACALL ELEMENT IN A DATA ITEM LIST.
	IT IS CALLED WITH THE GLOBAL "DATAITMPTR" POINTING TO  THE
	DATACALL NODE FOR WHICH AN ADDRESS IS TO BE COMPUTED.
***************************************************************************)%
BEGIN
	REGISTER PEXPRNODE DATAELEM;	!EXPRESSION NODE UNDER THE DATACALL - MAY BE
					! AN ARRAYREF OR A DATA ITEM
	REGISTER PEXPRNODE ARRAYNMENTRY;	!SYMBOL TABLE ENTRY FOR THE ARRAY NAME
	REGISTER PEXPRNODE ARRAYSIZE;	! THE NUMBER OF WDS IN THE ARRAY

	OWN OFFST;		!OFFSET IN THE ARRAY OF THE WD TO BE INITIALIZED
	DATAELEM_.DATAITMPTR[DCALLELEM];

	IF .DATAELEM[OPRCLS] EQL DATAOPR THEN RETURN .DATAELEM[IDADDR]
	ELSE
	IF .DATAELEM[OPRCLS] EQL ARRAYREF
	THEN
	BEGIN
		ARRAYNMENTRY_.DATAELEM[ARG1PTR];

		ARRAYSIZE_.ARRAYNMENTRY[IDDIM];	!DIM TABLE ENTRY FOR THE ARRAY
		ARRAYSIZE_.ARRAYSIZE[ARASIZ];	! THE NUMBER
					! OF WORDS IN THE ARRAY

		%(***IF THE SS WAS ALREADY FOLDED INTO THE ARRAY ADDR***)%
		IF .DATAELEM[ARG2PTR] EQL 0
		THEN OFFST _ EXTSIGN(.DATAELEM[TARGADDR])
		ELSE OFFST _ CNSTEVAL(.DATAELEM[ARG2PTR]) + EXTSIGN(.DATAELEM[TARGADDR]) ;

		%(**IF ARE TRYING TO SET A VALUE AFTER THE END OF THE ARRAY**)%
		IF .OFFST GTR (.ARRAYSIZE-1)
%1131%			OR .OFFST LSS 0		! or before the beginning . . .
		THEN FATLERR(.ARRAYNMENTRY[IDSYMBOL],.ISN,E135);

		RETURN .OFFST+.ARRAYNMENTRY[IDADDR];
	END
	ELSE CGERR();

END;	! of GETDADDR
ROUTINE GETCHADDR=			! [1242] New

! This routine returns a byte pointer and character count for the character
! variable or character array ref or character substring ref in a data item
! list.  Same as GETDADDR, but GETDADDR is called for numeric variables,
! GETCHADDR is called for character variables.
!
! Globals:	same as GETDADDR
! 		DATAITMPTR = datacall node for which address is to be computed
! Return:	CHDBP = byte pointer to char string to be initialized
!		CHDLEN = number of chars in the variable

BEGIN

	REGISTER PEXPRNODE DATAELEM;	! EXPRESSION NODE UNDER THE DATACALL,
					! MAY BE ARRAYREF, DATA ITEM, SUBSTRING
	REGISTER PEXPRNODE ARRAYNMENTRY; ! SYMBOL TABLE ENTRY FOR ARRAY NAME
	REGISTER PEXPRNODE ARRAYSIZE;	! NUMBER OF CHARS IN THE ARRAY

	OWN OFFST;			! CHAR OFFSET WITHIN ARRAY

	DATAELEM _ .DATAITMPTR[DCALLELEM];

	OFFST _ 0;			! INIT OFFSET TO 0
	CHDLEN _ -1;			! LENGTH NOT SET YET

	IF .DATAELEM[OPRCLS] EQL SUBSTRING
	THEN
	BEGIN				! SUBSTRING
		OFFST _ CNSTEVAL(.DATAELEM[ARG2PTR]); 	! GET LOWER BOUND - 1
		CHDLEN _ CNSTEVAL(.DATAELEM[ARG1PTR]);	! GET UPPER BOUND

		ARRAYNMENTRY _ .DATAELEM[ARG4PTR];
		IF .ARRAYNMENTRY[OPRCLS] EQL ARRAYREF
		THEN ARRAYNMENTRY _ .ARRAYNMENTRY[ARG1PTR];
		ARRAYSIZE _ .ARRAYNMENTRY[IDCHLEN];

		IF .OFFST LSS 0 OR .OFFST GEQ .ARRAYSIZE     !CHECK LOWER BOUND
		  OR .CHDLEN LEQ 0 OR .CHDLEN GTR .ARRAYSIZE !CHECK UPPER BOUND
		  OR .OFFST GEQ .CHDLEN		     !CHECK LOWER VS. UPPER
		THEN FATLERR(.ISN,E173<0,0>);	     !GIVE WARNING IF PROBLEM

		CHDLEN _ .CHDLEN - .OFFST; 	! SET LENGTH
		DATAELEM _ .DATAELEM[ARG4PTR];	! MOVE DOWN TO SUBSTRINGEE NODE
	END;				! SUBSTRING

	IF .DATAELEM[OPRCLS] EQL DATAOPR
	THEN
	BEGIN		! SIMPLE VARIABLE
%2216%		CHDBP _ BPADD(.DATAELEM[IDCHBP],.OFFST); ! SET BYTE PTR
		IF .CHDLEN LSS 0 THEN CHDLEN _ .DATAELEM[IDCHLEN];
					! IF LEN NOT SET BY SUBSTRING ABOVE,
					! SET TO WHOLE STRING
	END		! SIMPLE VARIABLE
	ELSE
	IF .DATAELEM[OPRCLS] EQL ARRAYREF
	THEN
	BEGIN		! ARRAYREF
		ARRAYNMENTRY _ .DATAELEM[ARG1PTR]; ! GET ARRAY ID TABLE ENTRY

		ARRAYSIZE _ .ARRAYNMENTRY[IDDIM]; ! DIM TABLE ENTRY
		ARRAYSIZE _ .ARRAYSIZE[ARASIZ];	! NUMBER OF CHARS IN ARRAY

		IF .DATAELEM[ARG2PTR] NEQ 0 	! ADD SUBSCRIPT INTO OFFSET
		THEN OFFST _ .OFFST + CNSTEVAL(.DATAELEM[ARG2PTR]);

		IF .OFFST GTR .ARRAYSIZE-1 OR .OFFST LSS 0    ! CHECK SUBSCRIPT
		THEN FATLERR(.ARRAYNMENTRY[IDSYMBOL],.ISN,E135<0,0>);

%2216%		CHDBP _ BPADD(.ARRAYNMENTRY[IDCHBP],.OFFST);    ! SET BYTE PTR
		IF .CHDLEN LSS 0 THEN CHDLEN _ .ARRAYNMENTRY[IDCHLEN];
					! IF LEN NOT SET BY SUBSTRING ABOVE,
					! SET TO WHOLE STRING
	END		!ARRAYREF
	ELSE CGERR();			! ERROR IF NOT DATAOPR OR ARRAYREF

END;	! of GETCHADDR
GLOBAL ROUTINE CNSTEVAL(EXPR)=
%(***************************************************************************
	TO FOLD AN ARITHMETIC EXPRESSION IN WHICH ALL TERMS  ARE INTEGER
	CONSTANTS.
	THE ARGUMENT "EXPR" MUST BE EITHER AN ARITHMETIC NODE OR AN INTEGER
	CONSTANT NODE OR A SYMBOL TABLE ENTRY FOR AN INDEX ON AN INPLICIT
	DO-LOOP INSIDE A DATA STATEMENT.

	RETURNS THE VALUE COMPUTED.
	THIS ROUTINE IS RECURSIVE
***************************************************************************)%
BEGIN
	MAP PEXPRNODE EXPR;

	IF .EXPR[OPR1] EQL CONSTFL THEN RETURN .EXPR[CONST2]
	ELSE

	%(***IF EXPR IS A SYMBOL TABLE ENTRY, ASSUME THAT IT
		IS AN INDEX ON AN IMPLIED DO IN A DATA STMNT AND
		THAT THE "IDDATVAL" FIELD OF THE SYMBOL TABLE ENTRY CONTAINS
		THE CURRENT VAL OF THAT INDEX***********)%
	IF .EXPR[OPRCLS] EQL DATAOPR
%2202%	THEN	RETURN .EXPR[IDDATVAL]
	ELSE

	IF .EXPR[OPRCLS] EQL ARITHMETIC
	THEN
	BEGIN
		CASE .EXPR[OPERSP] OF SET

		%(***FOR ADD*****)%
		RETURN CNSTEVAL(.EXPR[ARG1PTR]) + CNSTEVAL(.EXPR[ARG2PTR]);

		%(***FOR SUBTRACT***)%
		RETURN CNSTEVAL(.EXPR[ARG1PTR]) - CNSTEVAL(.EXPR[ARG2PTR]);

		%(***FOR MULTIPLY***)%
		RETURN CNSTEVAL(.EXPR[ARG1PTR])*CNSTEVAL(.EXPR[ARG2PTR]);

		%(***FOR DIVIDE***)%
		RETURN (CNSTEVAL(.EXPR[ARG1PTR]))/(CNSTEVAL(.EXPR[ARG2PTR]));

		%(***FOR EXPONENTIATION***)%
%1416%		RETURN IPOWER(CNSTEVAL(.EXPR[ARG1PTR]),CNSTEVAL(.EXPR[ARG2PTR]))

		TES;
	END

	ELSE
	%(***FOR NEG (APPEARS ABOVE NEGATIVE CONSTANTS)***)%
	IF .EXPR[OPR1] EQL NEGFL
	THEN RETURN -CNSTEVAL(.EXPR[ARG2PTR])

	ELSE CGERR();

END;	! of CNSTEVAL
GLOBAL ROUTINE IPOWER(BASE,EXP)=		! [1416] New
%(***************************************************************************
	ROUTINE TO EVALUATE INTEGER ** INTEGER
***************************************************************************)%
BEGIN
	REGISTER ANS,BASESQ,N;

	N = .EXP;
	IF .N LSS 0
	THEN
	BEGIN
		IF .BASE NEQ 1 AND .BASE NEQ -1
		THEN RETURN 0
		ELSE IF .N THEN RETURN .BASE ELSE RETURN 1;
	END;

	IF .N EQL 0 THEN RETURN 1;

	ANS = 1;
	BASESQ = .BASE;
	WHILE 1 DO
	BEGIN				! HERE BASE**EXP = ANS * BASESQ**N
		IF .N			! IF EXPONENT IS ODD
		THEN
		BEGIN
			ANS = .ANS * .BASESQ; 		! MULTIPLY
			IF .N LEQ 1 THEN RETURN .ANS;
		END;
		N = .N ^ (-1);		! ADJUST EXPONENT
		BASESQ = .BASESQ * .BASESQ; 	! ADJUST BASE
	END;

END;	! of IPOWER
GLOBAL ROUTINE GETDCNST(SYM)=
%(***************************************************************************
	ROUTINE TO SET UP THE NEXT CONSTANT WORD(S) TO BE OUTPUT FOR A GIVEN
	DATA-CONSTANT-LIST.
	CALLED WITH THE GLOBALS:
		DATACNSTPTR-PTR TO THE ENTRY ON THE DATA CONSTANT LIST TO BE USED NEXT
		CNSTCT- COUNT OF THE NUMBER OF TIMES THAT THE CONSTANT
			INDICATED BY "DATACNSTPTR" HAS BEEN OUTPUT (NOTE THAT FOR
			MULTI-WORD CONSTANTS, THIS COUNT IS ONLY INCREMENTED AFTER ALL
			WORDS OF THE CONSTANT HAVE BEEN OUTPUT)
		CNSTWDCT-COUNT OF THE NUMBER OF WORDS OF THE INDICATED CONSTANT THAT  HAVE
			ALREADY BEEN OUTPUT (NOTE THAT THIS CT IS SET BECK TO 0 FOR EACH
			REPITITION OF A GIVEN CONSTANT)
	CALLED WITH THE ARG
		SYM - THE SYMBOL THAT WILL BE SET TO THIS CONSTANT;
	UNLESS THE CONSTANT IS A LITERAL, IT MUST BE CONVERTED TO AGREE IN TYPE
	WITH "SYM"
	IF SYM IS DOUBLE-PREC OR COMPLEX THIS ROUTINE LEAVES THE GLOBALS-
		DCON1 - HIGH ORDER WD OF THE CONSTANT TO BE OUTPUT
		DCON2 - LOW ORDER WD TO BE OUTPUT
	OTHERWISE IT LEAVES
		DCON1- THE WORD TO BE OUTPUT
		DCON2 - IS IGNORED
***************************************************************************)%
BEGIN
	OWN BASE CNSTENTRY;	!CONSTANT TABLE ENTRY FOR THE DESIRED CONSTANT
	MAP PEXPRNODE SYM;

	%(***IF HAVE REACHED THE END OF THE LIST OF CONSTANTS (AND PRESUMABLY NOT THE
		END OF THE LIST OF DATA ITEMS) GIVE A WARNING MESSAGE
		AND FILL WITH ZEROES***)%
	IF .DATACNSTPTR EQL 0
	THEN
	BEGIN
		IF NOT .XTRAVARS	!IF THIS IS THE 1ST VAR TO BE FILLED WITH 0'S
		THEN
%1157%		WARNERR(PLIT'is greater than?0',.ISN,E57<0,0>);	!PRINT WARNING MESSAGE
		XTRAVARS_TRUE;
		DCON1_0;
		DCON2_0;
		RETURN
	END;

	CNSTENTRY_.DATACNSTPTR[DCONST];

	%(***FOR HOLLERITH********)%

!**;[1212], GETDCNST, TFV, 29-Apr-81
!**;[1212], Replace LITERAL with HOLLERITH, LITERALENTRY with HOLLENTRY
%[1212]%	IF .CNSTENTRY[VALTYPE] EQL HOLLERITH
%[1236]%		OR .CNSTENTRY[VALTYPE] EQL CHARACTER ! Allow quoted constants as well as H
	THEN
	BEGIN
%[1212]%	OWN HOLLENTRY  LITENTRY;
		OWN LITSIZ1;		!NUMBER OF WDS IN THE LITERAL EXCLUDING A
					! POSSIBLE PAD WD (DO NOT PUT ASCIZ OU FOR DATA STMNT)

		LITSIZ1_(IF .CNSTENTRY[LITEXWDFLG] THEN .CNSTENTRY[LITSIZ]-1
			ELSE .CNSTENTRY[LITSIZ] );

		LITENTRY_.CNSTENTRY;

		%(***VAL TO BE OUTPUT IS THE (N+1)TH WD OF THE LITERAL, WHERE N IS THE
			VALUE OF CNSTWDCT (IE NUMBER OF WDS OF THE LITERAL ALREADY OUTPUT***)%
		DCON1_.LITENTRY[.CNSTWDCT+1];

		%(***GO ON TO NEXT WD OF LITERAL***)%
		CNSTWDCT_.CNSTWDCT+1;

		%(***IF THE SYMBOL BEING INITIALIZED IS DOUBLE-WD,  MUST PICK UP  A 2ND
			WD OF THE LITERAL (IF HAVE REACHED THE END OF THE LITERAL, SET 2ND
			WD TO A WD OF BLANKS ***)%
		IF .SYM[DBLFLG]
		THEN
		BEGIN
			IF .CNSTWDCT EQL .LITSIZ1	!IF HAVE REACHED END OF LIT
%2423%			THEN DCON2 = '     '	!A WORD OF BLANKS


			ELSE
			BEGIN
				DCON2_.LITENTRY[.CNSTWDCT+1];
				CNSTWDCT_.CNSTWDCT+1;
			END;
		END;


		%(***IF HAVE OUTPUT THE ENTIRE LITERAL, SET THE WORD CT BACK TO 0 AND
			INCREMENT THE CT OF NUMBER OF TIMES THE WHOLE CONSTANT WAS OUTPUT***)%
		IF .CNSTWDCT EQL .LITSIZ1
		THEN
		BEGIN
			CNSTWDCT_0;
			CNSTCT_.CNSTCT+1;
		END;
	END

	ELSE
	%(***FOR CONSTANTS OTHER THAN LITERALS***)%
	BEGIN
		%(***IF THE SYMBOL IS OF A DIFFERENT VALTYPE THAN THE CONSTANT,
			CONVERT THE CONSTANT***)%
		IF .SYM[VALTP1] NEQ .CNSTENTRY[VALTP1]
		THEN
		BEGIN
			C1H_.CNSTENTRY[CONST1];
			C1L_.CNSTENTRY[CONST2];
			COPRIX_KKTPCNVIX(.SYM[VALTP2],.CNSTENTRY[VALTP2]);
			CNSTCMB();	!LEAVES THE GLOBALS C2H,C2L SET TO THE CONVERTED
					! VALUE
		END
		ELSE
		BEGIN
			C2H_.CNSTENTRY[CONST1];	!SET THE GLOBALS C2H,C2L TO THE ORIG VALUE
			C2L_.CNSTENTRY[CONST2];
		END;

		%(***SET UP DCON1 AND DCON2 TO BE THE CONSTANT***)%
		CASE .SYM[VALTP1] OF SET
		%(***IF THE TYPE IS INTEGER OR OCTAL/LOGICAL***)%
		DCON1_.C2L;
		%(***IF THE TYPE IS REAL - MUST ROUND SINCE HAVE STORED 2 WDS OF PREC***)%
%1542%		DCON1=IF .GFLOAT
%1542%		      THEN KISNGL(.C2H,.C2L)	!Even originally OCTAL constants need conversion under /GFL
		      ELSE IF BITPTNVALTYP(.CNSTENTRY[VALTYPE])	!IF THE CONSTANT WAS OCTAL,...
			   THEN .C2H		! DONT ROUND
			   ELSE KISNGL(.C2H,.C2L);
		%(***IF THE TYPE IS DOUBLE PREC ***)%
		BEGIN
			DCON1_.C2H;
			DCON2_.C2L;
		END;
		%(***IF THE TYPE IS COMPLEX***)%
		BEGIN
			DCON1_.C2H;
			DCON2_.C2L;
		END;

		TES;



		%(***INCR CT OF NUMBER OF TIMES THIS CONSTANT HAS BEEN USED***)%
		CNSTCT_.CNSTCT+1;
	END;


	%(***TEST FOR WHETHER HAVE FINISHED ALL REPITITIONS OF THE CONSTANT AND IF SO
		GO ON TO THE NEXT***)%
	IF .CNSTCT GEQ .DATACNSTPTR[DATARPT]
	THEN
	BEGIN
		DATACNSTPTR_.DATACNSTPTR[CLINK];
		CNSTCT_0;
	END;

END;	! of GETDCNST
ROUTINE GETCHCNST(SYM)=			! [1242] New

! Routine to set up the next character constant to be output for a given
! data-constant-list.  Same as GETDCNST, but GETDCNST is called for numeric
! variables, GETCHCNST is called for character variables.
!
! Globals:	same as GETDCNST
!		DATACNSTPTR = ptr to entry on the data constant list to be
!			used next
!		CNSTCT = count of the number of times that the constant
!			indicated by DATACNSTPTR has been output (note that
!			for multi-word constants, this count is only
!			incremented after all words of the constant have
!			been output)
!		CNSTWDCT = count of the number of words of the indicated
!			constant that have already been output (note that this
!			count is set back to 0 for each repetition of a given
!			constant)
! Args:		SYM = the symbol which will be set to this constant
!		      must be type CHARACTER
! The corresponding constant in the constant-list must be type character; if
! not, a fatal error message is typed.  The character constant cannot have
! been partially used up by numeric variables; if not, a fatal error message
! is typed.
!
! Returns DCON1 = pointer to literal table entry of a character constant
!		  or 0 if the corresponding variable should be set to blanks

BEGIN	! GETCHCNST

	MAP PEXPRNODE SYM;
	MAP PEXPRNODE DCON1;

	! If at end of the constant-list, type warning message
	IF .DATACNSTPTR EQL 0
	THEN
	BEGIN
		IF NOT .XTRAVARS 	! IF THIS IS THE FIRST TIME
		THEN
%1157%		WARNERR(PLIT'is greater than?0',.ISN,E57<0,0>);	!PRINT WARNING MESSAGE
		XTRAVARS _ TRUE;
		DCON1 _ 0;
		DCON2 _ 0;
		RETURN;
	END;

	DCON1 _ .DATACNSTPTR[DCONST];	! GET PTR TO CONSTANT
	DCON2 _ 0;

	IF .DCON1[VALTYPE] NEQ CHARACTER ! CHECK DATATYPE
	THEN
	BEGIN
		FATLERR(.SYM[IDSYMBOL],.ISN,E160<0,0>);
					      ! "Can't store numeric constant
					      !  in character variable X"
		DCON1 _ 0;
	END;

	IF .CNSTWDCT NEQ 0	! CHECK THAT WE ARE AT BEGINNING OF CONSTANT
	THEN
	BEGIN
		FATLERR(.ISN,E161<0,0>); ! "Character constant split between
					 !  numeric and character variables"
		CNSTWDCT _ 0;
		DCON1 _ 0;
	END;

	! Increment count of how many times this const has been used
	CNSTCT _ .CNSTCT + 1;

	! Test for whether we've finished all repetitions of this constant and
	! go to the next if we have
	IF .CNSTCT GEQ .DATACNSTPTR[DATARPT]
	THEN
	BEGIN
		DATACNSTPTR _ .DATACNSTPTR[CLINK];
		CNSTCT _ 0;
	END;

END;	! of GETCHCNST
ROUTINE OUTDATA(SYMADDR,SYMPT)=

!++
! FUNCTIONAL DESCRIPTION:
!
!	Routine to output a type 21 or 1160 REL block to initialize a
!	numeric variable to support DATA statements.
!
!	When using 1160 blocks, the data is never output immediately,
!	but is instead saved away in case the next item follows it in
!	the compiler's allocation of variables for the user's core
!	image.  This allows us to take advantage of the 1160's repeat
!	count feature.  However, if the current item can't be appended
!	to the last item, the last item is output.
!
!	Note that the second data word to be output (DCON2) is valid
!	iff SYMPT is a double word datatype.
!
! FORMAL PARAMETERS:
!
!	SYMADDR		The allocated address for the data.
!
!	SYMPT		A pointer to the symbol being initialized.
!
! IMPLICIT INPUTS:
!
!	DATDAT		Pointer to buffered literal table entry, or 1 or 2
!			buffered words of numeric data for 1160 support.
!
!	DATNEXT		Byte pointer or address this 1160 datum must match to
!			qualify as a repeat of the buffer contents.
!
!	DATPSECT	Internal psect index or pointer to COMMON block
!			for DATORG and DATNEXT.
!
!	DATRPT		Repeat count for buffer.
!
!	DATSIZE		Byte or word count for 1160 data.
!
!	DCON1, DCON2	The values to store.
!
!	F2<EXTENDFLAG>	True iff we are generating a psected object file.
!
!	FLGREG<OBJECT>	True iff we are generating an object file.
!
!	MAINRLBF	May contain a type 21 block to be appended to.
!
! IMPLICIT OUTPUTS:
!
!	DATDAT		1 or 2 buffered words of numeric data for 1160 support.
!
!	DATFILL		Number of fill bytes for 1160 block (0).
!
!	DATNEXT		Object address to match against next datum.
!
!	DATORG		Object address for buffered datum.
!
!	DATPSECT	Internal psect index or COMMON block pointer for
!			buffered data.
!
!	DATRPT		Updated repeat count for buffer.
!
!	DATSIZE		Length of buffered constant in words.
!
!	MAINRLBF	May have type 21 words appended, could be flushed.
!
!	R2		Sometimes smashed by Radix-50 conversion
!			of COMMON names.
!
!	RDATWD		Type 21 words are output through this.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Can result in type 21 or 1160 blocks being output to the
!	object and listing files.
!
!--


![2423] Moved from OUTMOD and doubled routine size to add 1160 support

BEGIN

MAP
BASE	R2:SYMPT;

REGISTER
%2423%	BASE MYPSECT,				! My psect index or COMMON
%2423%	NUMWORDS;				! Number of words of data

LABEL
%2453%	FLUSHING;

	IF NOT .FLGREG<OBJECT>			! Producing REL file ?
	THEN RETURN;				! No, punt

%2423%	IF .SYMPT[DBLFLG]			! DP or COMPLEX variable?
%2423%	THEN NUMWORDS = 2			! Yes, remember that
%2423%	ELSE					! Nope, must be single
%2423%	BEGIN	! NOT DOUBLE
%2423%		NUMWORDS = 1;			! Say one word
%2457%		DATDAT[1] = .DCON2;		! Make second comparison always
%2423%						!  win to make it simpler
%2423%	END;	! NOT DOUBLE

%1544%	IF EXTENDED				! Psected object code ?
%2423%	THEN					! Yes, use 1160 blocks
%2423%	BEGIN	! EXTENDED
%2423%		IF .SYMPT[IDATTRIBUT(INCOM)]	! In COMMON?
%2423%		THEN MYPSECT = .SYMPT[IDCOMMON]	! Yes, get COMMON block pointer
%2423%		ELSE MYPSECT = .SYMPT[IDPSECT];	! No, use psect index

		! The lack of a short-circuit OR ELSE operator in
		! Bliss-10 makes it necessary to construct one with a
		! sequence of IF/THENs and a LEAVE in order to attain
		! stylish levels of performance.

		! *** The following compound expression has one LEAVE
		! *** which *may* cause control to leave it early

FLUSHING:	BEGIN	! FLUSHING, NY

%2457%			IF .DCON1 EQL .DATDAT[0]	! Is the data the same
%2457%			THEN IF .DCON2 EQL .DATDAT[1]	!  or is it a string
%2453%			THEN IF .SYMADDR EQL .DATNEXT	!  or the wrong address
%2453%			THEN IF .MYPSECT EQL .DATPSECT	!  or the wrong psect
%2453%			THEN IF .NUMWORDS EQL .DATSIZE	!  or the wrong size?
%2453%			THEN LEAVE FLUSHING;		! No, GOTO Massapequa

			! If we did NOT manage to pass through the
			! above gauntlet of IFs, then new data we were
			! handed is different from what is in the
			! buffer.  Flush the buffer and start anew.

%2423%			FLUSHDATA();		! Output the old datum
%2457%			DATDAT[0] = .DCON1;	! Remember the new constant
%2457%			DATDAT[1] = .DCON2;	!  (both words of it),
%2423%			DATORG = DATNEXT = .SYMADDR;	!  and where it will go
%2423%			DATPSECT = .MYPSECT;	! Save the relocation
%2423%			DATSIZE = .NUMWORDS;	! Save variable size
%2423%			DATFILL = 0;		! No filler for numerics
%2423%		END;	! FLUSHING, NY

		! *** Control *may* reach here from a LEAVE of the
		! *** above compound expression.

		! Suburbia begins here.

		! At this point, regardless of whether the buffer has
		! just been flushed or not, we will dink the repeat
		! count and expected address of the next constant.

%2423%		DATNEXT = .DATNEXT+.NUMWORDS;	! Where the next one will start
%2423%		DATRPT = .DATRPT+1;		! One more init for LINK
%1544%	END	! EXTENDED
%2423%	ELSE					! Not psected, use 21 blocks
%2423%	BEGIN	! NOT EXTENDED
		IF .SYMPT[IDATTRIBUT(INCOM)]	! Variable in COMMON?
		THEN				! Yes, do special fixup
		BEGIN	! INCOM
			IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-4-.NUMWORDS
			THEN DMPMAINRLBF();	! Insure room for short count,
						!  relocation bits, symbol,
						!  subheader and data word(s)

			R2 = .SYMPT[IDCOMMON];	! Pointer to COMMON block node
			R2 = .R2[COMNAME];	! Fetch the block name
			RDATWD = RGLOBREQ+RADIX50();	! Convert to a symbol
			ZOUTBLOCK(RDATBLK,RELN);	!  request and output
%2423%			RDATWD = .NUMWORDS^18+.SYMADDR<RIGHT>;! Some word(s) at
							!  /COMMON/+SYMADDR
			ZOUTBLOCK(RDATBLK,RELN)	! Output count and offset
		END	! INCOM
		ELSE				! Not in COMMON
		BEGIN	! NOT INCOM
			IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-3-.NUMWORDS
			THEN DMPMAINRLBF();	! Insure room for short count,
						!  relocation bits, subheader
						!  and data word(s)
%2423%			RDATWD = .NUMWORDS^18+.SYMADDR<RIGHT>;! Some word(s)
							      !  at SYMADDR
			ZOUTBLOCK(RDATBLK,RELRI);	! Output count and addr
		END;	! NOT INCOM

%2457%		RDATWD = .DCON1;		! First value to be stored
		ZOUTBLOCK(RDATBLK,RELN);	! Output it

%2423%		IF .NUMWORDS EQL 2		! More to come?
%2423%		THEN				! Yes, go for it
%2423%		BEGIN	! 2 WORDS
%2457%			RDATWD = .DCON2;	! Second value to be stored
%2423%			ZOUTBLOCK(RDATBLK,RELN);	! Output it
%2423%		END;	! 2 WORDS

%2423%	END;	! NOT EXTENDED
END;	! of OUTDATA
ROUTINE OUTCHDATA(BP,LEN,CONST,SYM) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Routine to output a type 1004 or 1160 REL block to initialize
!	a character string.  The constant is truncated or padded to
!	the right length, if necessary, and put into the REL file.
!
!	When using 1160 blocks, the data is never output immediately,
!	but is instead saved away in case the next item follows it in
!	the compiler's allocation of variables for the user's core
!	image.  This allows us to take advantage of the 1160's repeat
!	count feature.  However, if the current item can't be appended
!	to the last item, the last item is output.
!
! FORMAL PARAMETERS:
!
!	BP		Object time byte pointer to the string to initialize.
!
!	LEN		Number of characters in the string to initialize.
!
!	CONST		Pointer to literal table entry of a character constant
!			(NIL when error has occurred).
!
!	SYM		Pointer to symbol table entry of variable.
!
! IMPLICIT INPUTS:
!
!	DATDAT		Pointer to buffered literal table entry, or 1 or 2
!			buffered words of numeric data for 1160 support.
!
!	DATNEXT		Byte pointer or address this 1160 datum must match to
!			qualify as a repeat of the buffer contents.
!
!	DATPSECT	Internal psect index or pointer to COMMON block
!			for DATORG and DATNEXT.
!
!	DATRPT		Repeat count for buffer.
!
!	DATSIZE		Byte or word count for 1160 data.
!
!	F2<EXTENDFLAG>	True iff we are generating a psected object file.
!
!	FLGREG<OBJECT>	True iff we are generating an object file.
!
! IMPLICIT OUTPUTS:
!
!	DATDAT		Address of literal table entry being buffered.
!
!	DATFILL		Number of fill bytes for 1160 block.
!
!	DATNEXT		Object byte pointer to match against next datum.
!
!	DATORG		Object byte pointer for buffered datum.
!
!	DATPSECT	Internal psect index or COMMON block pointer for
!			buffered data.
!
!	DATRPT		Updated repeat count for buffer.
!
!	DATSIZE		Length of buffered constant in characters.
!
!	R2		Sometimes smashed by Radix-50 conversion
!			of COMMON names.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Can result in type 1004 or 1160 blocks being output to the
!	object and listing files.
!
!--


![1242] New
![2423] Moved from RELBUF and doubled routine size to add 1160 support

BEGIN	! OUTCHDATA

MAP
BASE	CONST:
	SYM:
	R2;

OWN
	BLKHDR[5];

REGISTER
	WDLENGTH,				! LENGTH OF STRING IN WORDS
%2423%	BASE MYPSECT;				! My psect index or COMMON

LABEL
%2453%	FLUSHING;

        IF NOT .FLGREG<OBJECT> THEN RETURN;	! IF NO REL FILE, RETURN

	! If a pointer to a CHARACTER constant was not supplied by the
	! caller, punt immediately - an error occurred while GETCHCNST
	! was groping around on the DATACNSTPTR list and there is no
	! data to be output.

%2452%	IF .CONST EQL 0				! NIL pointer?
%2452%	THEN RETURN;				! Yes, punt immediately

%1544%	IF EXTENDED				! Psected object code ?
%2423%	THEN					! Yes, use 1160 blocks
%2423%	BEGIN	! EXTENDED
%2423%		IF .SYM[IDATTRIBUT(INCOM)]	! In COMMON?
%2423%		THEN MYPSECT = .SYM[IDCOMMON]	! Yes, get COMMON block pointer
%2423%		ELSE MYPSECT = .SYM[IDPSCHARS];	! No, use internal psect index

		! The lack of a short-circuit OR ELSE operator in
		! Bliss-10 makes it necessary to construct one with a
		! sequence of IF/THENs and a LEAVE in order to attain
		! stylish levels of performance.

		! *** The following compound expression has one LEAVE
		! *** which *may* cause control to leave it early

FLUSHING:	BEGIN	! FLUSHING, NY

%2453%			IF .CONST EQL .DATDAT		! Is the data numeric
%2453%							!  or not the same
%2453%			THEN IF .BP EQL .DATNEXT	!  or a different addr
%2453%			THEN IF .MYPSECT EQL .DATPSECT	!  or psect
%2453%			THEN IF .LEN EQL .DATSIZE+.DATFILL	!  or size?
%2453%			THEN LEAVE FLUSHING;		! No, GOTO Massapequa

			! If we did NOT manage to pass through the
			! above gauntlet of IFs, then new data we were
			! handed is different from what is in the
			! buffer.  Flush the buffer and start anew.

%2423%			FLUSHDATA();		! Output the old datum
%2423%			DATDAT = .CONST;	! Remember the new constant
%2423%			DATORG = DATNEXT = .BP;	!  and where it will go
%2423%			DATPSECT = .MYPSECT;	! Save the relocation

%2423%			IF .LEN LEQ .CONST[LITLEN]	! Variable smaller?
%2423%			THEN			! Yes, no filler needed
%2423%			BEGIN	! NO FILL
%2423%				DATSIZE = .LEN;	! Save variable size
%2423%				DATFILL = 0;	! Pure beef - no filler
%2423%			END	! NO FILL
%2423%			ELSE			! Variable bigger than literal
%2423%			BEGIN	! FILL
%2423%				DATSIZE = .CONST[LITLEN]; ! Use whole string
%2423%				DATFILL = .LEN-.CONST[LITLEN];	! Fill the rest
%2423%			END;	! FILL
%2423%		END;	! FLUSHING, NY

		! *** Control *may* reach here from a LEAVE of the
		! *** above compound expression.

		! Suburbia begins here.

		! At this point, regardless of whether the buffer has
		! just been flushed or not, we will dink the repeat
		! count and expected byte pointer of the next constant.

%2423%		DATNEXT = BPADD(.DATNEXT,.LEN);	! Where next one starts
%2423%		DATRPT = .DATRPT+1;		! One more init for LINK
%1544%	END	! EXTENDED
	ELSE					! Not extended, use 1004 blocks
	BEGIN	! NOT EXTENDED
		WDLENGTH _ (.LEN+4)/5;		! GET NUMBER OF WORDS OCCUPIED
						! BY INITIALIZATION STRING

		IF .SYM[IDATTRIBUT(INCOM)]
		THEN
		BEGIN	! IN COMMON
			BLKHDR[0]<LEFT> _ RCHDATA;	! BLOCK TYPE 1004
			BLKHDR[0]<RIGHT> _ .WDLENGTH + 4;	! LONG COUNT
			BLKHDR[1] _ 0;		! RELOCATION WORD: NONE
			R2 _ .SYM[IDCOMMON];	! COMMON BLOCK NODE
			BLKHDR[2] _ .R2[COMNAME];! SIXBIT COMMON BLOCK NAME
			BLKHDR[3] _ .LEN;	! BYTE COUNT
			BLKHDR[4] _ .BP;	! BYTE POINTER
			DMPRLBLOCK(BLKHDR,5);	! DUMP BLOCK HEADER
		END	! IN COMMON
		ELSE
		BEGIN	! NOT IN COMMON
			BLKHDR[0]<LEFT> _ RCHDATA; ! BLOCK TYPE 1004
			BLKHDR[0]<RIGHT> _ .WDLENGTH + 3;	! LONG COUNT
			BLKHDR[1] _ RELRI ^ 32;	! RELOCATION WORD: RIGHT HALF
						!  RELOC OF BYTE POINTER WORD
			BLKHDR[2] _ .LEN;	! BYTE COUNT
			BLKHDR[3] _ .BP;	! BYTE POINTER
			DMPRLBLOCK(BLKHDR,4);	! DUMP BLOCK HEADER
		END;	! NOT IN COMMON

		! Output the constant from the literal node.  If the
		! string to be initialized is exactly the same length
		! as the constant, fine.  If the string is shorter,
		! only output enough words of the constant to fill the
		! desired length of the string.  There may be unused
		! characters in the last word.  If the string is
		! longer, output the entire constant (which is padded
		! with blanks in the last word), then output blanks
		! until enough words have gone out.

		R1 _ .CONST[LITSIZ]-1;
		IF .R1 GTR .WDLENGTH THEN R1 _ .WDLENGTH;
		DMPRLBLOCK (CONST[LIT1], .R1);

		INCR I FROM .CONST[LITSIZ] TO .WDLENGTH DO
		DMPRLBLOCK (UPLIT'     ', 1);
	END;	! NOT EXTENDED
END;	! of OUTCHDATA
ROUTINE FLUSHDATA =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Uses information in a variety of module OWNs to construct and
!	output an 1160 Ultimate Sparse Data REL block.  This tells
!	LINK which locations to statically initialize for Fortran DATA
!	statements under extended addressing.
!
!	Only expects to be called when generating a REL file under
!	extended addressing.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	DATPSECT	Internal psect index or pointer to COMMON block
!			for DATORG and DATNEXT.
!
!	DATDAT[2]	If DATNEXT is a byte pointer, address of literal table
!			entry to output, otherwise 1 or 2 words of numeric
!			data to be output.
!
!	DATFILL		Number of bytes of fill for 1160 block.
!
!	DATORG		Origin byte pointer for start of buffered data.
!
!	DATRPT		Repeat count for 1160 block.
!
!	DATSIZE		Number of bytes of data in buffer to output.
!
! IMPLICIT OUTPUTS:
!
!	DATRPT		Repeat count is zeroed.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	May flush the 1160 REL buffer into the object and listing files.
!
!--


![2423] New

!		Type 1160 Ultimate Sparse Data REL Block

! !=========================================================================!
! !                1160                !             Long count             !
! !-------------------------------------------------------------------------!
! !R!F!B! Byte pos  !0! Symbol Length  !            Psect Index             !
! !-------------------------------------------------------------------------!
! !                            Symbol in SIXBIT                             !
! !-------------------------------------------------------------------------!
! ! Byte size !                       Origin address                        !
! !-------------------------------------------------------------------------!
! !                        Repetition count (if R=1)                        !
! !-------------------------------------------------------------------------!
! !                           Fill count (if F=1)                           !
! !-------------------------------------------------------------------------!
! !                           Fill byte (if F=1)                            !
! !-------------------------------------------------------------------------!
! !                           Byte count (if B=1)                           !
! !-------------------------------------------------------------------------!
! \                                                                         \
! \                               Data bytes                                \
! \                                                                         \
! !=========================================================================!

BEGIN
MAP
BASE	DATDAT;					! We are more interested in the
						!  fact that DATDAT[0] can be a
						!  pointer to a constant table
						!  entry than the fact that it
						!  is also a two word vector
REGISTER
%2423%	WORDCOUNT,				! Number of data words
%2423%	LONGCOUNT;				! Cursor into BLKHDR (long
						!  count under construction)
LOCAL
RELBUFF	BLKHDR[8];				! Holds header of 1160 block

! The following UPLIT maps the P&S field of a OWGBP into the P and S
! fields of a OWLBP.  Table entries contain an entire local byte
! pointer, with G, I, X and Y fields that contain 0.  The table should
! be indexed by the OWGBP's P&S field.

BIND	![2216] <LH> of OWLBPs indexed by OWG<30,6> (#61:#66)
%2216%	VECTOR BPLH = UPLIT(0<36,7>,0<29,7>,0<22,7>,0<15,7>,0<8,7>,0<1,7>)-#61;

	IF .DATRPT EQL 0			! Any data in buffer?
	THEN RETURN;				! No, punt quickly

	BLKHDR[RTYPE] = RULTIMATEDATA;		! Set block type
	LONGCOUNT = 1;				! Init long count for flag word
%2453%	BLKHDR[RULTFLAGS] = 0;			! Init whole flag word to 0

	IF .DATPSECT GEQ &JBDA<0,0>		! Address or psect index?
	THEN					! Address, must be COMMON block
	BEGIN	! COMMON

		BLKHDR[RULTSYMLEN] = 1;		! One word for the symbol
		BLKHDR[RULTPSECT] = PXABS;	! Don't relocate origin address

		! Get the COMMON block name in SIXBIT and account for
		!  the extra word in the long count

		BLKHDR[RULTSYMNAM] = .DATPSECT[COMNAME];
		LONGCOUNT = .LONGCOUNT+1;
	END	! COMMON
%2453%	ELSE BLKHDR[RULTPSECT] = .EXTERNPSECT[.DATPSECT];	! Psect index

	! Output the byte size, and the origin address

	BLKHDR[RULTORGADDR(LONGCOUNT = .LONGCOUNT+1)] = .DATORG<OWGBPADDR>;

	IF .DATORG<OWGBPP&S> NEQ 0		! Is DATORG a byte pointer?
	THEN					! Yes, set CHARACTER P and S
	BEGIN	! CHARACTER

		! Get P field from the OWGBP in DATORG

		BLKHDR[RULTPOS] = .BPLH[.DATORG<OWGBPP&S>]<OWLBPP>;

		! Set byte size

		BLKHDR[RULTSIZE(.LONGCOUNT)] = BITSPERCHAR;
		WORDCOUNT = CHWORDLEN(.DATSIZE);
	END	! CHARACTER
	ELSE					! Nope, must be a word address
	BEGIN	! NUMERIC
		BLKHDR[RULTPOS] = BITSPERWORD;	! Right justified ILDB P field
		BLKHDR[RULTSIZE(.LONGCOUNT)] = BITSPERWORD;	! Set word size
		WORDCOUNT = .DATSIZE;		! # Bytes equals # words
	END;	! NUMERIC

	IF .DATRPT GTR 1			! Non-trivial repeat count?
	THEN					! Yes, output it
	BEGIN	! REPEAT
		BLKHDR[RULTRPTFLAG] = 1;	! Flag for repeat field
		BLKHDR[RULTREPEATCOUNT(LONGCOUNT = .LONGCOUNT+1)] = .DATRPT;
	END;	! REPEAT

	IF .DATFILL GTR 0			! Are fill bytes needed?
	THEN					! Yes, output count and byte
	BEGIN	! FILL
		BLKHDR[RULTFILLFLAG] = 1;	! Flag for fill fields

		! Supply fill byte count and fill byte (always a space)

		BLKHDR[RULTFILLCOUNT(LONGCOUNT = .LONGCOUNT+1)] = .DATFILL;
		BLKHDR[RULTFILLBYTE(LONGCOUNT = .LONGCOUNT+1)] = " ";
	END;	! FILL

	IF .DATSIZE GTR 1			! More than one byte?
	THEN					! Yes, output a byte count
	BEGIN	! COUNT
		BLKHDR[RULTBYTEFLAG] = 1;	! Flag for byte count word

		! Supply size of data in bytes

		BLKHDR[RULTBYTECOUNT(LONGCOUNT = .LONGCOUNT+1)] = .DATSIZE;
	END;	! COUNT

	BLKHDR[RDATCNT] = .LONGCOUNT+.WORDCOUNT;	! Set the long count

	DMPRLBLOCK(BLKHDR,.LONGCOUNT+1);	! Output the block header

	IF .DATORG<OWGBPP&S> NEQ 0		! CHARACTER or numeric?
	THEN DMPRLBLOCK(DATDAT[LIT1],.WORDCOUNT)	! It's CHARACTER
	ELSE DMPRLBLOCK(DATDAT,.WORDCOUNT);	! Nope, it's numeric

	DATRPT = 0;				! Empty the buffer, nothing
						!  to repeat yet
END;	! of FLUSHDATA

END
ELUDOM