Google
 

Trailing-Edge - PDP-10 Archives - FORTRAN-10_V7wLink_Feb83 - srca.bli
There are 12 other files named srca.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) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR: F. INFANTE/HPW/NEA/DCE/SJW/CDM/TFV/AHM/PLB

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

GLOBAL BIND SRCAV = 6^24 + 0^18 + #1600;	! Version Date:	9-Jul-82

%(

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

41	-----	-----	REWRITE CORMAN TO ALLOCATE IN PAGES OR
			K DEPENDING UPON PROCESSOR 
			REWRITE CORMAN TO ELIMINATE REFERENCES
			TO BREG
			MAKE ERROUT EXTERNAL IN NEWENTRY
42	-----	-----	FIX NEWENTRY TO USE OPERSP INSTEAD OF SRCID
			IN I/O LIST NODES
43	-----	-----	TAKE OUT 42
44	----	-----	PUNT
45	-----	-----	PUNT + 1
46	-----	-----	ADD MAKEPR TO THIS MODULE

47	-----	-----	HAVE NEWENTRY SET THE NOALLOC BIT FOR SYMBOL
			TABLE ENTRIES GENERATED WHILE IN PHASE 1

48	----	-----	CHANGE THE NAME OF LIBSRCH TO SRCHLIB ( JUST TO
			GET ALL REFERENCES) AND ITS PARAMETER TO A
			SYMBOL TABLE POINTER RATHER THAN A NAME.
			THEN REJECT AND NAMES THAT HAVE BEEN TYPED WITH
			A CONFLICTING TYPE EVEN THOUGH THEY ARE LIBRARY
			FUNCTION NAMES
49	355	18132	ALLOCATE MORE THAN ONE CORE BLOCK AT A TIME, (DCE)

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

50	543	NONE	FIX THE BINARY SEARCH FOR LIBRARY FUNCTIONS
51	574	NONE	REWRITE BINARY SEARCH IN SRCHLIB TO WORK AFTER
			  EDIT 543, (SJW)

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

52	707	27153	CHANGE SAVSPACE TO REDUCE JOBFF IF POSSIBLE, (DCE)

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

53	1133	TFV	28-Sep-81	------
	Keep track of the maximum size of the compiler lowseg in MAXFF
	for /STATISTICS output.

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

54	1270	CDM	6-Oct-81
	Changed SRCHLIB not to give up when it finds a library name that
	was declared in a type declaration.  (deleted code)

55	1406	TFV/CDM	18-Dec-81
	Write   NEWDVAR   to   create   a   .Dnnnn   variable   for    a
	compile-time-constant character descriptor.  The entries are all
	linked together.  They have an  OPRCLS of DATAOPR and an  OPERSP
	of VARIABLE.  Either one word  (byte pointer only) or two  words
	(byte pointer  and  length)  are generated  based  on  the  flag
	IDGENLENFLG.  One word .Dnnnn variables are used for  SUBSTRINGs
	with constant lower bounds and non-constant upper bounds.

1526	AHM	11-May-82
	Make GENLAB always set SNPSECT of the label table entry it  is
	creating to the .CODE. psect.

1530	TFV	4-May-82
	Cleanup CORMAN and SAVSPACE.  Symbolize the number of  FREELISTs
	using FLSIZ.  Free nodes of at least FLSIZ words are linked onto
	FREELIST[0].   Free  nodes  of   SIZE  words  are  linked   onto
	FREELIST[.SIZE].

1535	CDM	28-Jun-82
	Moved MAKLIT to here.

1521	CDM	29-Jun-82
	Moved routine  SECDESC to here from RELBUF.

1567	CDM	1-Jul-82
	Changed name of SECSESC to CHEXLEN (CHaracter EXpression LENgth).

1600	PLB	9-Jul-82
	Convert CORMAN to use CORUUO simulated CORE UUO from
	COMMAN.MAC, so as to avoid spurious NXP interupts.
	Added REQUIRE for FTTENX.

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

)%

REQUIRE 'FTTENX.REQ';		![1600] O/S Feature test

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

FORWARD
	ADDLOOP(1),
	TBLSEARCH,
	THASH,
	SRCHLIB(1),
	NEWENTRY,
	TESTENTRY,
	SAVSPACE(2),
	CORMAN,
	GENLAB,
	MAKEPR(5),
	MAKPR1(6),
	NEWDVAR;	! Create new .Dnnnn variable

EXTERNAL
	CGERR,
	CHAR,
	CORERR,
