Google
 

Trailing-Edge - PDP-10 Archives - bb-4157j-bm_fortran20_v11_16mt9 - fortran-compiler/relbuf.bli
There are 26 other files named relbuf.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1974, 1987
!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/CKS/AHM/CDM/PLB/MEM

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

GLOBAL BIND RELBUV = #11^24 + 0^18 + #4554; ! Version Date: 3-Dec-86

%(

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

21	-----	-----	MOVE THE DECLARATIONS FOR THE STRUCTURES RELBUFF
			AND PRELBUFF TO A REQUIRE FILE.
22	-----	-----	PUT A NUMBER OF UTILITY ROUTINES USED IN MAKING
			LISTINGS THAT WERE REPEATED IN BOTH THE MODULES
			"LISTOU" AND "OUTMOD" INTO THIS MODULE
			ROUTINES ARE:  ZOUTMSG,ZOUTSYM,ZOUTOCT,RADIX50,
			ZOUDECIMAL,ZOUOFFSET
24	-----	-----	MOVE THE ROUTINE "DMPRLBLOCK" INTO THIS MODULE
25	-----	-----	MOVE THE ROUTINE "LSTRLWD" FROM LISTOU INTO THIS MODULE
26	-----	-----	SHOULD BE SHIFTING RELOCATION BITS LEFT BY (35-COUNT)
			RATHER THAN (36-COUNT)
29	-----	-----	SHOULD BE SHIFTING RELOC BITS BY (36-COUNT*2)
30	-----	-----	MAKE "DMPMAINRLBF" INTO A GLOBAL ROUTINE RATHER
			THAN LOCAL TO "ZOUTBLOCK"

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

31	1242	CKS	29-Jul-81
	Add routine OUTCHDATA to output the .REL block to initialize a
	character variable

32	1403	AHM	26-Oct-81
	Add support for having "$" in symbol names to routine RADIX50.
	Needed for extended addressing development.

1474	TFV	15-Mar-82
	Fix ZOUDECIMAL to handle up to 12 decimal digits.

1511	CDM	18-Mar-82
	Added ZSAVEOUT to output rel blocks for SAVE statements.

1512	AHM	24-Mar-82
	Add ZSYMBOL  and ZNEWBLOCK  to output  type 2  or 1070  symbol
	blocks depending on /EXTEND.  Also reformat module slightly.

1521	CDM	26-Mar-82
	Add routines  TPARGDES,  SECDESC, SIXTO7,  ARGCHECK,  ZCOERCION,
	ZSFARGCHECK for argument checking.
	Remove SECDES 29-Jun-82 to SRCA.

1525	AHM	1-Apr-82
	If writing a psected REL file, always output a type 22 default
	psect index block before flushing out the type 10 local  fixup
	block buffer.  Also, use PXCODE instead of PXHIGH to  relocate
	argument descriptor entries that  point to the argument  block
	and subroutine call.

1526	AHM	6-Apr-82
	Add ZCODE routine to output type  2 or 1010 code blocks.   Use
	CURADDR and  CURPSECT to  specify  the current  address  being
	loaded into  instead  of  always  using  HILOC.   Also,  don't
	subtract HIORIGIN  from  the address  of  subroutine  argument
	blocks in ZARGCHECK, since we now never add it in.

1531	CDM	4-May-82
	SAVE changes per code review.

1540	AHM	21-May-82
	Don't output  a  default  psect  index  block  before  calling
	BUFFOUT, since  it  will  flush the  main  rel  buffer  before
	flushing the local  fixup rel  buffer.  LINK  is suspected  of
	destroying the current default psect index in arbitrary  ways,
	so the index should set immediately before the local fixups.

1544	AHM	26-May-82
	Output type 22 default psect index blocks for the .DATA. psect
	before type 21 or 1004 sparse data blocks so that they have  a
	chance to work while  the new psected  sparse data blocks  are
	not in LINK.  This edit is only for V8 development and will be
	removed when the LINK support is finally in.

1551	AHM	3-Jun-82
	Make ZCODE and ZSYMBOL call CGERR if they are passed the psect
	PSOOPS as an argument.  Also change the EXTERNPSECT uplit to
	account for the new PS???? symbol values.

1566	CDM	24-Jun-82
	Changes to not ouput SAVE-d  named commons to writeable  overlay
	blocks that have not been declared in COMMON statements.

1567	CDM	1-Jul-82
	Move SECDESC to SRCA.
	Change name of SECDESC to CHEXLEN.

1570	AHM	25-Jun-82
	Change the entry in LONGTAB so that type 1070 additive  symbol
	fixups for extended  programs don't try  to relocate a  symbol
	name (though  since all  the calls  to ZSYMBOL  with  function
	GLBSYMFIX used PSABS anyhow) and perform 30 bit fixups instead
	of 18 bit fixups so that  numerics in COMMON don't lose  their
	section numbers.

1613	CDM	13-Aug-82
	Change /DEBUG:PARAMETERS to /DEBUG:ARGUMENTS.

1674	CDM	11-Nov-82
	Fix  argchecking  further  so   that  constant  and   expression
	arguments get  flagged  as  no-update,  and  character  function
	return values are implicit (not checked).

***** End V7 Development *****

1770	CDM	25-Jul-83
	Perform argument checking for length of numeric arrays when  the
	length is known at  compile time. Create  SECDESC to return  the
	length needed  for  a secondary  descriptor  (or 0  if  none  is
	needed).

2022	CDM	1-Dec-83
	Writable overlay  blocks  (type  1045)  were  put  out  for  the
	following program:

		PROGRAM FOO
		SAVE /FOO/
		END

	ZSAVEOUT deletes undeclared common  blocks (FOO above) from  the
	list of those to put in the rel block, but does not check to see
	if there is a  reason to put ANY  1045 block out after  deleting
	these undeclared commons.  If there are no delcared commons, and
	no local variable to SAVE, then do not put out a 1045 block.

2075	CDM	22-Jan-85
	Fix for edit 2022, output writeable overlay rel block if
	blank COMMON is seen, even if no other common blocks are
	declared and used.

2602	MEM	18-Nov-86
	Change entry in coercion block for singleton actual and an
	array formal to give an warning.

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

2216	PLB	27-Sep-83
	Modifications for output of OWGs for use in one section.  The
	section is specified in the global OWGBPSECTION.  OUTCHDATA
	must convert back to OWL format until there is a LINK block
	for OWG sparse data.

2254	AHM	28-Dec-83
	Make type 1070 local and global symbol definitions use 30 bit
	relocation instead of 18 bit RH relocation.  Unlike type 2
	blocks, 1070 blocks do not use LINK's kludge of relocating the
	whole symbol value if the left half is zero.

2267	AHM	16-Jan-84
	Complete the work of edit 2254 (I hope).  Make type 1070 RH
	chained and additive fixups also use 30 bit relocation instead
	of 18 bit RH relocation.

2311	PLB	19-Feb-84	IGNORANCE IS STRENGTH
	Add routine ZOUTADDR to output 24 bits to listing; ZOUTOFFSET
	now uses ZOUTADDR.  New routine ZOUSMOFFSET uses ZOUTOCT like
	in days of yore.

2323	AHM	14-Mar-84
	Create a new routine named Z30CODE which will output R30CODE
	(type 1030) 30 bit relocation rel blocks under /EXTEND.  It
	calls ZCODE under /NOEXTEND.  Also, make ZOUTBLOCK recognize
	that type 1030 blocks need a loading address put in the first
	word of a buffer, just like 1 and 1010 blocks.  Finally, make
	DMPMAINRLBF recognize that all blocks greater than or equal to
	1000 are long count blocks.

2330	AHM	28-Mar-84
	Make OUTCHDATA use EXTENDED instead of .OWGBPSECTION NEQ 0 as
	the test for changing OWGBPs to OWLBPs when generating type
	1004 byte initialization REL blocks.  This removes all
	references to OWGBPSECTION from this module.

2342	AHM	17-Apr-84
	Make DATA statements work for some variables in .LARG.  Make
	OUTCHDATA use the psect indices in the variables it is passed
	instead of always using .DATA.  Move EXTERNPSECT into a GLOBAL
	BIND in GLOBAL so that OUTDATA in OUTMOD can reference it.
	This should allow CHARACTER variables in the first section of
	.LARG. to be statically initialized by DATA statements.

2423	AHM	17-Jul-84
	Move OUTCHDATA to DATAST, where it can share secret OWNs for
	buffering Ultimate Sparse Data REL blocks.

2434	CDM	23-Jul-84
	Enhance argument  checking  to differentiate  between  character
	expressions /EXTEND and /NOEXTEND.  We do not want to pass a one
	word  LOCAL  byte  pointer  where  a  GLOBAL  is  wanted.   This
	condition could reference data in the wrong section.

2502	CDM	20-Nov-84
	Correct argument checking in the coercion block to have LINK 
	complain about calling a function as if it were a subroutine.
	Module:
		RELBUF

2517	CDM	1-Feb-85
	Enhancements to argument checking, upgrading for statement
	functions to be up with external routines, and a few bug fixes in
	statement functions.  Added checks for structure in arguments;
	singleton (scalar), array, routine.  Added character length
	checking in statement functions.

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

2532	CDM	9-May-85
	Only put out type checking information for known (called)
	function names.  Subroutine and ambiguous external names
	should not have type checking information output.

2575	CDM	28-Apr-86
	A scalar, which has the same name as the routine its in, and is
	passed to another routine, gives a structure type of "routine"
	instead of "singleton" to LINK for /DEBUG:ARGUMENTS typechecking.

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

***** Begin Version 11 *****

4527	CDM	1-Jan-86
	VMS Long symbols phase II.  Convert all internal symbols from
	one word of Sixbit to [length,,pointer].  The lengths will be one
	(word) until a later edit, which will store and use long symbols.

4530	MEM	17-Feb-86
	Add long symbol support: Modify routines do dump out symbols more
	than one word; change underline in a radix50 word to a percent;
	modify routines	to handle long title, long entry and long common blocks

4554	MEM	3-Dec-86
	Add boolean parameter to ZOUTSYM to determine whether or not the
	symbol should be blank padded to 31 characters.

ENDV11
)%

	SWITCHES NOLIST;

	REQUIRE FIRST.BLI;
	REQUIRE TABLES.BLI;
	REQUIRE REQREL.BLI;

	SWITCHES LIST;


EXTERNAL
%1521%	ARGLINKPT,	! Global pointer to begining of argument blocks.
%1512%	CGERR,		! Routine to call on internal errors
%1526%	CURADDRESS,	! Current loading address
%1526%	CURPSECT,	! Current psect being loaded into
	EVALTAB EVALU,	! Table for conversion from Fortran [valtype] to
			! type codes for LINK.
%4530%	EPSTAB EXTERNPSECT,	! Table of external psect indices
			!  indexed by internal psect indices
%1521%	HIORIGIN,	! Origin of HISEG
%4530%	LONGREL,	! if =1 then Put out rel blocks for long names
%4530%	LONGUSED,	! =1 if Long symbols used
	LSTOUT,		! Routine to output a character to the listing
	RELBUFF LOCRLBF,! Buffer for type 10 local request rel blocks
			!  (Does fixups for forward refs to a label)
	RELBUFF MAINRLBF,	! Main rel file buffer - used for type 1 and 1010
			!  (code and data) as well as miscellaneous
			!  (hiseg, end, etc.)
%1526%	PSECTS,		! Current free locations in each psect (LOWLOC, etc)
			!  indexed by psect index (PSDATA, etc)
	RDATWD,		! Holds the data word for ZOUTBLOCK
%1567%	CHEXLEN,	! Returns length of character expression or LENSTAR
%1521%	SORCPTR,	! Pointer to 1st and last statement nodes
	RELBUFF SYMRLBF;! Buffer for type 2 and 1070 symbol rel blocks
			!  (Symbol definitions and global requests)

FORWARD
	ZCODE,		! Output a data word in a type 1 or 1010 block
%2323%	Z30CODE,	! Output a 1030 block or pass the buck to ZCODE
%1512%	ZSYMBOL, 	! Outputs symbols to the REL file	
	ZOUTBLOCK,	! Buffers a word to the REL file
