Google
 

Trailing-Edge - PDP-10 Archives - BB-4157F-BM_1983 - fortran/compiler/relbuf.bli
There are 26 other files named relbuf.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
!  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1983
!AUTHOR: S. MURPHY/CKS/AHM/CDM

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

GLOBAL BIND RELBUV = 7^24 + 0^18 + #1674;	! Version Date: 9-Dec-82

%(

***** 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 EXTERNPSECTS 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 Revision History *****

)%

	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
RELBUFF SYMRLBF:	! Buffer for type 2 and 1070 symbol rel blocks
			!  (Symbol definitions and global requests)
	LOCRLBF:	! Buffer for type 10 local request rel blocks
			!  (Does fixups for forward refs to a label)
	MAINRLBF,	! Main rel file buffer - used for type 1 and 1010
			!  (code and data) as well as miscellaneous
			!  (hiseg, end, etc.)
EVALTAB EVALU,		! Table for conversion from Fortran [valtype] to
			! type codes for LINK.
%1521%	HIORIGIN,	! Origin of HISEG
	LSTOUT,		! Routine to output a character to the listing
%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

FORWARD
	BUFFOUT,	! Stores a data word into a particular rel buffer
	DMPMAINRLBF,
	DMPRLBLOCK,
	LSTRLWD,	! List a word of the rel file for /EXPAND
	RADIX50,	! Return Radix-50 of the sixbit word in R2
%1512%	ZNEWBLOCK,	! Buffers a word of an unrelocated block type
	ZOUTBLOCK,	! Buffers a word to the REL file
	ZSAVEOUT,
%1512%	ZSYMBOL, 	! Outputs symbols to the REL file
%1521%	TPARGDES,	! Fills in buffer for each argument.
%1521%	SIXTO7,		! Sixbit to ASCIZ conversion.
%1521%	ZARGCHECK,	! Puts out type checking blocks for subprog calls.
%1521%	ZCOERCION,	! Puts out coercion blocks for type checking.
%1521%	ZSFARGCHECK;	! Puts out type checking blocks for subprog definitions

BIND ![1512] New
	EXTERNPSECT = UPLIT(	! Mapping between internal STE psects and
				!  external REL file psect indices
%PSDATA:%	PXDATA,
%PSCODE:%	PXCODE,
%PSLARGE:%	PXLARGE,
%PSABS:%	PXABS
%1551%		)-1;		! Well almost.  We shifted things over by one
				!  so that a psect index of 0 was illegal.
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 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

BIND
	LONGTAB = UPLIT(	! A table entry is all the data that goes into
				!  the flag word of a type 1070 symbol
%LOCDEF:%	TYPE1070FILL(RLSLOCAL,RLSRRH),
%LOCSUPDEF:%	TYPE1070FILL(RLSLOCAL OR RLSSUPPRESS,RLSRRH),
%GLBDEF:%	TYPE1070FILL(RLSGLOBAL,RLSRRH),
%GLBSUPDEF:%	TYPE1070FILL(RLSGLOBAL OR RLSSUPPRESS,RLSRRH),
%GLBSYMFIX:%	TYPE1070FILL(RLSGLOBAL OR RLSSYMBOL OR RLS30FIX,RLSRABS),![1570]
%GLB18CHNFIX:%	TYPE1070FILL(RLSGLOBAL OR RLSCHAIN OR RLSRHFIX,RLSRRH),
%GLB18ADDFIX:%	TYPE1070FILL(RLSGLOBAL OR RLSADDITIVE OR RLSRHFIX,RLSRRH),
%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

	IF EXTENDED		! Should we use TWOSEG or psected symbols ?
	THEN			! Non-zero section, use psected symbols
	BEGIN
		RDATWD = .LONGTAB[.FUNC];	! Get proper flag word

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

		RDATWD = .VALUE;		! Get the value
		ZNEWBLOCK(RLONGSYMBOL);

		RDATWD = .NAM;			! And get the name in SIXBIT
		ZNEWBLOCK(RLONGSYMBOL)
	END
	ELSE ! NOT EXTENDED			! Use TWOSEG scheme (type 2)
	BEGIN

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

		R2 = .NAM;
		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
			R2 = .VALUE;	! 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
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
%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 - Not presently used for strange 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).

	IF .ZBLKTYPE EQL RLONGSYMBOL	! Symbol definition or global request
	THEN
	BEGIN
		IF .SYMRLBF[RDATCNT] GEQ SYMBOLMAX	! Any room left ?
		THEN			! No, output what we have so far
		BEGIN
			DMPMAINRLBF();	! Dump out code that might need fixups
			DMPRLBLOCK(SYMRLBF,.SYMRLBF[RDATCNT]+1);
			SYMRLBF[RDATCNT] = 0	! Clear the word count
		END;

		! 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

	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