%1600%	CORUUO,		! Simulated CORE UUO
%1406%	DANCHOR,	! Pointer to start of linked list of .Dnnnn variables.
			! They are used for compile-time-constant character
			! descriptors.  They are not reused.
%1406%	DCNT,		! Counter to use when generating the next .Dnnnn
	DELETPTR,
	DLOOPTREE,
	ENTRY,
	FREELIST,	! Vector of free nodes.  Nodes of at least FLSIZ
			! words are linked onto FREELIST[0] and are  not
			! reused.   All  other  nodes  are  linked  onto
			! FREELIST[.SIZE].
	ILABIX,
	IOLSPTR,
	JOBFF,
	JOBREL,
	LASLVL0,
%1406%	BASE LASTD,	! Pointer to the last .Dnnnn variable created
	LIBATTRIBUTES,
	LIBFUNTAB,
	LITERL,
%1133%	MAXFF,		! Maximum size of compiler lowseg
	NAME,
	NAMLPTR,
	PUTMSG,
	QUEUE,
	SEGINCORE,
	SPACEFREE,
	STTTYP,
	TABSPACE,
	TTOTAL;

GLOBAL ROUTINE ADDLOOP(LEVEL)=
BEGIN
	!***************************************************************
	! Add DO loop  node to tree.   This routine builds  a tree  that
	! describes the  DO loops of a program.   See the  DO tree  node
	! description in FIRST.BLI.   The tree  is binary  in the  sense
	! that it points  to only one  parallel loop and  one loop at  a
	! deeper level.
	!***************************************************************

	LOCAL BASE DOFATHER;
	OWN TEM1;
	REGISTER BASE DONODE;
	MAP BASE SORCPTR;

	XTRAC;		! For debugging trace

	NAME<LEFT> = DONODESIZ;
	TEM1 =  CORMAN();		! Reserve space for entry

	IF .DLOOPTREE EQL 0
	THEN
	BEGIN
		DONODE = .TEM1;
		DLOOPTREE = .DONODE;
		LASLVL0 = .DONODE;
		DONODE[LEVL] = 1;
		SORCPTR[INNERDOFLG] = 1;
		DONODE[DOSRC] = .LASTSRC;
		RETURN .DONODE
	END;

	DONODE = .LASLVL0<RIGHT>;	! Set up search

	WHILE 1 DO
	BEGIN
		WHILE .DONODE[PARLVL] NEQ 0 DO DONODE = .DONODE[PARLVL];

		IF .DONODE[LEVL] EQL .LEVEL
		THEN
		BEGIN	! Equal level of DO.  First time through .LEVEL
			! must equal 0 to do the setup

			DONODE[PARLVL] = .TEM1;		! The parallel level
			DONODE = .TEM1;
			DONODE[LEVL] = .LEVEL;		! Set level

			! Set last level for next search

			IF .LEVEL EQL 1 THEN LASLVL0 = .DONODE;

			SORCPTR[INNERDOFLG] = 1;
			DONODE[NEXTDO] = 0;		! Zero next DO level
			DONODE[DOSRC] = .LASTSRC;
			RETURN .DONODE

		END;	! Equal level of DO.  First time through .LEVEL
			! must equal 0 to do the setup

		DO
		BEGIN
			WHILE .DONODE[PARLVL] NEQ 0
			DO DONODE = .DONODE[PARLVL];

			IF .DONODE[NEXTDO] EQL 0
			THEN
			BEGIN
				DOFATHER = .DONODE[DOSRC];
				DOFATHER[INNERDOFLG] =  0;
				DONODE[NEXTDO] = .TEM1;	! Deeper level of DO
				DONODE = .TEM1;		! New ptr to deepest DO
				SORCPTR[INNERDOFLG] = 1;
				DONODE[LEVL] = .LEVEL;
				DONODE[DOSRC] = .LASTSRC;

				RETURN .DONODE
			END;

			DONODE = .DONODE[NEXTDO];
		END
		WHILE .DONODE[LEVL] LSS .LEVEL;

	END;	! of WHILE 1 DO

END;	! of ADDLOOP