%1512%	ZNEWBLOCK,	! Buffers a word of an unrelocated block type
	BUFFOUT,	! Stores a data word into a particular rel buffer
	DMPMAINRLBF,
	INIRLBUFFS,	! Initializes all 3 REL file buffers
	DMPRLBLOCK,
	LSTRLWD,	! List a word of the rel file for /EXPAND
	ZOUTMSG,	! Prints an ASCIZ string
	ZOUTSYM,	! Lists a SIXBIT symbol
	ZOUTOCT,	! List octal half word
	ZOUTADDR,	! Output 24 bit octal address to listing file
	RADIX50,	! Return Radix-50 of the sixbit word in R2
	ZOUDECIMAL,	! Output a decimal number
	ZOUOFFSET,	! List a value as a signed octal offset
	ZOUSMOFFSET,	! List an 18 bit (small) signed offset
	ZSAVEOUT,
%1521%	ZARGCHECK,	! Puts out type checking blocks for subprog calls.
%1521%	SIXTO7,		! Sixbit to ASCIZ conversion.
%1521%	TPARGDES,	! Fills in buffer for each argument.
%1521%	ZSFARGCHECK,	! Puts out type checking blocks for subprog definitions
%1521%	ZCOERCION,	! Puts out coercion blocks for type checking.
%1770%	SECDESC;	! Returns size needed for secondary descriptor in
%1770%			! argument checking.

BIND	! Values for ARGTYPE to give to routine TPARGDES.
%2575%	NOTSPECIAL = 0,	! J Random argument
%2575%	IMPLARG = 1,	! Implicit argument, don't type check
%2575%	FNRETVAL = 2;	! Function return value
GLOBAL ROUTINE ZCODE(EAPSECT,LOADPSECT)=!NOVALUE [1526] New
BEGIN

! Routine to output the a word with type 1 or 1010 blocks for  loading
! data and instructions into memory.  Takes three parameters:

! RDATWD (Global variable) - The word to be output
! EAPSECT (Argument) - PSECT index to relocate the right half of RDATWD by.
! LOADPSECT (Argument) - Index of the psect to load the word into.

! Format of an old-style type 1 block

! !=========================================================================!
! !                 1                  !            Short count             !
! !-------------------------------------------------------------------------!
! !L!R!L!R! . ! . ! . !          Relocation bits for each halfword          !
! !=========================================================================!
! !                             Loading address                             !
! !-------------------------------------------------------------------------!
! !                                Data word                                !
! !-------------------------------------------------------------------------!
! \                                                                         \
! \                             More data words                             \
! \                                                                         \
! !=========================================================================!

! Format of a new-style type 1010 block

! !=========================================================================!
! !                1010                !             Long count             !
! !-------------------------------------------------------------------------!
! !P1 !P2 ! . ! . ! . !             Two bit wide psect indices              !
! !=========================================================================!
! !                             Loading address                             !
! !-------------------------------------------------------------------------!
! !                                Data word                                !
! !-------------------------------------------------------------------------!
! \                                                                         \
! \                             More data words                             \
! \                                                                         \
! !=========================================================================!

	IF .LOADPSECT EQL PSOOPS	! Loading into an unknown psect ?
	THEN CGERR()			! Yes, give fatal error
	ELSE IF .EAPSECT EQL PSOOPS	! No, are we relocating improperly ?
	THEN CGERR();			! Yes, give fatal error

	CURADDRESS = .PSECTS[.LOADPSECT];	! Get load address

	IF EXTENDED		! Should we use TWOSEG or psected blocks ?
	THEN			! Use psected blocks (new type 1010)
	BEGIN
		CURPSECT = .EXTERNPSECT[.LOADPSECT];	! Store in given psect
		ZOUTBLOCK(RRIGHTCODE,.EXTERNPSECT[.EAPSECT])
	END
	ELSE			! Use TWOSEG scheme (old type 1)
	BEGIN
		CURPSECT = RELRI;	! We relocate the loading address

		IF .EAPSECT EQL PSCODE	! Pointing to the high segment ?
		THEN RDATWD<RIGHT> = .RDATWD<RIGHT>+.HIORIGIN;	! Yes, hisegize

		IF .LOADPSECT EQL PSCODE
		THEN CURADDRESS<RIGHT> = .CURADDRESS<RIGHT>+.HIORIGIN;

		IF .EAPSECT EQL PSABS	! Absolute right half ?
		THEN ZOUTBLOCK(RCODE,RELN)	! Yes, say so
		ELSE ZOUTBLOCK(RCODE,RELRI)	! No, relocate the right half
	END
END; ! of ZCODE
GLOBAL ROUTINE Z30CODE(EAPSECT,LOADPSECT) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	If /NOEXTEND, then let ZCODE output the data word in RDATWD,
!	passing EAPSECT and LOADPSECT unchanged as arguments.
!	Otherwise, do the following:
!
!	Call CGERR if called with EAPSECT or LOADPSECT set to PSOOPS.
!
!	Set up CURADDRESS and  CURPSECT from LOADPSECT  in case a  new
!	REL buffer needs the current loading address.
!
!	Call ZOUTBLOCK to place RDATWD in an R30CODE (type 1030) REL
!	block, relocated by EAPSECT.
!
! FORMAL PARAMETERS:
!
!	EAPSECT		Internal index of psect to relocate the Y of RDATWD.
!
!	LOADPSECT	Internal index of RDATWD's destination psect.
!
! IMPLICIT INPUTS:
!
!	PSECTS		Table of relocation counters, indexed by
!			internal psect index.
!
!	RDATWD		The word to be output to the REL file.
!
! IMPLICIT OUTPUTS:
!
!	CURADDRESS	The object address that RDATWD will be loaded into.
!
!	CURPSECT	The external index of psect that RDATWD will go into.
!
!	PSECTS		Updated relocation counter for current psect.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	May flush MAINRLBF, which will cause output to the REL file.
!
!	May ICE the compiler if a PSOOPS psect index is encountered.
!
!--


BEGIN	![2323] New

	IF NOT EXTENDED			! /EXTEND?
	THEN ZCODE(.EAPSECT,.LOADPSECT)	! No, use 18 bit RH relocation
	ELSE
	BEGIN	! EXTENDED
		IF .EAPSECT EQL PSOOPS	! Bad psect index for E/A?
		THEN CGERR()		! Yes, cause an ICE
		ELSE IF .LOADPSECT EQL PSOOPS	! No, how about load address?
		THEN CGERR();		! Yes, die horribly

		CURADDRESS = .PSECTS[.LOADPSECT];	! Get loading address
		CURPSECT = .EXTERNPSECT[.LOADPSECT];	! Translate into
							!  external psect index
		ZOUTBLOCK(R30CODE,.EXTERNPSECT[.EAPSECT]);	! Output word
	END;	! EXTENDED
END;	! of Z30CODE
GLOBAL ROUTINE ZSYMBOL(FUNC,NAM,VALUE,PSECT)=!NOVALUE [1512] New
BEGIN

! Routine to output  the proper sequence  of words in  type 2 or  1070
! blocks for doing things with symbols (definitions, fixups, etc).

! First the new type 1070 blocks

! !=========================================================================!
! !                1070                !             Long count             !
! !=========================================================================!
! !  Function code  ! 0 !Name size (0) !D!  R  !             0              !
! !-------------------------------------------------------------------------!
! !           Left psect (0)           !            Right psect             !
! !-------------------------------------------------------------------------!
! !                                  Value                                  !
! !-------------------------------------------------------------------------!
! !                             Name in SIXBIT                              !
! !-------------------------------------------------------------------------!
! \                                                                         \
! \                     More quads of names and values                      \
! \                                                                         \
! !=========================================================================!

MACRO
	TYPE1070FILL(F,R)=((F)^27 OR	! Fill in the function code field
		1^17 OR			! Always set the default (D) bit
					!  (There are psects in the next word)
		(R)^14)$,	! Fill in the R field (what to relocate)
	RFIELD=14,3$,		! R field in type 1070 block flag word
%4530%	LVALEN = 7,7$,		! Number of words -1 for a long value name
%4530%	LNAMLEN = 18,7$;	! Number of words -1 for a long symbol name
LOCAL
%4530%	WCNT;			! Number of words for a symbol name

BIND
	LONGTAB = UPLIT(	! A table entry is all the data that goes into
				!  the flag word of a type 1070 symbol
%LOCDEF:%	TYPE1070FILL(RLSLOCAL,RLSR30),	![2254]
%LOCSUPDEF:%	TYPE1070FILL(RLSLOCAL OR RLSSUPPRESS,RLSR30),	![2254]
%GLBDEF:%	TYPE1070FILL(RLSGLOBAL,RLSR30),	![2254]
%GLBSUPDEF:%	TYPE1070FILL(RLSGLOBAL OR RLSSUPPRESS,RLSR30),	![2254]
%GLBSYMFIX:%	TYPE1070FILL(RLSGLOBAL OR RLSSYMBOL OR RLS30FIX,RLSRABS),![1570]
%GLB18CHNFIX:%	TYPE1070FILL(RLSGLOBAL OR RLSCHAIN OR RLSRHFIX,RLSR30),	![2267]
%GLB18ADDFIX:%	TYPE1070FILL(RLSGLOBAL OR RLSADDITIVE OR RLSRHFIX,RLSR30),![2267]
%GLB30CHNFIX:%	TYPE1070FILL(RLSGLOBAL OR RLSCHAIN OR RLS30FIX,RLSR30),
%GLB30ADDFIX:%	TYPE1070FILL(RLSGLOBAL OR RLSADDITIVE OR RLS30FIX,RLSR30)
		);

! Next the old type 2 blocks

! !=========================================================================!
! !                 2                  !            Short count             !
! !-------------------------------------------------------------------------!
! !                             Relocation bits                             !
! !=========================================================================!
! ! Code  !                     Symbol name in Radix 50                     !
! !-------------------------------------------------------------------------!
! !                             Value of symbol                             !
! !-------------------------------------------------------------------------!
! \                                                                         \
! \                     More pairs of names and values                      \
! \                                                                         \
! !=========================================================================!

MACRO
	TYPE2FILL(A,B)=((A) OR (B)^(-18))$,	! Puts the left halves of its
						!  args into half words
	R50NAME=LEFT$,			! The left half of a table entry is
					!  ORed into the radix 50 symbol name
					!  that is being output
	R50VAL=RIGHT$;			! The right half of a table entry is
					!  ORed into the value in the same way

BIND
	R50TAB = UPLIT(			! Radix-50 flag bits indexed by FUNC
%LOCDEF:%	TYPE2FILL(RLOCDEF,0),
%LOCSUPDEF:%	TYPE2FILL(RLOCDDTSUP,0),
%GLBDEF:%	TYPE2FILL(RGLOBDEF,0),
%GLBSUPDEF:%	TYPE2FILL(RGLOBDDTSUP,0),
%GLBSYMFIX:%	TYPE2FILL(RGLOBREQ,RLOCFIX),
%GLB18CHNFIX:%	TYPE2FILL(RGLOBREQ,RGLOB0^18),
%GLB18ADDFIX:%	TYPE2FILL(RGLOBREQ,RGLOB4^18),
%GLB30CHNFIX:%	TYPE2FILL(0,0),
%GLB30ADDFIX:%	TYPE2FILL(0,0)
		);


	IF .PSECT EQL PSOOPS		! Defining in an unknown psect ?
	THEN CGERR();			! Yes, give fatal error

%4530%	WCNT = .NAM<SYMLENGTH>;	!number of words in long symbol

%4530%	IF (.LONGREL AND .LONGUSED) OR EXTENDED	!Put out long symbols to rel blocks
	THEN			! Non-zero section, use psected symbols
	BEGIN	! psected symbols

%4530%		!Check if we will have room for this symbol in SYMRLB
%4530%		!If we don't then dump out its contents
%4530%		!This check below was removed from ZNEWBLOCK and moved here
%4530%	
%4530%		! A symbol entry consists of 3 words(flags,psects,value) besides symbol name
%4530%		IF (.SYMRLBF[RDATCNT]+.WCNT+3) GEQ SYMBOLMAX	! Any room left ?
%4530%		THEN			! No, output what we have so far
%4530%		BEGIN
%4530%			DMPMAINRLBF();	! Dump out code that might need fixups
%4530%			DMPRLBLOCK(SYMRLBF,.SYMRLBF[RDATCNT]+1);
%4530%			SYMRLBF[RDATCNT] = 0	! Clear the word count
%4530%		END;

		RDATWD = .LONGTAB[.FUNC];	! Get proper flag word