%1526%	IF .MAINRLBF[RTYPE] EQL RRIGHTCODE	! New block (only 1010 so far)?
%1526%	THEN					! Yes, block count must include
%1526%	BEGIN					!  the relocation word
%1526%		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

%1512%	IF 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=
BEGIN

! R2 contains symbol in SIXBIT to be listed

	DECR I FROM 6 TO 1		! Maximum of 6 characters listed
	DO
	BEGIN
		R1 = 0;			! Clear out the character temp
		LSHC(R1,6);		! Get the next character

		IF .R1 GTR 0		! Is it non blank ?
		THEN			! Yes
		BEGIN
			CHR = .R1+#40;	! Convert to ASCII
			LSTOUT()	! Print it
		END
		ELSE RETURN		! Blank - all done
	END;

END;	! of ZOUTMSG
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 RADIX50=	!R2 CONTAINS THE SYMBOL IN SIXBIT LEFT JUSTIFIED
			!CONVERT IT TO RADIX 50
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 (
	R1 _ 0; LSHC(R1,6);
	IF SIXALPHA(R1) THEN R1 _ .R1 -#26
	  ELSE IF SIXDIGIT(R1) THEN R1 _ .R1 -#17
%1403%	    ELSE IF .R1 EQL SIXBIT "$" THEN R1=#46
	      ELSE R1 _ #45;	!A . BY DEFAULT
	R50 _ .R50*#50; R50 _ .R50 + .R1;
   ) 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
	LOCAL Z[6];
	!LIST IN ASCII THE VALUE OF R1 A REGISTER
	IF .R1 LSS 0 THEN CHR _ "-" ELSE CHR _ "+";
	LSTOUT();
	R2<LEFT> _ ABS(.R1);
	ZOUTOCT();	!OCTAL OUTPUT VALUE IN R2<LEFT>

END;	! of ZOUOFFSET
GLOBAL ROUTINE OUTCHDATA (BP,LEN,CONST,SYM) =           ! [1242] New

! Routine to output a type 1004 .REL block to initialize a character string
! Args:		BP = byte pointer to the string to initialize
!		LEN = number of chars in the string
!		CONST = pointer to literal table entry of a character constant
!		SYM = pointer to symbol table entry of variable 
!
! The constant is truncated or padded to the right length, if necessary, and
! put into the .REL file in a type 1004 block.

BEGIN		! OUTCHDATA

	MAP BASE CONST;
	MAP BASE SYM;
	MAP BASE R2;
	OWN BLKHDR[5];
	REGISTER WDLENGTH;		! LENGTH OF STRING IN WORDS
	REGISTER T1;			! TEMP

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

%1544%	IF EXTENDED			! Psected object code ?
	THEN				! Yes
	BEGIN	LOCAL RELBUFF MYRELBUF[3];

		DMPMAINRLBF();		! Flush out possible previous type 21
					!  sparse data block so that it is next
					!  to its default psect index block

		! Set the default psect before we dump the data.  Note
		! that all the data are in .DATA.

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

	WDLENGTH _ (.LEN+4)/5;		! GET NUMBER OF WORDS OCCUPIED BY
					! INITIALIZATION STRING

	IF .SYM[IDATTRIBUT(INCOM)]
	THEN
	BEGIN	! IN COMMON
		BLKHDR[0]<LEFT> _ RCHDATA; ! BLOCK TYPE 1004
		BLKHDR[0]<RIGHT> _ .WDLENGTH + 4; ! LONG COUNT
		BLKHDR[1] _ 0;		! RELOCATION WORD: NONE
		R2 _ .SYM[IDCOMMON];	! COMMON BLOCK NODE
		BLKHDR[2] _ .R2[COMNAME]; ! SIXBIT COMMON BLOCK NAME
		BLKHDR[3] _ .LEN;	! BYTE COUNT
		BLKHDR[4] _ .BP;	! BYTE POINTER
		DMPRLBLOCK(BLKHDR,5);	! DUMP BLOCK HEADER
	END	! IN COMMON
	ELSE
	BEGIN	! NOT IN COMMON
		BLKHDR[0]<LEFT> _ RCHDATA; ! BLOCK TYPE 1004
		BLKHDR[0]<RIGHT> _ .WDLENGTH + 3; ! LONG COUNT
		BLKHDR[1] _ RELRI ^ 32;	! RELOCATION WORD: RIGHT HALF RELOC
					!   OF BYTE POINTER WORD
		BLKHDR[2] _ .LEN;	! BYTE COUNT
		BLKHDR[3] _ .BP;	! BYTE POINTER
		DMPRLBLOCK(BLKHDR,4);	! DUMP BLOCK HEADER
	END;	! NOT IN COMMON
				
	! Output the constant from the literal node.  If the string to be
	! initialized is exactly the same length as the constant, fine.
	! If the string is shorter, only output enough words of the constant
	! to fill the desired length of the string.  There may be unused
	! characters in the last word.  If the string is longer, output the
	! entire constant (which is padded with blanks in the last word), then
	! output blanks until enough words have gone out.

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

	INCR I FROM .CONST[LITSIZ] TO .WDLENGTH DO
	DMPRLBLOCK (UPLIT'     ', 1);