GLOBAL ROUTINE TBLSEARCH=
BEGIN
	!***************************************************************
	! Lookup an entry in  the the various  dynamic tables.  It  also
	! makes entries  into  tables  for new  entries  and  returns  a
	! pointer to the table entry just made or found and also sets  a
	! flag (FLAG). If the entry was already in the table, the  value
	! of flag is  set to -1,  if the  entry was not  already in  the
	! table the value is set to 0.
	!
	! The parameters for this routine are two global variables  NAME
	! and ENTRY.  NAME contains the  table number in the right  half
	! and the entry size in the left half.  ENTRY is the address  of
	! the first word of  the table argument to  be looked up  and/or
	! entered in a table.  .ENTRY is the value of the first word  of
	! the argument.
	!***************************************************************

	BIND
		LISTX = UPLIT(SYMTBL,CONTBL,EXPTBL,LABTBL,SRCTBL,
				DIMTBL,DATTBL,NAMTBL,LITTBL),
		ITEM = .LISTX[.NAME<RIGHT>]<RIGHT>;
	LOCAL I;
	MAP BASE DELETPTR;

	XTRAC;		! For debugging trace

	IF .NAME<RIGHT> GTR 12 THEN RETURN;

	IF .NAME<RIGHT> GTR 3
	THEN
	BEGIN
		NEWENTRY();
		FLAG = 0;
		RETURN .BASEPOINT	! NEWENTRY resets BASEPOINT
	END;

	I = THASH();
	BASEPOINT = .ITEM[.I];		! Get hash table entry value

	IF .BASEPOINT EQL 0
	THEN
	BEGIN	! Unique hash - generate a new entry

		NEWENTRY();		! Initialize BASEPOINT and setup data
		ITEM[.I] = .BASEPOINT;
		BASEPTR[CLINK] = 0;
		FLAG = 0;
		RETURN .BASEPOINT

	END	! Unique hash - generate a new entry
	ELSE
	BEGIN	! See if an entry is in the linked list for the hash I

		WHILE 1 DO
		BEGIN
			IF TESTENTRY()
			THEN
			BEGIN
				FLAG = -1;
				RETURN .BASEPOINT
			END
			ELSE	IF .BASEPTR[CLINK] NEQ 0
			THEN	BASEPOINT = .BASEPTR[CLINK]
			ELSE
			BEGIN
				NEWENTRY();
				BASEPTR[CLINK] = .ITEM[.I]<RIGHT>;
				ITEM[.I]<RIGHT> = .BASEPOINT;
				FLAG = 0;
				RETURN .BASEPOINT
			END;

		END;	! of WHILE 1 DO

	END	! See if an entry is in the linked list for the hash I

END;	! of TBLSEARCH


GLOBAL ROUTINE THASH=
BEGIN
	!***************************************************************
	! Develop  hash code from possible  entry using .NAME to  define
	! the table needed.
	!***************************************************************

	XTRAC;		! For debugging trace

	RETURN ABS(CASE .NAME OF SET

		.ENTRY MOD SSIZ;	! 0 - Symbol table

		(.(ENTRY + 1) XOR .ENTRY) MOD CSIZ;	! 1 - Constant table

		BEGIN END;		! 2 - (Not used) Common sub-expression 

		IF .ENTRY GEQ LASIZ	! 3 - Statement number table
		THEN .ENTRY MOD LASIZ
		ELSE .ENTRY;

		TES)

END;	! of THASH


GLOBAL ROUTINE SRCHLIB(NODE) =
BEGIN
	!***************************************************************
	! Search the library function table  for the sixbit name in  the
	! IDSYMBOL field of NODE.   If found then  returns a pointer  to
	! the table entry.  If not found then returns -1.  Binary search
	! is algorithm B in 6.2.1 of Knuth Vol. 3.
	!***************************************************************

	MAP
		BASE  NODE,
		LIBATTSTR  LIBATTRIBUTES;

	OWN
		TOP,
		BOTTOM;

	REGISTER
		PARAM,
		CENTER;

	PARAM = .NODE [IDSYMBOL];		! Get candidate name
	TOP = LIBFUNTAB<0,0>;			! First table entry

	! Note that ONEAFTERLIB is a counted plit

	BOTTOM = (ONEAFTERLIB - 2)<0,0>;	! Last table entry

	WHILE 1 DO
	BEGIN
		IF .BOTTOM LSS .TOP THEN RETURN -1;	! Entry not found
		CENTER = (.TOP + .BOTTOM) / 2;		! Find mid-point

		! Return pointer to table entry if desired entry found

%1270%		IF .PARAM EQL @@CENTER THEN RETURN .CENTER<RIGHT>;

		IF .PARAM GTR @@CENTER
		THEN TOP = .CENTER + 1		! Ignore old top thru center
		ELSE BOTTOM = .CENTER - 1;	! Ignore center thru old bottom

	END;	! of WHILE 1 DO

END;	! of SRCHLIB


