Google
 

Trailing-Edge - PDP-10 Archives - BB-D480F-SB_FORTRAN10_V10 - srca.bli
There are 12 other files named srca.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: F. INFANTE/HPW/NEA/DCE/SJW/CDM/TFV/AHM/PLB/AlB/RVM

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

GLOBAL BIND SRCAV = #10^24 + 0^18 + #2464;	! Version Date:	8-Oct-84

%(

***** 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 V7 Development *****

1732	CDM	17-March-83
	Change CLINK to LITLINK, set PRVLIT.


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

2200	TFV	11-Mar-83
	Link INQUIRE statement into IOFIRST, IOLAST linked list.

2205	CDM	21-JUN-83
	Add  manipulation  of  EFIW   tables  to  NEWENTRY,   TBLSEARCH,
	TESTENTRY, THASH,  add MAKEFIW.
	Obliterate macro references BP, BPR, BASEPOINT and replace  them
	with the global  symbol BASEPTR,  which they  defined as.   Also
	kill macro PARM  which was  defined to  be ENTRY,  and not  even
	used!

2322	CDM	18-Apr-84
	Fix array subscript calculations for /EXTEND.  In PROCEQUIV  and
	BLDDIM, correct  maximum  size of  an  array of  a  legal  array
	declaration /EXTEND.   In BLDDIM,  call  CNSTCM for  array  size
	calculations to  give  proper  underflow/overflow  messages  for
	illegal declarations.  Otherwise arrays that are too  large  may
	not be detected.  Add routines ADDINT, MULINT, and SUBINT.

2236	AlB	11-Nov-83
	Jam PSDATA into the psect field (COMPSECT) of the Common Block
	entry when it is built.  This code could be removed when the
	command handler recognizes Common in the /EXTEND switch.
	Routine: NEWENTRY

2343	RVM	18-Apr-84
	Create the FNDCOMMON routine to manipulate ECTAB, the table of
	COMMON blocks named in /EXTEND:[NO]COMMON.  Use FNDCOMMON to
	correctly set the psect of COMMON blocks as they are created
	in NEWENTRY.  The edit supersedes 2236.

2356	AHM	8-May-84
	Make NEWENTRY set the new flag globals LCOMP or SCOMP when
	creating COMMON blocks in a particular psect.

2464	AHM	8-Oct-84
	Have MAKEFIW pass a variable's IDPSECT instead of 0 in
	ENTRY[2] when calling TBLSEARCH.

++++	PLB	25-Oct-84
	Add code to support COMPLEX parameter arithmetic.  Routines
	handle operations on scaled double precision numbers.

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

***** 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
%2205%	MAKEFIW(4),	! Returns EFIW table entry (new or used)
%2322%	ADDINT(2),	! Integer add routine using CNSTCM
%2322%	MULINT(2),	! Integer mul routine using CNSTCM
%2322%	SUBINT(2);	! Integer sub routine using CNSTCM


EXTERNAL
%2322%	C1H,		! High word of argument
%2322%	C1L,		! Low word of argument
%2322%	C2H,		! High word of argument
%2322%	C2L,		! Low word of argument
	CGERR,
	CHAR,
%2322%	CNSTCM,		! Does acurate arithmetic (Constant combine)
%2322%	COPRIX,		! Argument to CNSTCM
	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,
%2343%	DFCMPS,		! Default psect for COMMON blocks (set by /EXTEND).
	DLOOPTREE,
%2343%	VECTOR ECHASH,	! Hash table of COMMON blocks named in /EXTEND switch.
%2343%	ECHSHL,		! Length of the hash table for list of COMMON blks.
%2343%	VECTOR ECTAB,	! Table of COMMON blocks named in /EXTEND switch.
%2343%	ECTABL,		! Number of common blocks which can be named in a
%2343%			! /EXTEND switch.
%2343%	ECRECL,		! Size of an entry in ECTAB
%2343%	ECUSED,		! Number of entries in ECTAB
%2205%	BASE EFIWTBL,	! EFIW hash table
	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
%2356%	LCOMP,		! Flag for at least one COMMON block in .LARG.
	LIBATTRIBUTES,
	LIBFUNTAB,
	LITERL,
%1133%	MAXFF,		! Maximum size of compiler lowseg
	NAME,
	NAMLPTR,
%1732%	PRVLIT,		! Previous literal in linked literal list.
	PUTMSG,
	QUEUE,
%2356%	SCOMP,		! Flag for at least one COMMON block in .DATA.
	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
	!***************************************************************
	! Makes an entry into a dynamic table as specified by the global
	! NAME.  Existing  table  entries  are searched  to  see  if  an
	! identical entry has already been  made.  It returns a  pointer
	! to the  table entry  made  or found  and  also sets  FLAG  (in
	! FLGREG). If the entry was already in the table, FLAG is set to
	! -1, otherwise 0.
	!
	! Global arguments:
	! 	NAME - entry size ,, table number
	!	ENTRY -  Vector  of arguments  to  be looked  up  and/or
	!		entered in a table.
	!***************************************************************

	BIND
%2205%		LISTX = UPLIT(	SYMTBL<0,0>,	! 0
%2205%				CONTBL<0,0>,	! 1
%2205%				EXPTBL<0,0>,	! 2
%2205%				LABTBL<0,0>,	! 3
%2205%				0,		! 4
%2205%				0,		! 5
%2205%				0,		! 6
%2205%				0,		! 7
%2205%				0,		! 8
%2205%				0,		! 9
%2205%				0,		! 10
%2205%				0,		! 11
%2205%				0,		! 12
%2205%				0,		! 13
%2205%				0,		! 14
%2205%				EFIWTBL<0,0>),	! 15
%2205%
%2205%		ITEM = .LISTX[.NAME<RIGHT>];

	LOCAL I;
	MAP BASE DELETPTR;

%2205%	MACRO NOTHASHED =
%2205%	BEGIN
 		NEWENTRY();
		FLAG = 0;
		RETURN .BASEPTR	! NEWENTRY resets BASEPTR
%2205%	END$;

	XTRAC;		! For debugging trace


%2205%	CASE .NAME<RIGHT> OF SET

%2205%	BEGIN END;	! 0 Symbol table - Hash below

%2205%	BEGIN END;	! 1 Constant table - Hash below

%2205%	BEGIN END;	! 2 Common subexpression - Hash below

%2205%	BEGIN END;	! 3 Label table - Hash below

%2205%	NOTHASHED;	! 4 COMMON block

%2205%	NOTHASHED;	! 5 Encoded source

%2205%	NOTHASHED;	! 6 Dimension

%2205%	NOTHASHED;	! 7 Expression

%2205%	NOTHASHED;	! 8 Iolist

%2205%	NOTHASHED;	! 9 Literal

%2205%	NOTHASHED;	! 10 Library funcion id

%2205%	NOTHASHED;	! 11 Equivalence group

%2205%	NOTHASHED;	! 12 Equivalence list

%2205%	RETURN;		! 13 Data group - Don't process

%2205%	RETURN;		! 14 Namelist group - Don't process

%2205%	BEGIN END;	! 15 - EFIW table - Hash below

%2205%	TES;


	! Table is to be hashed

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

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

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

	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	! Search through each link off this hash

			IF TESTENTRY()	! TESTENTRY may  create an  EFIW
					! table entry.
			THEN
			BEGIN	! The entry is equal to an existing hash
				FLAG = -1;	! Old entry
				RETURN .BASEPTR;
			END
			ELSE	! Entry not equal

				IF .BASEPTR[CLINK] NEQ 0
				THEN	BASEPTR = .BASEPTR[CLINK]
				ELSE
				BEGIN	! Last chance, no equal hash
					NEWENTRY();
					BASEPTR[CLINK] = .ITEM[.I]<RIGHT>;
					ITEM[.I]<RIGHT> = .BASEPTR;
					FLAG = 0;	! New entry
					RETURN .BASEPTR;
				END;

		END	! Search through each link off this hash

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

END;	! of TBLSEARCH


GLOBAL ROUTINE THASH=
BEGIN
	!***************************************************************
	! Returns position in  hash table.   NAME to  defines the  table
	! concerned.
	!
	! Global arguments:
	!	ENTRY - Vector of what to put in the table reference.
	!	NAME - Contains which table we're working on.
	!***************************************************************

	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

%2205%		CGERR();		! 2 - (Not used) Common sub-expression 

%2205%		.ENTRY MOD LASIZ;	! 3 - Statement number table

%2205%		CGERR();		! 4 - (Not used)

%2205%		CGERR();		! 5 - (Not used)

%2205%		CGERR();		! 6 - (Not used)

%2205%		CGERR();		! 7 - (Not used)

%2205%		CGERR();		! 8 - (Not used)

%2205%		CGERR();		! 9 - (Not used)

%2205%		CGERR();		! 10 - (Not used)

%2205%		CGERR();		! 11 - (Not used)

%2205%		CGERR();		! 12 - (Not used)

%2205%		CGERR();		! 13 - (Not used)

%2205%		CGERR();		! 14 - (Not used)

%2205%		(.ENTRY[0] XOR .ENTRY[2]) MOD EFSIZ	! 15 - EFIW table

		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 FNDCOMMON(NAME, INSERT) = 

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine searches ECTAB (the table of COMMON blocks named
!	in an /EXTEND switch) for an entry for a particular COMMON
!	block.  If the entry is not found, this routine will create
!	the entry if requested to do so.
!
! FORMAL PARAMETERS:
!
!	NAME		The SIXBIT name of the COMMON block to be search
!			for or inserted.
!	INSERT		A flag:  If true, then a new common block entry for
!			NAME will be created if none exists.  If false, no
!			new entry will be created and a zero will be returned.
!
! IMPLICIT INPUTS:
!
!	ECHASH		Hash table for ECTAB.
!	ECHSHL		Length of the ECHASH.
!	ECTAB		Table of COMMON blocks named in /EXTEND.
!	ECTABL		Number of common blocks which can be named in a
!			/EXTEND switch.
!	ECRECL		Size of an entry in ECTAB.
!	ECUSED		Number of entries in ECTAB.
!
! IMPLICIT OUTPUTS:
!
!	ECHASH		On INSERT, hash chain modified.
!	ECTAB		On INSERT, new entry created.
!	ECUSED		On INSERT, set to number of entries in ECTAB.
!
! ROUTINE VALUE:
!
!	The address of the table entry for the COMMON block or zero.  The
!	zero has different interpretations depending on the value of the
!	INSERT argument.  If INSERT is true, this routine returns zero if
!	the table overflowed and no new entry could be created.  If INSERT
!	is false, this routine returns zero if the entry for the COMMON
!	block could not be found.
!
! SIDE EFFECTS:
!
!	None
!
!--



![2343] New Routine

BEGIN

REGISTER HASH, BASE ENTRY;

	! Calculate hash value

	HASH = ABS(.NAME MOD ECHSHL<0,0>);

	ENTRY = .ECHASH[.HASH];

	WHILE .ENTRY NEQ 0
	DO
	BEGIN	!Search for entry
		IF .ENTRY[ECNAME] EQL .NAME THEN RETURN .ENTRY;
		ENTRY = .ENTRY[ECLINK];
	END;	!Search for entry

	! There is no entry matching NAME.  See if a new entry should be
	! created.

	IF .INSERT
	THEN
	BEGIN	!Create New Entry

		!Get address of new entry
		ENTRY = ECTAB[.ECUSED*ECRECL<0,0>]<0,0>;
		ECUSED=.ECUSED+1;

		! See if this entry overflows the table
		IF .ECUSED GTR ECTABL<0,0> THEN RETURN 0;

		ENTRY[ECNAME] = .NAME;
		ENTRY[ECLINK] = .ECHASH[.HASH];
		ECHASH[.HASH] = .ENTRY;
		RETURN .ENTRY;
	END;	!Create New Entry

	! No entry matched (and none was created).

	RETURN 0;

END;	! of FNDCOMMON

GLOBAL ROUTINE NEWENTRY=
BEGIN
	!***************************************************************
	! Make a new  table entry.  The  right half of  the global  NAME
	! specifies which table.
	!
	! Global arguments:
	!	ENTRY, NAME
	!***************************************************************

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

	OWN
		TOP,
		BOTTOM;

	XTRAC;		! For debugging trace

	! Get space -  NAME<LEFT> defines the  number of words.   CORMAN
	! zeroes the space before returning
	BASEPTR = CORMAN();

	! Keep count of tables space being used

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

	CASE .NAME OF SET

	BEGIN	! 0 - Symbol table

		BASEPTR[VALTYPE] = .SYMTYPE;
		BASEPTR[IDSYMBOL] = .ENTRY;
		BASEPTR[OPRCLS] = DATAOPR;
		BASEPTR[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 BASEPTR[IDATTRIBUT(NOALLOC)] = 1;

	END;	! 0 - Symbol table

	BEGIN	! 1 - Constant table

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

	END;	! 1 - Constant table

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

	BEGIN	! 3 - Statement number table

		BASEPTR[SNUMBER] = .ENTRY;
		BASEPTR[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.

		BASEPTR[SNREF] = 1;

	END;	! 3 - Statement number table

	BEGIN	! 4 - COMMON block table

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

		BASEPTR[COMNAME] = .ENTRY;	! Store name

%2343%		! Put the COMMON block into the proper psect
%2343%		IF EXTENDED
%2343%		THEN
%2343%		BEGIN	!/EXTEND
%2343%			REGISTER BASE ECENTRY;

%2343%			! Look in the table of COMMON blocks set up
%2343%			ECENTRY = FNDCOMMON(.ENTRY, FALSE);

%2343%			! If found an entry, then use its value.  Otherwise
%2343%			! use the default set by /EXTEND.
%2343%			IF .ECENTRY NEQ 0
%2343%			THEN BASEPTR[COMPSECT] = .ECENTRY[ECPSECT]
%2343%			ELSE BASEPTR[COMPSECT] = .DFCMPS;
%2343%		END	!/EXTEND
%2343%		ELSE BASEPTR[COMPSECT] = PSDATA;

		! Finally, set one of two flags depending on whether
		! the COMMON block will reside in the small or large
		! data psect at runtime.

%2356%		IF .BASEPTR[COMPSECT] EQL PSDATA	! In the small psect?
%2356%		THEN SCOMP = 1				! Yes, set small flag
%2356%		ELSE LCOMP = 1;				! No, set large flag
	END;	! 4 - COMMON block table


	BEGIN	! 5 - Executable source table

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

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

		END;	! Make a dummy CONTINUE node as first statement

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

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

		BASEPTR[SRCLBL] = .LABLOFSTATEMENT;	! If any

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

	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

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

	END;	! 7 - Expressions (not hashed)

	BEGIN	! 8 - Iolist node or data intialization

		BASEPTR[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
%1732%			PRVLIT = .LASTLIT;		! Save last literal
%1732%			LITPOINTER[LITLINK] = .BASEPTR;	! Link from last lit
			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> = .BASEPTR
		ELSE
		BEGIN
			EQVPTR[EQVLINK] = .BASEPTR;	! Link in new group
			EQVPTR<RIGHT> = .BASEPTR	! Pointer to last group made
		END;

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

		BASEPTR[EQVFIRST] = BASEPTR[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> = .BASEPTR
		ELSE
		BEGIN
			DATASPTR[DATALNK] = .BASEPTR; 	! Point to last
			DATASPTR<RIGHT> = .BASEPTR;
		END;

	END;	! 13 -  Data group nodes for DATA statements

	BEGIN	! 14 -  NAMELIST list header

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

	END;	! 14 -  NAMELIST list header

%2205%	BEGIN	! 15 - EFIW table
%2205%
%2205%		REGISTER BASE SYMTAB;
%2205%
%2205%		BASEPTR[EFSYMPTR] = SYMTAB = .ENTRY[1];	! Symbol table entry
%2205%
%2205%		BASEPTR[IDATTRIBUT(ALLOFTHEM)] =	! Symbol table flags
%2205%			.SYMTAB[IDATTRIBUT(ALLOFTHEM)];
%2205%		BASEPTR[VALTYPE] = .SYMTAB[VALTYPE];	! Copy from the id
%2205%		BASEPTR[OPRCLS] = EFIWREF;		! Leave OPERSP 0.
%2205%
%2205%		BASEPTR[EFADDR] = .ENTRY[0];	! I, X, Y
%2205%
%2205%		BASEPTR[EFEXTERN] = .ENTRY[2];	! External name
%2205%
%2205%		! Representative node.  Will be  reset later if this  is
%2205%		! not the fist in the list of Similar entrys.
%2205%		BASEPTR[EFREP] = .BASEPTR;
%2205%
%2205%	END;	! 15 - EFIW table

	TES;

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

	RETURN .BASEPTR

END;	! of NEWENTRY


GLOBAL ROUTINE TESTENTRY=
BEGIN
	!***************************************************************
	! Test an existing table  entry vs the desired  entry to see  if
	! they're equal.  If  so, we  can just reuse  an existing  table
	! entry.
	!
	! Returns:
	!	-1 if there is a match,
	!	 0 otherwise.
	!
	! Global arguments:
	!	ENTRY - The table entry we want.
	!	BASEPTR - Node to check against.
	!***************************************************************

%2205%	REGISTER BASE SIMILAR;	! Similar nodes in EFIW table processing


	XTRAC;		! For debugging trace

%2205%	CASE .NAME OF SET

	BEGIN	! 0 - Symbol table

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

	END;	! 0 - Symbol table

	BEGIN	! 1 - Constant table

%2205%		RETURN
		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

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

	END;	! 3 - Statement number table

%2205%	RETURN CGERR();		! 4 - Not used

%2205%	RETURN CGERR();		! 5 - Not used

%2205%	RETURN CGERR();		! 6 - Not used

%2205%	RETURN CGERR();		! 7 - Not used

%2205%	RETURN CGERR();		! 8 - Not used

%2205%	RETURN CGERR();		! 9 - Not used

%2205%	RETURN CGERR();		! 10 - Not used

%2205%	RETURN CGERR();		! 11 - Not used

%2205%	RETURN CGERR();		! 12 - Not used

%2205%	RETURN CGERR();		! 13 - Not used

%2205%	RETURN CGERR();		! 14 - Not used

%2205%	BEGIN 	! 15 - EFIW table
%2205%
%2205%		LABEL LOOP;	! So we can leave a loop...
%2205%
%2205%		! If I,  X, Y  and the  sixbit external  symbol are  all
%2205%		! equal to  the  entry we're  testing,  then we  have  a
%2205%		! similar node.  Two id's equivalenced together will  be
%2205%		! similar, but not equal.
%2205%
%2205%		IF .BASEPTR[EFADDR] EQL .ENTRY[0]		! I, X, Y
%2205%			AND .BASEPTR[EFEXTERN] EQL .ENTRY[2]	! External
%2205%		THEN
%2205%		BEGIN	! Hashed and entry are similar
%2205%
%2205%			! If we can find an entry that is equal,  return
%2205%			! it.  Otherwise  make  one,  add  it  into  the
%2205%			! similar linking,  and  make  believe  that  we
%2205%			! found it.
%2205%
%2205%			SIMILAR = .BASEPTR;	! 1st similar
%2205%
%2205%		LOOP:	WHILE TRUE
%2205%			DO
%2205%			BEGIN	! Step through each linked similar EFIW
%2205%
%2205%				! Symbol table entry equal?
%2205%				IF .ENTRY[1] EQL .SIMILAR[EFSYMPTR]
%2205%				THEN
%2205%				BEGIN	! Entry is equal to an existing one.
%2205%					BASEPTR = .SIMILAR;
%2205%					RETURN -1;
%2205%				END;
%2205%
%2205%				! If the link to the next similar  table
%2205%				! is 0, then we  have the last one.   We
%2205%				! want to exit this loop, preserving the
%2205%				! value in  SIMILAR  (not  zeroing  it),
%2205%				! since we need it  below to link a  new
%2205%				! one in.
%2205%				IF .SIMILAR[EFSIMILAR] EQL 0
%2205%				THEN	LEAVE LOOP			! Leave
%2205%				ELSE	SIMILAR = .SIMILAR[EFSIMILAR];	! Next
%2205%
%2205%			END;	! Step through each linked similar EFIW
%2205%				! (of label LOOP)
%2205%
%2205%			! Make a new node and thread it in.
%2205%
%2205%			! 	-------------------------
%2205%			! ->+-->|	| CLINK		| ----> ...
%2205%			!   |	-------------------------
%2205%			!   |	| EFREF	| EFSIMILAR	|
%2205%			!   |	-------------------------
%2205%			!   +<----|		|
%2205%			!   ^			|
%2205%			!   |			V
%2205%			!   |   -------------------------
%2205%			!   |	|			|
%2205%			!   |	-------------------------
%2205%			!   ----| EFREP	| EFSIMILAR = 0	|
%2205%			! 	-------------------------
%2205%
%2205%			! Get a new EFIW entry.  Returned in BASEPTR.
%2205%			NEWENTRY();
%2205%
%2205%			! Make the last node now point to this new node.
%2205%			SIMILAR[EFSIMILAR] = .BASEPTR;
%2205%			BASEPTR[EFREP] = .SIMILAR[EFREP];
%2205%
%2205%			RETURN -1;	! Found similar
%2205%
%2205%		END	! Hash and entry are similar
%2205%		ELSE 	RETURN 0;	! Not equal at all...
%2205%
%2205%	END; 	! 15 - EFIW 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

GLOBAL ROUTINE MAKEFIW(I,X,Y,SYMTAB)=	![2205] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Returns EFIW table reference for the symbol reference passed.
!	Called during code generation phase of the compiler.
!
! FORMAL PARAMETERS:
!
!	I		EFIW's indirect bit.
!
!	X		EFIW's index register field.
!
!	Y		EFIW's 30 bit address field.
!
!	SYMTAB		Location of identifier's symbol table entry.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	ENTRY		Smashed when passing arguments to TBLSEARCH.
!
!	NAME		Smashed when passing arguments to TBLSEARCH.
!
! ROUTINE VALUE:
!
!	Address of EFIW table entry.
!
! SIDE EFFECTS:
!
!	None
!
!--
![2205] Mike likes comments.


BEGIN

	MAP BASE SYMTAB;
	REGISTER BASE EXTERN;	! External name (if any)


	! No business being here if a non symbol was passed

	IF .SYMTAB[OPRCLS] NEQ DATAOPR
	THEN CGERR();	! Give an ICE

	! Set up ENTRY to contain the  values of the EFIW entry we  want
	! to make.

	! Enter the I, X,  and Y.  Be defensive  and mask off any  stray
	! bits beyond the size of each field.

	ENTRY[0] = (.I AND 1)^34 + (.X AND #17)^30 + (.Y AND #7777777777);

	ENTRY[1] = .SYMTAB;	! Symbol table id

	! Assign name for fixup or psect for relocation

	IF .SYMTAB[IDATTRIBUT(INCOM)]
	THEN					! In COMMON?
	BEGIN	! INCOM
		EXTERN = .SYMTAB[IDCOMMON];	! Common table entry
		ENTRY[2] = .EXTERN[COMNAME];	! Common name in SIXBIT
	END	! INCOM
%2464%	ELSE IF .SYMTAB[OPR1] EQL FMLARRFL	! Nope, formal array?
%2464%	THEN ENTRY[2] = PSABS			! Yep, not relocated
	ELSE IF .SYMTAB[OPR1] EQL FNNAMFL	! Nope, external routine name
	THEN ENTRY[2] = .SYMTAB[IDSYMBOL]	! Yep, use the name
%2464%	ELSE ENTRY[2] = .SYMTAB[IDPSECT];	! Nope, STE is a local variable

	! Get an EFIW table.  TBLSEARCH will decide whether to make it
	! or use an existing one.

	NAME = EFIWTAB;		! What kind we want
	RETURN TBLSEARCH();	! Do it.

END;	! of MAKEFIW

GLOBAL ROUTINE ADDINT(INT1,INT2)=	![2322] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Adds two integers using the accurate constant combine
!	routines which checks for overflows and underflows.
!
! FORMAL PARAMETERS:
!
!	INT1	Integer
!
!	INT2	Integer
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	(These are not returned values, but are changed)
!
!	C1L	Low word of argument
!
!	C1H	High word of argument
!
!	C2L	Low word of argument
!
!	C2H	High word of argument
!
! ROUTINE VALUE:
!
!	Integer result of addition, INT1 + INT2
!
! SIDE EFFECTS:
!
!	None
!
!--


BEGIN
	C2H = C1H = 0;	! No high order words for integers
	C1L = .INT1;	! First integer
	C2L = .INT2;	! Second integer

	COPRIX = KKARITHOP(INTEG1,ADDOP);	! Do integer add
	CNSTCM();	! Do it

	RETURN .C2L;		! Return value

END;	! of ADDINT

GLOBAL ROUTINE MULINT(INT1,INT2)=	![2322] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Mutiplies two integer constants using the accurate CNSTCM
!	constant combine routines.
!
! FORMAL PARAMETERS:
!
!	INT1	Integer
!
!	INT2	Integer
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	(These are not returned values, but are changed)
!
!	C1L	Low word of argument
!
!	C1H	High word of argument
!
!	C2L	Low word of argument
!
!	C2H	High word of argument
!
! ROUTINE VALUE:
!
!	Integer result of multiplication, INT1 * INT2
!
! SIDE EFFECTS:
!
!	None.
!
!--


BEGIN
	C2H = C1H = 0;	! No high order words for integers
	C1L = .INT1;	! First integer
	C2L = .INT2;	! Second integer

	COPRIX = KKARITHOP(INTEG1,MULOP);	! Do integer multiply
	CNSTCM();	! Do it

	RETURN .C2L;		! Return value

END;	! Of MULINT

GLOBAL ROUTINE SUBINT(INT1,INT2)=	![2322] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Subtracts two integers using the accurate constant combine
!	routines which checks for overflows and underflows.
!
! FORMAL PARAMETERS:
!
!	INT1	Integer to subtract INT2 from
!
!	INT2	Integer that is subtracted from INT1
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	(These are not returned values, but are changed)
!
!	C1L	Low word of argument
!
!	C1H	High word of argument
!
!	C2L	Low word of argument
!
!	C2H	High word of argument
!
! ROUTINE VALUE:
!
!	Integer result of subtraction, INT1 - INT2
!
! SIDE EFFECTS:
!
!	None
!
!--


BEGIN
	C2H = C1H = 0;	! No high order words for integers
	C1L = .INT1;	! First integer
	C2L = .INT2;	! Second integer

	COPRIX = KKARITHOP(INTEG1,SUBOP);	! Do integer subtract
	CNSTCM();	! Do it

	RETURN .C2L;		! Return value

END;	! Of SUBINT
%(	Description of  double  scaled arithmetic  used  for  compiler
	COMPLEX arithmetic:

	Ideally COMPLEX arthmetic should  be performed in  G-floating,
	since it would  provide a  larger number of  bits of  accuracy
	(compared  to  single  precision),  as  well  as  an  expanded
	exponent range  allowing  straightforward computations  to  be
	performed.  However, G-floating hardware  is not available  in
	all configurations that FORTRAN-10/20 must function under.

	Therefore for  *, /,  and  ** COMPLEX  numbers are  stored  as
	double precision numbers, with  an integer scale factor.   The
	double precision number  will at  all times  have an  exponent
	between 0 and +100  octal.  If before  (or after) any  complex
	operation the exponent  should exceed this  range the  integer
	scale factor  will be  incremented  (or decremented)  and  the
	exponent will be adjusted down (up) by 100.

	The final  result can  be converted  to single  precision  and
	FSC'ed by 100  (octal) times  the scale  factor.  Overflow  or
	underflow will  happen  only if  the  final result  cannot  be
	represented as a  single precision number.   Under or overflow
	should NEVER occur as a result of a scaled operation.

	Storage format:
	+================+
	| H.O. OF DOUBLE |
	+----------------+
	| L.O. OF DOUBLE |
	+----------------+
	| INTEGER  SCALE |
	+================+

)%


MACHOP	DFAD	= #110,			!DOUBLE FLOATING ADD
	DFSB	= #111,			!DOUBLE FLOATING SUBTRACT
	DFMP	= #112,			!DOUBLE FLOATING MULTIPLY
	DFDV	= #113,			!DOUBLE FLOATING DIVIDE
	DMOVE	= #120,			!DOUBLE MOVE
	DMOVN	= #121,			!DOUBLE MOVE NEGATED
	DMOVEM	= #124;			!DOUBLE MOVE TO MEMORY
		
! FIELD DESCRIPTORS FOR SCALED DOUBLE 3 WORD BLOCK
MACRO	DOUBL1	 = 0,0,0,36$,		!HIGH ORDER WORD OF DOUBLE FLOAT
	EXPONENT = 0,0,27,8$,		!EXPONENT OF DOUBLE
	DOUBL2	 = 0,1,0,36$,		!LOW ORDER WORD OF DOUBLE
	SCALE	 = 0,2,0,36$;		!SCALE FACTOR

MACRO	ADR = 0,0 $;			!GET ADDRESS OF A VAR
GLOBAL ROUTINE ADJUST(A) =

!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
!	This routine ensures that the  exponent of a scaled double  is
!	within the range 0 to 100  (octal).  If this is not the  case,
!	the exponent, and scale factor  are adjusted until the  number
!	is in normal scaled form.
!
! FORMAL PARAMETERS:
!
!	A is a pointer to a 3 word block holding a scaled double.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
! This routine is called from CNSTCM.MAC
!
!--

BEGIN	!ADJUST
	LOCAL I,NEGFLG;
	MAP BASE A;

	IF .A[DOUBL1] EQL 0		!IF FIRST WORD IS ZERO
	THEN IF .A[DOUBL2] EQL 0	!*****
	THEN				!NUMBER IS ZERO
	BEGIN	!NUMBER IS ZERO
		A[SCALE] = 0;		!ENSURE ZERO SCALE
		RETURN .VREG		!RETURN NOW
	END;	!NUMBER IS ZERO

	IF .A[DOUBL1] LSS 0		!IF NEGATIVE TAKE ABSOLUTE
	THEN
	BEGIN	!NEGATIVE NUMBER
		A[DOUBL1] = -.A[DOUBL1]; !ENSURE POSITIVE NUMBER
		NEGFLG = 1		!SET FLAG SO WE CAN RESTORE SIGN
	END	!NEGATIVE NUMBER
	ELSE NEGFLG = 0;		!NOT NEGATIVE

	I = .A[EXPONENT] - #200;	!GET SIGNED EXPONENT

	IF .I GTR 0
	THEN
	BEGIN	!POSITIVE EXPONENT
		IF .I GTR #100
		THEN
		BEGIN	!POSITIVE EXPONENT .GT. #100
			A[EXPONENT] = .I - #100 + #200;	!ADJUST EXPONENT DOWN
			A[SCALE] = .A[SCALE] + 1 !INCREMENT SCALE FACTOR
		END	!POSITIVE EXPONENT .GT. #100
	END	!POSITIVE EXPONENT
	ELSE
	BEGIN	!NEGATIVE EXPONENT
		WHILE .I LSS 0
		DO
		BEGIN	!WHILE EXPONENT .LT. 0
			I = .I + #100;	!BUMP EXPONENT UP BY #100
			A[SCALE] = .A[SCALE] - 1 !DECREMENT SCALE FACTOR
		END;	!WHILE EXPONENT .LT. 0
		A[EXPONENT] = .I + #200	!RESTORE EXPONENT
	END;	!NEGATIVE EXPONENT

	IF .NEGFLG NEQ 0		!IF STARTING NUMBER WAS NEGATIVE
	THEN A[DOUBL1] = -.A[DOUBL1];	!RESTORE SIGN

	RETURN .VREG			!RETURN NO VALUE
END;	!ADJUST
ROUTINE	MULTIPLY(A,B,C) =

!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
!	Perform multiplication of two scaled double numbers.
!
! FORMAL PARAMETERS:
!
!	A, B, and C are pointers  to 3 word blocks for storing  scaled
!	doubles.  A will recieve the result of multiplying the numbers
!	contained in B and C.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--

BEGIN
	REGISTER REG[2];
	MAP BASE A:B:C;

	DMOVE	(REG,.B);		!FETCH B
	DFMP	(REG,.C);		!MULTIPLY BY C
	DMOVEM	(REG,.A);		!STORE IN A

	A[SCALE] = .B[SCALE] + .C[SCALE]; !COMPUTE SCALE
	ADJUST(.A)
END;
ROUTINE	DIVIDE(A,B,C) =

!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
!	Perform scaled  double division;  Divide the  two doubles  and
!	calculate new scale.
!
! FORMAL PARAMETERS:
!
!	A, B, and C are pointers  to 3 word blocks for storing  scaled
!	doubles.  A  will recieve  the result  of dividingthe  numbers
!	contained in B and C.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--

BEGIN
	REGISTER REG[2];
	MAP BASE A:B:C;

	DMOVE	(REG,.B);		!FETCH B
	DFDV	(REG,.C);		!DIVIDE BY C
	DMOVEM	(REG,.A);		!STORE IN A

	A[SCALE] = .B[SCALE] - .C[SCALE]; !COMPUTE SCALE
	ADJUST(.A)
END;
ROUTINE SCADD(A,B,C) =

!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
!	Add two  scaled doubles.   If the  scales are  identical,  the
!	numbers may be added.  However,  if the scales differ by  one,
!	the number with the smaller scale  must be multiplied by 2  **
!	-#100 to avoid the possibility of losing bits.  If the  scales
!	differ by more than  one, the numbers  cannot overlap and  the
!	result is the number with the larger scale.
!
!	If either number  is zero,  the result  is the  result is  the
!	other one.
!
! FORMAL PARAMETERS:
!
!	A, B, and C are pointers  to 3 word blocks for storing  scaled
!	doubles.  A  will recieve  the result  of adding  the  numbers
!	contained in B and C.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--

BEGIN	!SCADD
	MAP BASE A:B:C;
	REGISTER BASE L:S;		!LARGER, SMALLER (SCALE)
	LOCAL DELTA;			!POSITIVE SCALE DIFFERENCE

	! CHECK FOR A = 0 + C

	IF .B[SCALE] EQL 0		!ZERO SCALE?
	THEN IF .B[DOUBL1] EQL 0	!IS IT ZERO?
	THEN IF .B[DOUBL2] EQL 0	!******
	THEN
	BEGIN
		A[DOUBL1] = .C[DOUBL1];	!RESULT IS C
		A[DOUBL2] = .C[DOUBL2];
		A[SCALE] = .C[SCALE];
		RETURN .VREG		!RETURN NOVALUE
	END;

	! CHECK FOR A = B + 0

	IF .C[SCALE] EQL 0		!ZERO SCALE?
	THEN IF .C[DOUBL1] EQL 0	!IS IT ZERO?
	THEN IF .C[DOUBL2] EQL 0	!****
	THEN
	BEGIN
		A[DOUBL1] = .B[DOUBL1];	!RESULT IS B
		A[DOUBL2] = .B[DOUBL2];
		A[SCALE] = .B[SCALE];
		RETURN .VREG		!RETURN NOVALUE
	END;

	! FIND WHICH HAS LARGER SCALE FACTOR

	IF .B[SCALE] GTR .C[SCALE]
	THEN
	BEGIN	!B IS LARGER
		L = .B;
		S = .C
	END	!B IS LARGER
	ELSE
	BEGIN	!B IS SMALLER (OR SAME)
		L = .C;
		S = .B
	END;	!B IS SMALLER (OR SAME)

	DELTA = .L[SCALE] - .S[SCALE];	!GET POSITIVE DIFFERENCE

	IF .DELTA EQL 0
	THEN
	BEGIN	!SCALES ARE EQUAL
		REGISTER REG[2];

		DMOVE	(REG,.L);	!FETCH LARGER
		DFAD	(REG,.S);	!ADD SMALLER
		DMOVEM	(REG,.A);	!STORE IN A
		A[SCALE] = .B[SCALE];	!COPY SCALE (ANY SINCE THEY ARE EQL)
		RETURN .VREG		!RETURN NOVALUE
	END;	!SCALES ARE EQUAL

	! HERE WHEN SCALES ARE NOT EQUAL

	IF .DELTA EQL 1
	THEN
	BEGIN	!SCALES DIFFER BY 1
		REGISTER REG[2];

		REG[0] = #101400^18;	!2.0 ** -#100
		REG[1] = #0;
		DFMP	(REG,.S);	!MULTIPLY SMALLER BY 2.**-64.
		DFAD	(REG,.L);	!ADD IN LARGER
		DMOVEM	(REG,.A);	!STORE IN A
		A[SCALE] = .L[SCALE]	!COPY SCALE FROM LARGER

	END	!SCALES DIFFER BY 1
	ELSE
	BEGIN	!SCALES DIFFER BY 2 OR MORE
		A[DOUBL1] = .L[DOUBL1];	!RESULT IS LARGER
		A[DOUBL2] = .L[DOUBL2];
		A[SCALE] = .L[SCALE]
	END;	!SCALES DIFFER BY 2 OR MORE

	RETURN .VREG			!RETURN NOVALUE
END;	!SCADD
ROUTINE SUBTRACT(A,B,C) =

!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
!	Subtract scaled doubles by negation and addition.
!
! FORMAL PARAMETERS:
!
!	A, B, and C are pointers  to 3 word blocks for storing  scaled
!	doubles.  A will recieve the result of subtracting the numbers
!	contained in B and C.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	Scaled result is stored back into block addressed by A.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--

BEGIN	!SUBTRACT
	MAP BASE A:B:C;
	LOCAL TEMP[3];
	REGISTER R[2];

	DMOVN	(R,.C);			!GET C, NEGATED
	DMOVEM	(R,TEMP);		!STORE IN TEMP
	TEMP[2] = .C[SCALE];		!COPY SCALE
	SCADD(.A,.B,TEMP<ADR>)		!PERFORM ADDITION
END;	!SUBTRACT
GLOBAL ROUTINE COMPMUL(A,B,C,D) =

!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
!	Perform double COMPLEX multiplication on scaled double
!	coefficents (A,B) and (C,D).
!
!	(A + Bi) * (C + Di) == (AC - BD) + (AD + BC)i
!
! FORMAL PARAMETERS:
!
!	A, B, C, and D are pointers to three word blocks
!	holding scaled double precision numbers.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	Real part of result is stored back into block pointed to by A.
!	Imaginary part of result is stored back into block pointed to by B.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
! This routine is called from CNSTCM.MAC
!
!--

BEGIN	!COMPMUL
	MAP BASE A:B:C:D;
	LOCAL TEMP1[3],TEMP2[3],TEMP3[3];

	MULTIPLY(TEMP1<ADR>,.A,.C);	!TEMP1 := A * C
	MULTIPLY(TEMP2<ADR>,.B,.D);	!TEMP2 := B * D
	SUBTRACT(TEMP1<ADR>,TEMP1<ADR>,TEMP2<ADR>); !TEMP1 := TEMP1 - TEMP2

	MULTIPLY(TEMP2<ADR>,.B,.C);	!TEMP2 := B * C
	MULTIPLY(TEMP3<ADR>,.A,.D);	!TEMP3 := A * D
	SCADD(.B,TEMP2<ADR>,TEMP3<ADR>); !B := TEMP2 + TEMP3

	A[DOUBL1] = .TEMP1[0];
	A[DOUBL2] = .TEMP1[1];
	A[SCALE] = .TEMP1[2]
	
END;	!COMPMUL
GLOBAL ROUTINE COMPDIV(A,B,C,D) =

!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
!	Perform COMPLEX division on scaled double coefficients (A,B) and (C,D).
!
!	(A + Bi)      (AC + BD) + (BC - AD)i
!	--------  ==  ----------------------
!	(C + Di)	      2    2
!			     C  + D
!
! FORMAL PARAMETERS:
!
!	A, B, C, and D are pointers to three word blocks
!	holding scaled double precision numbers.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	Real part of result is stored back into block pointed to by C.
!	Imaginary part of result is stored back into block pointed to by D.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
! This routine is called from CNSTCM.MAC
!
!--

BEGIN	!COMPDIV
	MAP BASE A:B:C:D;
	LOCAL COMSUB[3],TEMP1[3],TEMP2[3];

	MULTIPLY(COMSUB<ADR>,.C,.C);	!COMSUB := C * C
	MULTIPLY(TEMP1<ADR>,.D,.D);	!TEMP1 := D * D
	SCADD(COMSUB<ADR>,COMSUB<ADR>,TEMP1<ADR>); !COMSUB := COMSUB + TEMP1

	MULTIPLY(TEMP1<ADR>,.A,.C);	!TEMP1 := A * C
	MULTIPLY(TEMP2<ADR>,.B,.D);	!TEMP2 := B * D
	SCADD(TEMP1<ADR>,TEMP1<ADR>,TEMP2<ADR>); !TEMP1 := TEMP1 + TEMP2
	DIVIDE(TEMP1<ADR>,TEMP1<ADR>,COMSUB<ADR>); !TEMP1 := TEMP1 / COMSUB

	MULTIPLY(TEMP2<ADR>,.B,.C);	!TEMP2 := B * C
	MULTIPLY(.D,.A,.D);		!D := A * D
	SUBTRACT(.D,TEMP2<ADR>,.D);	!D := TEMP2 - D
	DIVIDE(.D,.D,COMSUB<ADR>);	!D := D / COMSUB

	C[DOUBL1] = .TEMP1[0];
	C[DOUBL2] = .TEMP1[1];
	C[SCALE] = .TEMP1[2]

END;	!COMPDIV
GLOBAL ROUTINE COMPSQ(A,B) =

!++
! New [++++]/PLB
! FUNCTIONAL DESCRIPTION:
!
!	Perform double  COMPLEX square  on scaled  double  coefficents
!	(A,B).
!
!	Formula from a  preliminary technical report  by Ned  Anderson
!	entitled: "A Note  on Accurate  Computation of  Complex-Valued
!	Functions"
!
!	(A,B)*(A,B) = (A+B)*(A-B) + i(2*A*B)
!
! FORMAL PARAMETERS:
!
!	A and  B are  pointers  to three  word blocks  holding  scaled
!	double precision numbers.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	Real part of result is stored back into block pointed to by A.
!	Imaginary part of result is stored back into block pointed to by B.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
! This routine is called from CNSTCM.MAC
!
!--

BEGIN	!COMPSQ
	MAP BASE A:B;
	LOCAL TEMP1[3],TEMP2[3];

	! EVALUATE REAL PART INTO TEMP1

	SCADD(TEMP1<ADR>,.A,.B);	!TEMP1 := A + B
	SUBTRACT(TEMP2<ADR>,.A,.B);	!TEMP2 := A - B
	MULTIPLY(TEMP1<ADR>,TEMP1<ADR>,TEMP2<ADR>); !TEMP1 := TEMP1 * TEMP2

	! EVALUATE IMAG PART INTO B

	MULTIPLY(TEMP2<ADR>,.A,.B);	!TEMP2 := A * B
	SCADD(.B,TEMP2<ADR>,TEMP2<ADR>); !B := TEMP2 + TEMP2

	! COPY TEMP1 INTO A

	A[DOUBL1] = .TEMP1[0];
	A[DOUBL2] = .TEMP1[1];
	A[SCALE] = .TEMP1[2]
	
END;	!COMPSQ

END
ELUDOM