%4530%		RDATWD<LNAMLEN> = .WCNT - 1;	!word count - 1 for symbol name
%4530%		IF .FUNC EQL GLBSYMFIX
%4530%		THEN RDATWD<LVALEN> = .VALUE<SYMLENGTH> - 1; !Cnt-1 for value

		IF .PSECT EQL PSABS		! Doing relocation ?
		THEN RDATWD<RFIELD> = RLSRABS;	! No, emphasize this for LINK

		ZNEWBLOCK(RLONGSYMBOL);		! There go the flags

		RDATWD = .EXTERNPSECT[.PSECT];	! Get the proper external psect
		ZNEWBLOCK(RLONGSYMBOL);

%4527%		! We have either numeric or [length,,pointer] symbol.
%4527%
%4530%		IF .FUNC NEQ GLBSYMFIX	! Fixup of an existing symbol's value ?
%4530%		THEN RDATWD = .VALUE		! No, Numeric
%4530%		ELSE
%4530%		BEGIN
%4530%			RDATWD = @(.VALUE<SYMPOINTER>);! Yes, Symbol get the name in SIXBIT
%4530%		END;
			
	 	ZNEWBLOCK(RLONGSYMBOL);		! Output 1st word of VALUE


%4530%		! Output symbol name
%4530%		INCR I FROM 0 TO .WCNT - 1
%4530%	     	DO
%4530%		BEGIN	! long symbol
%4530%			RDATWD = @(.NAM<SYMPOINTER> + .I);! And get the name in SIXBIT
%4530%			ZNEWBLOCK(RLONGSYMBOL)
%4530%		END;

%4530%		IF .FUNC EQL GLBSYMFIX	! Fixup of an existing symbol's value ?
%4530%		THEN IF .VALUE<SYMLENGTH> GTR 1
%4530%		THEN
%4530%		BEGIN
%4530%			INCR I FROM 1 TO .VALUE<SYMLENGTH> - 1
%4530%	     		DO
%4530%			BEGIN	! long symbol
%4530%				RDATWD = @(.VALUE<SYMPOINTER> + .I);! And get the name in SIXBIT
%4530%				ZNEWBLOCK(RLONGSYMBOL)
%4530%			END;
%4530%		END;


	END	! psected symbols
	ELSE
	BEGIN	! Use TWOSEG scheme (type 2)

		! Convert the  name to  radix  50, place  the  correct
		! flags in the first 4 bits of the name and output  it
		! to the rel file.

%4530%		R2 = @(.NAM<SYMPOINTER>); ! First word of symbol name
		RDATWD = RADIX50() OR .R50TAB[.FUNC]<R50NAME>^18;
		ZOUTBLOCK(RSYMBOL,RELN);

		! Now accumulate the value

		IF .FUNC EQL GLBSYMFIX	! Fixup of an existing symbol's value ?
		THEN			! Yes, this is a special case
		BEGIN
%4530%			R2 = @(.VALUE<SYMPOINTER>);	! Convert name to radix 50 and set bits
			RDATWD = RADIX50() OR .R50TAB[.FUNC]<R50VAL>^18
		END
		ELSE RDATWD = .VALUE OR .R50TAB[.FUNC]<R50VAL>^18;

%1526%		IF .PSECT EQL PSCODE	! Meant for the high segment ?
%1526%		THEN RDATWD<RIGHT> = .RDATWD<RIGHT>+.HIORIGIN;	! Yes, hisegize

		IF .PSECT EQL PSABS		! Relocating the value ?
		THEN ZOUTBLOCK(RSYMBOL,RELN)	! No
		ELSE ZOUTBLOCK(RSYMBOL,RELRI)	! Yes

	END	! Not psected symbols

END; ! of ZSYMBOL
GLOBAL ROUTINE ZOUTBLOCK(ZBLKTYPE,RELBITS)=
BEGIN

! Buffers one data word that is to be output to the REL file.

! Called with the global RDATWD containing the data word and the args:
!
! 1. ZBLKTYPE - The REL file block type of the block into
! 		which this data word should be placed.
! 2. RELBITS -  The 2 relocation bits that should be associated
! 		with this data word.
!
! We maintain the separate REL file buffers:
!
! 1. SYMRLBF -	For REL file block types 2 and 1070 - this type code is used
!		for symbol definitions and global requests
! 2. LOCRLBF -  For REL file block type 10 - this type code is used
!		for local requests (ie definition of labels to
!		which there were forward references)
! 3. MAINRLBF - For all other block types (primarily this will
!		be block type 1 - code and data - but it will
!		also be used for other misc block types)
!
! When either  SYMRLBF  or  LOCRLBF  is full,  we  must  first  output
! anything in  MAINRLBF  before outputing  the  contents of  the  full
! buffer (since a  local or global  fixup cannot precede  the word  of
! data it refers to).

LABEL
	BLOCKSELECT;	! SELECT statement that figures out which buffer to use

BLOCKSELECT:
	SELECT .ZBLKTYPE OF
	NSET

	RSYMBOL:	! For a symbol definition or global request
		BEGIN
			BUFFOUT(SYMRLBF,.RELBITS);
			LEAVE BLOCKSELECT
		END;

	RLOCAL:
		BEGIN
%1526%			IF NOT EXTENDED
%1526%			THEN
%1526%			BEGIN
%1526%				! Make the addresses refer to the high segment.
%1526%
%1526%				RDATWD<LEFT> = .RDATWD<LEFT> + .HIORIGIN;
%1526%				RDATWD<RIGHT> = .RDATWD<RIGHT> + .HIORIGIN
%1526%			END;

			BUFFOUT(LOCRLBF,.RELBITS);
			LEAVE BLOCKSELECT
		END;

	OTHERWISE:	! For code and data, and for all other block types
		BEGIN

			! If the main buffer is full or is being  used
			! for some  other block  type than  this  data
			! word should go into, then flush the buffer.

			IF .MAINRLBF[RDATCNT] EQL RBLKSIZ-2
				OR .MAINRLBF[RTYPE] NEQ .ZBLKTYPE
			THEN
			BEGIN
				DMPMAINRLBF();	! Output the contents of
						!  MAINRLBF and reinitialize it
				MAINRLBF[RTYPE] = .ZBLKTYPE;
			END;

			! The first data  word of a  block of type  1,
			! 1010  or  1030   block  (code/data)   should
			! contain the address  for the  first word  of
			! code (and use the proper relocation or psect
			! index for the address).

%1526%			IF .MAINRLBF[RDATCNT] EQL 0
%1526%			THEN IF .ZBLKTYPE EQL RCODE OR .ZBLKTYPE EQL RRIGHTCODE
%2323%				OR .ZBLKTYPE EQL R30CODE
%1526%			THEN
%1526%			BEGIN
%1526%				MAINRLBF[1,RLDATWD] = .CURADDRESS;
%1526%				MAINRLBF[RDATCNT] = 1;
%1526%				MAINRLBF[RRELOCWD] = .CURPSECT^34
%1526%			END;

			! Increment the count of the data words, store
			! the data  word in  the  buffer and  put  the
			! relocation bits for this data word into  the
			! relocation word at the ead of the buffer.

			MAINRLBF[RDATCNT] = .MAINRLBF[RDATCNT]+1;
			MAINRLBF[.MAINRLBF[RDATCNT],RLDATWD] = .RDATWD;
			MAINRLBF[RRELOCWD] = .MAINRLBF[RRELOCWD]
				OR .RELBITS^(36-.MAINRLBF[RDATCNT]*2);
		END;
	TESN;

END;  ! of ZOUTBLOCK
GLOBAL ROUTINE ZNEWBLOCK(ZBLKTYPE)=!NOVALUE [1512] New
BEGIN

! Buffers one data word that is to  be output to the REL file with  no
! relocation.  The present user is block type 1070 (long symbol name).
!
! Called with the global RDATWD containing  the data word and the  arg
! ZBLKTYPE containing the REL file block type of the block into  which
! this data word should be placed.
!
! The REL file buffer that the data word is temporarily stored into is
! selected depending upon the REL block type.
!
! 1. SYMRLBF -	For REL file block type 1070 - this type code is used
!		for symbol definitions and global requests.
! 2. LOCRLBF -  Not presently used for strange block types.
! 3. MAINRLBF - For REL file block types 1002, 1003 and 1074  [4530]
!
! When either  SYMRLBF  or  LOCRLBF  is full,  we  must  first  output
! anything in  MAINRLBF  before outputing  the  contents of  the  full
! buffer (since a  local or global  fixup cannot precede  the word  of
! data it refers to).

	IF .ZBLKTYPE EQL RLONGSYMBOL	! Symbol definition or global request
	THEN
	BEGIN
%4530%		! Check to see if SYMRLB was full was moved to ZSYMBOL

		! Drop off the  word and increment  the buffer  count.
		! Note that while block  types that have a  relocation
		! word start dropping off words at  buffer[1,RLDATWD],
		! 2, 3, since type 1070 blocks don't have  relocation,
		! they drop off words at buffer[0,RLDATWD], 1, 2, etc.

		SYMRLBF[.SYMRLBF[RDATCNT],RLDATWD] = .RDATWD;
		SYMRLBF[RDATCNT] = .SYMRLBF[RDATCNT]+1
	END
%4530%	ELSE IF (.ZBLKTYPE EQL RLONGENTRY) OR (.ZBLKTYPE EQL RLONGTITLE)
%4530%	OR (.ZBLKTYPE EQL RLONGCOMMON)
%4530%	THEN
%4530%	BEGIN
%4530%		IF .MAINRLBF[RTYPE] NEQ .ZBLKTYPE
%4530%		THEN
%4530%		BEGIN
%4530%			DMPMAINRLBF();	! Output the contents of
%4530%					!  MAINRLBF and reinitialize it
%4530%			MAINRLBF[RTYPE] = .ZBLKTYPE;
%4530%		END;
%4530%		
%4530%		MAINRLBF[.MAINRLBF[RDATCNT],RLDATWD] = .RDATWD;
%4530%		MAINRLBF[RDATCNT] = .MAINRLBF[RDATCNT]+1	
%4530%	END
	ELSE CGERR();			! None of the above !

END;  ! of ZNEWBLOCK
ROUTINE BUFFOUT(BUFFER,RELBITS)=
BEGIN
MAP
	PRELBUFF BUFFER;	! BUFFER is a pointer to a REL file buffer
LOCAL
	RELBUFF MYRELBUF[3];

! Puts the data word contained in the global RDATWD into the REL  file
! buffer indicated by BUFFER.  RELBITS specifies the relocation  bits.
! If BUFFER is full, the contents of the main REL file buffer MAINRLBF
! will be output to the REL file, followed by the contents of  BUFFER.

	IF .BUFFER[RDATCNT] EQL RBLKSIZ-2	! Is buffer full ?
	THEN			! Yes
	BEGIN
		DMPMAINRLBF();	! Output the contents of MAINRLBF
				!  and reinitialize MAINRLBF

%1540%		IF .BUFFER[RTYPE] EQL RLOCAL	! Local fixups ?
		THEN IF EXTENDED		! Yes, psected object code ?
		THEN				! Yes, buffer is full
		BEGIN

			! Set the  default psect  before we  dump  the
			! local fixups.  Note that  all fixups are  in
			! .CODE.

			MYRELBUF[RTYPE] = RPSECTORG;	! Psect index rel block
			MYRELBUF[RDATCNT] = 1;		! One data word
			MYRELBUF[RRELOCWD] = 0;		! Don't relocate it
			MYRELBUF[1,RLDATWD] = PXCODE;	! Index for .CODE.
			DMPRLBLOCK(MYRELBUF,3)		! Output the data
%1540%		END;

		DMPRLBLOCK(.BUFFER,RBLKSIZ);	! Output the contents of BUFFER

		BUFFER[RDATCNT] = 0;	! Clear the buffer's word count
		BUFFER[RRELOCWD] = 0;	!  and say there is no relocation
	END;

	BUFFER[RDATCNT] = .BUFFER[RDATCNT]+1;	! Bump count of stored words

	BUFFER[RRELOCWD] = .BUFFER[RRELOCWD] OR	! Store the relocation bits
				.RELBITS^(36-.BUFFER[RDATCNT]*2);

	BUFFER[.BUFFER[RDATCNT],RLDATWD] = .RDATWD	! Store the data word