GLOBAL ROUTINE NEWENTRY=
BEGIN
	!***************************************************************
	! Enter a new item into the  table defined by the right half  of
	! NAME.
	!***************************************************************

	MAP
		BASE COMBLKPTR,
		BASE DATASPTR,
		BASE EQVPTR,
		BASE IOLSPTR,
		BASE LABLOFSTATEMENT,
		BASE LITPOINTER,
		BASE NAMLPTR,
		BASE SORCPTR;

	MACRO
		PARAM = ENTRY$,
		BP = BASEPTR$;

	OWN
		TOP,
		BOTTOM;

	XTRAC;		! For debugging trace
	BP = CORMAN();	! Get space - NAME<LEFT> defines the number of words.
			! CORMAN zeroes the space before returning

	! Keep count of tables space being used

	! TABSPACE[.NAME] _ .TABSPACE[.NAME]+.NAME<LEFT>;

	CASE .NAME OF SET

	BEGIN	! 0 - Symbol table

		BP[VALTYPE] = .SYMTYPE;
		BP[IDSYMBOL] = .ENTRY;
		BP[OPRCLS] = DATAOPR;
		BP[OPERSP] = VARIABLE;		! Node is a variable

		! Set the noallocate bit until the name is referenced It
		! will be cleared by NAMSET/NAMREF

		IF .SEGINCORE EQL 1
		THEN BP[IDATTRIBUT(NOALLOC)] = 1;

	END;	! 0 - Symbol table

	BEGIN	! 1 - Constant table

		BP[CONST1] = .ENTRY;
		BP[CONST2] = .ENTRY[1];
		BP[OPRCLS] = DATAOPR;
		BP[VALTYPE] = .SYMTYPE;
		BP[OPERSP] = CONSTANT;

	END;	! 1 - Constant table

	BEGIN END;	! 2 - (Not used) Common sub-expression 

	BEGIN	! 3 - Statement number table

		BP[SNUMBER] = .ENTRY;
		BP[OPRCLS] = LABOP;

		! Initialize SNHDR to  0 and SNREFNO  to 1.  This  makes
		! the reference count one larger  than it actually is  -
		! for unfortunate historical reasons.

		BP[SNREF] = 1;

	END;	! 3 - Statement number table

	BEGIN	! 4 - COMMON block table

		IF .LASCOMBLK EQL 0
		THEN LASCOMBLK = FIRCOMBLK =  .BASEPOINT
		ELSE
		BEGIN
			COMBLKPTR[NEXCOMBLK] = .BASEPOINT;
			LASCOMBLK = .BASEPOINT;
		END;

		BP[COMNAME] = .ENTRY;	! Store name

	END;	! 4 - COMMON block table


	BEGIN	! 5 - Executable source table

		IF .SORCPTR NEQ 0
		THEN SORCPTR[CLINK] = .BASEPOINT
		ELSE
		BEGIN	! Make a dummy CONTINUE node as first statement

			FIRSTSRC = LASTSRC = .BASEPOINT;
			BP[SRCID] = CONTID;
			BP[SRCISN] = 0;
			BP[OPRCLS] = STATEMENT;
			BASEPOINT = CORMAN();	! Make a CONTINUE node
			SORCPTR[CLINK] = .BASEPOINT;	! Link to CONTINUE

		END;	! Make a dummy CONTINUE node as first statement

		LASTSRC = .BASEPOINT;
		BP[SRCISN]  = .ISN;		! Internal sequence number
		BP[SRCID]  = .IDOFSTATEMENT;
		BP[OPRCLS] = STATEMENT;

		IF (.IDOFSTATEMENT<RIGHT> GEQ STOPID)
			AND (.IDOFSTATEMENT<RIGHT> LEQ OPENID)
			AND (.IDOFSTATEMENT<RIGHT> NEQ ENDID) THEN
		IF .IOFIRST EQL 0
		THEN IOFIRST = IOLAST = .BP
		ELSE
		BEGIN
			IOLSPTR[IOLINK] = .BP; ! Link in new I/O statement
			IOLAST = .BP;
		END;

		BP[SRCLBL] = .LABLOFSTATEMENT;	! If any

		IF .LABLOFSTATEMENT NEQ 0 THEN LABLOFSTATEMENT[SNHDR] = .BP;

	END;	! 5 - Executable source table

	BEGIN END;	! 6 - Dimension entries for arrays

	BEGIN	! 7 - Expressions (not hashed)

	! Call NEWENTRY directly; EXPTAB should be loaded into NAME

	BP[ARG1PTR] = .ENTRY;		! First operand
	BP[ARG2PTR] = .ENTRY[1];	! Second operand
	BP[TARGET] = 0;
	BP[VALTYPE] = .SYMTYPE;

	END;	! 7 - Expressions (not hashed)

	BEGIN	! 8 - Iolist node or data intialization

		BP[SRCID] = .IDOFSTATEMENT;
	END;	! 8 - Iolist node or data intialization

	BEGIN	! 9 - Literal table

		MACRO
			FIRLIT = LITPOINTER<LEFT>$,
			LASTLIT = LITPOINTER<RIGHT>$;

		IF .FIRLIT EQL 0
		THEN FIRLIT = LASTLIT = .BASEPTR
		ELSE
		BEGIN
			LITPOINTER[CLINK] = .BASEPTR;
			LASTLIT = .BASEPTR
		END;

	END;	! 9 - Literal table

	BEGIN	! 10 - Search for library function in library table

		CGERR();

	END;	! 10 - Search for library function in library table

	BEGIN	! 11 -  Equivalence group or class entry

		IF .EQVPTR EQL 0
		THEN EQVPTR<LEFT> = EQVPTR<RIGHT> = .BP
		ELSE
		BEGIN
			EQVPTR[EQVLINK] = .BP;	! Link in new group
			EQVPTR<RIGHT> = .BP	! Pointer to last group made
		END;

		! ENTRY has pointer to first EQVITEM made by case 12 for
		! current EQVGROUP

		BP[EQVFIRST] = BP[EQVLAST] = .ENTRY;

	END;	! 11 -  Equivalence group or class entry

	BEGIN END;	! 12 -  Equivalence list entry

	BEGIN	! 13 -  Data group nodes for DATA statements

		IF .DATASPTR EQL 0
		THEN DATASPTR<LEFT> = DATASPTR<RIGHT> = .BP
		ELSE
		BEGIN
			DATASPTR[DATALNK] = .BP; 	! Point to last
			DATASPTR<RIGHT> = .BP;
		END;

	END;	! 13 -  Data group nodes for DATA statements

	BEGIN	! 14 -  NAMELIST list header

		IF .NAMLPTR EQL 0
		THEN NAMLPTR<LEFT> = NAMLPTR<RIGHT> = .BP
		ELSE
		BEGIN
			NAMLPTR[CLINK] = .BP;
			NAMLPTR<RIGHT> = .BP;
		END;

	END;	! 14 -  NAMELIST list header

	TES;

