Google
 

Trailing-Edge - PDP-10 Archives - bb-4157j-bm_fortran20_v11_16mt9 - fortran-compiler/cgdo.bli
There are 12 other files named cgdo.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 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 NORMA ABEL/HPW/MD/DCE/SJW/RDH/TFV/CKS/AHM/CDM/RVM/TJK/MEM

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

GLOBAL BIND CGDOV = #11^24 + 0^18 + #4550;	! Version Date:	25-Aug-86


%(

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

119	-----	-----	MAKE ARGGEN A GLOBAL ROUTINE

120	-----	-----	IN "CGRETURN", WHEN LOOK FOR NEXT STMNT AFTER
			THE RETURN EQUAL TO END, SKIP OVER AN INTERVENING CONTINUE
121	-----	-----	IN "CGRETURN", WHEN CHECKING THE SRCID OF NXTSTMNT,
			MUST FIRST CHECK THE NXTSTMNT NEQ 0
122	-----	-----	IN "CGRETURN", GENERATE A RETURN WHEN THERE
			ARE LABEL ARGUMENTS IN ALL CASES
123	-----	-----	FIX ARGGEN TO PERMIT MULTIPLE LEVEL PASSING
			OF SUBPROGRAM NAMES
124	-----	-----	FIX 123 (I HOPE)
125	-----	-----	CHANGE REFERENCES TO PROEPITYP
126	-----	-----	PUT OUT TYPE CODE WITH LABEL ARGUMENTS
127	-----	-----	GIVE ERROR MESSAGES FOR MULTIPLE RETURN
					WHEN THERE WERE NO LABEL PARAMS; AND
			FOR VALUE OF A FN NEVER DEFINED
128	-----	-----	MESSAGE FOR VAL OF FN UNDEFINED SHOULD NOT
			BE GIVEN FOR A STMNT FN
129	-----	-----	MACRO SET1ZGEN MISSPELLED IN CGRETURN
130	-----	-----	FIX CALLS TO FATLERR TO INCLUDE .ISN
131	-----	-----	WHEN /DEB:TRACE WAS SPECIFIED, FOR STMNT FNS
			AND ENTRIES THE XCT FDDT. MUST BE GENERATED AFTER
			THE ENTRY NAME IS DEFINED.
132	-----	-----	IN "CGPROEPI", SHOULD CLEAR PBFISN FIELD
			BEFORE OUTPUT SIXBIT FOR ENTRY NAME; SET
			IT TO THE STMNT ISN BEFORE THE 1ST INSTRUCTION
133	-----	-----	GENERATE COMMON SUBS ON DO STMNTS
134	256	15493	DO NOT LOOK FOR LABEL DUMMIES IN STATEMENT FUNCTIONS,
			(JNT)
135	323	16729	USE .A00NN FOR NAME OF TEMPORARY USED  TO SAVE
			REGISTERS IN PROLOGUE OF A FUNCTION, (MD)
136	360	18243	FIX RETURN BEFORE CONTINUE, END STMNTS, (DCE)

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

137	607	22685	SET GLOBAL FLAG NEDZER IN CGSBPRGM TO INDICATE
			  ZERO-ARG-BLOCK NEEDED
140	613	QA2114	IGNORE INDIRECT BIT IN FORMAL FUNCTION TARGET
			  ON ENTRY PROLOGUE, (SJW)

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

141	674	11803	TEST FOR DOSTAK OVERFLOW AND GIVE ERROR MSG, (DCE)
142	677	25573	GENERATE CODE TO CHECK FOR CORRECT
			 NUMBER OF PARAMETERS IF DEBUG:PARAM SET, (DCE)

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

143	750	TFV	1-Jan-80	------
	remove Debug:parameters (edit 677)

144	761	TFV	1-Mar-80	-----
	Remove KA10FLG and add in /GFLOATING

145	1002	TFV	1-Jul-80	------
	MAP EVALU onto EVALTAB to get the argtype for argblock entries

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

146	1206	DCE	20-Mar-81	-----
	For real DO loops, put out potential jump around (zero trip F77)
	together with a label for it, and be sure to make "final" loop value
	available at end of loop.

147	1227	CKS	22-Jun-81
	Use CONST2L instead of CW4L to access LH of constant AOBJN pointer.

148	1253	CKS	11-Aug-81
	When ARGGEN is doing a character arrayref node, point symbol table
	pointer at the .Q temp (from TARGADDR) not the array name
	(from ARG1PTR).

149	1266	TFV	5-Oct-81	------
	Add code to copy 1 or 2 words of descriptor for character formal
	at subroutine entrance.  Don't copy it back on subroutine exit.
	Fix up lots of code and comments to look nice.

150	1276	DCE	21-Oct-81	-----
	Only materialize loop variable at normal exit if /F77 given.

151	1400	CKS	21-Oct-81
	In CGSBPRGM, check for function call with zero arguments and use ZERBLK

152	1401	AHM	2-Oct-81
	Make ARGGEN emit arg block entries that are IFIWs.  Do the  same
	in CGPROEPI  for  the vector  of  addresses that  point  into  a
	subroutine's arg  block used  for  multiple returns.   Delete  a
	macro that  fudged over  misspellings  of ENTLIST  in  CGPROEPI.
	Rework and pretty up ARGGEN and CGARGS.  Put form feeds  between
	all routines in this module.

153	1422	TFV	12-Nov-81	------
	Fix CGEPILOGUE  to handle  character functions.   The result  of
	character functions is  not returned in  AC0, AC1.  Instead  the
	first argument has the descriptor for the result.

154	1437	CDM	16-Dec-81	------
	Save address call in CGARGS to a subprogram for argument checking
	processing.

155	1455	TFV	5-Jan-82	------
	Modify CGSFN  for  character statement  function.   A  statement
	function is turned into either a call to CHSFN.  (the subroutine
	form of CHASN.)  or  a call to CHSFC.   (the subroutine form  of
	CONCA.).  CHSFC.   is  used  if  the  character  expression  has
	concatenations at its top  level, CHSFN. is  used for all  other
	character expressions.  Modify  CGSBPRGM so it  doesn't set  the
	indirect bit for character statement function names.

156	1466	CDM	2-Feb-82
	Modified CGARGS to allow zero argument blocks to be allocated if
	/DEBUG:ARGUMENTS is specified.

1505	AHM	9-Mar-82
	Set the IDPSECT field in symbol table enties for .A00nn  temps
	to .DATA.  Also optimize macro TNAME by removing a LSH and two
	adds.

1524	RVM	31-Mar-82
	Don't turn on the indirect bit of an argument block entry for
	an argument of type dummy character function.

1526	AHM	27-Apr-82
	Don't subtract HIORIGIN from  the address of subroutine  calls
	when saving them for argument checking in CGARGS, since we now
	never add it in in the first place.

1533	TFV	17-May-82
	Modify CGSBPRGM for dynamic concatenations.  Call CHMRK.  before
	the subprogram  call  and  call  CHUNW.  after.   If  there  are
	multiple returns, generate error handling code to do the  CHUNW.
	call and then JRST to the user label.

1562	TFV	18-Jun-82
	Fix CGSBPRGM to only check ARGMARK if there is an argument list.

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


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

2245	CDM	18-Dec-83
	Improve argument checking.  Subroutine  calls with no  arguments
	would not output  argument checking (1120)  rel blocks for  Link
	unless /DEBUG:ARGUMENTS was  given.  Now always  output the  the
	rel block, and change the call to the subroutine not to have its
	own unique  argument block  of  0, but  instead use  the  shared
	ZERBLK which  everyone  else  with no  arguments  shares.   This
	simplifies code in several places.
	Delete unneeded local variable ARGFLG in CGSBPRGM.  Code becomes
	much simpler without it.

2313	TJK	21-Feb-84
	Rewrite CGRETURN.   This  routine  had a  number  of  problems
	including inefficiency  within the  routine itself,  incorrect
	code produced for  alternate returns  using array  references,
	and pessimal code  produced for some  cases.  Added a  routine
	header.  Removed macro  MOV1GEN.  Commented  out code  pattern
	MOVRET.  Added entry point for code pattern OPGZER.

2317	AHM	4-Mar-84
	Make ARGGEN use GENREF to construct memory references instead
	of doing it itself.  Remove code in CGPROEPI which believed
	that formal array STEs had an indirect bit set in IDADDR.

2462	AHM	2-Oct-84
	Use execrable TRUE/FALSE/TRUTH/FALSITY miasma for boolean in
	call to GENREF to satisfy programming conventions.

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

2541	MEM	1-Aug-85
	When the loop count can stay in a register, but the induction
	variable must be materialized (MATRLZIXONLY bit is set), make
	sure induction variable is updated after exiting the loop.

2563	MEM	17-Dec-85
	When a subprogram has a subprogram name as a formal parameter, the
	the indirect bit is set in the STE for the subprogram name after the
	address of the subprogram has been moved into the dummy argument.
	However, if this subprogram has an entry statement (also passing the
	subprogram name as a parameter) the indirect bit in the STE must be
	ignored when moving the address of the subprogram into the dummy 
	argument.

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

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

4515	CDM	20-Sep-85
	Phase I for VMS long symbols.  Create routine ONEWPTR for Sixbit
	symbols.  For now, return what is passed it.  For phase II, return
	[1,,pointer to symbol].

4527	CDM	1-Jan-86
	VMS Long symbols phase II.  Convert all internal symbols from
	one word of Sixbit to [length,,pointer].


4532	MEM	19-Feb-86
	Add long symbol support: Preceding each function/subroutine we want
	a pointer to a sixbitz name instead of the name. When outputting arg
	blocks, check if we have an arg block for a call to PROSB. If we do
	then change the fifth argument to an address where the long name is.
	This fifth argument is currently a constant table entry containing
	the cnt,,ptr to name.

4550	MEM	25-Aug-86
	Remove lines from CGPROEPI which force the section number of the
	routine name to be in section 1 under extended addressing.
	
ENDV11
)%

SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE REQREL.BLI;	;[4532]
SWITCHES LIST;

! Below is for RUNOFF in generating .PLM files
!++
!.LITERAL
!--

OWN
	JUMPABOUT,
	JMPVECT,
	LABARGCT,
	JMPSFN,
%1505%	BASE EPILAB;	! Holds pointer to labels  of epilogue code  and
			! STE of  temp that  holds  the address  of  the
			! proper epilogue at runtime

FORWARD
	CGDOLOOP,
	CGDOEND(1),
	CGPROEPI ,
	CGEPILOGUE(1),
	CGRETURN(1),
	CGSFN,
	CGSBPRGM(2),	! Generate code for a subroutine call
	ARGGEN(1),
	CGARGS,
%4532%	PROSBARGLIST;	!Generate arg list for PROSB.

EXTERNAL 
	A1LABEL,
%2313%	BASE A1NODE,	! Points to first argument of expression
	A2LABEL,
	ARGLINKPT,	! Points to linked list of arg blocks
%761%	CALLER,
	CGASMNT,
%1533%	CGCHMRK,	! Generate code for a CHMRK. call
%1533%	CGCHUNW,	! Generate code for a CHUNW. call
	CGCMNSUB,	! Generate code for common subs
%2313%	CGEND,		! Generate code for END statement
	CGERR,
	CGETVAL,
	CGOPGEN,	! Code generation routine
	CLOBBREGS,
%2313%	BASE CSTMNT,	! Points to current statement
	DEFLAB,		! Defines a label
%674%	DOSTAK,
%2313%	E130,		! Error for alternate RETURN with no dummy labels
	E131,
%674%	E144,		! Error message declarations
%1002%	EVALTAB EVALU,	! Maps internal type codes to external
	FATLERR,
	GENLAB,
%2317%	GENREF,		! Constructs memory references
	LASTONE,
	NEDZER,		! Flag to indicate if zero-arg-block needed
%1533%	OBUFF,
	OBUFFA,		! Outputs a word
%1401%	OIFIW,		! Makes the word in PBOPWD into an IFIW
			!  and writes it out with OBUFFA
%4515%	ONEWPTR,	! Returns [1,,pointer] from sixbit argument
	OPDSPIX,
%2313%	OPGETI,		! OPGEN table entry for "get in register"
	OPGSFN,
%761%	OPGSTI,
%2313%	OPGZER,		! OPGEN table entry for setting an AC to zero
%2317%	OBJECTCODE PBOPWD,	! Holds data word to output
	PROGNAME,
	PSYMPTR,	! Holds relocation info for OBUFFA
%761%	REGFORCOMP,
%761%	TBLSEARCH,
%2313%	BASE TREEPTR,	! Points to current expression
	ZERBLK;
GLOBAL ROUTINE CGDOLOOP=
BEGIN
	! Code generator drivers for DO loops

%1206%	EXTERNAL DOZJMP,A1LABEL;
	EXTERNAL TREEPTR,A1NODE,A2NODE,REGFORCOMP,CSTMNT;
	EXTERNAL DOSTI;
%761%	EXTERNAL CGETVAL,OPGETI,DOSP,OPGSTI,DOSTC;

	MAP BASE DOSP:A1NODE:CSTMNT:TREEPTR;
	OWN PEXPRNODE DOCEXPR;	! Ptr to expression for control wd
	LOCAL	CTLREG,		! Control word register
		IVALREG;	! Initial value register

	IF .CSTMNT[SRCCOMNSUB] NEQ 0	! Gen code for any common subs
	THEN CGCMNSUB();

	CTLREG = .CSTMNT[DOCREG]^23;	! Set up local values
	IVALREG = .CSTMNT[DOIREG]^23;

	! Get the val of the control expression into the loop ctl reg

	DOCEXPR = .CSTMNT[DOLPCTL];
	A1NODE = .DOCEXPR;

	! If the ctl expr needs to be evaluated at run time, generate code to evaluate it

	IF .DOCEXPR[OPRCLS] NEQ DATAOPR
	THEN
	BEGIN
		TREEPTR = .DOCEXPR;
		CGETVAL();
	END;

	! Get the value of the ctl expression into the loop ctl reg

	IF NOT .CSTMNT[CTLSAMEFLG]
	THEN
	BEGIN
		REGFORCOMP = .CTLREG;
		A1NODE = .DOCEXPR;

		IF .CSTMNT[FLCWD]	! If the ctl is in an AOBJN wd
%761%		THEN	OPDSPIX = OPGETI
		ELSE	OPDSPIX = DOGETAOPIX(.CSTMNT[CTLIMMED], .A1NODE[VALTP1],.CSTMNT[CTLNEG]);
		CGOPGEN();
	END;

	! Control word is now in a register
	! Get the initial value in one if necessary

	IF NOT .CSTMNT[FLCWD] THEN
	BEGIN
		REGFORCOMP = .IVALREG;
		A1NODE = .CSTMNT[DOM1];	! Initial value

		! If the initial val is not in the reg for the DO index, put it there
		IF .A1NODE[OPRCLS] EQL REGCONTENTS
		AND .A1NODE[TARGTAC] EQL .CSTMNT[DOIREG]
		THEN
		BEGIN END
		ELSE 
		BEGIN
			IF .CSTMNT[INITLIMMED]
			THEN	OPDSPIX = DOGETAOPIX(1,.A1NODE[VALTP1],.CSTMNT[INITLNEG])
			ELSE	OPDSPIX = DOGETAOPIX(0,.A1NODE[VALTP1],.CSTMNT[INITLNEG]);
			CGOPGEN();
		END
	END;

	! If this loop must have its count-ctl var materialized, generate code
	! to store the count

	IF .CSTMNT[NEDSMATRLZ] OR .CSTMNT[MATRLZCTLONLY]
	THEN
	BEGIN
		! Generate code to store the count

		A1NODE = .CSTMNT[DOCTLVAR];
		REGFORCOMP = .CTLREG;
		OPDSPIX = DOSTC + .CSTMNT[FLCWD];
		CGOPGEN();
	END;

%1206%	! If this is a potential zero trip loop, we need a label to
%1206%	! jump to at the end of the loop...
%1206%	! Also code to jump around the loop if appropriate.

%1206%	IF F77 THEN
%1206%	IF .CSTMNT[MAYBEZTRIP] NEQ 0 THEN
%1206%	BEGIN
%1206%		EXTERNAL PBOPWD,PSYMPTR,OBUFF;
%1206%		CSTMNT[DOZTRLABEL] = A1LABEL = GENLAB();
%1206%		REGFORCOMP = .CTLREG;