END;	! of BUFFOUT
GLOBAL ROUTINE DMPMAINRLBF=
BEGIN

! Outputs the contents of the main rel file buffer to the rel file and
! reinitializes the buffer.  If the buffer is empty, does nothing.

	IF .MAINRLBF[RDATCNT] EQL 0	! Are there any word in the buffer ?
	THEN RETURN;			! No, punt

%2323%	IF .MAINRLBF[RTYPE] GEQ RLNGCNTBLK	! Long count block?
%1526%	THEN					! Yes, block count must include
%1526%	BEGIN					!  the relocation word
%4530%		IF .MAINRLBF[RTYPE] NEQ RLONGCOMMON
%4530%		THEN MAINRLBF[RDATCNT] = .MAINRLBF[RDATCNT]+1;! Long count
%1526%	 	DMPRLBLOCK(MAINRLBF,.MAINRLBF[RDATCNT]+1)
%1526%	END					! No, old block
%1526%	ELSE DMPRLBLOCK(MAINRLBF,.MAINRLBF[RDATCNT]+2);	! Use short count

	MAINRLBF[RDATCNT] = 0;		! Set the buffer word count to zero
	MAINRLBF[RRELOCWD] = 0		! And say we have nothing
					!  to relocate so far
END;	! of DMPMAINRLBF
GLOBAL ROUTINE INIRLBUFFS=
BEGIN

! Initializes all 3 REL file buffers

	! Initialize buffer  used  for symbol  definition  and  global
	! requests.  First,  set  block  type  code  used  for  symbol
	! definitions and global requests

%4530%	IF (.LONGREL AND .LONGUSED) OR EXTENDED	! Using type 1070 or 2 ?
%1512%	THEN SYMRLBF[RTYPE] = RLONGSYMBOL	! New style 1070
%1512%	ELSE SYMRLBF[RTYPE] = RSYMBOL;		! Old style 2

	SYMRLBF[RDATCNT] = 0;		! Count of data words in this block
	SYMRLBF[RRELOCWD] = 0;		! Relocation bits for this block

	LOCRLBF[RTYPE] = RLOCAL;	! Init buffer used for local requests
	LOCRLBF[RDATCNT] = 0;
	LOCRLBF[RRELOCWD] = 0;

	MAINRLBF[RDATCNT] = 0;		! Init buffer used for code, data
	MAINRLBF[RRELOCWD] = 0;		!  and all other block types

END;	! of INIRLBUFFS
GLOBAL ROUTINE DMPRLBLOCK(RLBLK,WDCT)=
BEGIN

! Outputs a block of rel code pointed to by RLBLK to the REL file.
! WDCT is the number of words (including header words) in the block.

EXTERNAL
	RELOUT;		! Writes a word in the rel file

STRUCTURE
	PVECTOR[WD]=	! Structure for a pointer to a vector
		(@.PVECTOR + .WD);

MAP
	PVECTOR RLBLK;


	INCR I FROM 0 TO .WDCT-1
	DO
	BEGIN
		CHR = .RLBLK[.I];
		RELOUT()
	END;

	IF .FLGREG<LISTING>		! If a listing was requested
		AND .FLGREG<EXPAND>	!  and /EXPAND was given
	THEN
	BEGIN
		CRLF;
		INCR I FROM 0 TO .WDCT-1
		DO
		BEGIN
			R2 = .RLBLK[.I];
			LSTRLWD()	! List each word in the block in octal
		END
	END;

END;	! of DMPRLBLOCK
GLOBAL ROUTINE LSTRLWD=
BEGIN

! Lists the REL file word in the global register R2

	DECR J FROM 12 TO 1
	DO
	BEGIN
		R1 = 0;
		LSHC(R1,3);		! Move over three bits
		CHR = "0"[.R1]<0,0>;	! Convert to ASCII
		LSTOUT();		! Print it
	END;

	CRLF;

END;	! of LSTRLWD
GLOBAL ROUTINE ZOUTMSG(PTR)=
BEGIN

! Prints an ASCIZ string

	PTR = (.PTR)<36,7>;

	UNTIL (CHR = SCANI(PTR)) EQL 0
	DO LSTOUT();

END;	! of ZOUTMSG
GLOBAL ROUTINE ZOUTSYM(PAD)=	![4554] PAD is boolean, TRUE -> pad symbols
BEGIN

! R2 contains symbol in SIXBIT to be listed

%4527%	REGISTER PTR;	! Pointer to symbol
%4530%	LOCAL	NWORDS;	! Length of symbol

%4530%	NWORDS = .R2<SYMLENGTH>;
%4527%	PTR = .R2<SYMPOINTER>;

%4530%	INCR I FROM 0 TO .NWORDS - 1
%4527%	DO
%4527%	BEGIN	! Each word in symbol
%4527%
%4527%		R2 = @(.PTR + .I);		! Ith word
%4527%
%4527%		DECR J FROM SIXBCHARSPERWORD TO 1
		DO
		BEGIN	! Each character

			R1 = 0;			! Clear out the character temp
			LSHC(R1,6);		! Get the next character

			IF .R1 GTR 0		! Is it non blank ?
%4554%			OR (.LONGUSED		! or long symbols used
%4554%                      AND .PAD EQL TRUE)	! and we want blank padding
			THEN			! Yes
			BEGIN			! Character(s) exist
				CHR = .R1+#40;	! Convert to ASCII
				LSTOUT()	! Print it
			END
			ELSE RETURN		! Blank - all done

		END;	! Each character

%4527%	END;	! Each word of symbol

%4530%	! Now print blanks for any more words so listing looks nice
%4530%	! The longest identifer is 6 words long 
%4530%	
%4530%	IF .LONGUSED	! Only blank pad if had long symbols
%4530%	THEN
%4530%	BEGIN
%4530%		CHR=#40;		!blank
%4530%		INCR W FROM .NWORDS TO MAXSYMWORDS-1
%4530%		DO INCR I FROM 1 TO SIXBCHARSPERWORD
%4530%		DO	LSTOUT();
%4530%	END;
END;	! of ZOUTSYM
GLOBAL ROUTINE ZOUTOCT=
BEGIN

! List octal half word.  R2<LEFT> contains half word octal value

REGISTER
	I;

	R1 = 0;
	I = 6;

	DO
	BEGIN
		LSHC(R1,3);
		IF (I = .I-1) EQL 0
		THEN EXITLOOP
	END WHILE .R1 EQL 0;

	DO
	BEGIN
		CHR = "0"[.R1]<0,0>;
		LSTOUT();
		R1 = 0;
		LSHC(R1,3);
	END WHILE (I = .I-1) GEQ 0;

	.VREG
END;	! of ZOUTOCT
GLOBAL ROUTINE ZOUTADDR=	![2311] /PLB
!++
! FUNCTIONAL DESCRIPTION:
!
!	OUTPUT 24 BIT OCTAL ADDRESS TO LISTING FILE; 24 BITS (8 OITS)
!	IS THE ADDRESS SPACE IMPLEMENTED BY THE EXTENDED KL.
!
! FORMAL PARAMETERS:
!
!	NONE
!
! IMPLICIT INPUTS:
!
!	ADDRESS IN GLOBAL REGISTER R2
!
! IMPLICIT OUTPUTS:
!
!	TRASHES R1, R2, CHR
!
! ROUTINE VALUE:
!
!	NONE
!
! SIDE EFFECTS:
!
!	OUTPUT TO LISTING FILE
!
!--

BEGIN

MACHOP
	LSH=#242;

REGISTER
	I;

	R1 = 0;
	I = 8;			!THIS MANY OITS
	LSH(R2,12);		!MAKE BITS LEFT JUSTIFIED

	DO
	BEGIN
		LSHC(R1,3);
		IF (I = .I-1) EQL 0
		THEN EXITLOOP
	END WHILE .R1 EQL 0;

	DO
	BEGIN
		CHR = "0"[.R1]<0,0>;
		LSTOUT();
		R1 = 0;
		LSHC(R1,3);
	END WHILE (I = .I-1) GEQ 0;

	.VREG