!   	IF DEBUG
!   	THEN
!	BEGIN
!		XAREA0<LEFT> = .NAME<LEFT>;
!		XAREA0<RIGHT> = .BASEPOINT<RIGHT>;
!		XAREA();
!	END;

	RETURN .BASEPTR

END;	! of NEWENTRY


GLOBAL ROUTINE TESTENTRY=
BEGIN
	!***************************************************************
	! Test the current  table entry against  the search argument  to
	! see if there is a match.  Returns -1 if there is a match.
	!***************************************************************

	XTRAC;		! For debugging trace

	RETURN CASE .NAME OF SET

	BEGIN	! 0 - Symbol table

	IF .BASEPTR[IDSYMBOL] EQL .ENTRY THEN -1 ELSE 0

	END;	! 0 - Symbol table

	BEGIN	! 1 - Constant table

		IF .SYMTYPE EQL .BASEPTR[VALTYPE]
		THEN
		BEGIN
			IF .BASEPTR[VALTP1] NEQ INTEG1
			THEN
			BEGIN
				IF .BASEPTR[CONST1] EQL .ENTRY
				THEN	IF .BASEPTR[CONST2] EQL .(ENTRY + 1)
					THEN -1
					ELSE 0
			END
			ELSE	IF .BASEPTR[CONST2] EQL .(ENTRY+1)
				THEN -1
				ELSE 0
		END

	END;	! 1 - Constant table

	BEGIN END;	! 2 - Common subexpression (not used)

	BEGIN	! 3 - Statement number table

		IF .BASEPTR[SNUMBER] EQL .ENTRY
		THEN
		BEGIN
			BASEPTR[SNREF] = .BASEPTR[SNREF] + 1;
			-1
		END
		ELSE 0

	END;	! 3 - Statement number table

	TES;

END;	! of TESTENTRY


GLOBAL ROUTINE SAVSPACE(SIZE,POINTER)=
BEGIN
	!***************************************************************
	! Free up space by linking a node onto  the FREELISTs.  SIZE  is
	! actually one  less than  the  number of  words in  the  entry.
	! POINTER points to  the node  to free.  All  nodes of at  least
	! FLSIZ words are linked onto FREELIST[0] and are never  reused.
	! This is used  for literals  which assume that  their space  is
	! never reused.
	!***************************************************************