END;		! OUTCHDATA
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).

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

	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.

	IF NOT .SAVALL
	THEN
	BEGIN	! 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

			IF NOT .COMSYM[IDATTRIBUT(COMBL)]
			THEN
			BEGIN	! Block not declared COMMON - delete it

				COMPTR  = .COMPTR[CLINK];
				OLDCOMPTR[CLINK] = .COMPTR;
				NUMSAVCOMMON = .NUMSAVCOMMON - 1;
			END
			ELSE
			BEGIN
				OLDCOMPTR = .COMPTR;	! Save for next delete
				COMPTR = .COMPTR[CLINK]; ! Next common
			END;

		END;	! For each common name SAVE
	END;

	! Fill in header word

	! Block type
	MAINRLBF[SVTYPE] = RWRITELINK;

	! Number of words in rel block
	MAINRLBF[SVCOUNT] = 1 + .NUMSAVCOMMON;

	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

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

			BOFFSET = .BOFFSET + 1;
			IF .BOFFSET GEQ RBLKSIZ
			THEN
			BEGIN
				DMPRLBLOCK(MAINRLBF,RBLKSIZ);
				BOFFSET = 0;
			END;

			! Put sixbit symbol into rel file.

			COMSYM = .COMPTR[CW0L];  ! Common symbol table entry
			MAINRLBF[.BOFFSET,FULL] =
				.COMSYM[IDSYMBOL];	! Common name
			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

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

			BOFFSET = .BOFFSET + 1;
			IF .BOFFSET GEQ RBLKSIZ
			THEN
			BEGIN
				DMPRLBLOCK(MAINRLBF,RBLKSIZ);
				BOFFSET = 0;
			END;

			! Put sixbit  symbol into  rel  block and  get  new
			! pointer for next go around.

			MAINRLBF[.BOFFSET,FULL] = .COMPTR[COMNAME];	! Name
			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
%1674%	IMPLARG,		! Flag for whether "this arg" is implicit
%1674%				! (link should not type check)
	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

%1674%		IMPLARG = FALSE;	! 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.

			! 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] = 0;	! Zero out name in case
			MAINRLBF[TPNAME1] = 0;	! it doesn't take full word

			! 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. Need an extra word if one is  needed.
			! Must not do if there are no arguments.

			IF .ARGLIST[ARGCOUNT] NEQ 0
			THEN
			DECR CNT FROM .ARGLIST[ARGCOUNT] TO 1 DO
			BEGIN
				CNODE = .ARGLIST[.CNT,ARGNPTR];
				IF .CNODE[VALTYPE] EQL CHARACTER THEN
%1567%				IF CHEXLEN(.CNODE) NEQ LENSTAR
				THEN	MAINRLBF[TPRELSIZE] = 
					.MAINRLBF[TPRELSIZE] + 1; ! Extra word
			END;


  			! If this  is  a  character  function,  we  must
  			! include the functions return value (and  check
  			! for a secondary descriptor) twice.  The  first
  			! time is for the physical location which is  in
  			! the arg block and the second is for the  dummy
  			! location we put 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.
%1674%				IMPLARG = TRUE;

%1567%				IF CHEXLEN(.ARGLIST[1,ARGNPTR]) NEQ LENSTAR
				THEN	MAINRLBF[TPRELSIZE] =
					.MAINRLBF[TPRELSIZE] + 1; ! Extra word