END;	! of ZOUTADDR
GLOBAL ROUTINE RADIX50=
!++
! Convert to RADIX 50.
! R2 contains the symbol in Sixbit left justified, [length,,pointer].
!--
BEGIN
	REGISTER R50;

	MACRO	SIXALPHA(X) =MOVEI(VREG,-#40,X) LEQ ("Z"-#100)$,!Sixbit alpha
		SIXDIGIT(X) =MOVEI(VREG,-#20,X) LEQ 9$; 	!Sixbit digit


	R50=0;
	DO
	BEGIN	! Translate each character

		R1 = 0;
		LSHC(R1,6);
		IF SIXALPHA(R1)
		THEN R1 = .R1 -#26		! Alphabetic
		ELSE IF SIXDIGIT(R1)
		THEN R1 = .R1 -#17	! Digit
%4530%		ELSE IF .R1 EQL SIXBIT "_"
%4530%		THEN R1 = #47	! Radix "%"
%1403%		ELSE IF .R1 EQL SIXBIT "$"
		THEN R1 = #46	! Radix50 "$"
		ELSE R1 = #45;	! A "." by default
		R50 = .R50 * #50;
		R50 = .R50 + .R1;

	END	! Translate each character
	WHILE .R2 NEQ 0;
	RETURN .R50

END;	! of RADIX50
GLOBAL ROUTINE ZOUDECIMAL=
BEGIN
	! Output a decimal number - any number of digits
%1474%	! up to 12 (i.e. a full word)

	LOCAL Z[12];
%1474%	INCR I FROM 0 TO 12  DO
	BEGIN
		Z[.I] = (.R1 MOD 10);
		R1 =  .R1 / 10;
		IF .R1 EQL 0
		THEN
		BEGIN
			DECR J FROM .I TO 0 DO
			BEGIN
				CHR =  .Z[.J] + #60;
				LSTOUT();
			END;
			RETURN
		END;
	END;

END;	! of ZOUDECIMAL
GLOBAL ROUTINE ZOUOFFSET=
BEGIN
	!LIST IN ASCII THE VALUE OF R1 A REGISTER
	IF .R1 LSS 0 THEN CHR _ "-" ELSE CHR _ "+";
	LSTOUT();
%2311%	IF EXTENDED
%2311%	THEN
%2311%	BEGIN
%2311%		R2 _ ABS(.R1);
%2311%		ZOUTADDR()
%2311%	END
%2311%	ELSE
%2311%	BEGIN
		R2<LEFT> _ ABS(.R1);
		ZOUTOCT()	!OCTAL OUTPUT VALUE IN R2<LEFT>
%2311%	END
END;	! of ZOUOFFSET
GLOBAL ROUTINE ZOUSMOFFSET=	![2311] /PLB
!++
! FUNCTIONAL DESCRIPTION:
!
!	OUTPUT AN 18 BIT (SMALL) SIGNED OFFSET TO THE LISTING FILE
!
! FORMAL PARAMETERS:
!
!	NONE
!
! IMPLICIT INPUTS:
!
!	SIGNED BINARY OFFSET IN GLOBAL REGISTER R1
!
! IMPLICIT OUTPUTS:
!
!	TRASHES R1, R2, CHR
!
! ROUTINE VALUE:
!
!	TRASH
!
! SIDE EFFECTS:
!
!	OUTPUT TO LISTING
!
!--

BEGIN
	IF .R1 LSS 0 THEN CHR _ "-" ELSE CHR _ "+"; !GET CHAR FOR SIGN
	LSTOUT();		!OUTPUT IT
	R2<LEFT> _ ABS(.R1);	!GET ABSOLUTE VALUE FOR ZOUTOCT
	ZOUTOCT()		!OCTAL OUTPUT VALUE IN R2<LEFT>
END;	! of ZOUSMOFFSET
GLOBAL ROUTINE ZSAVEOUT=	! [1511] New [1566] Rewritten
!++
! Processing to output a SAVE  writable link overlay block.  Block  type
! 1045 is put out.  It  is assumed that if  this routine is called  that
! processing is necessary (the caller has determined this).
!
!================================================
!	1045		!	long count	!
!-----------------------------------------------!
!		flags				!
!-----------------------------------------------!
!		Symbol				!
!-----------------------------------------------!
!	...	...	...			!
!================================================
!
!	Where each symbol may be one word of Sixbit or:
!
!0     5 6	      29 30	       35
!========================================
!  0	| Reserved	! Long Count	!
!---------------------------------------!
! Word 1 of Sixbit Symbol name		!
!---------------------------------------!
! ...	...	...			!
!---------------------------------------!
! Word (long Count -1) of Symbol name	!
!========================================
!--

BEGIN
	EXTERNAL
		COMBLKPTR,	! Pointer to the list of common blocks
		RELBUFFER MAINRLBF, ! Buffer to put out arg check blocks
		NUMSAVCOMMON,	! Number of commons to save
		PTRSAVCOMMON,	! Ptr to linked list for COMMONs to be SAVE-d	
				! [ptr] -> [ptr sym tab common,,ptr to next]
		SAVALL,		! SAVE all - everything possible
		SAVBLC,		! SAVE blank common
		SAVLOC,		! SAVE local variables
		SAVNED;		! SAVE rel block is needed

	LOCAL
		BASE COMPTR,	! Pointer to common block
		BASE COMSYM,	! Symbol table entry for common block
		BASE OLDCOMPTR,	! Old pointer to common
%4530%		NAM,		! Common block name
%4530%		COUNT;		! Number of words in relblock

	REGISTER
		BOFFSET;	! Offset into MAINRLBF

	MACRO	SVTYPE=0,LEFT$,		! Rel SVock type
		SVCOUNT=0,RIGHT$,	! Rel block count
		SVLOCAL=1,34,1$,	! Bit whether locals must be saved
		SVLOCWORD=1,FULL$;	! Word to zero out


	! Clear out MAINRLBF for use
	DMPMAINRLBF();

	! If any named commons specified in a SAVE haven't been declared
	! in a COMMON statement in the program unit, then don't put them
	! out into the rel block.  The standard requires that to SAVE  a
	! named common, all units using said common must SAVE it, so  if
	! this unit doesn't use it, it will be ignored.

%4530%	COUNT = 1;

	! Walk through the list of common blocks.  If we  remove
	! the common name, we must also decrement the count  put
	! out to the rel block before the MAINRLBF can be output
	! (in case we have more than 18 blocks to SAVE).

	OLDCOMPTR = PTRSAVCOMMON;	! Init to delete the first

	DECR CNT FROM .NUMSAVCOMMON TO 1
	DO
	BEGIN	! For each common name SAVE

		COMPTR = .OLDCOMPTR[CLINK];	! Pointer to look at
		COMSYM = .COMPTR[CW0L];	! common symbol table entry

%4530%		IF NOT .SAVALL	! blank SAVE not specified
%4530%		THEN IF NOT .COMSYM[IDATTRIBUT(COMBL)]
		THEN
		BEGIN	! Block not declared COMMON - delete it

			COMPTR  = .COMPTR[CLINK];
			OLDCOMPTR[CLINK] = .COMPTR;
			NUMSAVCOMMON = .NUMSAVCOMMON - 1;

		END	! Block not declared COMMON - delete it
		ELSE
		BEGIN	! Block declared COMMON

%4530%			! Increment count by 1 (length) + length of name
%4530%			COMSYM = .COMPTR[CW0L];
%4530%			COUNT = .COUNT + 1 + .COMSYM[IDSYMLENGTH];

			OLDCOMPTR = .COMPTR;	! Save for next delete
			COMPTR = .COMPTR[CLINK]; ! Next common

		END;	! Block declared COMMON

	END;	! For each common name SAVE

	! If we don't have any common blocks left, and there were
	! not any local variables delclared in SAVE or blank common
	! blocks in the program, then return now and don't bother
	! outputting a rel block.

%2022%	IF (.NUMSAVCOMMON EQL 0)		! No commns left
%2075%	THEN IF NOT (.SAVLOC OR .SAVBLC)	! No locals or blk comm
%2022%	THEN RETURN;				! SAVE not needed.


	! Fill in header word

	MAINRLBF[SVTYPE] = RWRITELINK;		! Block type

%4530%	MAINRLBF[SVCOUNT] = .COUNT;	! Number of words in rel block

	IF .SAVBLC THEN		! Extra for blank common
	IF NOT .SAVALL		! Included in common walk
	THEN MAINRLBF[SVCOUNT] = .MAINRLBF[SVCOUNT] + 1;

	! Light bit to SAVE module being processed

	MAINRLBF[SVLOCWORD] = 0;
	IF .SAVLOC
	THEN	MAINRLBF[SVLOCAL] = 1;	! Yes, save it


	BOFFSET = 1;		! Offset into MAINRLBF

	IF .SAVBLC		! A blank common has appeared,
	THEN			! must SAVE it from the devil!!
	BEGIN
		BOFFSET = .BOFFSET + 1;
		MAINRLBF[.BOFFSET,FULL] = SIXBIT'.COMM.';
	END;

	! Ouput any COMMON blocks specified

	IF NOT .SAVALL
	THEN
	BEGIN	! Use SAVE linked list
	
		COMPTR = .PTRSAVCOMMON;	! Ptr to common

		DECR CNT FROM .NUMSAVCOMMON TO 1
		DO
		BEGIN	! For each COMMON to be SAVE-d

			COMSYM = .COMPTR[CW0L];  ! Common symbol table entry

			! If offset  > 20  then  dump buffer  and  start
			! refilling it again.

			BOFFSET = .BOFFSET + 1;
%4530%			IF .BOFFSET GEQ RBLKSIZ - .COMSYM[IDSYMLENGTH] - 1
			THEN
			BEGIN
				DMPRLBLOCK(MAINRLBF,RBLKSIZ);
				BOFFSET = 0;
			END;

			! Put sixbit symbol into rel file.

%4530%			MAINRLBF[.BOFFSET,FULL] = .COMSYM[IDSYMLENGTH] + 1;
%4530%			INCR I FROM 0 TO .COMSYM[IDSYMLENGTH] - 1
%4530%			DO
%4530%			BEGIN
%4530%				BOFFSET = .BOFFSET + 1;
%4530%				MAINRLBF[.BOFFSET,FULL] = @(.COMSYM[IDSYMPOINTER] + .I);
%4530%			END;
			COMPTR = .COMPTR[CLINK]; ! New pointer for next common

		END;	! For each COMMON to be SAVE-d

	END	! Use SAVE linked list
	ELSE
	BEGIN	! Save all COMMON-s

		! This is a  walk through  all common  blocks to  output
		! their names into the rel buffer.

		BOFFSET = 1;
		COMPTR = .FIRCOMBLK;	! First common block

		DECR CNT FROM .NUMSAVCOMMON TO 1
		DO
		BEGIN	! For all COMMON blocks

			COMSYM = .COMPTR[CW0L];  ! Common symbol table entry

			! If offset  > 20  then  dump buffer  and  start
			! refilling it again.

			BOFFSET = .BOFFSET + 1;
%4530%			IF .BOFFSET GEQ RBLKSIZ - .COMSYM[IDSYMLENGTH] - 1
			THEN
			BEGIN
				DMPRLBLOCK(MAINRLBF,RBLKSIZ);
				BOFFSET = 0;
			END;

			! Put sixbit symbol into rel file.

%4530%			MAINRLBF[.BOFFSET,FULL] = .COMSYM[IDSYMLENGTH] + 1;
%4530%			INCR I FROM 0 TO .COMSYM[IDSYMLENGTH] - 1
%4530%			DO
%4530%			BEGIN
%4530%				BOFFSET = .BOFFSET + 1;
%4530%				MAINRLBF[.BOFFSET,FULL] = @(.COMSYM[IDSYMPOINTER] + .I);
%4530%			END;
			COMPTR = .COMPTR[NEXCOMBLK];	! New pointer

		END;	! For all COMMON blocks

	END;	! Save all Commons


	! Put out remaining rel block
	DMPRLBLOCK(MAINRLBF,.BOFFSET+1);


	BEGIN	! Redefine MAINRLBF

		! Clears out MAINRLBF using the "proper" definition in case
		! anyone else wants to re-use it.  We're done with it.

		MAP RELBUFF MAINRLBF;

		MAINRLBF[RDATCNT] = 0;
		MAINRLBF[RRELOCWD] = 0;

	END	! Redefine MAINRLBF

END;	! of ZSAVEOUT
GLOBAL ROUTINE ZARGCHECK=	![1521] New
BEGIN

! Outputs argument checking 1120 rel blocks for calls to subroutines and
! functions.  Starts  at the  begining of  the argument  block list  and
! creates a  buffer for  each argument  list which  needs argument  type
! checking.


REGISTER
	ARGUMENTLIST ARGLIST,	! Used for each arg list
	ARGOFFSET;		! Offset into the buffer being assigned

LOCAL
	BASE CNODE,		! Used for examining nodes
%2575%	ARGTYPE,		! Pass the type of this argument along
%2575%				! to TPARGDES.
	BASE PARNODE,		! Parent node of argument list
	BASE SYMTAB;		! Symbol table entry

	MAP RELBUFFER MAINRLBF;


	! Insure that MAINRLBF  is empty before  using it.  We  simply
	! use it as a buffer, we don't use the structure RELBUFF  used
	! elsewhere.
	DMPMAINRLBF();	

	ARGLIST = .ARGLINKPT;		! 1st arg list in program
	WHILE .ARGLIST NEQ 0  DO	! Do one arg list at a time.
	BEGIN	!Check each arg

%2575%		ARGTYPE = NOTSPECIAL;	! 1st argument is not yet  known
%1674%					! to be implicit

		! Watch out for statements that may have been deleted by
		! folding.  ARGLABEL is  0 for  these statements.   Only
		! user functions and subroutines need arg check  blocks,
		! check the flag when the arg list was made to see if we
		! need one.

		IF .ARGLIST[ARGLABEL] NEQ 0 THEN
		IF .ARGLIST[ARGCHBLOCK]
		THEN
		BEGIN	!Need arg check block

			! Parent node above arg list
			PARNODE = .ARGLIST[ARGPARENT];

			IF .PARNODE[OPRCLS] EQL STATEMENT
			THEN	SYMTAB = .PARNODE[CALSYM]   ! Call statement
			ELSE	SYMTAB = .PARNODE[ARG1PTR]; ! Function ref

			! Type of rel block
			MAINRLBF[TPRELTYPE] = RARGDESC;

			! Count the number of  words needed for the  entire
			! buffer.  If a 5 or more letter name, we need more
			! than 1  word to  store it.   If a  non  character
			! function need extra  word for  return value.   If
			! character  argument,  may   need  2nd  word   for
			! secondary descriptor.


			! Zero out name in case it doesn't take full word
%4530%			! The length of a 7bit name could be up to 2 words
%4530%			! more than the length of a 6bit name
%4530%
%4530%			INCR I FROM 0 TO .SYMTAB[IDSYMLENGTH]+1
%4530%			DO MAINRLBF[.I+TPNAME0] = 0;
				 		    

			! Convert the SIXBIT name, put it and the number
			! of bytes needed for storage into the rel file.

			MAINRLBF[TPNAMSIZE] = 
				SIXTO7(.SYMTAB[IDSYMBOL],MAINRLBF[TPNAME0]);

			! TPMIN is a  "magic" number  denoting the  minimum
			! number of words needed for a rel block (minus the
			! size of the function name).

			ARGOFFSET = TPMIN + CHWORDLEN(.MAINRLBF[TPNAMSIZE]);

			! Number of words in block (minus the header block)
			! Add to below, as needed.

			MAINRLBF[TPRELSIZE] = .ARGOFFSET + .ARGLIST[ARGCOUNT];

			! Functions need an extra word for their  return
			! values.

			IF .PARNODE[OPRCLS] EQL FNCALL
			THEN	MAINRLBF[TPRELSIZE] =
				.MAINRLBF[TPRELSIZE] + 1;

			! Check each arg for secondary descriptor needed
			! to be  put out.   If needed,  add one  to  the
			! count of words in the rel block.

			DECR CNT FROM .ARGLIST[ARGCOUNT] TO 1 
%1770%			DO	IF SECDESC(.ARGLIST[.CNT,ARGNPTR]) NEQ 0
				THEN	MAINRLBF[TPRELSIZE] = 
					.MAINRLBF[TPRELSIZE] + 1; ! Extra word


			! If this  is  a  character  function,  we  must
			! include the function's return value (and check
			! if a  secondary  descriptor's  needed)  twice.
			! The first time  is for  the physical  location
			! which is the first  argument in arg block  and
			! the second is for the dummy location we put as
			! the last argument in the rel block for link to
			! know the value of the function.

			IF .PARNODE[OPRCLS] EQL FNCALL THEN
			IF .PARNODE[VALTYPE] EQL CHARACTER THEN
%1674%			BEGIN	! Character function call
%1674%
%1674%				! The first  argument in  the rel  block
%1674%				! will be an "implicit" argument, not to
%1674%				! be type checked.
%2575%				ARGTYPE = IMPLARG;

				! Bump the  count if  we need  an  extra
				! word for a secondary descriptor.
%1770%				IF SECDESC(.ARGLIST[1,ARGNPTR]) NEQ 0
				THEN	MAINRLBF[TPRELSIZE] =
					.MAINRLBF[TPRELSIZE] + 1;
%1674%			END;


			! 2-bit byte relocation information.  Only the
			! argument block address  and associated  call
			! address are relocated.  The "psect  indices"
			! to use  when writing  a TWOSEGged  REL  file
			! are: lowseg=1, hiseg=2.

%1525%			IF EXTENDED
%1525%			THEN MAINRLBF[TPNBITRELOC] = PXCODE^34 + PXCODE^32
%1525%			ELSE MAINRLBF[TPNBITRELOC] = PXHIGH^34 + PXHIGH^32;

			! Argument block address

			CNODE = .ARGLIST[ARGLABEL];	! Label table entry
%1526%			MAINRLBF[TPARBLADD] = .CNODE[SNADDR];	! Object addr

			! Associated call address

			MAINRLBF[TPASOCCALL] = .ARGLIST[ARGCALL];

			! Loading address.  Never load the descriptor.

			MAINRLBF[TPLDADD] = 0;

			! Clear flag bits for argument block.  

			MAINRLBF[.ARGOFFSET,LEFT] = 0;

			! Complain if number of args for caller, callee are
			! different if /DEBUG:ARGUMENTS was specified.

%1613%			IF .FLGREG<DBGARGMNTS>
			THEN	MAINRLBF[.ARGOFFSET,TPCNT] = 1;

			MAINRLBF[.ARGOFFSET,TPWHO] = 1;	! Call to a subprogram

			MAINRLBF[.ARGOFFSET,TPLOD] = 0;	! Do not load descr

%1674%			! Complain if the caller and called can't  agree
%1674%			! whether this is a subroutine or function.
%1674%			MAINRLBF[.ARGOFFSET,TPSFERR] = 1;


			! Count of args - doesn't include any  secondary
			! descriptors.   Add    one    for    functions.
			! (Character functions have  their return  value
			! as their 1st arg in the arg list).

			IF .PARNODE[OPRCLS] EQL FNCALL
			THEN
%1674%			BEGIN
				MAINRLBF[.ARGOFFSET,TPARGCOUNT] =
%1674%					.ARGLIST[ARGCOUNT] + 1;	! function

%1674%				MAINRLBF[.ARGOFFSET,TPVAL] = 1; ! Returns value
%1674%			END
%1674%			ELSE	MAINRLBF[.ARGOFFSET,TPARGCOUNT] =
					.ARGLIST[ARGCOUNT];


			! Build argument descriptors for each  argument.
			! Call routine TPARGDES to put into MAINRLBF the
			! information for each argument.

			INCR CNT FROM 1 TO .ARGLIST[ARGCOUNT]
			DO
%1674%			BEGIN
				ARGOFFSET = TPARGDES(.ARGOFFSET,
%2575%					.ARGLIST[.CNT,ARGNPTR], .ARGTYPE);
%1674%
%2575%				ARGTYPE = NOTSPECIAL;	! No more are implicit
%1674%			END;

			! If a  function call,  then last  argument is  the
			! func's return value.  Put it in MAINRLBF

			IF .PARNODE[OPRCLS] EQL FNCALL
			THEN	ARGOFFSET = TPARGDES(.ARGOFFSET,
%2575%					.PARNODE[ARG1PTR], FNRETVAL);

			! Put out the .REL block for this argument list

			DMPRLBLOCK(MAINRLBF,.ARGOFFSET+1);

		END;	! Need arg check block


		! Next arglist

		ARGLIST = .ARGLIST[ARGLINK];

	END;	! Check each arg


	BEGIN	! Redefine MAINRLBF

		! Clears out MAINRLBF using the "proper" definition in case
		! anyone else wants to re-use it.  We're done with it.

		MAP RELBUFF MAINRLBF;

		MAINRLBF[RDATCNT] = 0;
		MAINRLBF[RRELOCWD] = 0;

	END	! Redefine MAINRLBF

END;	! of ZARGCHECK
GLOBAL ROUTINE SIXTO7(SIX,SEV)=	![1521] New

! Converts one word of SIXBIT to ASCIZ, returning the size in bytes.

! PASSED:	-SIXBIT value to convert
!		-Address for destination for ASCIZ
! RETURNS:	-Number of bytes + 1 (for the zero) of the name

BEGIN

REGISTER
	COUNT,		! Number of bytes needed for ASCII name
	DEST,		! Destination for movement
	SOURCE;		! Source for movement

LOCAL	WORD;		! Temp for shifting name to determine COUNT

%4527%	MAP BASE SIX;


%4530%	! Number of  bytes  needed for  ASCII name = (word count - 1)*SIXBCHARSPERWORD
%4530%	! +number of letters in last word. To calculate number in last word
	! shift out letter by letter until the name is null.

%4530%	COUNT = (.SIX<SYMLENGTH> - 1)*SIXBCHARSPERWORD; ! Number of chars in all but last word
	WORD = @(.SIX<SYMPOINTER>)[.SIX<SYMLENGTH>-1]; ! Last word
	WHILE .WORD NEQ 0 DO
	BEGIN	! Count letters in name
		WORD = .WORD ^6;
		COUNT = .COUNT + 1;
	END;
	! Convert from SIXBIT to ASCIZ

	DEST = (.SEV)<36,7>;			! Byte pointer for destination
%4527%	SOURCE = (.SIX<SYMPOINTER>)<36,6>;	! "    "       for source

	! Stuff in one letter at a time, converting to ASCII

	DECR CNT FROM .COUNT TO 1
	DO REPLACEI(DEST,SCANI(SOURCE)+#40);

	REPLACEI(DEST,#0);		! Zero at end

	! Number of bytes + zero byte
	RETURN .COUNT + 1;

END;	! of SIXTO7
ROUTINE TPARGDES(ARGOFFSET, CNODE, ARGTYPE)=	! [2575]

!++
! FUNCTIONAL DESCRIPTION:
!
!	Routine to put the needed  information for block type 1120  into
!	the buffer  for each  argument node  CNODE passed  it.  Adds  to
!	ARGOFFSET as neccessary.
!
! FORMAL PARAMETERS:
!
!	ARGOFFSET	Offset into buffer MAINRLBF.
!			Returned as either +1, +2, or reset to zero.
!
!	CNODE		Node to retrieve information from.
!
!	ARGTYPE		Type of argument beging passed.
!			IMPLARG	- This argument is implicit
!			FNRETVAL - This is a function return value
!			NOTSPECIAL - Don't do anything special
!
! IMPLICIT INPUTS:
!
!	Unknown
!
! IMPLICIT OUTPUTS:
!
!	Unknown
!
! ROUTINE VALUE:
!
!	Returns current offset into buffer.
!
! SIDE EFFECTS:
!
!	Outputs 1120 blocks to the .REL file.
!
!--


BEGIN
	MAP BASE CNODE;
	MAP RELBUFFER MAINRLBF;	! Buffer to put information into.
	REGISTER ARGSIZE,	! Size in bytes of a character variable from 
				! CHEXLEN.
%2517%		TMP;		! Temporary.  Used for structure calculation.


	ARGOFFSET = .ARGOFFSET + 1;	! Bump offset up

	! If reached max size then output the current buffer and start  the
	! offset back at 0.  Insure that we have at least 2 words (in  case
	! we need a secondary descriptor)

	IF .ARGOFFSET GTR RBLKSIZ - 2
 	THEN
 	BEGIN
		! ARGOFFSET is one too big  which is the correct number  to
		! dump.
		DMPRLBLOCK(MAINRLBF,.ARGOFFSET);
		ARGOFFSET = 0;
	END;

	! Zero out the word before we start out
	MAINRLBF[.ARGOFFSET,FULL] = 0;


	! If the node passed is 0, then we have an alternate return  label.
	! No need to process any further, and in fact we can't, since there
	! is no node to proccess.

	IF .CNODE EQL 0
	THEN
	BEGIN	! Alternate return label

		MAINRLBF[.ARGOFFSET,TPTYP] = #7;	! Arg type is label
%1674%		MAINRLBF[.ARGOFFSET,TPNUP] = 1;		! Don't update
		RETURN .ARGOFFSET;
	END;

%1770%	IF .CNODE[OPR1] EQL CONSTFL
	THEN
	BEGIN	! Argument is constant
%1674%		MAINRLBF[.ARGOFFSET,TPNUP] = 1;	! Don't update
		MAINRLBF[.ARGOFFSET,TPCTC] = 1;	! Compile time constant
	END;

%1674%	! On called side, fill in no update if the variable is not updated
%1674%
%1674%	IF .CNODE[OPRCLS] EQL DATAOPR THEN
%1674%	IF .CNODE[FORMLFLG] THEN
%1674%	IF NOT .CNODE[IDATTRIBUT(STORD)]	! Not stored into here
%1674%	THEN	MAINRLBF[.ARGOFFSET,TPNUP] = 1;	! Is not updated here

	IF .CNODE[VALTYPE] EQL CHARACTER
	THEN	MAINRLBF[.ARGOFFSET,TPPAS] = PASSDESCR	! Pass by descriptor
	ELSE	MAINRLBF[.ARGOFFSET,TPPAS] = PASSADDR;	! Pass by address

	! Argument type code based on value of argument, except for a "few"
	! special cases.

	IF .CNODE[OPRCLS] EQL LABOP
	THEN	MAINRLBF[.ARGOFFSET,TPTYP] = ADDRTYPE	! Alternate return lab
	ELSE
%2434%	BEGIN	! Not Label
%2434%
%2434%		! We want Character /EXTEND to be different so we can tell
%2434%		! the difference between passing a one word LOCAL byte pointer
%2434%		! and a one word GLOBAL byte pointer.
%2532%		! If we don't assign a value, then 0 is the default, which
%2532%		! translates to "don't care".  This is done for subroutine
%2532%		! names or externals when we don't know if they are
%2532%		! functions or subroutines.  Only function names get type
%2532%		! checking info.
%2532%		
%2532%		IF (IF .CNODE[OPRCLS] EQL DATAOPR	! Only check if...
%2532%		    THEN NOT .CNODE[IDSUBROUTINE]	! Subroutine name
%2532%		    ELSE TRUE)				! ARRAYREF
%2532%		THEN IF (IF .CNODE[OPRCLS] EQL DATAOPR	! Only check if...
%2532%		         THEN IF .CNODE[IDATTRIBUT(INEXTERN)]	! External name
%2532%			      THEN (.CNODE[DATOPS1]		! Function
%2532%					EQL FNNAME1		! or dummy fn
%2532%				    AND .CNODE[IDFUNCTION])	! Really called
%2532%			      ELSE TRUE			! Not external
%2532%			 ELSE TRUE)			! ARRAYREF
%2434%		THEN IF (.CNODE[VALTYPE] EQL CHARACTER) AND EXTENDED ! Chr /EXT
%2434%		THEN	MAINRLBF[.ARGOFFSET,TPTYP] = TYPEXTCHARACTER
%2434%		ELSE	! Index into table based on type of variable
			MAINRLBF[.ARGOFFSET,TPTYP] = .EVALU[.CNODE[VALTYPE]];
%2434%
%2434%	END;	! Not Label


%2517%	! Insert argument structure code.  We have three types of
%2517%	! structures:
%2517%	! 
%2517%	! 	o Singleton	(single unit)
%2517%	! 	o Array		(multi unit)
%2517%	! 	o Routine	(address of routine to call)
%2517%	!
%2517%	! DATAOPR's have this built into the DATOPS1 field, expressions
%2517%	! of any sort are singleton.
%2517%
%2575%	IF .ARGTYPE EQL FNRETVAL
%2575%	THEN TMP = TPSINGLETON		! Function return value
%2575%	ELSE
%2575%	BEGIN	! Regular argument
%2575%
%2517%		IF .CNODE[OPRCLS] EQL DATAOPR
%2517%	 	THEN
%2517%		BEGIN	! DATAOPR's have DATOPS1 defined
%2517%
%2517%			CASE .CNODE[DATOPS1] OF SET
%2517%
%2517%			TMP = TPSINGLETON;		! Constant/temp
%2517%			TMP = TPSINGLETON;		! VARIABL1
%2517%			TMP = TPARRAY;			! ARRAYNM1
%2517%			TMP = TPROUTINE;		! FNNAME1
%2517%
%2517%			TES;
%2517%
%2517%			IF .CNODE[IDATTRIBUT(FENTRYNAME)]     ! Function entry
%2575%			THEN IF NOT .CNODE[IDATTRIBUT(STORD)] ! Not variable
%2517%			THEN TMP = TPROUTINE;		      ! Mark as routine
%2517%	
%2517%		END	! DATAOPR's have DATOPS1 defined
%2517%		ELSE TMP = TPSINGLETON;			! Non DATAOPR
%2575%
%2575%	END;	! Regular argument
%2517%
%2517%	MAINRLBF[.ARGOFFSET,TPSTR] = .TMP;	! Store calc'd structure


%1674%	! The physical character function return value argument should
%1674%	! not be checked by link.  Light an "implicit argument" bit.
%1674%
%2575%	IF .ARGTYPE EQL IMPLARG THEN MAINRLBF[.ARGOFFSET,TPIMPL] = 1;

	! Decide if secondary descriptor is needed.  If so, then put it out.

%1770%	IF (ARGSIZE = SECDESC(.CNODE)) NEQ 0
	THEN
	BEGIN	! Secondary descriptor needed

		MAINRLBF[.ARGOFFSET,TPSND] = 1;	! 1 secondary descriptor

		ARGOFFSET = .ARGOFFSET + 1;
		MAINRLBF[.ARGOFFSET,FULL] = 0;

		! Set length(formal)  =<  length(actual)  for  allowable
		! conditions. This is according to the ANSI-77 standard,
		! section 15.9.3.1.  This has  been extended to  include
		! character function references.

		MAINRLBF[.ARGOFFSET,TPMCH] = TPFLEA;

		! Set size of arg found
		MAINRLBF[.ARGOFFSET,TPSIZ] = .ARGSIZE;

	END;	! Secondary descriptor needed

	RETURN .ARGOFFSET;	! Return last offset used.

END;	! of TPARGDES
GLOBAL ROUTINE ZSFARGCHECK=	![1521] New

! Puts  out  1120  arg  checking  blocks  for  SUBROUTINE  and  FUNCTION
! statements.  Routine walks  through any  and all  ENTRY points  linked
! together to put out this rel block.

! Must be careful  of nonexistant argument  lists, ARGLIST is  0 for  no
! arguments (or no return value for character functions).

BEGIN
	
LOCAL
	ARGCNT,			! Count of the number of arguments
	ARGOFFSET,		! Offset into MAINRLBF
	ARGUMENTLIST ARGLIST,	! Argument list
	BASE CNODE,		! Structure used generally
	BASE ENTSTAT,		! Entry point being worked on.
%2575%	ARGTYPE,		! Type of argument
	BASE SYMTAB;		! Symbol table entry


	MAP RELBUFFER MAINRLBF;	! Buffer to put out the blocks


%2575%	ARGTYPE = NOTSPECIAL;	! 1st argument is not yet know to be
%1674%				! implicit

	! Get the call node for the definition of the subprogram

	ENTSTAT = .FIRSTSRC;			! 1st statement node
	WHILE .ENTSTAT[SRCID] NEQ ENTRID	! Search for the ENTRY statmnt.
	DO  ENTSTAT = .ENTSTAT[SRCLINK];	! Cant' be sure where it is!

	! Insure that MAINRLBF is empty before using it.  We simply use  it
	! as a  buffer to  put the  information into,  not using  structure
	! RELBUF.

	DMPMAINRLBF();

	WHILE .ENTSTAT NEQ 0 DO
	BEGIN	! For each ENTRY statement

		SYMTAB = .ENTSTAT[ENTSYM];	! Symbol table for entry
		ARGLIST = .ENTSTAT[ENTLIST];	! Arg list for this ENTRY

		IF .ARGLIST NEQ 0		! Set number of arguments
		THEN	ARGCNT = .ARGLIST[ARGCOUNT]
		ELSE	ARGCNT = 0;

		! Type of rel block
		MAINRLBF[TPRELTYPE] = RARGDESC;

		! Count the number of words  needed for the entire  buffer.
		! If a 5 or more letter name,  we need more than 1 word  to
		! store it.  If a non  character function, need estra  word
		! for the return  value.  If character  argument is  given,
		! may need 2nd word for secondary descriptor.

		! Set ARGOFFSET according to the number of words needed  to
		! store the ASCIZ name and  also put this information  into
		! the rel block while we have it.

		MAINRLBF[TPNAME0] = MAINRLBF[TPNAME1] = 0;	! Zero out
		MAINRLBF[TPNAMSIZE] =
			SIXTO7(.SYMTAB[IDSYMBOL],MAINRLBF[TPNAME0]);

		! TPMIN is a "magic" number denoting the minimum number  of
		! words needed  for a  rel  block (minus  the size  of  the
		! function name).

		ARGOFFSET = TPMIN + CHWORDLEN(.MAINRLBF[TPNAMSIZE]);

		! Number of words in block  (minus the header block.)   Add
		! to this count as needed below.

		MAINRLBF[TPRELSIZE] = .ARGOFFSET + .ARGCNT;

 		! Functions need an extra word for their return  values.

		IF .FLGREG<PROGTYP> EQL FNPROG
		THEN	MAINRLBF[TPRELSIZE] = .MAINRLBF[TPRELSIZE] + 1;

		! Check each arg for secondary descriptor needed to be  put
		! out

		DECR CNT FROM .ARGCNT TO 1 DO
		BEGIN	! For each argument

			CNODE = .ARGLIST[.CNT,ARGNPTR];
			IF .CNODE NEQ 0 THEN	! Return label
%1770%			IF SECDESC(.CNODE) NEQ 0
			THEN	MAINRLBF[TPRELSIZE] =
				.MAINRLBF[TPRELSIZE] + 1;
		END;

		! If this is a character  function, we must include  the
		! function's return  value  (and check  if  a  secondary
		! descriptor's needed) twice.  The first time is for the
		! physical location which is  the first argument in  the
		! arg block and the second is for the dummy location  we
		! put as the last argument in the rel block for link  to
		! know the value of the function.

		IF .FLGREG<PROGTYP> EQL FNPROG THEN
		IF .SYMTAB[VALTYPE] EQL CHARACTER THEN
%1674%		BEGIN
%1770%			IF SECDESC(.ARGLIST[1,ARGNPTR]) NEQ 0
			THEN	MAINRLBF[TPRELSIZE] = .MAINRLBF[TPRELSIZE] + 1;
%1674%
%2575%			ARGTYPE = IMPLARG;	! First argument is implicit
%1674%		END;

		! N-Bit byte  relocation  information.  Only  the  argument
		! block address, associated  call address  and the  loading
		! address can be relocatable.  Loading address is not used.
		! 1=lowseg, 2=hiseg

		MAINRLBF[TPNBITRELOC] = 0;	!Nothing to relocate

		! Argument block address
		MAINRLBF[TPARBLADD] = 0;

		! Assoc call  address.  There  is  no  call,  this  is  the
		! definition of the subprogram.
		MAINRLBF[TPASOCCALL] = 0;

		! Load address.  Never load this descriptor.
		MAINRLBF[TPLDADD] = 0;

		! Clear flag bits for argument block.
		MAINRLBF[.ARGOFFSET,LEFT] = 0;

		! Complain if  number of  args for  caller and  callee  are
		! different if /DEBUG:ARGUMENTS was specified.
%1613%		IF .FLGREG<DBGARGMNTS> THEN MAINRLBF[.ARGOFFSET,TPCNT] = 1;

		MAINRLBF[.ARGOFFSET,TPWHO] = 0;	! Definition of a subprogram

		MAINRLBF[.ARGOFFSET,TPLOD] = 0;	! Do not load descriptor

%1674%		! Complain if the caller and called can't agree  whether
%1674%		! this is a subroutine or function.
%1674%		MAINRLBF[.ARGOFFSET,TPSFERR] = 1;

		! Number  of  args.   Does  not  include  any  secondary
		! descriptors.   Add  one  for  functions.    (Character
		! functions have their return value as their 1st arg  in
		! the arg list).

		IF .FLGREG<PROGTYP> EQL FNPROG 
%1674%		THEN
%1674%		BEGIN	! Function
%1674%			MAINRLBF[.ARGOFFSET,TPARGCOUNT] = .ARGCNT +1;
%1674%			MAINRLBF[.ARGOFFSET,TPVAL] = 1; ! Returns value.
%1674%		END
%1674%		ELSE	MAINRLBF[.ARGOFFSET,TPARGCOUNT] = .ARGCNT;


		! Build argument  descriptors for  each argument.   Call
		! routine TPARGDES to put into MAINRLBF the  information
		! for each arg.

		INCR CNT FROM 1 TO .ARGCNT
		DO
%1674%		BEGIN
			ARGOFFSET = TPARGDES(.ARGOFFSET,
%2575%				.ARGLIST[.CNT,ARGNPTR], .ARGTYPE);
%1674%
%2575%			ARGTYPE = NOTSPECIAL;	! No more implicit args
%1674%		END;

		! If a function call, then last argument is the  function's
		! return value.

		IF .FLGREG<PROGTYP> EQL FNPROG
%2575%		THEN	ARGOFFSET = TPARGDES(.ARGOFFSET, .SYMTAB, FNRETVAL);

		! Put ot the rel block for this argument list

		DMPRLBLOCK(MAINRLBF,.ARGOFFSET+1);

		! Link to next entry point.

		ENTSTAT = .ENTSTAT[ENTLINK];

	END;	! For each ENTRY statement.


	BEGIN	! Redefine MAINRLBF

		! Clears out MAINRLBF using the "proper" definition in case
		! anyone else wants to re-use it.  We're done with it.

		MAP RELBUFF MAINRLBF;

		MAINRLBF[RDATCNT] = 0;
		MAINRLBF[RRELOCWD] = 0;

	END	! Redefine MAINRLBF

END;	! of ZSFARGCHECK
GLOBAL ROUTINE ZCOERCION=

!++
! FUNCTIONAL DESCRIPTION:
!
!	Outputs  type  1130  Coercion  blocks  for  LINK  argument  type
!	checking.  This block gives LINK the instructions of what to  do
!	when it encounters a difference between callee and caller.
!
!	If /DEBUG:ARGUMENTS has  been specified, then  put out a  larger
!	block asking LINK  to complain about  more, otherwise Link  does
!	the special  Fortran fixup  of changing  character constants  to
!	hollerith constants for old programs expecting numeric data.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	MAINRLBF	The buffer used to output rel blocks.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	A coercion rel block is output the the .rel file.
!
!--


BEGIN

	MAP RELBUFFER MAINRLBF;	! Buffer to output block.

%1674%	LOCAL HEADRWORD;	! Header word for rel block.

	! The information format is:
	! +---------------------+-----------------------+
	! | Field code		| Action to take	|
	! +---------------------+-----------------------+
	! | Formal attribute	| Actual attribute	|
	! +---------------------+-----------------------+

	MACRO COERCE(FIELD, ACTION, FORMAL, ACTUAL)
		= ((FIELD)^18 OR ACTION),	! 1st word
		  ((FORMAL)^18 OR ACTUAL)$;	! 2nd word

	BIND	YES=1,
		NO=0;


	! Table used if /DEBUG:ARGUMENTS is NOT specifed
	! Must be a PLIT so that we have a word count of the table.

%1613%	BIND NOARGS =
	PLIT(
		! Fixup blocks for Character constant to hollerith conversion

		COERCE(CBPAS, CBFIXUP, PASSADDR, PASSDESCR),

		! Supress "informational messages"

		COERCE(CBCONST, CBNOACTION, NO, YES),		! constant
%1674%		COERCE(CBNOUPDATE, CBNOACTION, YES, NO),	! No update
%1674%		COERCE(CBRETVAL, CBNOACTION, YES, NO),		! return val

%1674%		! Mixing of double precision and g-floating gets warnings
%1674%
%1674%		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPDOUBLPREC),
%1674%		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPGFLDBLPREC),

%2434%		! Can't pass a one word LOCAL byte pointer when the routine
%2434%		! expects a one word GLOBAL byte pointer.
%2434%
%2434%		COERCE(CBTYP, CBNOACTION, TYPCHARACTER, TYPEXTCHARACTER),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPCHARACTER)

	);	! Table used if /DEBUG:ARGUMENTS is NOT specifed


	! Table used if /DEBUG:ARGUMENTS is specified.
	! Must be a PLIT so that we have a word count of the table.

%1613%	BIND ARGS =
	PLIT(
		! Fixup  blocks   for  Character   constant  to   hollerith
		! conversion. Same as entries in the table NOARGS above.

		COERCE(CBPAS, CBFIXUP, PASSADDR, PASSDESCR),

		! Don't complain about passing a constant to a non-constant.

		COERCE(CBCONST, CBNOACTION, NO, YES),

%1674%		! Complain for no-update
%1674%
%1674%		COERCE(CBNOUPDATE, CBWARNING, NO, YES),
%1674%		COERCE(CBNOUPDATE, CBNOACTION, YES, NO),

%1674%		! Complain for number of arguments being different
%1674%
%1674%		COERCE(CBNUMARG, CBWARNING, 0, 0),

%1674%		! Check for missing funtion return value on either side.
%1674%
%1674%		COERCE(CBRETVAL, CBWARNING, NO, YES),
%2502%		COERCE(CBRETVAL, CBWARNING, YES, NO),

%1674%		! Complain for character argument length missmatches
%1674%
%1674%		COERCE(CBARGLEN, CBWARNING, 0, 0),

%2434%		! Can't pass a one word LOCAL byte pointer when the routine
%2434%		! expects a one word GLOBAL byte pointer.
%2434%
%2434%		COERCE(CBTYP, CBNOACTION, TYPCHARACTER, TYPEXTCHARACTER),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPCHARACTER),


%2517%		! Give warnings for invalid structure mixups.  Mixing up of
%2517%		! singleton and array names with routine names are an
%2517%		! error.  Mixing of arrays and singletons are probably done
%2517%		! by the users (ugh) and are not.  Mixing with "not
%2517%		! specified" means a program compiled prior to this edit,
%2517%		! since the field would be zero for that case.
%2517%
%2517%		COERCE(CBSTRUCTURE, CBNOACTION, TPSINGLETON, TPARRAY),
%2517%		COERCE(CBSTRUCTURE, CBWARNING, TPSINGLETON, TPROUTINE),
%2517%		COERCE(CBSTRUCTURE, CBNOACTION, TPSINGLETON, TPNOTSPECIFIED),
%2517%
%2602%		COERCE(CBSTRUCTURE, CBWARNING, TPARRAY, TPSINGLETON),
%2517%		COERCE(CBSTRUCTURE, CBWARNING, TPARRAY, TPROUTINE),
%2517%		COERCE(CBSTRUCTURE, CBNOACTION, TPARRAY, TPNOTSPECIFIED),
%2517%
%2517%		COERCE(CBSTRUCTURE, CBWARNING, TPROUTINE, TPSINGLETON),
%2517%		COERCE(CBSTRUCTURE, CBWARNING, TPROUTINE, TPARRAY),
%2517%		COERCE(CBSTRUCTURE, CBNOACTION, TPROUTINE, TPNOTSPECIFIED),
%2517%
%2517%		COERCE(CBSTRUCTURE, CBNOACTION, TPNOTSPECIFIED, TPSINGLETON),
%2517%		COERCE(CBSTRUCTURE, CBNOACTION, TPNOTSPECIFIED, TPARRAY),
%2517%		COERCE(CBSTRUCTURE, CBNOACTION, TPNOTSPECIFIED, TPROUTINE),


		! Give warnings for the following invalid type mismatches:

		! Logical Actual

		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPLOGICAL),
		COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPLOGICAL),
		COERCE(CBTYP, CBWARNING, TYPREAL, TYPLOGICAL),
		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPLOGICAL),
		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPLOGICAL),
		COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPLOGICAL),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPLOGICAL),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPLOGICAL),

		! Integer Actual

		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPINTEGER),
		COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPINTEGER),
		COERCE(CBTYP, CBWARNING, TYPREAL, TYPINTEGER),
		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPINTEGER),
		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPINTEGER),
		COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPINTEGER),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPINTEGER),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPINTEGER),

		! Real Actual

		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPREAL),
		COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPREAL),
		COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPREAL),
		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPREAL),
		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPREAL),
		COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPREAL),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPREAL),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPREAL),

		! Double Precision Actual

		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPDOUBLPREC),
		COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPDOUBLPREC),
		COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPDOUBLPREC),
		COERCE(CBTYP, CBWARNING, TYPREAL, TYPDOUBLPREC),
		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPDOUBLPREC),
		COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPDOUBLPREC),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPDOUBLPREC),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPDOUBLPREC),

		! G-Floating Actual

		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPGFLDBLPREC),
		COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPGFLDBLPREC),
		COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPGFLDBLPREC),
		COERCE(CBTYP, CBWARNING, TYPREAL, TYPGFLDBLPREC),
		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPGFLDBLPREC),
		COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPGFLDBLPREC),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPGFLDBLPREC),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPGFLDBLPREC),

		! Complex Actual

		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPCOMPLEX),
		COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPCOMPLEX),
		COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPCOMPLEX),
		COERCE(CBTYP, CBWARNING, TYPREAL, TYPCOMPLEX),
		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPCOMPLEX),
		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPCOMPLEX),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPCOMPLEX),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPCOMPLEX),

		! Label Actual

		COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPLABEL),
		COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPLABEL),
		COERCE(CBTYP, CBWARNING, TYPREAL, TYPLABEL),
		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPLABEL),
		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPLABEL),
		COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPLABEL),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPLABEL),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPLABEL),
		
		! Character Actual

		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPCHARACTER),
		COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPCHARACTER),
		COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPCHARACTER),
		COERCE(CBTYP, CBWARNING, TYPREAL, TYPCHARACTER),
		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPCHARACTER),
		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPCHARACTER),
		COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPCHARACTER),

		! Character Actual /EXTEND