%1206%		IF .CSTMNT[FLCWD] AND NOT .CSTMNT[NEDSMATRLZ] ! Trip count constant
%1227%		AND .DOCEXPR[CONST2L] EQL 0	! Trip count zero
%1206%		THEN	JRSTGEN(.A1LABEL)	! Too late to delete the loop,
%1206%						! but we can still jump around it!
%1206%		ELSE
%1206%		BEGIN	! Put out a JUMPGE on negative count
%1206%			OPDSPIX = DOZJMP;
%1206%			CGOPGEN()
%1206%		END
%1206%	END;

	! If this loop must have its index materialized, generate code to store the index

	IF .CSTMNT[NEDSMATRLZ] OR .CSTMNT[MATRLZIXONLY]
	THEN
	BEGIN
		! Generate the materialization label

		DOSP[LEFTP] = GENLAB();
		DEFLAB(.DOSP[LEFTP]);

		! Now store initial value using opgnta tables to get
		! double precision unless its an HRRM

		IF .CSTMNT[FLCWD] THEN
		BEGIN
			A1NODE = .CSTMNT[DOSYM];	! Induction variable
			REGFORCOMP = .CTLREG;
			OPDSPIX = DOSTI;
			CGOPGEN();
		END
		ELSE
		BEGIN
			REGFORCOMP = .IVALREG;
			TREEPTR = .CSTMNT[DOSYM];
			OPDSPIX = STOROPIX(TREEPTR);
			CGOPGEN();
		END;
	END;

	! Now generate non-materialization labels

	DOSP[RIGHTP] = GENLAB();
	DEFLAB(.DOSP[RIGHTP]);
	DOSP = .DOSP+1;

%674%	! Test for stack overflow, and issue message if necessary
%674%	IF (.DOSP-DOSTAK) GTR TDOSTSIZ THEN FATLERR(.ISN,E144<0,0>);

END;	! CGDOLOOP
GLOBAL ROUTINE CGDOEND(TLAB)=
BEGIN

![761] OPGARG for /GFLOATING code generation
	EXTERNAL REGFORCOMP,TREEPTR,
%761%	A1NODE,A2NODE,DOSP,DOEND,OPGARG,OPGARI,OPGDOE;

%1206%	EXTERNAL OPGETI,OPGDOS,OPGSTI,DOSTI;
	MAP BASE TLAB;
	MAP BASE A1NODE:DOSP:A2NODE:TREEPTR;

	! TLAB points to label table entry for label terminating the scope of
	! one or more do statements.
	! SNDOLNK points to a linked list of the DO statements terminating here

	LOCAL	CURDO,		! the current DO loop
		NXTWD,		! word containing link and do pointer
		NXTLNK,		! word containing link to next word
		TMP1;

	MAP BASE CURDO:TMP1:NXTWD:NXTLNK;

	IF .TLAB[SNDOLVL] EQL 0 THEN RETURN;	! No DO's end here

	NXTWD = .TLAB[SNDOLNK];			! Point at first of list

	WHILE .NXTWD NEQ 0 DO
	BEGIN
		CURDO = .NXTWD[LEFTP];

		! If the loop is still there

%1206%		IF .CURDO NEQ 0 THEN
		IF NOT .CURDO[DOREMOVED] THEN
		BEGIN
			DOSP = .DOSP-1;

			! Look at the correct stack entry determine which
			! label to transfer to at loop ending if the
			! index is materialized, transfer to materialize label

			IF .CURDO[NEDSMATRLZ] OR .CURDO[MATRLZIXONLY]
			THEN	A1LABEL = .DOSP[LEFTP]
			ELSE	A1LABEL = .DOSP[RIGHTP];

			IF .A1LABEL EQL 0 THEN CGERR();

			! For the AOBJN case - the control wd and the loop
			! index are incremented together

			IF .CURDO[FLCWD] AND NOT .CURDO[NEDSMATRLZ]
			THEN
			BEGIN	! Generate AOBJN CREG,A1LABEL

				A1NODE = .CURDO[DOCTLVAR];	! Temp for contol word
				REGFORCOMP = .CURDO[DOCREG]^23;
				OPDSPIX = OPGDOE;
			END
			ELSE
			BEGIN

				! For cases other than AOBJN - must generate
				! code to increment the loop index and code to
				! increment and test the control-word

				REGFORCOMP = .CURDO[DOIREG]^23;

				IF NOT .CURDO[NEDSMATRLZ] AND NOT .CURDO[MATRLZIXONLY]
				THEN
				BEGIN
					! If the loop index is not materialized
					! simply generate an add of the incr to
					! the reg holding the index

					A2NODE = .CURDO[DOSSIZE];	! ptr to incr

					IF (.CURDO[SSIZONE] OR .CURDO[SSIZIMMED])
					AND .A2NODE[VALTYPE] NEQ DOUBLPREC
					THEN	OPDSPIX = DOARITHOPIX(.A2NODE[VALTP1],0,1,.CURDO[SSIZNEGFLG])
					ELSE	OPDSPIX = DOARITHOPIX(.A2NODE[VALTP1],0,0,.CURDO[SSIZNEGFLG]);
					CGOPGEN();
				END
				ELSE
				IF (.CURDO[SSIZONE] AND NOT .CURDO[REALARITH])
	 				OR .CURDO[FLCWD]
				THEN
				BEGIN
					! If the loop index is materialized and
					! the increment is 1, generate AOS

					A1LABEL = .DOSP[RIGHTP];
					OPDSPIX = OPGDOS;	! Non-matrlize label

					A1NODE = .CURDO[DOSYM];
					CGOPGEN();
				END
				ELSE
				BEGIN
					! If the loop index needs to be materialized
					! pick up the increment and them add it
					! to memory if valtype is not double-prec
					A1NODE = .CURDO[DOSSIZE];
					IF (.CURDO[SSIZONE] OR .CURDO[SSIZIMMED])
					AND .A1NODE[VALTYPE] NEQ DOUBLPREC
					THEN OPDSPIX = DOGETAOPIX(1,.A1NODE[VALTP1],.CURDO[SSIZNEGFLG])
					ELSE OPDSPIX = DOGETAOPIX(0,.A1NODE[VALTP1],.CURDO[SSIZNEGFLG]);
					CGOPGEN();

					! Unless the index is double-prec will
					! add the increment to it in both the
					! reg used and memory, and transfer at
					! loop end will be to the code after
					! the materialization code

					A2NODE = .CURDO[DOSYM];
					IF .A2NODE[DBLFLG]
%1206%					THEN	OPDSPIX = DOARITHOPIX(.A2NODE[VALTP1],1,1,0)
					ELSE
					BEGIN
						! Index to generate ADD to both
						! for REAL or INTEGER

						A1LABEL = .DOSP[RIGHTP];
						OPDSPIX = DOARBOTHOPIX(.A2NODE[VALTP1]);
					END;
					CGOPGEN();
				END;

				! generate code to increment and test the control word
				! AOJL
				! OR
				! AOSGE
				! JRST
				! The control register is used

				REGFORCOMP = .CURDO[DOCREG]^23;

				! Code to be generated depends on whether the
				! ctl-count word is materialized

				OPDSPIX = OPGDOE+2+(.CURDO[NEDSMATRLZ] OR .CURDO[MATRLZCTLONLY]);
				A1NODE = .CURDO[DOCTLVAR];
			END;
			CGOPGEN();

%1206%			! If a zero trip label is required, put one out.
%1206%			! Also make sure that the final loop value gets
%1206% 			! generated - handle all the various cases.

%1206%			IF .CURDO[DOZTRLABEL] NEQ 0 
%1206%			THEN DEFLAB(.CURDO[DOZTRLABEL]);

%1276%			IF F77 THEN	! Need to get final value to variable
%2541%			IF NOT .CURDO[MAYBEZTRIP] AND .CURDO[NEDSMATRLZ]
%1206%			THEN BEGIN END ! Already got the index materialized
%1206%			ELSE	IF .CURDO[FLCWD] 	! Need to get the final value for loop variable 
%1206%				THEN
%1206%				BEGIN
%1206%					A1NODE = .CURDO[DOSYM];
%1206%					REGFORCOMP = .CURDO[DOCREG]^23;
%1206%					OPDSPIX = DOSTI;
%1206%					CGOPGEN();
%1206%				END
%1206%				ELSE
%1206%				BEGIN
%1206%					REGFORCOMP = .CURDO[DOIREG]^23;
%1206%					TREEPTR = .CURDO[DOSYM];
%1206%					OPDSPIX = STOROPIX(TREEPTR);
%1206%					CGOPGEN();
%1206%				END;
		END;	! Do loop really there test

		NXTLNK = .NXTWD[RIGHTP];
		NXTWD = .NXTLNK;

	END;	! WHILE .NXTWD NEQ 0 DO