%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,
%1674%					.ARGLIST[.CNT,ARGNPTR], .IMPLARG);
%1674%
%1674%				IMPLARG = FALSE;	! 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,
%1674%					.PARNODE[ARG1PTR], FALSE);

			! 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


	! Count the  number of  bytes  needed for  ASCII name.   Shift  out
	! letter by letter until the name is null.

	COUNT = 0;
	WORD = .SIX;
	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
	SOURCE = SIX<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,IMPLARG)=	! [1521] New

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

! PASSED:	ARGOFFSET	-Offset into buffer MAINRLBF
! 		CNODE		-Node to retrieve information from
!		IMPLARG		-Flag on whether this argument is implicit

! RETURNS:	ARGOFFSET	-Current offset into MAINRLBF
!		 		 Either +1 +2 or reset to zero.

BEGIN
	MAP BASE CNODE;
	MAP RELBUFFER MAINRLBF;	! Buffer to put information into.
	REGISTER ARGSIZE;	! Size in bytes of a character variable from 
				! CHEXLEN.


	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;

	IF .CNODE[OPRCLS] EQL DATAOPR THEN
	IF .CNODE[OPERSP] EQL CONSTANT
	THEN
	BEGIN
%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

	IF .CNODE[OPRCLS] EQL LABOP
	THEN	MAINRLBF[.ARGOFFSET,TPTYP] = ADDRTYPE	! Alternate return lab
	ELSE	MAINRLBF[.ARGOFFSET,TPTYP] = .EVALU[.CNODE[VALTYPE]];

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

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

	IF .CNODE[VALTYPE] EQL CHARACTER THEN
%1567%	IF (ARGSIZE = CHEXLEN(.CNODE)) NEQ LENSTAR
	THEN
	BEGIN	! Secondary descriptor needed

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

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

		! Set formal =<  actual for allowable  conditions. This  is
		! according to the  ANSII-77 standard  , section  15.9.3.1.
		! This has been extended to include 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

! Routine which puts out arg checking blocks for definitions of subroutines
! and functions.  Routine  walks through  any and all  ENTRY points  linked
! together to put out this rel block.

! Must be  carefull 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.
%1674%	IMPLARG,		! Flag indicating implicit argument
	BASE SYMTAB;		! Symbol table entry


	MAP RELBUFFER MAINRLBF;	! Buffer to put out the blocks


%1674%	IMPLARG = FALSE;	! 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

		IF .ARGCNT NEQ 0
		THEN
		DECR CNT FROM .ARGCNT TO 1 DO
		BEGIN
			CNODE = .ARGLIST[.CNT,ARGNPTR];
			IF .CNODE NEQ 0 THEN	! Return label
			IF .CNODE[VALTYPE] EQL CHARACTER THEN
%1567%			IF CHEXLEN(.CNODE) NEQ LENSTAR
			THEN	MAINRLBF[TPRELSIZE] =
				.MAINRLBF[TPRELSIZE] + 1;
		END;

 		! If this is a character  function, we must include  the
 		! functions return  value  (and check  for  a  secondary
 		! descriptor) twice.  The first time is for the physical
 		! location which is in the  arg block and the second  is
 		! for the dummy  location we  put 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
			IF CHEXLEN(.ARGLIST[1,ARGNPTR]) NEQ LENSTAR
			THEN	MAINRLBF[TPRELSIZE] = .MAINRLBF[TPRELSIZE] + 1;
%1674%
%1674%			IMPLARG = TRUE;	! 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,
%1674%				.ARGLIST[.CNT,ARGNPTR], .IMPLARG);
%1674%
%1674%			IMPLARG = FALSE;	! No more implicit args
%1674%		END;

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

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

		! 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=
BEGIN

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

	MAP RELBUFFER MAINRLBF;	! Buffer to output block.

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

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

	MACRO COERCE(FIELD,ACTION,FORMAL,ACTUAL)
		= ((FIELD)^18 OR ACTION),
		  ((FORMAL)^18 OR ACTUAL)$;

	BIND	YES=1,
		NO=0;


	! Table used if no /DEBUG:ARGUMENTS is specifed
%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)
	);


	! Table used if /DEBUG:ARGUMENTS is specified.

%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 return value on the called side
%1674%
%1674%		COERCE(CBRETVAL, CBWARNING, NO, YES),
%1674%		COERCE(CBRETVAL, CBNOACTION, YES, NO),

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

		! 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),

		! 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),

		! 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),

		! 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),

		! 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),

		! 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),

		! 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),
		
		! 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),

		! 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),

		! 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),

		! Hollerith actual

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

	);

	! 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

END
ELUDOM