%1530%	! Rewritten by TFV on 4-May-82

	! OWN FREETOTAL[FLSIZ];

	XTRAC;		! For debugging trace

	! Keep track of maximum compiler lowseg size

%1133%	IF .JOBFF GTR .MAXFF THEN MAXFF = .JOBFF;

	SIZE = .SIZE + 1;	! The front end counts relative to 0

%707%	! Bring JOBFF back down if possible - prevents fragmentation

%707%	IF (.POINTER + .SIZE) EQL .JOBFF
%707%	THEN	JOBFF = .JOBFF - .SIZE
%707%	ELSE	IF .SIZE GEQ FLSIZ
		THEN
		BEGIN	! Large entries are linked on FREELIST[0]

			(.POINTER)<RIGHT> = .FREELIST[0]<RIGHT>;
			FREELIST[0]<RIGHT> = .POINTER;

			! FREETOTAL[0] = .FREETOTAL[0] + .SIZE;

		END	! Large entries are linked on FREELIST[0]
		ELSE
		BEGIN	! Reusable node

			(.POINTER)<RIGHT> = .FREELIST[.SIZE]<RIGHT>;
			FREELIST[.SIZE]<RIGHT> = .POINTER;

			! FREETOTAL[.SIZE] = .FREETOTAL[.SIZE] + .SIZE;

		END;	! Reusable node

		! TTOTAL = .TTOTAL + .SIZE;
	.VREG

END;	! of SAVSPACE


GLOBAL ROUTINE CORMAN=
BEGIN
	!***************************************************************
	! Allocate a new node in memory.  The parameter for this routine
	! is the global NAME which contains  the entry size in the  left
	! half.  If  FREELIST[.SIZE] is  non-zero, a  free node  of  the
	! right size exists and is  reused.  Literals assume that  nodes
	! of at least FLSIZ words are built at JOBFF and that  succesive
	! CORMAN calls append to the literal.
	!***************************************************************

%1530%	! Rewritten by TFV on 4-May-82

	REGISTER
		SIZE,		! Size of the created node
		BASE POINTER,	! Pointer to the created node
		BASE BLTPTR;	! Used to BLT the node to zero

	! OWN BLKLIM;		! Limit of area to be returned

	! The next line is for debugging and performance anaylsis

	! OWN BLKS[FLSIZ];

	XTRAC;		! For debugging trace

	SIZE = .NAME<LEFT>;	! The number of words in the node

	! The next line is for debugging and performance analysis

	! IF .SIZE LSS FLSIZ
	! THEN BLKS[.SIZE] = .BLKS[.SIZE] + 1
	! ELSE BLKS[0] = .BLKS[0] + 1;

	IF .SIZE LSS FLSIZ
	THEN POINTER = .FREELIST[.SIZE]<RIGHT>	! Try to reuse a free node
	ELSE POINTER = 0;			! Can't reuse a node

	IF .POINTER NEQ 0
	THEN
	BEGIN	! Reuse a free node

		FREELIST[.SIZE]<RIGHT> = @.POINTER;

		! TTOTAL = .TTOTAL - .SIZE;

	END	! Reuse a free node
	ELSE
	BEGIN	! Allocate a new node

		POINTER = .JOBFF;	! Pointer to the node

		JOBFF = .JOBFF + .SIZE;		! Update JOBFF
		SPACEFREE = .JOBREL - .JOBFF;	! Compute remaining free space

		IF .SPACEFREE LSS 0
		THEN
		BEGIN	! Allocate more memory

			! May have to allocate more than 1 core block so
			! allocate all you need

