Google
 

Trailing-Edge - PDP-10 Archives - FORTRAN-10_Alpha_31-jul-86 - pha3.bli
There are 12 other files named pha3.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1986
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR ANY  OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
!AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

!AUTHOR: S MURPHY/SJW/EGM/CDM/AHM/MEM

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

!	REQUIRES FIRST, TABLES, REQREL

SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE 'REQREL.BLI';				![2325] REL block definitions
SWITCHES LIST;

GLOBAL BIND PHA3V = #11^24 + 0^18 + #4530;	! Version Date: 1-Jan-86

%(

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

46	-----	-----	CHANGE REFERENCES TO PROGNAME

47	-----	-----	OUTPUT THE MACRO LISTING HEADING IN PHA3 SO
			THAT THE SIXBIT FUNCTION NAME WILL FOLLOW IT

48	-----	-----	IF THE "DBGTRAC" FLAG IS SET, CALL
			INIFDDT  TO OUTPUT
			"XCT FDDT."

49	-----	-----	FIX ARGUMENT BLOCKS HEADING TO ONLY BE OUTPUT
			IF MACROCODE IS REQUESTED
50	464	QA754	HANDLE HEADINGS FOR LINE-NUMBER/OCTAL-LOCATION
			  MAP IF NO MACRO LISTING REQUESTED, (SJW)
51	476	QA754	MAKE LINE/OCTAL MAP HEADING OPTIONAL UNDER
			  /MAP=MAPFLG, (SJW)

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

52	607	22685	GENERATE ZERO-ARG-BLOCK ONLY IF NEEDED (IE, IF
			  NEDZER SET)

****** Begin version 6 ******

53	1047	EGM	22-Jan-81	Q10-05325
	Add support for TOPS-10 execute only.

****** Begin version 7 ******

1511	CDM	17-Mar-82
	Add hooks for SAVE statement processing.  Call to ZSAVEOUT  must
	be un-commented.

1521	CDM	26-Mar-82
	Add hooks for argument checking processing.  ARGCHK=TRUE sets 
	arg checking on.

1531	CDM	4-May-82
	SAVE statement code review.

1566	CDM	24-Jun-82
	Enable writable overlay block (1045 for SAVE) output.

1572	AHM	29-Jun-82
	Move check for ?Program too large from ZENDALL to MRP3 so that
	the check is performed even if object code isn't generated.

1576	AHM	7-Jul-82
	Make the compiler emit a JRST to the start address of programs
	under /EXTENDED and have ZENDALL make that the entry vector.

1614	CDM	16-Aug-82
	Moved call to ZARGCHECK from here to ZENDALL so that rel  blocks
	would be output after the symbol table was dumped.

1624	AHM	28-Aug-82
	Don't call ZSAVEOUT in MRP3 if /EXTEND was specified, since we
	don't support overlays for  extended addressing and  variables
	are always preserved when not using overlays.
	Module:
		PHA3

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

2210	AHM	27-Jul-83
	Rename DUMPDIM to DMPDIM to reserve DUMP?? for SIX12.

2325	AHM	16-Mar-84
	Create a new routine named DMPEFIW to dump the EFIW table to
	the object file.  It will output the EFIWs themselves,
	additive fixups for their references to externals, and local
	fixups to resolve references to the EFIWs from instructions
	and arg blocks.  Call DMPEFIW near the end of MRP3,
	before the call to ZENDALL.

2334	AHM	5-Apr-84
	Place the entry vector generated under /EXTEND in the lowseg.
	Generate JRST MAIN. in the first location by hand with ZCODE.

2346	AHM	23-Apr-84
	Make MRP3 in PHA3 use the new globals SCOMSZ and LCOMSZ when
	computing the sizes of the psects in the test for the "?FTNPTL
	Program too large" diagnostic.

2355	AHM	3-May-84
	Put a JRST @[REENT.##] in the second word of the entry vector
	that is generated under /EXTEND.  Also, replace magic numbers
	with symbols for all entry vector offsets.

2433	CDM	23-Jul-84
	Use VMSIZE  for  the size  of  virtual memory  in  the  decision
	whether to declare  the "Program too  large".  Should have  been
	done in edit 2322.
	Also delete use of ARGCHK, used for disabling argument  checking
	in V7 field test.  No reason to continue this!

2464	AHM	9-Oct-84
	Teach DMPEFIW that if EFFIXEDUP is zero, EFEXTERN contains the
	internal psect index to relocate EFY by.

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

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

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

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

4530	MEM	19-Feb-86
	Add long symbol support: Make STADDR global.

ENDV11
)%

FORWARD
	MRP3,
%2325%	DMPEFIW;	! Dump out the contents of the EFIW table

EXTERNAL
	CGARGS,
	CGASMNT,
	CGIOARGS,	!ROUTINES TO GENERATE ARG BLOCKS FOR
	CGOPGEN,
	CGSTMNT,
	CGSTPAUARGS,	! IO STMNTS AND STOP/PAUSE STMNTS
	CSTMNT,		! Current statement
	DEFLAB,
%2210%	DMPDIM,		!ROUTINE TO OUTPUT ALL DIMENSION INFORMATION
			! FOR ALL PROTECTED ARRAYS (FOR ALL ARRAYS
			! WHEN THE USER SPECIFIES THE "DEBUG" SWITCH)
%2334%	DMPMAINRLBF,	! Dumps the main REL buffer
	DOSP,
	DOSTAK,
%1572%	E142,		! Error message - ? Program too large
%2325%	EFIWTBL,	! Hash table of EFIWs
%2334%	ENTADDR,	! Address of entry vector
%1572%	FATLER,		! Prints error messages
	GENLAB,
	HILOC,		! Next free location in .CODE.
	INIFDDT,	!TO GENERATE "XCT FDDT."
	INIISNRLBLK,	!TO INIT  BUFFER USED FOR
			! THE LABELS INSERTED WHEN THE "DEBUG" SWITCH
			! IS SPECIFIED BY THE USER
	ISN,		!INTERNAL SEQ NUMBER OF STMNT
%1572%	LARGELOC,	! Next free location in .LARG.
%2346%	LCOMSZ,		! Sum of the sizes of all large COMMON blocks in words
	LSTFORMATS,	!TO LIST FORMAT STMNTS IN THE MACRO-EXPANDED
			! LISTING
%1572%	LOWLOC,		! Next free location in .DATA.
	NAMGEN,		!TO GENERATE NAMELIST ENTRIES
	NEDZER,		! FLAG TO INDICATE IF ZERO-ARG-BLOCK NEEDED
	OBUFF,
	OBUFFA,
%4527%	ONEWPTR,	! Returns [1,,pointer] to Sixbit argument
	OPDSPIX,
	OPGRES,
	OUTMDA,
	OUTMOD,
	PBFPTR,
	PBOPWD,
	PBUFF,
	PHAZCONTROL,
	PSYMPTR,
%2325%	RDATWD,		! Holds word destined for the REL file
%1511%	SAVNED,		! SAVE statement is needed
%2346%	SCOMSZ,		! Sum of the sizes of all small COMMON blocks in words
	SEGINCORE,
%4530%	STADDR,		!PROGRAM STARTING ADDRESS
%2433%	VMSIZE,		! Size of Virtual Memory
%2325%	Z30CODE,	! Outputs a word in a type 1030 REL block
%2334%	ZCODE,		! Outputs a word in a type 1010 REL block
%1521%	ZCOERCION,	! Puts out coercion blocks
	ZENDALL,
	ZERBLK,
%2325%	ZOUTBLOCK,	! Outputs arbitrary REL blocks
	ZOUTMSG,
%1511%	ZSAVEOUT,	! Processing for SAVE statement
%1521%	ZSFARGCHECK,	! Arg checking blocks for defn of subprograms
%2325%	ZSYMBOL;	! Outputs a type 2 or 1070 REL block

%[1047]% PORTAL ROUTINE MRP3 =
BEGIN
%(***OVERLAY TO DO CODE GENERATION****)%

	MAP PPEEPFRAME PBFPTR;
	MAP BASE CSTMNT;
	MAP PEEPFRAME PBUFF;

LOCAL
%2334%	SAVELOWLOC;		! Holds LOWLOC while ZCODE writes entry vector


	! If user  specified the  "DEBUG" switch  init buffer  used  for
	! labels inserted on each line.
	IF .FLGREG<DBGLABL> THEN INIISNRLBLK();

	! If the user specified the "TRACE" option of the DEBUG  switch,
	! init for generation of "XCT FDDT."
	IF .FLGREG<DBGTRAC> THEN INIFDDT();


	%(***INIT PTR TO DO-INFORMATION AREA***)%
	DOSP_DOSTAK;

	%(***DEFINE A LABEL TO CORRESPOND TO A ZERO-ARG-BLOCK FOR FOROTS - THIS
		ARGBLOCK WILL BE USED FOR A NUMBER OF STMNTS***)%
	NEDZER _ 0;	! INITIALIZE TO "ZERO-ARG-BLOCK NOT NEEDED"
	ZERBLK_GENLAB();

	IF .FLGREG<LISTING>
	THEN
	BEGIN
		EXTERNAL  HEADING, PAGELINE, STRNGOUT;
		IF .FLGREG<MACROCODE>
		THEN
		BEGIN
			IF (PAGELINE _ .PAGELINE - 4) LEQ 0 
			THEN
			BEGIN
				HEADING ();
				PAGELINE _ .PAGELINE - 4;
			END;
			STRNGOUT(PLIT ASCIZ '?M?J?M?JLINE	LOC	LABEL	GENERATED CODE?M?J');
		END
		ELSE
			IF .FLGREG<MAPFLG>
			THEN
			BEGIN
				IF (PAGELINE _ .PAGELINE - 7) LEQ 0
				THEN 
				BEGIN
					HEADING ();
					PAGELINE _ .PAGELINE - 7;
				END;
				STRNGOUT (PLIT ASCIZ '?M?J?M?JLINE NUMBER/OCTAL LOCATION MAP');
				STRNGOUT (PLIT ASCIZ '?M?J?M?J      : 0?I1?I2?I3?I4?I5?I6?I7?I8?I9?M?J');
				STRNGOUT (PLIT ASCIZ '------:-------------------------------------------------------------------------------');
				STRNGOUT (PLIT ASCIZ '?M?J      :?M?J00000 : ');
			END;
		END;

	CSTMNT_.SORCPTR<LEFT>;

	%(***SKIP 1ST STMNT OF PROGRAM - WHICH IS A DUMMY CONTINUE***)%
	IF .CSTMNT NEQ 0
	THEN
	CSTMNT_.CSTMNT[SRCLINK];

	PBFPTR_PBUFF;			!INIT PTR TO NEXT AVAILABLE PEEPHOLER ENTRY

	PBFPTR[PBFISN]_NOISN;		!INIT INTERNAL SEQ NO FIELD FOR 1ST INSTR

	%(****STARTING ADDRESS OF PROGRAM***)%
	STADDR _ .HILOC;

%1521%	! Output coercion block for argument type checking blocks.

%1521%	IF .FLGREG<OBJECT> THEN
%1521%	IF .FLGREG<PROGTYP> NEQ BKPROG	! Not block data program
%1521%	THEN	 ZCOERCION();


	%(***GENERATE A CALL TO RESET. AT THE BEGINNING OF THE PROGRAM***)%
	%(***FOR THE MAIN PROGRAM ONLY***)%
	IF .FLGREG<PROGTYP> EQL MAPROG THEN
	BEGIN
		OPDSPIX_OPGRES;
		CGOPGEN();
	END;


	%(***GENERATE CODE FOR ALL STMNTS OF THE PROGRAM****)%

	WHILE .CSTMNT NEQ 0
	DO
	BEGIN
		ISN_.CSTMNT[SRCISN];
		CGSTMNT();
		CSTMNT_.CSTMNT[SRCLINK];
	END;



	%(***OUTPUT ANY INSTRUCTIONS STILL REMAINING IN THE PEEPHOLE BUFFER AND SET THE
		PTR TO NEXT AVAILABLE WD OF PEEPHOLE BUFFER BACK TO THE START 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;

%1521%	! If a subroutine or function, output the arg check blocks for  the
%1521%	! definition of the subprogram

%1521%	IF .FLGREG<OBJECT> THEN
%1521%	IF .FLGREG<PROGTYP> EQL SUPROG  OR  .FLGREG<PROGTYP> EQL FNPROG
%1521%	THEN ZSFARGCHECK();



	%(***OUTPUT HEADINGS FOR ARG-BLOCKS***)%
	IF .FLGREG<LISTING> THEN
	IF .FLGREG<MACROCODE>
	THEN	
	BEGIN
		EXTERNAL  HEADING,PAGELINE,STRNGOUT;
		IF ( PAGELINE_.PAGELINE-4) LEQ 0 
		THEN	( HEADING(); PAGELINE_.PAGELINE-4);
%1521%		STRNGOUT(PLIT ASCIZ '?M?J?M?JARGUMENT BLOCKS:?M?J?M?J')
	END;


	%(***OUTPUT A "ZERO-ARG-BLOCK" TO BE USED FOR EVERY FN AND SUBR CALL THAT
		HAS NO ARGS (ALSO USED BY STOP PAUSE AND END WHEN THERE IS NO ARG).
		BLOCK WILL BE 2 WDS OF 0. THE LABEL "ZERBLK" ON THE 2ND WD.
	******)%
	IF .NEDZER NEQ 0		! IS ZERO-ARG-BLOCK NEEDED ?
	THEN
	BEGIN
	    PSYMPTR_PBF2NOSYM;
	    PBOPWD_0;
	    OBUFFA();
	    DEFLAB(.ZERBLK);
	    PSYMPTR_PBF2NOSYM;
	    PBOPWD_0;
	    OBUFFA();
	END;		! OF IF .NEDZER NEQ 0 THEN BEGIN


	%(*** Output the argument blocks for any call statements
		or function references ***)%
	CGARGS();



	%(***WALK THRU ALL IO STMNTS OUTPUTTING ALL ARGLISTS FOR THEM***)%
	CSTMNT_.IOFIRST;		!PTR TO 1ST IO STMNT

	WHILE .CSTMNT NEQ 0
	DO
	BEGIN
		ISN_.CSTMNT[SRCISN];
		IF .CSTMNT[SRCID] EQL STOPID OR .CSTMNT[SRCID] EQL PAUSID
		THEN	CGSTPAUARGS()			!TO GENERATE ARG-BLOCK
							! FOR STOP OR PAUSE

		ELSE	CGIOARGS();			!TO GENERATE ARG-BLOCK
							! FOR AN IO STMNT

		CSTMNT_.CSTMNT[IOLINK];
	END;

	%(****GENERATE NAMELISTS IF ANY EXIST****)%
	NAMGEN();

	%(***OUTPUT DIMENSION INFORMATION FOR ALL PROTECTED ARRAYS***)%
%2210%	DMPDIM();

	%(***OUTPUT ANY INSTRUCTIONS STILL REMAINING IN THE  PEEPHOLE BUFFER***)%
	IF .PBFPTR NEQ PBUFF
	THEN OUTMDA(PBUFF,(.PBFPTR-PBUFF)/PBFENTSIZE);


%1511%	! Output anything required for the SAVE statement

%1531%	IF .SAVNED			! Any SAVE-ing needed?
%1531%	AND .FLGREG<OBJECT>		! Yes, producing a .REL file?
%1624%	AND NOT EXTENDED		! Yes, hacking extended addressing?
%1511%	THEN ZSAVEOUT();		! No, program could get overlayed


	%(**If user requested a macro-expanded listing, list the format
		statements***)%
	IF .FLGREG<LISTING> AND .FLGREG<MACROCODE> THEN LSTFORMATS();

	IF .FLGREG<OBJECT>
	THEN
%2325%	BEGIN	! OBJECT

%2325%		IF EXTENDED		! /EXTEND?
%2334%		THEN
%2334%		BEGIN	! EXTEND
%2325%			DMPEFIW();	! Dump EFIW table to the REL file

%2334%			IF .FLGREG<PROGTYP> EQL MAPROG	! Main program?
%2334%			THEN		! Yes, output entry vector
%2334%			BEGIN	! MAPROG
%2334%				DMPMAINRLBF();	! Empty out the main REL buffer
						!  so that ZCODE outputs code
						!  to right address

%2334%				SAVELOWLOC = .LOWLOC;	! Save the .DATA.
							!  relocation counter
%2355%				LOWLOC = .ENTADDR+STARTOFF;	! Start word
%2334%				RDATWD = JRSTOC OR .STADDR;	! JRST MAIN.
%2334%				ZCODE(PSCODE, PSDATA);	! Output JRST

%2355%				LOWLOC = .ENTADDR+REENTOFF;	! Reenter word
%2355%				RDATWD = JRSTOC OR INDBIT
%2355%					OR .ENTADDR+REEINDOFF;	! Output JRST @
%2355%				ZCODE(PSDATA, PSDATA);

%2355%				LOWLOC = .ENTADDR+VERSIONOFF;	! Version word
%2355%				RDATWD = 0;		! Make it zero for fun
%2355%				ZCODE(PSABS, PSDATA);	! Output it

%2355%				LOWLOC = .ENTADDR+REEINDOFF;	! Reentry EFIW
%2355%				RDATWD = 0;		! Zero it for fixup
%2355%				ZCODE(PSABS, PSDATA);	! Output it

%2355%				ZSYMBOL(GLB30ADDFIX,	! Make EXTERNAL request
%4527%					ONEWPTR(SIXBIT 'REENT.'),
%2355%					.ENTADDR+REEINDOFF,
%2355%					PSDATA);

%2334%				LOWLOC = .SAVELOWLOC;	! Restore LOWLOC
%2334%			END;	! MAPROG
%2334%		END;	! EXTEND

		! To terminate the REL file
%4530%		ZENDALL();	
%2325%	END;	! OBJECT

! Check for section overflows if program too large

%2346%	IF (.HILOC + .LOWLOC + .SCOMSZ) GEQ 1^18	! Code
%2433%		OR (.LARGELOC + .LCOMSZ) GEQ .VMSIZE	! Data
	THEN FATLER(.ISN,E142<0,0>)

END;			!END OF MRP3

ROUTINE DMPEFIW =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Output the contents of the EFIW table to the REL file and emit
!	local fixups for the EFIW references.  Emit additive fixups
!	for EFIWs that reference common blocks or routine names.
!
!	First, define a local symbol named "..EFIW" at the beginning
!	of the region of .CODE. which will contain the EFIWs.
!
!	Then loop over all entries in the EFIW table, following the
!	CLINK list and outputting each entry as a data word in a type
!	1030 (R30CODE) 30 bit relocation data REL block.  If an entry
!	has a non-zero EFFIXEDUP field, output a 30 bit additive fixup
!	with a type 1070 (RLONGSYMBOL) block to add the external's
!	value to the EFIW's Y field, otherwise perform 30 bit
!	relocation by the internal psect index in EFEXTERN.  When each
!	entry is output, also output a type 10 (RLOCAL) local fixup
!	REL block, in order to fixup references to the EFIW in the
!	previously generated code.
!
!	After each data word is output by calling Z30CODE, HILOC will
!	be updated in order to allocate space in the .CODE. psect.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	EFIWTBL		The hash table of EFIWs to be output to the REL file.
!
!	HILOC		Relocation counter for .CODE.
!
! IMPLICIT OUTPUTS:
!
!	HILOC		.CODE. relocation counter, updated to reflect
!			the EFIWs which have been output.
!
!	RDATWD		Destroyed.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Outputs RLOCAL, RPSECTORG, R30CODE and RLONGSYMBOL REL blocks
!	to the REL file.
!
!--


![2325] New

BEGIN

REGISTER
	BASE EFIW,			! Points to current EFIW
	BASE STE;			! Points to EFIW's STE

	! Define local symbol ..EFIW at start of dumped EFIWs

%4527%	ZSYMBOL(LOCDEF, ONEWPTR(SIXBIT '..EFIW'), .HILOC, PSCODE);

	! Now start dumping the EFIW table out to the REL file

	DECR I FROM EFSIZ-1 TO 0	! Loop over all the buckets
	DO				!  in the EFIW table
	BEGIN	! EFIW BUCKET
		EFIW = .EFIWTBL[.I];	! See what is in the bucket

		WHILE .EFIW NEQ 0	! Loop over all entries in the bucket
		DO
		BEGIN	! EFIW ENTRY

			! First get the EFIW word itself and output it
			! to the .CODE. psect.

			RDATWD = .EFIW[EFADDR];

%2464%			IF .EFIW[EFFIXEDUP] NEQ 0	! Is a fixup needed?
			THEN				! Yes
			BEGIN	! FIXUP

				! The Y field of the EFIW is the
				! subject of a fixup because of a
				! reference to COMMON or an external
				! routine, don't relocate it.

				Z30CODE(PSABS, PSCODE);

				! Output a a global additive fixup to
				! add the external's value to the
				! EFIW's Y field.

				ZSYMBOL(GLB30ADDFIX, .EFIW[EFEXTERN],
					.HILOC, PSCODE);
			END	! FIXUP
%2464%			ELSE Z30CODE(.EFIW[EFEXTERN], PSCODE);	! Non-FIXUP

			! Output the local fixup which backpatches all
			! the references to the EFIW.  Format is "head
			! of chain,,value to substitute"

			RDATWD = .EFIW[TARGADDR]^18+.HILOC;
			ZOUTBLOCK(RLOCAL, RELB);	! Relocate both halves

			HILOC = .HILOC+1;	! Allocate space for EFIW

			EFIW = .EFIW[CLINK];	! Get the next entry
		END;	! EFIW ENTRY
	END;	! EFIW BUCKET
END;	! of DMPEFIW
MACHOP POPJ=#263;
MRP3();
POPJ(#17,0)