END;	! CGDOEND;
MACRO TNAME(INDX)=

	! Defines .A00nn temp names to save the registers used in  the
	! function.  .A0002 to .A0016  are for register saves,  .A0017
	! holds the epilogue address if there are multiple entries.

%1505%	(SIXBIT '.A0000'+(((INDX) AND #70)^3)+((INDX) AND #7))$;
GLOBAL ROUTINE CGPROEPI =
BEGIN
	! Generate subroutine prologue and epilogue, using temps
	! .A0002 to .A0017

%4527%	OWN BASE ENTNAME;
%4532%	LOCAL	SAVLAB;		!Label at start of sixbit entry name
	LOCAL ARGLSTPT;
	EXTERNAL OPGADJ,A2LABEL;
	EXTERNAL OPGMVL;
%761%	EXTERNAL OPGPHR,OPGPPR,DVALU,OPINSI,CLOBBREGS;
	EXTERNAL OUTMOD,PBFPTR,PBUFF,PBOPWD,OBUFF,OBUFFA,PSYMPTR,C1H;
	EXTERNAL CSTMNT,NAME,TBLSEARCH,ENTRY,POPRET,CRETN,PROGNAME;
%761%	EXTERNAL REGFORCOMP,A1NODE,OPINDI,OPGETI;
%1505%	EXTERNAL BASE TREEPTR;
%1266%	EXTERNAL OPIND2,OPGST2,OPGSTI;
	EXTERNAL XCTFDDT;
	MAP PPEEPFRAME PBFPTR;
	EXTERNAL ARGLINKPT;
	MAP PEXPRNODE CSTMNT:A1NODE;
	MAP ARGUMENTLIST ARGLSTPT;
	MAP PEEPFRAME PBUFF;
	EXTERNAL OUTMDA,OPGIIN;

	PBFPTR[PBFISN] = NOISN;	! Remove the seq number from the next instr
				! (instead it will go on the 1st instr after
				! the entry pt)

	JUMPABOUT = 0;	! If an entry then JRST around prologue	and epilogue

	IF .CSTMNT[SRCID] EQL SFNID THEN
	BEGIN
		JMPSFN = GENLAB();
		JRSTGEN(.JMPSFN);

		! Use A1NODE as a temp to make and save the label for the sfn
		! that will be used in the PUSHJ at reference time

		A1NODE = .CSTMNT[SFNNAME];
		A1NODE[IDSFNLAB] = GENLAB();
	END;

	IF .CSTMNT[ENTNUM] NEQ 0 AND .CSTMNT[SRCID] NEQ SFNID
	THEN
	BEGIN
		JUMPABOUT = GENLAB();
		JRSTGEN(.JUMPABOUT);
	END;

	! Output any instrs remaining in the peephole buffer (and initialize
	! the ptr to next available wd in buffer to the 1st wd of buffer

	IF .PBFPTR NEQ PBUFF
	THEN
	BEGIN
		OUTMOD(PBUFF,(.PBFPTR-PBUFF)/PBFENTSIZE);
		PBUFF[PBFLABEL] = NOLABEL;	! Init label field of 1st instr
		PBFPTR = PBUFF;
	END;

	! Clear ISN field in peephole buffer - want the isn on the 1st instr,
	! not on the sixbit

	PBFPTR[PBFISN] = NOISN;

	! Output sixbit for the entry name. use the output routine OBUFFA to
	! bypass the peephole optimizer

	ENTNAME = .CSTMNT[ENTSYM];
%4532%	DEFLAB(SAVLAB = GENLAB());	!Generate and put out label at
%4532%					!beginning of entry name
%4532%					!Store name in SAVLAB
	PSYMPTR = PBF2NOSYM;		!Don't relocate this word
%4532%
%4532%	INCR I FROM 0 TO .ENTNAME[IDSYMLENGTH]-1 ! Output name
%4532%	DO 	!Loop to output name
%4532%	BEGIN
%4532%		PBOPWD = @(.ENTNAME[IDSYMPOINTER] + .I);
%4532%		OBUFFA();
%4532%	END;
%4532%	PBOPWD = 0;	!Follow name by a zero word
%4532%	OBUFFA();	
%4532%
%4532%	PBOPWD = .SAVLAB;	!Label at start of entry name
%4532%	PSYMPTR = PBFLABREF;	!PBOPWD contains label table entry
	OBUFFA();

	! Must now clear the peephole buffer again before start peepholing

	IF .PBFPTR NEQ PBUFF
	THEN
	BEGIN
		OUTMDA(PBUFF,(.PBFPTR - PBUFF) / PBFENTSIZE);
		PBFPTR = PBUFF;
		PBUFF[PBFLABEL] = NOLABEL;
	END;

	! There should be only one subroutine or function per compilation unit.
	! Save the epilogue address if necessary, make the entry name a global
	! for LINK

	IF .CSTMNT[SRCID] NEQ SFNID
	THEN
	BEGIN
		PBOPWD = .CSTMNT[ENTSYM];
		PSYMPTR = PBFENTRY;
		OBUFF();
	END
	ELSE
	BEGIN
		A1NODE = .CSTMNT[SFNNAME];
		DEFLAB(.A1NODE[IDSFNLAB]);
	END;

	PBFPTR[PBFISN] = .CSTMNT[SRCISN];	! Internal seq number of the entry
					! stmnt goes on the 1st instruction
					! of the entry sequence

	! If the user specified /DEB:TRACE, generate "XCT FDDT."

	IF .FLGREG<DBGTRAC> THEN XCTFDDT();

	! Define the epilogue label

	EPILAB = GENLAB();

	IF .FLGREG<MULTENT>
	THEN
	BEGIN	! If multiple entries

		REGFORCOMP = 1^23;	! Hope to generate MOVEM 1, A0017
		A1LABEL = .EPILAB;
		OPDSPIX = OPGMVL;
		NAME = IDTAB;
%4515%		ENTRY[0] = ONEWPTR(TNAME(#17));
		A1NODE = TBLSEARCH();
%1505%		A1NODE[IDPSECT] = PSDATA;	! .A0017 goes in .DATA.

		CGOPGEN();
	END;

	! Save register 16 except if its a statement function or a function
	! that does not call FOROTS or any other functions use PUSH for sfn
	! MOVEM otherwise

	IF .CSTMNT[SRCID] EQL SFNID
	THEN	OPDSPIX = OPGPHR	! Store the other regs using PUSH
	ELSE	IF NOT (.BTTMSTFNFLG AND .IOFIRST EQL 0 AND NOT .LIBARITHFLG)
		THEN
		BEGIN
%761%			OPDSPIX = OPGSTI;
			NAME = IDTAB;
%4515%			ENTRY[0] = ONEWPTR(TNAME(#16));
			TREEPTR = TBLSEARCH();
%1505%			TREEPTR[IDPSECT] = PSDATA;	! .A0016 goes in .DATA.

			REGFORCOMP = #16^23;
			CGOPGEN();
		END
%761%		ELSE OPDSPIX = OPGSTI;	! Will store any other regs using MOVEM

	! Now if it is a function

	IF .FLGREG<PROGTYP> EQL FNPROG
	THEN	DECR I FROM LASTONE(.CLOBBREGS) TO 2 DO
		BEGIN
			IF .CSTMNT[SRCID] EQL ENTRID THEN
			BEGIN
				NAME = IDTAB;
%4515%				ENTRY[0] = ONEWPTR(TNAME(.I));
				TREEPTR = TBLSEARCH();
%1505%				TREEPTR[IDPSECT] = PSDATA;	! In .DATA.
			END;
			REGFORCOMP = .I^23;
			CGOPGEN();
		END;

	! Move args to temps - address of temp is in symbol table for argument

	REGFORCOMP = 0;

%1401%	IF .CSTMNT[ENTLIST] NEQ 0 THEN
	BEGIN
%1401%		ARGLSTPT = .CSTMNT[ENTLIST];
		INCR I FROM 1 TO .ARGLSTPT[ARGCOUNT] DO
		BEGIN	! Walk down args

			TREEPTR = A1NODE = .ARGLSTPT[.I,ARGNPTR];

			IF .A1NODE NEQ 0 THEN		! Zero means label
			IF NOT .ARGLSTPT[.I,ENTNOCOPYFLG]
			THEN
			BEGIN	! Local copy is to be made of this param

%1266%				! For character formals copy the descriptor
%1266%				! Always copy the byte pointer, copy the length
%1266%				! if the formal is length *

%1266%				IF .A1NODE[VALTYPE] EQL CHARACTER
%1266%				THEN
%1266%				BEGIN
%1266%					IF .A1NODE[IDCHLEN] EQL LENSTAR
%1266%					THEN	OPDSPIX = OPIND2	! Copy BP and length
%1266%					ELSE	OPDSPIX = OPINDI;	! Copy BP only
%1266%					C1H = INDBIT OR (.I - 1);	! Set indirect bit and Y field
%1266%				END
%1266%				ELSE
%1266%				BEGIN	! Not character

					IF .A1NODE[OPR1] EQL OPR1C(DATAOPR,FORMLVAR)
					THEN
					BEGIN	! Move value of scalar to register

%761%						OPDSPIX = .A1NODE[VALTP1] + OPINDI;
%761%						C1H = INDBIT OR (.I-1);
					END
					ELSE
					BEGIN
						OPDSPIX = OPGIIN;
						C1H = INDBIT OR (.I-1);
					END
%1266%				END;	! Not character

				! Pick up register from entac field

				REGFORCOMP = .ARGLSTPT[.I,ENTAC]^23;
				CGOPGEN();	! Value now in a register

				! Now store value or pointer in temp

%1266%				IF .A1NODE[VALTYPE] EQL CHARACTER
%1266%				THEN	IF .A1NODE[IDCHLEN] EQL LENSTAR
%1266%					THEN	OPDSPIX = OPGST2	! Copy BP and length
%1266%					ELSE	OPDSPIX = OPGSTI	! Copy BP only
%1266%				ELSE	IF .A1NODE[OPR1] EQL OPR1C(DATAOPR,FORMLVAR)
%761%					THEN	OPDSPIX = .A1NODE[DBLFLG]+OPGSTI
%761%
					ELSE	OPDSPIX = OPGSTI;

				! Only do store if not globally allocated

				IF NOT .ARGLSTPT [.I, ENTGALLOCFLG]
%2563%				THEN
%2563%				BEGIN
%2563%					LOCAL	IBIT;
%2563%					IBIT = .A1NODE[TARGIF];
%2563%					A1NODE[TARGIF] = 0;
%2563%	 				CGOPGEN ();
%2563%					A1NODE[TARGIF] = .IBIT;
%2563%				END;
			END;	! Local copy is to be made of this param
		END;	! Walk down args
	END;

	! Now generate JRST to first executable statement

	!**********************************************************************
	!**********************************************************************
	! This JRST  is special.  If we  are going  to create  a  jump
	! vector for  multiple returns,  we must  output the  peephole
	! buffer before  generating  the JRST.  Else,  it would  be  a
	! labeled JRST and  receive cross-jumping optimization.  Since
	! the peephole optimizer always looks  at the third from  last
	! instruction, making it  the first  instruction will  inhibit
	! the peephole.
	!**********************************************************************
	!**********************************************************************

	IF .JUMPABOUT EQL 0 THEN JUMPABOUT = GENLAB();	! Already have label if
							! jumpabout is set

	! If there were label dummy args

	IF .FLGREG<LABLDUM>
	THEN
	BEGIN	! Make this JRST the base of the jump vector so we dont waste a space
		!*****************************************
		! Here is the special output of the buffer
		!*****************************************

		OUTMOD(PBUFF,(.PBFPTR-PBUFF)/PBFENTSIZE);
		PBFPTR = PBUFF;
		PBUFF[PBFLABEL] = NOLABEL;

		JMPVECT = GENLAB();
		DEFLAB(.JMPVECT);
	END;

	! Now JRST to first executable if there are label args (and hence a
	! jump vector) or multiple entries.  This entry follows the prologue

	IF .FLGREG<LABLDUM> OR .FLGREG<MULTENT> THEN JRSTGEN(.JUMPABOUT);

	! Now the rest of the jump vector if needed

	IF .CSTMNT[SRCID] NEQ SFNID	! Don't need it if it's an arithmetic statement function
	THEN	
	BEGIN
		LABARGCT = 0;
		IF .FLGREG<LABLDUM>
		THEN
		BEGIN
			! First output the JRST, it must go thru OUTMOD.
	
			OUTMOD(PBUFF,1);
			PBFPTR = PBUFF;
			PBUFF[PBFLABEL] = NOLABEL;
	
%1401%			IF .CSTMNT[ENTLIST] NEQ 0 THEN
			BEGIN
%1401%				ARGLSTPT = .CSTMNT[ENTLIST];
				INCR I FROM 1 TO .ARGLSTPT[ARGCOUNT] DO
				BEGIN
					IF .ARGLSTPT[.I,ARGNPTR] EQL 0
					THEN	! It is a label
					BEGIN
						! Generate @N-1(16) (which is
						! added to the value of the
						! are list base by a RETURN N)

						LABARGCT = .LABARGCT+1;
%1401%						PSYMPTR = PBF2NOSYM;
%1401%						PBOPWD=(#36^18) OR (.I-1);
%1401%						OIFIW()
					END;
				END;
			END;

			! Now output the jump vector through outmda
	
			OUTMDA(PBUFF,.LABARGCT);
			PBFPTR = PBUFF;
	
		END;
	END;	! End of if statement function

	! For multiple entry subroutines, generate the epilogue right after
	! the prologue for each entry

	IF .FLGREG<MULTENT> THEN CGEPILOGUE(.CSTMNT);

	! Define label of first executable statement

	DEFLAB(.JUMPABOUT);

	! If there are multiple entries (the return will be an indirect JRST)
	! then make EPILAB point to the temp in which the epilogue address is
	! stored.

	IF .FLGREG<MULTENT> THEN
	BEGIN
		NAME = IDTAB;
%4515%		ENTRY[0] = ONEWPTR(TNAME(#17));
		EPILAB = TBLSEARCH();
	END;
END;	! CGPROEPI
GLOBAL ROUTINE CGEPILOGUE(ENTSTMN)=
BEGIN
	! Routine to generate code for function/subroutine epilogue. ENTSTMN
	! points to the entry statement to which this epilogue corresponds

	EXTERNAL A1NODE,C1H,REGFORCOMP;
	EXTERNAL PROGNAME;
	MAP PEXPRNODE A1NODE;
%761%	EXTERNAL OPGETI,POPRET,CRETN,OPINSI,OPGPPR;
	EXTERNAL CLOBBREGS,TBLSEARCH;
	EXTERNAL NAME;
	MAP BASE ENTSTMN;
	REGISTER ARGUMENTLIST ARGLSTPT;

	DEFLAB(.EPILAB);	! Define the epilogue label

	! Restore register 16. Statement functions and bottommost functions
	! won't restore 16 

	IF .ENTSTMN[SRCID] NEQ SFNID
		AND (NOT .BTTMSTFNFLG OR .IOFIRST NEQ 0 OR .LIBARITHFLG)
	THEN
	BEGIN
		NAME = IDTAB;
%4515%		ENTRY[0] = ONEWPTR(TNAME(#16));
		A1NODE = TBLSEARCH();
%761%		OPDSPIX = OPGETI;
		REGFORCOMP = #16^23;
		CGOPGEN();
	END;

	! For labels as parameters generate the complex return

	IF .FLGREG<LABLDUM>
	THEN
	BEGIN
		A2LABEL = .JMPVECT;
		A1LABEL = GENLAB();	! Label for out of bounds
		C1H = .LABARGCT;
		OPDSPIX = CRETN;
		CGOPGEN();
		DEFLAB(.A1LABEL);
	END;

	! Now move scalars back. Not necessary for  statement functions

%1401%	IF .ENTSTMN[ENTLIST] NEQ 0 AND .ENTSTMN[SRCID] NEQ SFNID
	THEN
	BEGIN
		REGFORCOMP = 0;
%1401%		ARGLSTPT = .ENTSTMN[ENTLIST];
		INCR I FROM 1 TO .ARGLSTPT[ARGCOUNT] DO
		BEGIN	! Walk down args

			A1NODE = .ARGLSTPT[.I,ARGNPTR];

			IF .A1NODE NEQ 0 THEN
			IF NOT .ARGLSTPT[.I,ENTNOCOPYFLG]
			THEN
			BEGIN	! Local copy was made of this param

				! Only move them back if they were stored into,
				! else we are in trouble with generating hiseg
				! stores. Never copy back character descriptors

				IF .A1NODE[IDATTRIBUT(STORD)] THEN
%1266%				IF .A1NODE[VALTYPE] NEQ CHARACTER THEN
				IF .A1NODE[OPR1] EQL OPR1C(DATAOPR,FORMLVAR) THEN
				IF NOT .ARGLSTPT[.I,ENTGALLOCFLG] THEN
				BEGIN
					! Local case - set regforcomp.
					! Things are different if global
					! allocation of an argument has
					! occurred

					REGFORCOMP = (IF .ENTSTMN[VALINR0] THEN
					1^23 ELSE 0);
					C1H = INDBIT OR (.I-1);
%761%					OPDSPIX = .A1NODE[VALTP1]+OPGETI;
					CGOPGEN();
%761%					OPDSPIX = .A1NODE[DBLFLG]+OPINSI;
					CGOPGEN();
				END
				ELSE
				BEGIN	! Globally allocated

					REGFORCOMP = .ARGLSTPT[.I,ENTAC]^23;
					C1H = INDBIT OR (.I-1);
%761%					OPDSPIX = .A1NODE[DBLFLG]+OPINSI;
					CGOPGEN();
				END;
			END;	! Local copy was made of this param
		END;	! Walk down args
	END;

	IF .ENTSTMN[SRCID] EQL SFNID	! Restore registers if need be
	THEN	OPDSPIX = OPGPPR
%761%	ELSE	OPDSPIX = OPGETI;

	NAME = IDTAB;

	IF .FLGREG<PROGTYP> EQL FNPROG
	THEN
	BEGIN
		!******************************************************
		! Since statement functions PUSH and POP for register
		! save and restore, these must be symetrically reversed
		! to the save code in the prologue
		!******************************************************

		INCR I FROM 2 TO LASTONE(.CLOBBREGS) DO
		BEGIN
			IF .ENTSTMN[SRCID] EQL ENTRID THEN
			BEGIN
%4515%				ENTRY[0] = ONEWPTR(TNAME(.I));
				A1NODE = TBLSEARCH();
			END;

			REGFORCOMP = .I^23;
			CGOPGEN();
		END;

		A1NODE = .ENTSTMN[ENTSYM];	! Name of fn

		IF NOT .A1NODE[IDATTRIBUT(STORD)]
			AND NOT .ENTSTMN[SRCID] EQL SFNID
		THEN FATLERR(.ISN,E131<0,0>);	! If the value is never stored

%1422%		! Pick up return function value  for if not already put  there
%1422%		! by global allocator.  Don't  do it for character  functions.
%1422%		! Character functions have  the descriptor for  the result  as
%1422%		! their first argument.

%1422%		IF NOT .ENTSTMN[VALINR0] THEN
%1422%		IF .A1NODE[VALTYPE] NEQ CHARACTER
		THEN
		BEGIN
			REGFORCOMP = 0;
%761%			OPDSPIX = .A1NODE[VALTP1]+ OPGETI;
			CGOPGEN();
		END;
	END;	! FNPROG

	OPDSPIX = POPRET;
	CGOPGEN();
END;	! CGEPILOGUE
MACRO JRSTIVAR(ADDR)=
BEGIN

	! Macro to generate an indirect JRST through a variable.
	! Differs from JRSTIGEN in the setting of PSYMPTR

	PBOPWD = JRSTOC OR INDBIT OR ADDR[IDADDR];
	PSYMPTR = ADDR;
	OBUFF();
END$;
GLOBAL ROUTINE CGRETURN(EXPR) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine  generates code  for RETURN  statements.  If  the
!	RETURN is a plain  RETURN right before  the END statement,  no
!	code is  generated  since  the  code  generated  for  the  END
!	statement will perform the RETURN.
!
!	If the  RETURN  is in  a  main  program, CGEND  is  called  to
!	generate code  for CALL  EXIT. (which  is how  a main  program
!	ends).
!
!	If the RETURN is in a routine without dummy label  parameters,
!	it generates a JRST to the epilogue label (indirectly  through
!	.A0017 if it has multiple ENTRY points).
!
!	If  the  RETURN  is  in  a  routine  which  has  dummy   label
!	parameters, it moves the  alternate RETURN index (defaults  to
!	zero for a plain RETURN) to AC 1, then generates a JRST to the
!	epilogue label as above.
!
! FORMAL PARAMETERS:
!
!	EXPR		Points to the return expression (0 if none)
!
! IMPLICIT INPUTS:
!
!	CSTMNT		Points to the current statement
!
!	EPILAB		Points to the epilogue label of the current program
!			unit
!
!	FLGREG		Flag register; contains information about current
!			program unit
!
! IMPLICIT OUTPUTS:
!
!	A1NODE		Points to first argument of expression
!
!	OPDSPIX		Pointer into the OPGENTABLE dispatch table
!
!	REGFORCOMP	Bits 9-12 indicate the register to be used in
!			the computation for which code is being generated
!
!	TREEPTR		Points to expression to be evaluated
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--


![2313] Rewritten

BEGIN
	MAP BASE EXPR;			! EXPR is 0 or points to an expression

	REGISTER BASE NXTSTMNT;		! Used for pointer to next statement

	IF NOT .FLGREG<LABLDUM>		! Are dummy labels absent?
	THEN IF .EXPR NEQ 0		! Yes, do we have an expression?
	THEN FATLERR(.ISN, E130<0,0>);	! Yes, give an error message

	! Check to see if we have a plain RETURN right before the  END
	! statement.  If so, we won't bother to generate any code  for
	! the RETURN.

	IF .EXPR EQL 0					! Plain RETURN?
	THEN IF (NXTSTMNT = .CSTMNT[SRCLINK]) NEQ 0	! Yes, check next stmnt
	THEN
	BEGIN	! Plain RETURN with non-zero SRCLINK

		! We have a plain RETURN which is not the branch of  a
		! logical IF and we're not being called by CGEND.  See
		! if we're at the last  statement in the program  unit
		! before the END statement.

		! Skip  the   CONTINUE  statement   inserted  by   the
		! optimizer (if any).  Make sure it's a dummy CONTINUE
		! by checking for a zero source statement number.

		IF .NXTSTMNT[SRCID] EQL CONTID		! Is next a CONTINUE?
		THEN IF .NXTSTMNT[SRCISN] EQL 0		! Yes, is ISN zero?
		THEN NXTSTMNT = .NXTSTMNT[SRCLINK];	! Yes, skip it

		! If next statement  is the END  statement then  don't
		! generate the RETURN.   It will  be part  of the  END
		! code.

		IF .NXTSTMNT[SRCID] EQL ENDID	! Is the next stmnt the END?
		THEN RETURN;			! Yes, don't bother

	END;	! Plain RETURN with non-zero SRCLINK

	! A RETURN that appears in a main program will be treated like
	! a CALL EXIT. by CGEND.

	IF .FLGREG<PROGTYP> EQL MAPROG
	THEN
	BEGIN	! Main program

		CGEND();	! Generate the call to EXIT.
		RETURN;		! Done

	END;	! Main program

	IF .FLGREG<LABLDUM>	! Do dummy labels exist?
	THEN
	BEGIN	! Dummy labels exist

		IF .EXPR EQL 0			! Plain RETURN?
		THEN OPDSPIX = OPGZER		! Yes, treat as RETURN 0
		ELSE
		BEGIN	! We have an expression

			IF .EXPR[OPRCLS] NEQ DATAOPR
			THEN
			BEGIN	! Must evaluate

				TREEPTR = .EXPR;	! Evaluate EXPR
				CGETVAL();		! Do it

			END;	! Must evaluate

			A1NODE = .EXPR;		! Source is EXPR
			OPDSPIX = OPGETI;	! Get in register (one word,
						! no flags)

		END;	! We have an expression

		REGFORCOMP = 1^23;	! Destination is AC 1
		CGOPGEN();		! Move alternate RETURN index

	END;	! Dummy labels exist

	IF .FLGREG<MULTENT>		! Do multiple entries exist?
	THEN JRSTIVAR(.EPILAB)		! Yes, generate indirect jump
	ELSE JRSTGEN(.EPILAB);		! No, generate direct jump

END;	! of CGRETURN
GLOBAL ROUTINE CGSFN=
BEGIN

%1455%	! Rewritten by TFV on 5-Jan-82

	! Code generation for statement function

	OWN
		OCSTMNT,
		OCLOBB,
		OPRGM,
		OPE,
		SFNSYM,
		OEPILB;

	MAP
		BASE CSTMNT,
		BASE SFNSYM;

	! Save away pertinent globals

	OCLOBB = .CLOBBREGS;	! Current set of clobbered registers
	OPRGM = .PROGNAME;	! Program name for this unit
	OPE = .FLGREG<0,36>;	! Current flag register
	OCSTMNT = .CSTMNT;	! Current statement pointer
	OEPILB = .EPILAB;	! Current epilog label

	! Adjust flgreg

	FLGREG<PROGTYP> = FNPROG;	! This is a function subprogram
	FLGREG<MULTENT> = 0;		! Statement functions have one entry
	FLGREG<LABLDUM> = 0;		! No dummy labels

	! Setup clobbregs  with  registers clobbered  by  the  statement
	! function

	CLOBBREGS<LEFT> = .CSTMNT[SFNCLBREG];

	! Get the statement function name -  it is put out in SIXBIT  to
	! the .REL file for traceback

	SFNSYM = .CSTMNT[SFNNAME];
	PROGNAME = .SFNSYM[IDSYMBOL];	

	CGPROEPI();			! Generate prologue & epilogue
	CSTMNT = .CSTMNT[SFNEXPR];	! Get the assignment or call node

	IF .SFNSYM[VALTYPE] EQL CHARACTER
	THEN
	BEGIN	! Generate code for a call

		! Generate code for any common subs

		IF .CSTMNT[SRCCOMNSUB] NEQ 0 THEN CGCMNSUB();

		! Generate code for the call to CHSFN. or CHSFC.

		CGSBPRGM(.CSTMNT[CALLIST],.CSTMNT[CALSYM]);	

	END	! Generate code for a call
	ELSE	CGASMNT();		! Generate code for an assignment

	CGEPILOGUE(.OCSTMNT);		! Generate the epilogue code

	! Restore the saved globals

	CLOBBREGS = .OCLOBB;		! Clobbered registers
	PROGNAME = .OPRGM;		! Program name
	FLGREG<0,36> = .OPE;		! Flag register
	CSTMNT = .OCSTMNT;		! Current statement
	EPILAB = .OEPILB;		! Epilog label

	DEFLAB(.JMPSFN);	! Define the label for the start of  the
				! statment function

END;	! CGSFN
GLOBAL ROUTINE CGSBPRGM(ARLISTT,NAMEP)=
BEGIN
!++
! Perform vital code generation for argument lists of
!	o subroutine calls,
!	o function references,
!	o library function references,
! 	o statement function references.
!
! ARLISTT is a pointer to the argument list.
! NAMEP is a pointer to  the symbol table entry for the routine name.
!--
	MAP	BASE NAMEP,
		ARGUMENTLIST ARLISTT;

	LOCAL
%1533%		HASMULTRETS,	! Flag for has multiple returns
%1533%		JRSTPAST;	! The label for the instruction after the error
%1533%				! handling code

	REGISTER
		BASE ARGNODE,	! Argument node in the arg list
%1533%		MARK,		! The ARGMARK field
%1533%		CURLBL;		! The label for the current location


%1533%	HASMULTRETS = FALSE;

%2245%	IF .ARLISTT NEQ 0
	THEN
	BEGIN	! arguments present

%1533%		! If there  are  dynamic  concatenations  as  arguments,
%1533%		! generate the CHMRK. call

%1533%		MARK = .ARLISTT[ARGMARK];
%1533%		IF .MARK NEQ 0 THEN CGCHMRK(.MARK);

		ARLISTT[ARGLINK] = .ARGLINKPT;
		ARGLINKPT = .ARLISTT;

		INCR I FROM 1 TO .ARLISTT[ARGCOUNT] DO
		BEGIN	! Generate code to evaluate arguments

			ARGNODE = .ARLISTT[.I,ARGNPTR];	! Pick up arg ptr

%1533%			! Set the flag if an argument is a label

%1533%			IF .ARGNODE[OPRCLS] EQL LABOP
%1533%			THEN HASMULTRETS = TRUE;

			IF NOT .ARLISTT[.I,AVALFLG]
			THEN
			BEGIN	! Not DATAOPR
				TREEPTR = .ARGNODE;
				CGETVAL();
			END
			ELSE
			BEGIN	! DATAOPR

				! If its a register and a library  function
				! stash  it  away  in  memory.  If  it's  a
				! register and not a library function  then
				! you lose

				IF .ARGNODE[OPRCLS] EQL REGCONTENTS THEN
				BEGIN
					MAP PEXPRNODE TREEPTR;
					TREEPTR = .ARGNODE[ARG2PTR];
					REGFORCOMP = .ARGNODE[TARGTAC]^23;
					OPDSPIX = STOROPIX(TREEPTR);
					CGOPGEN();

					! Take the regcontents node out
					! so the arg list will be right

					ARLISTT[.I,ARGNPTR] = .ARGNODE[ARG2PTR];
				END;
			END;	! DATAOPR
		END;	! Generate code to evaluate arguments


		! If there are arguments, then generate a label for  the
		! argument list.  If not, then  use the shared zero  arg
		! block.

%2245%		IF .ARLISTT[ARGCOUNT] NEQ 0 THEN
			A1LABEL = ARLISTT[ARGLABEL] = GENLAB()	! Gen label
%2245%		ELSE
%2245%		BEGIN	! No arguments
%2245%			NEDZER  =  1;		! Flag zero-arg-block needed
%2245%			A1LABEL = ARLISTT[ARGLABEL] = .ZERBLK;
%2245%		END;

	END	! arguments present
	ELSE
	BEGIN	! No arguments

%1533%		MARK = 0;	! No argument list

		! Reference a common 2 word zero arg block, defined once
		! per program unit.

		NEDZER  =  1;		! Flag zero-arg-block needed
		A1LABEL = .ZERBLK;
	END;

	! For a formal function set the indirect bit in the symbol table
%1455%	! Do not set the indirect bit for character statement functions

%1455%	IF (.NAMEP[IDATTRIBUT(DUMMY)] AND NOT .NAMEP[IDATTRIBUT(SFN)])
	THEN NAMEP[TARGET] = .NAMEP[TARGET] OR INDBIT;

	IF .NAMEP[IDATTRIBUT(SFN)]
	THEN
	BEGIN
		A2LABEL = .NAMEP[IDSFNLAB];
		OPDSPIX = OPGSFN;
	END
	ELSE
	BEGIN
		A1NODE = .NAMEP;
		OPDSPIX = CALLER;
	END;

	CGOPGEN();	! Generate the subprogram call

%1533%	! If there are dynamic concatenations as arguments, generate the
%1533%	! CHUNW. call

%1533%	IF .MARK NEQ 0 THEN CGCHUNW(.MARK);

%1533%	! If there are multiple returns, generate special error handling
%1533%	! code

%1533%	IF .HASMULTRETS
%1533%	THEN 	IF .MARK NEQ 0
%1533%	THEN
%1533%	BEGIN	! Multiple returns

%1533%		! Generate a  label for  the  location after  the  error
%1533%		! handling code

%1533%		JRSTPAST = GENLAB();

%1533%		JRSTGEN(.JRSTPAST);	! Generate JRST JRSTPAST

%1533%		INCR I FROM 1 TO .ARLISTT[ARGCOUNT]
%1533%		DO
%1533%		BEGIN	! Walk down arguments to generate error handling code

%1533%			ARGNODE = .ARLISTT[.I,ARGNPTR];	! Pointer to argument

%1533%			IF .ARGNODE[OPRCLS] EQL LABOP
%1533%			THEN
%1533%			BEGIN	! Argument is a multiple return

%1533%				! Generate a label for the current address

%1533%				CURLBL = GENLAB();
%1533%				DEFLAB(.CURLBL);

%1533%				! Replace the user specified label with the
%1533%				! compiler generated one

%1533%				ARLISTT[.I,ARGNPTR] = .CURLBL;

%1533%				! Generate the CHUNW. call

%1533%				CGCHUNW(.MARK);

%1533%				! Generate JRST user_label

%1533%				JRSTGEN(.ARGNODE);

%1533%			END;	! Argument is a multiple return

%1533%		END;	! Walk down arguments to generate error handling code

%1533%		DEFLAB(.JRSTPAST);	! Define the label for the instruction
%1533%					! after the error handling code.

%1533%	END;

END;	! CGSBPRGM
GLOBAL ROUTINE ARGGEN(PTR)=

!++
! FUNCTIONAL DESCRIPTION:
!
!	Generate an arg block entry for an expression node.  Unlike
!	FOROTS arg block generation (IOPTR), this routine does not
!	allow its caller to fill in any of the fields in PBOPWD.
!
! FORMAL PARAMETERS:
!
!	PTR		Points to expression node for argument.
!
! IMPLICIT INPUTS:
!
!	EVALU		Used to map PTR[VALTYPE] into argument type code.
!
! IMPLICIT OUTPUTS:
!
!	PBOPWD		Destroyed.
!
!	PBUFF		Peephole buffer gets the finished arg block word.
!
!	PSYMPTR		Destroyed.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Could flush the peephole buffer into the object and listing files.
!
!--


![1401] Rewritten to support extended addressing

BEGIN

!=========================================================================!
!1!0!      0      ! Type  !I! Index  !              Address               !
!=========================================================================!

MAP PEXPRNODE PTR;			! Points to the expression

	PBOPWD = 0;			! Start out with an empty word

	![1524] If PTR is not character then we want to set the
	![1524] indirect bit if it is a formal function name.

	! [Remark by RVM: I don't understand this comment.]

	! The indirect bit may already have been set if it was
	! previously referenced as a formal function.  Thus we set the
	! bit explicitly.

%2317%	IF .PTR[OPRCLS] EQL DATAOPR
%1524%	THEN IF .PTR[VALTYPE] NEQ CHARACTER
	THEN IF (.PTR[FORMLFLG] AND .PTR[IDATTRIBUT(INEXTERN)])
	THEN PBOPWD[OTSIND] = 1;

	IF .PTR[OPRCLS] EQL LABOP
	THEN PBOPWD[OTSTYPE]=ADDRTYPE
%1002%	ELSE PBOPWD[OTSTYPE]=.EVALU[.PTR[VALTYPE]];

%2317%	PBOPWD[OTSIFIW] = 1;		! Make the word an IFIW
%2462%	GENREF(.PTR,TRUE);		! Construct memory reference for
					!  argument word and buffer it
END;	! ARGGEN
GLOBAL ROUTINE CGARGS=
BEGIN

![1401] Rewritten to support extended addressing

!++
! At the  end of  a block,  generate any  argument lists  that have  not
! already been  generated.  They  are on  a linked  list pointed  to  by
! ARGLINKPT.  The object code for an arg  list is a labeled vector of  n
! IFIWs to  arguments,  preceeded by  "-n,,0".   The routine  ARGGEN  is
! called to output words that point to the arguments.
!--

	REGISTER ARGCT;			! Will hold number of args
%1437%	REGISTER BASE LABTAB;		! Label table entry
%1437%	REGISTER ARGUMENTLIST ARGLSTPT;	! Arg blocks pointed to by ARGLINKPT


%1437%	ARGLSTPT = .ARGLINKPT;		!The global pointer to all arguments

%1437%	WHILE .ARGLSTPT NEQ 0
	DO
	BEGIN	! For all arg lists . . .

		! Watch out for statements that may have been deleted by
		! folding.  ARGLABEL is 0 for these statements.
%2245%		! Also do not generate an argument block if there are no
%2245%		! arguments.  This  could  exist for  argument  checking
%2245%		! purposes.

		IF .ARGLSTPT[ARGLABEL] NEQ 0
%2245%			AND .ARGLSTPT[ARGCOUNT] NEQ 0	! Any arguments?
		THEN
		BEGIN	! Generate argument block

			ARGCT=.ARGLSTPT[ARGCOUNT];
			PBOPWD=(-.ARGCT)^18;		! -n,,0
			PSYMPTR=PBF2NOSYM;
			OBUFFA();			! Write out count word

			! Save away  the  location  of the  call  using  the
			! label, which is the last reference.  Make sure the
			! label's been referenced, but not resolved.

%1437%			IF .FLGREG<OBJECT>
%1437%			THEN		!.REL file
%1437%			BEGIN
%1437%				LABTAB = .ARGLSTPT[ARGLABEL];
%1437%				IF .LABTAB[SNDEFINED] AND	!Referenced
%1437%				(.LABTAB[SNSTATUS] EQL UNRESOLVED)!Not resolved
%1526%				THEN	ARGLSTPT[ARGCALL] = .LABTAB[SNADDR]
%1437%				ELSE	CGERR();
%1437%			END;

%1437%			!** Here the label is defined***
			DEFLAB(.ARGLSTPT[ARGLABEL]);	! "nnnnnM:"

%4532%			IF NOT PROSBARGLIST(.ARGLSTPT)
%4532%			THEN
%1466%			INCR I FROM 1 TO .ARGCT	! Write out each arg
			DO ARGGEN(.ARGLSTPT[.I,ARGNPTR]);

		END;	! Generate argument block

%1437%		ARGLSTPT = .ARGLSTPT[ARGLINK]		! Move to next arg list

	END	! For all arg lists . . .

END;	! of CGARGS

ROUTINE PROSBARGLIST (ARGLST) = 

!++
! FUNCTIONAL DESCRIPTION:
!
!	Checks if ARGLST is the argument list for a call to PROSB.
!	If it is then the fifth and last argument in the argument list is a
!	constant table entry containing a count and pointer to a symbol.
!	This fifth argument must be changed to a address of the sixbitz symbol.
!
! FORMAL PARAMETERS:
!
!	ARGLST		an argument list
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	True if ARGLST is the argument list for a PROSB. call
!	False otherwise
!
! SIDE EFFECTS:
!
!	None
!
!--



BEGIN	!New [4532] 
	MAP 	ARGUMENTLIST ARGLST;	! argument block being generated by CGARGS
	LOCAL BASE TEMP;

	TEMP = .ARGLST[ARGPARENT];	!Parent of arg list

	IF .TEMP[OPRCLS] NEQ FNCALL OR .TEMP[OPERSP] NEQ LIBARY
	THEN RETURN 0;

	TEMP = .TEMP[ARG1PTR];		!Name of library function

	IF .TEMP[ID1ST6CHAR] NEQ SIXBIT 'PROSB.'	!Not PROSB.
	THEN RETURN 0;

	INCR I FROM 1 TO 4		! Write out each arg
	DO ARGGEN(.ARGLST[.I,ARGNPTR]);

	PBOPWD = TEMP = GENLAB();	!Label where symbol starts
	PBOPWD[OTSTYPE] = SIXBITZTYPE;	! Type is pointer to sixbitz string
	PBOPWD[OTSIFIW] = 1;		! Make the word an IFIW
	PSYMPTR = PBFLABREF;		!PBOPWD contains label table entry
	GENREF(.TEMP,TRUE);		!Generate the reference

	DEFLAB(.TEMP);			! Define label
	TEMP = .ARGLST[5,ARGNPTR];	! Constant entry
	TEMP = .TEMP[CONST2];		! CNT,,PTR TO SYMBOL

	PSYMPTR = PBF2NOSYM;		!Don't relocate this word

	INCR I FROM 0 TO .TEMP<SYMLENGTH> - 1
	DO	!Dump out symbol
	BEGIN
		PBOPWD = @(.TEMP<SYMPOINTER> + .I);
		OBUFFA();
	END;

	PBOPWD = 0;
	OBUFFA();

	RETURN 1;	!We already generated the arglist for ARGLST

END;	!PROSBARGLIST

! Below is for RUNOFF in generating .PLM files
!++
!.END LITERAL
!--

END
ELUDOM