%1600%			IF FTTENEX
%1600%			THEN CORUUO(.JOBFF) 		! TOPS-20
%1600%			ELSE
%1600%			BEGIN				! TOPS-10
%1600%				POINTER = .JOBFF;	! Put into an AC
				CALLI(POINTER,#11);	! Do a CORE UUO
				 CORERR()		! Did not skip - error
%1600%			END;				! TOPS-10

			SPACEFREE = .JOBREL - .JOBFF;
			POINTER = .JOBFF - .SIZE;

%1133%			! Keep track of maximum compiler lowseg size

%1133%			IF .JOBFF GTR .MAXFF THEN MAXFF = .JOBFF;

		END;	! Allocate more memory

	END;	! Reuse a free node

	(.POINTER)<FULL> = 0;		! Clear first word in node for BLT

	IF .SIZE NEQ 1 THEN
	BEGIN
		BLTPTR<LEFT> = #0[.POINTER]<0,0>;
		BLTPTR<RIGHT> = #1[.POINTER]<0,0>;
		BLT(BLTPTR,(.SIZE - 1)[.POINTER]);
	END;

	RETURN .POINTER;

END;	! of CORMAN


GLOBAL ROUTINE GENLAB=
BEGIN

	! Create a label table entry for a new internal label.  ILABIX
	! is initialized to 100000 to distinguish internal labels from
	! FORTRAN program labels.

REGISTER
%1526%	BASE LAB;

	ENTRY = .ILABIX;
	NAME = LABTAB;
	ILABIX = .ILABIX+1;
	LAB = TBLSEARCH();
%1526%	LAB[SNPSECT] = PSCODE;	! Generated labels are always in the hiseg
	RETURN .LAB;		! Return pointer to label table entry

END;	! of GENLAB

GLOBAL ROUTINE MAKEPR(CLAS,SPECFI,VTYPE,A1PTR,A2PTR) =
BEGIN
	!***************************************************************
	! Make an expression node for phase 2 skeleton and phase 2
	!***************************************************************

	REGISTER PEXPRNODE T;

	NAME<LEFT> = 4;		! Entry is 4 words long
	T = CORMAN();		! Get space for entry
	T[FIRSTWORD] = 0;	! First word is zero
	T[EXPFLAGS] = 0;	! flags are zero
	T[OPRCLS] = .CLAS;	! Operator class
	T[OPERSP] = .SPECFI;	! specific operator
	T[VALTYPE] = .VTYPE;	! value type
	T[TARGET] = 0;		! Zero target word
	T[ARG1PTR] = .A1PTR;	! Argument one
	T[ARG2PTR] = .A2PTR;	! Argument two

	RETURN .T

END;	! of MAKEPR


GLOBAL ROUTINE MAKPR1(PARPTR,CLAS,SPECFI,VTYPE,A1PTR,A2PTR)=
BEGIN
	!***************************************************************
	! Make an  expression  node for  phase  1 array  expansion,  and
	! value-type analysis - also for  phase 2 skeleton and phase  2.
	! Sets VALFLGS and puts in parent pointers.
	!***************************************************************

	MAP
		PEXPRNODE A1PTR,
		PEXPRNODE A2PTR;

	REGISTER
		PEXPRNODE T;

	NAME<LEFT> = 4;		! Expression node is 4 words long
	T = CORMAN();		! Get space for entry

	T[FIRSTWORD] = 0;	! First word is zero
	T[EXPFLAGS] = 0;	! Flags are zero
	T[OPRCLS] = .CLAS;	! Operator class
	T[OPERSP] = .SPECFI;	! Specific operator
	T[VALTYPE] = .VTYPE;	! Value type
	T[TARGET] = 0;		! Zero target word
	T[ARG1PTR] = .A1PTR;	! Argument one
	T[ARG2PTR] = .A2PTR;	! Argument two
	T[PARENT] = .PARPTR;	! Parent pointer field for this node

	IF .A1PTR NEQ 0
	THEN
	BEGIN
		IF .A1PTR[OPRCLS] EQL DATAOPR OR .A1PTR[OPRCLS] EQL CMNSUB
		THEN	T[A1VALFLG] = 1
		ELSE	A1PTR[PARENT] = .T;
	END;


	IF .A2PTR NEQ 0
	THEN
	BEGIN
		IF .A2PTR[OPRCLS] EQL DATAOPR OR .A2PTR[OPRCLS] EQL CMNSUB
		THEN	T[A2VALFLG] = 1
		ELSE	A2PTR[PARENT] = .T;
	END;

	RETURN .T

END;	! of MAKPR1


GLOBAL ROUTINE NEWDVAR(GENLEN)=
BEGIN
	!***************************************************************
	! Create a .Dnnnn variable for a compile-time-constant character
	! descriptor.  The entries are  all linked together.  They  have
	! an OPRCLS of DATAOPR  and an OPERSP  of VARIABLE.  Either  one
	! word (byte  pointer  only)  or two  words  (byte  pointer  and
	! length) are generated based on the flag IDGENLENFLG.  One word
	! .Dnnnn variables are used  for SUBSTRINGs with constant  lower
	! bounds and non-constant upper bounds.
	!***************************************************************

%1406%	! Written by TFV on 27-Oct-81

	REGISTER PEXPRNODE DVAR;	! Pointer to entry

	NAME<LEFT> = IDSIZ;		! Use a symbol table like entry
	DVAR = CORMAN();		! Get space for new .D variable

	IF .DANCHOR EQL 0
	THEN	DANCHOR = .DVAR		! Setup DANCHOR to point to .D0000
	ELSE	LASTD[CLINK] = .DVAR;	! Link in the .D variable

	LASTD = .DVAR;			! Update lastd used

	DVAR[OPRCLS] = DATAOPR;		! Data operator OPRCLS
	DVAR[OPERSP] = VARIABLE;	! Specific operator is VARIABLE
	DVAR[VALTYPE] = CHARACTER;	! VALTYPE is CHARACTER
	DVAR[IDGENLENFLG] = .GENLEN;	! Set flag for 1 word or 2 words

	DVAR[IDSYMBOL] = SIXBIT'.D0000' +	! Make the .Dnnnn name
		(.DCNT<9,3>)^18 +
		(.DCNT<6,3>)^12 +
		(.DCNT<3,3>)^6 +
		(.DCNT<0,3>);

	DCNT = .DCNT + 1;	! Increment DCNT

	RETURN .DVAR

END;	! of NEWDVAR

GLOBAL ROUTINE MAKLIT (LEN) =		! [1527] New
					! [1535] name changed to MAKLIT

! Returns an empty literal table entry LEN characters long

BEGIN
	REGISTER WLEN;
	REGISTER BASE RESULT;

%1535%	WLEN = CHWORDLEN(.LEN) + 1;
	NAME<LEFT> = .WLEN + LTLSIZ;
	NAME<RIGHT> = LITTAB;
	RESULT = NEWENTRY();

	RESULT[LITLEN] = .LEN;
	RESULT[LITSIZ] = .WLEN;
	RESULT[OPERATOR] = CHARCONST;
	RESULT[LITEXWDFLG] = 1;

	RETURN .RESULT;

END;	! MAKLIT

GLOBAL ROUTINE CHEXLEN(CNODE)=		![1521] New

! Routine to find the length of a character node (the node is assumed to be
! character before this routine is called). For argument descriptor blocks.

! PASSED:	CNODE	-Argument node to check

! RETURNS:	-Size of character variable in bytes or
!		-LENSTAR (Size not known at compile time)

BEGIN
	MAP BASE CNODE;
	REGISTER BASE SYMTAB;	! For symbol table entries

	! If this has a compile time length, then put out a  secondary
	! descriptor

	IF .CNODE[OPRCLS] EQL DATAOPR 
	THEN
	BEGIN	! Symbol table entry

		IF .CNODE[OPERSP] EQL CONSTANT 
		THEN	RETURN .CNODE[LITLEN];

		IF .CNODE[OPERSP] EQL VARIABLE
		THEN	RETURN .CNODE[IDCHLEN];

		IF .CNODE[OPERSP] EQL FORMLVAR
		THEN	RETURN .CNODE[IDCHLEN];

		IF .CNODE[OPERSP] EQL FNNAME
		THEN	RETURN .CNODE[IDCHLEN];

		IF .CNODE[OPERSP] EQL FORMLFN
		THEN	RETURN .CNODE[IDCHLEN];

		! Array - return size of entire array

		IF .CNODE[DATOPS1] EQL ARRAYNM1 OR 
			.CNODE[OPERSP] EQL FORMLARRAY
		THEN
		BEGIN
			REGISTER DIMENTRY DIMENTAB;
			DIMENTAB = .CNODE[IDDIM];	! Dimension Table
			IF NOT .DIMENTAB[ADJDIMFLG]	! Not adjustably dim.
			THEN RETURN .DIMENTAB[ARASIZ]	! Size of array
			ELSE RETURN LENSTAR;		! Length not known yet.
		END;

	END;	! Symbol table entry


	IF .CNODE[OPRCLS] EQL ARRAYREF
	THEN
	BEGIN	! Array reference - single element in array.

		SYMTAB = .CNODE[ARG1PTR];	! Symbol table for array
		RETURN .SYMTAB[IDCHLEN];	! Length for single element

	END;	! Array reference


	! If argument  is  a  character function  call, return the length
	! given in the symbol table for that function.

	IF .CNODE[OPRCLS] EQL FNCALL
	THEN	
	BEGIN
		SYMTAB = .CNODE[ARG1PTR];	!Symbol table entry
		RETURN .SYMTAB[IDCHLEN];
	END;


	RETURN LENSTAR;	!Descriptor not needed

END;	! of CHEXLEN

END
ELUDOM