%2434%		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPEXTCHARACTER),
%2434%		COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPEXTCHARACTER),
%2434%		COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPEXTCHARACTER),
%2434%		COERCE(CBTYP, CBWARNING, TYPREAL, TYPEXTCHARACTER),
%2434%		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPEXTCHARACTER),
%2434%		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPEXTCHARACTER),
%2434%		COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPEXTCHARACTER),

		! Octal actual

		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPOCTAL),
		COERCE(CBTYP, CBWARNING, TYPDOUBLPREC, TYPOCTAL),
		COERCE(CBTYP, CBWARNING, TYPGFLDBLPREC, TYPOCTAL),
		COERCE(CBTYP, CBWARNING, TYPCOMPLEX, TYPOCTAL),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPOCTAL),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPOCTAL),

		! Double Octal actual

		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPDBLOCTAL),
		COERCE(CBTYP, CBWARNING, TYPLOGICAL, TYPDBLOCTAL),
		COERCE(CBTYP, CBWARNING, TYPINTEGER, TYPDBLOCTAL),
		COERCE(CBTYP, CBWARNING, TYPREAL, TYPDBLOCTAL),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPDBLOCTAL),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPDBLOCTAL),

		! Hollerith actual

%1674%		COERCE(CBTYP, CBWARNING, TYPLABEL, TYPHOLLERITH),
		COERCE(CBTYP, CBWARNING, TYPCHARACTER, TYPHOLLERITH),
%2434%		COERCE(CBTYP, CBWARNING, TYPEXTCHARACTER, TYPHOLLERITH)

	);	! Table used if /DEBUG:ARGUMENTS is specified.


	! Type of block being put out.  We must have a separate word  to
	! output the header because PLIT's  are put in the  non-writable
	! high seg on the 10, and we can't write into the PLIT.

%1674%	HEADRWORD = RCOERCION^18;

	! Output a coercion block depending on whether  /DEBUG:ARGUMENTS
	! was specified.  Hi  Tyrone!  (He's  never been  in a  compiler
	! before!)

%1613%	IF .FLGREG<DBGARGMNTS>
%1613%	THEN
%1674%	BEGIN	! /DEBUG:ARGUMENTS specified
%1674%
%1674%		HEADRWORD<RIGHT> = .(ARGS-1);	! Header word
%1674%		DMPRLBLOCK(HEADRWORD,1);
%1674%
%1613%		DMPRLBLOCK(ARGS,.(ARGS-1))	! Rest of rel block
%1674%	END
%1613%	ELSE
%1674%	BEGIN	! /DEBUG:ARGUMENTS not specified
%1674%
%1674%		HEADRWORD<RIGHT> = .(NOARGS-1);	! Header word
%1674%		DMPRLBLOCK(HEADRWORD,1);
%1674%
%1613%		DMPRLBLOCK(NOARGS,.(NOARGS-1));	! Rest of rel block
%1674%	END;

END;	! of ZCOERCION
GLOBAL ROUTINE SECDESC(ARG)=	![1770] New
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
! 
!	SECDESC returns the length needed for a secondary descriptor for
!	argument checking for the argument  passed or 0.  0 is  returned
!	if the  size is  not  calculable at  compile time  (length  star
!	character) or not significant (non array numeric).
!
! FORMAL PARAMETER:
!
!	ARG	Is an  argument  expression  to  be  passed  to  a  user
!		subprogram.
!
! IMPLICIT INPUTS:
!
!	FLGREG
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	Returns size of argument found;  bytes for character, words  for
!	numeric arrays, or  0 if  a secondary  descriptor isn't  needed.
!	The size of the entire element is returned, so a bare array gets
!	all of its elements.
!
! SIDE EFFECTS:
!
!	None
!
!--


	MAP	 BASE ARG;	! Argument expression

	REGISTER
		BASE EXPRLEN,	! Expression length
		BASE DIMTAB;	! Dimension table entry


	! Unless /DEBUG:ARGUMENTS  is  specified, there's  no  point  in
	! putting out the secondary descriptors.

	IF NOT .FLGREG<DBGARGMNTS> THEN RETURN 0;

	! Return the value, if possible, of the character expression  or
	! numeric array.

	IF .ARG[VALTYPE] EQL CHARACTER
	THEN
	BEGIN	! Character argument

		! Length * means  that the length  is not calculable  at
		! compile time.

		IF (EXPRLEN = CHEXLEN(.ARG)) NEQ LENSTAR
		THEN RETURN .EXPRLEN;
	END
	ELSE
	BEGIN	! Numeric argument

		! We're not interested unless this  is a bare array.   A
		! bare array is the only numeric quantity that may  have
		! multiple elements to check the length of.

		IF .ARG[OPR1] EQL ARRAYFL
			OR .ARG[OPR1] EQL FMLARRFL
		THEN
		BEGIN	! Array

			DIMTAB = .ARG[IDDIM];	! Dimens table ref

			! Size is not calculable at compile time
			! if the array is assumed size or adjustably
			! dimensioned.

			IF NOT .DIMTAB[ASSUMESIZFLG] THEN
			IF NOT .DIMTAB[ADJDIMFLG]
			THEN	RETURN .DIMTAB[ARASIZ];	! return size

		END;	! Array

	END;	! Numeric argument

	RETURN 0;	! No secondary descriptor needed

END;	! of SECDESC

END
ELUDOM