Google
 

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

!AUTHOR F.INFANTE/DCE/SJW/JNG/TFV/CKS/RVM/AHM/CDM/AlB/PLB/MEM

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

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

%(

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

39	-----	------	GENERATE SYMBOL TABLE ENTRIES FOR FORMAT STMNTS,
			USE THE SYMBOL "STMNT-NUMBER F"
40	-----	-----	FIX BUG IN EDIT 39
41	-----	-----	ADD ROUTINE "LSTFORMATS" TO LIST ALL FORMAT STMNTS
			AT THE END OF A MACRO-EXPANDED LISTING
42	-----	-----	FIX BUG IN LSTFORMATS TO LIST RELATIVE ADDRS
			CORRECTLY
43	-----	-----	CHANGE "OUTMDA" SO THAT WHEN PSYMPTR IS THE CODE
			"PBFFORMAT" WE EXPECT THE RIGHT HALF OF THE INSTR
			IN THE PEEPHOLE BUFFER TO CONTAIN A PTR TO THE
			FORMAT STMNT (RATHER THAN THE REL ADDR OF THE FORMAT STRING)
44	-----	-----	TAKE OUT DEFINITIONS OF LOADER BLOCK TYPES - PUT
			THEM INTO A SEPARATE "REQUIRE" FILE.
			ALSO REMOVE THE ROUTINES "ZOUTBLOCK" AND 
			"ZDMPBLK". ZOUTBLOCK HAS BEEN MOVED TO THE MODULE
			RELBUF. ZDMPBLK IS NO LONGER NEEDED.
			ALSO, EDIT "ZENDALL" TO OUTPUT ANY CODE
			LEFT IN THE BUFFERS SYMRLBF,LOCRLBF, AND MAINRLBF.
			ALSO REMOVE THE ROUTINE "DATAOUT", MAKE OUTDATA CALL
			ZOUTBLOCK INSTEAD.
			ALSO REMOVE THE ROUTINE DMPRELONLST.
			ALSO REMOVE ALL REFERENCES TO "RELOCPTR" AND "RELBLOCK"
			AND DELETE THEIR DEFINITIONS.
45	-----	-----	REMOVE THE ROUTINES: ZOUTMSG,ZOUTSYM,ZOUTOCT,RADIX50,
			ZOUDECIMAL,ZOUOFFSET.
			THESE HAVE BEEN PUT INTO THE MODULE "RELBUFF"
46	-----	-----	REMOVE THE ROUTINE LSTRLWD WHICH HAS BEEN
			PUT INTO THE MODULE RELBUF
47	-----	-----	TAKE OUT DEF OF THE MACRO "CRLF" - IT IS NOW
			IN THE REQUIRE FILE "REQREL"
48	-----	-----	REMOVE THE ROUTINE OUTDATA - ITS NOT NEEDED IN
			FORTG
49	-----	-----	IN ZENDALL - MUST CALL DMPMAINRLBF (TO DUMP
			ANY CODE IN THE BUFFER) BEFORE DUMPING
			THE CONTENTS OF THE FIXUP BUFFERS
50	-----	-----	IN LSTINST  MOVE THE OUTPUT OF THE MACRO
			LISTING HEADING TO PHA3 SO THAT THE SIXBIT FUNCTION
			NAME WILL COME OUT AFTER THE HEADING

			IN OUTMDA - CHANGE IT SO THAT IT PUTS OUT
			A CRLF AT THE BEGINNING OF EACH LINE INSTEAD OF
			AT THE END.  THIS WILL MATCH THE WAY LSTINST DOES
			IT AND STRAIGHTEN OUT THE LISTING

			PUT PAGEHEADING CHECKS IN BOTH OF THE ABOVE ROUTINES

51	-----	-----	PUT OUT F LABELS AT THE END OF FORMAT STRINGS IF
			THE FLAG "DBGLABL" IS SET; OUTPUT L LABELS FOR
			THE LINES IF THE FLAG "DBGLABL" IS SET. HAVE P
			LABELS AT START OF FORMAT STMNTS.
52	-----	-----	PUT OUT THE SYMBOL '.VEND' AFTER THE END
			OF THE SCALARS AND ARRAYS
53	-----	------	DO NOT PUT OUT THE EXIT UUO (HAVE CALL TO FOROTS
			EXIT.)
54	15349	247	CHANGE ALL REFERENCES TO FORMAT LABELS TO XXXXP, (JNT)
55	QAR	317	FIX 247 TO STILL PUT XXF ON END, FIX SYMBOL TABLE, (JNT)
56	18015	356	PUT OUT GLOBAL MAIN. FOR MAIN PROG, (DCE)
57	19477	461	CHECK SIZES OF HIGH AND LOW SEGMENTS FOR OVERFLOW, (DCE)
58	QA754	464	ADD LINE/OCTAL MAP OUTPUT IF NO MACRO LISTING, (SJW)
59	QA754	476	MAKE LINE/OCTAL MAP OPTIONAL UNDER /MAP=MAPFLG, (SJW)

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

60	22281	555	FIX MAP WITH ENTRY POINTS, (DCE)
61	23760	614	OUTPUT ONLY NON-BLANK LINES IN /LNMAP, (SJW)

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

62	23066	636	DON'T DUMP LABELS TO THE REL FILE THAT WE DON'T
			  KNOW THE VALUE OF.  ALSO SET SNDEFINED WHEN
			  WE FILL IN THE SNADDR FIELD., (JNG)
63	25249	645	ENTRY POINTS CAUSE LINE COUNT TO BE OFF BY ONE, (DCE)
64	25250	646	SIXBIT SUBROUTINE NAMES HAVE LOCATION 0, (DCE)
65	25247	650	IMPROVE LISTING FILE WITH RESPECT TO DOUBLE
			PRECISION AND STRING LITERAL CONSTANTS, (DCE)
66	26442	705	USE NAME FROM PROGRAM STATEMENT AS THE ENTRY 
			POINT FOR THE MAIN PROGRAM, (DCE)
67	-----	734	ONLY PRINT DP CONSTANTS IN LISTING WHEN APPROPRIATE,
			(DCE)

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

68	761	TFV	1-Mar-80	-----
	Adjust mnemonic table offset to deal with GFAD, etc.
	Print double octal literals for GFAD, etc. (/GFLOATING)

69	1003	TFV	1-Jul-80
	Add global symbol ..GFL. if compiling /GFLOATING for FORDDT
	support.  Suppress DDT output of .VEND and ..GFL. .

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

70      1221    CKS     4-Jun-81
	Use LIT1 and LIT2 instead of CONST1 and CONST2 when referring to
	literal nodes.  Also test for end of ASCIZ string by using word
	count instead of literal-entry[CW5] EQL 0 check.

71      1224	CKS	12-Jun-81
	One more try at 1221... Remove dependence of ASCIZ lister on LITSIZ;
	have it output the whole string.  For the record, LITSIZ is the number
	of words in the character string including the null word at the end.

72	1245	TFV	3-Aug-81	------
	Fix ROUSYM to handle HISEG character descriptors.

73	1251	CKS	14-Aug-81	------
	LSTINST types addresses as NAME+OFFSET or NAME-OFFSET.  The calculation
	it uses to get the offset is OFFSET = EXTSIGN(ADDR) - NAME.  This does
	not work if ADDR is above 400000 octal.   Make it EXTSIGN(ADDR-NAME).

74	1261	CKS	21-Sep-81
	Do not output common block fixup for descriptor of character variable

75	1274	TFV	20-Oct-81	------
	Fix DMPSYMTAB to output all the .Qnnnn variables to the DDT symbol
	table

76	1406	TFV	27-Oct-81	------
	Fix DMPSYMTAB to output all the .Dnnnn variables to the DDT symbol
	table

77	1424	RVM	19-Nov-81
	Precede the formats in the object program and in the listed code
	by a count of the number of words in the format (in other words,
	make formats look like BLISS-10 PLIT's).  This is needed for
	assignable formats.

78	1433	RVM	14-Dec-81
	Rewrite LSTFORMAT to print as much format text per line as possible,
	instead of listing format text one word at a time.  Also, suppress
	listing nulls in format text.

79	1434	TFV	14-Dec-81	------
	Fix ROUSYM  to handle  external  character functions.   In  argument
	blocks, it should use the decriptor  for the function, not a  global
	request for its address.

1506	AHM	14-Mar-82
	Delete call  to ENDISNRLBLK  in ZENDALL  since the  output  of
	statement labels in DEBUG is now done with ZOUTBLOCK.

1512	AHM	26-Mar-82
	Convert all calls to  ZOUTBLOCK that created symbols  (RSYMBOL
	rel blocks) to  call the ZSYMBOL  routine instead.  Also  make
	flushing of SYMRLBF in ZENDALL work properly for 1070 blocks.

1525	AHM	1-Apr-82
	Various changes for  psected REL  files.  Emit  type 22  psect
	index blocks before dumping the type 10 local fixup buffer and
	before writing the type 7 start address block.  Write out type
	24 psect  end blocks  with  the values  of LOWLOC,  HILOC  and
	LARGELOC.  Also,  write out  a single  segment break  of  zero
	because LINK still needs a  type 5 END block.  Finally,  don't
	emit polish for instructions with negative Y fields that  look
	like hiseg references.

1526	AHM	7-Apr-82
	Change all the calls to ZOUTBLOCK for RCODE (type 1) blocks to
	calls to ZCODE to prepare  for psected REL files.  Call  CGERR
	if a peephole buffer entry of type PBF2LABREF is  encountered,
	since I  can't  find anything  that  uses them.   If  LARGELOC
	exceeds 30 bits, give the  error message "Program too  large".
	Use the proper relocation counter  to allocate space for  each
	psect instead of  always using  HILOC to  tell ZOUTBLOCK  what
	address is  being output.   Make DUMPSYMTAB  use SNPSECT  when
	defining labels.

1547	AHM	1-Jun-82
	Make ZENDALL complain  if the  size of all  the COMMON  blocks
	plus the sizes of the high and low segments exceeds 18 bits of
	address space, or if .LARG. exceeds 30 bits of address  space.

1562	TFV	18-Jun-82
	Fix ROUSYM to handle TYPECNV nodes in argument lists.  These are
	inserted over .Qnnnn variables used as the result descriptor for
	concatenations.  They cause the VALTYPE for the .Qnnnn  variable
	to be CHARACTER.

1564	AHM	21-Jun-82
	Make ZENDALL output /SYMSEG and /PVBLOCK to LINK if  compiling
	/EXTENDED.

1567	CDM	24-Jun-82
	Don't put out .Dnnn variables if NOALLOC is lit.

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
	Move the call to ARGCHECK for arg checking rel blocks from  PHA3
	to ZENDALL, after symbol table is dumped.


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

2306	AlB	13-Feb-84
	Added code to DMPSYMTAB to put out global definitions of FLGVX.
	and FLG77. if Compatibility Flaggng is being done.

	FLGVX. is defined as all ones if /FLAG:VAX is used.
	FLG77. is defined as all ones if /FLAG:STANDARD is used.

2311	PLB	19-Feb-84	FREEDOM IS SLAVERY
	Use new routine ZOUSMOFFSET instead of ZOUOFFSET.
	OUTOFFSET now uses ZOUTADDR and outputs 24 bits
	and we are outputting instruction offsets to listing.

2321	AHM	13-Mar-84
	Make ROUSYM recognize references to EFIW table entries.  It
	calls a new routine named ROUEFIW to process such references.

2334	AHM	5-Apr-84
	Make the type 7 (Start) rel block output by ZENDALL reference
	the entry vector which lives in .DATA. under /EXTEND.

2337	CDM	8-Apr-84
	Output EFIW references /LISTING/MACRO.

2346	AHM	23-Apr-84
	Get rid of EXTERNAL for COMTSIZ, since no one uses it anymore,
	and the variable has been removed from GLOBAL.

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!

2455	MEM	30-Aug-84
	Replace all occurrences of VAX with VMS.

2464	AHM	10-Oct-84
	When listing an EFIW in LSTEFIW don't output the variable name
	or use IDADDR in the offset computation for an EFIW with PSABS
	in EFEXTERN - it is an unrelocated formal array reference.

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

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

)%

	! The routines in this module are for the purpose of generating  the
	! macro expanded listing of the code generated and the generation of
	! the relocatable binary information in the .REL file.

SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE REQREL.BLI;
SWITCHES LIST;

FORWARD
%2321%	ROUEFIW,	! Output a reference to an EFIW
	GMULENTRY,	! Generate a global symbol definition for multiple
			!  entry point names
%2337%	LSTEFIW;	! Outputs an EFIW ref to the listing file


EXTERNAL
	CHDSTART,
%1526%	CGERR,		! Fatal error message
	CODELINES,
%1406%	DANCHOR,	! Start of .Dnnnn variable linked list
	DEFISN,		! Routine called for first instruction of each line to
			! put out a label corresponding to the line seq number
	DMPRLBLOCK,	! Routine to dump a buffered rel-file block out
	DMPMAINRLBF,	! Routine to dump the main rel-file buffer
	ENDSCAA,
%2334%	ENTADDR,	! Address of entry vector
	ERROUT,
	FORMPTR,	! Pointer to the first format statement in program
	HEADCHK,	! Checks line count and outputs headings
	HEADING,
	HILOC,		! Current hiseg available location
	HIORIGIN,	! Origin of high segment for twoseg compilations
	ISN,
	LABTBL,
%1526%	LARGELOC,	! Next available location in .LARG.
	LMCONO,		! Current map column number
	LMLINO,		! Current source line number
	LMRONO,		! Current map row number
	LOCRLBF,	! Rel file buffer
	LOWLOC,		! Current lowseg available location
	LSTOUT,
	MAINRLBF,	! Rel file buffer
	OPMNEM,
	OUTMSG,
%645%	PAGELINE,
	PROGNAME,
%1274%	QANCHOR,	! Start of .Qnnnn variable linked list
	RADIX50,
%2321%	OBJECTCODE RDATWD,	! Contains current rel data word
	RELBLOCK,	! Relocatable binary block
	RELDATA,	! Data word - current block number,,current data count
	RELOCWD,	! The relocation word for the block
	RELOUT,
%650%	STRNGOUT,
	SYMRLBF,	! Rel file buffer
	SYMTBL,
%1614%	ZARGCHECK,	! Argument checking rel block routine.
%1526%	ZCODE,		! Outputs type 1 or 1010 data blocks to rel file
	ZLABLMAK,
	ZOUDLB,		! Routine to  add to  the macro  expanded listing  a
			! label that is inserted on the first instruction of
			! each statement when the user has specified /DEBUG
	ZOUDECIMAL,
%2337%	ZOUOFFSET,	! Output 18 or 30 bit offset to listing
	ZOUTBLOCK,
	ZOUTMSG,
	ZOUTOCT,
%2311%	ZOUSMOFFSET,	! Outputs (+/-) offset to listing file
	ZOUTSYM,
%1512%	ZSYMBOL;	! Outputs a type 2 or 1070 symbol block to the REL file

MACRO
	CHROUT(C) = (CHR = (C);  LSTOUT()) $,	! Outputs a char to the listing
						! Argument  "C"   must  be   in
						! double (") rather than single
						! (') quotes.
%2337%	DECOUT(X) = (R1 = (X);  ZOUDECIMAL()) $,    ! Outputs a decimal number
%2337%	OCTOUT(X) = (R2<LEFT> = (X);  ZOUTOCT()) $; ! Outputs an octal number
ROUTINE DMPSYMTAB=
BEGIN
	!DUMPS THE SYMBOL TABLE TO REL FILE
OWN LABL;
%1274%	REGISTER BASE  SYMPTR;	! Pointer to the symbol to be output

	ROUTINE BLDLABL=
	%(***************************
		LOCAL ROUTINE TO BUILD THE SIXBIT FOR THE
		DECIMAL FORM OF THE STMNT NUMBER IN THE REG "R1".
		CALLED WITH THE VAR "LABL" CONTAINING ONE
		SIXBIT CHAR IN THE LEFTMOST SIX BITS. LEAVES "LABL" CONTAINING
		THE STMNT NUMBER FOLLOWED BY THAT CHAR.
	****************************)%
	BEGIN
			DO (
				LABL _ .LABL ^(-6);
				R2 _ .R1 MOD 10; R1 _ .R1/10;
				LABL<30,6> _ (#20[.R2]<0,0>); !MAKING ROOM FOR NEXT
				IF .R1 EQL 0 THEN EXITLOOP;
	   		   ) WHILE 1;
	END;



	%(**DUMP THE SYMBOL TABLE***)%
	DECR I FROM SSIZ-1 TO 0 DO
	BEGIN
		IF (SYMPTR _ .SYMTBL[.I]) NEQ 0
		THEN BEGIN
			DO BEGIN
				IF .FLGREG<DBGDIMN>	!IF USER SPECIFIED THE "DEBUG" SWITCH
				THEN		! THEN FOR ALL ARRAYS WE WANT TO
						! PUT A PTR IN THE SYMBOL TABLE ENTRY POINTING
						! TO THE DIMENSION INFORMATION FOR THE ARRAY
				BEGIN
					IF .SYMPTR[OPRSP1] EQL ARRAYNM1
						AND ((NOT .SYMPTR[IDATTRIBUT(NOALLOC)])
						OR .SYMPTR[IDATTRIBUT(INCOM)])	!PUT IN COMMON
					THEN
					BEGIN
						! Use the kluge of  adding a 2nd entry  for the same symbol  immediately
						! before its true definition which points to the dimension  information.
						! Note that since FORDDT searches the symbol table backwards, this means
						! it will see the symbol for the variable before it sees the pointer  to
						! the dimension table.

						REGISTER BASE T1;
						T1_.SYMPTR[IDDIM];	!PTR TO DIMENS TABLE ENT
						T1_.T1[ARADLBL];	!PTR TO LABEL TABLE ENTRY FOR
									!LABEL ON DIMENS INFO ARG BLOCK

%1512%						ZSYMBOL(LOCSUPDEF,.SYMPTR[IDSYMBOL],.T1[SNADDR],PSCODE)
					END
				END;


				IF .SYMPTR[IDATTRIBUT(INCOM)]
%1261%				   AND .SYMPTR[VALTYPE] NEQ CHARACTER
				THEN
				  BEGIN
					MAP BASE R2;
%1512%					ZSYMBOL(LOCDEF,.SYMPTR[IDSYMBOL],.SYMPTR[IDADDR],PSABS);	! Common block offset
					R2 _ .SYMPTR[IDCOMMON];						! Add to symbol when the
%1512%					ZSYMBOL(GLBSYMFIX,.R2[COMNAME],.SYMPTR[IDSYMBOL],PSABS)		!  common address is set
				  END
				ELSE IF .SYMPTR[OPRSP1] NEQ FNNAME1
					AND NOT .SYMPTR[IDATTRIBUT(NOALLOC)]
%1512%				THEN ZSYMBOL(LOCDEF,.SYMPTR[IDSYMBOL],.SYMPTR[IDADDR],.SYMPTR[IDPSECT])	! Define vanilla symbol as
													!  an unsuppressed local
			   END WHILE (SYMPTR _ .SYMPTR[CLINK]) NEQ 0;
		      END;
	END;

! Output a  symbol for  the word  after  the end  of the  scalars  and
! arrays.  ENDSCAA contains the location  after the end of arrays  and
! scalars and is set in ALLSCA.

![1003]	Suppress DDT output of .VEND

%1512%	ZSYMBOL(LOCSUPDEF,SIXBIT '.VEND',.ENDSCAA,PSDATA);

![1003]	Output the global symbol ..GFL. if compiling /GFLOAT for FORDDT support

%1003%	IF .GFLOAT
%1512%	THEN ZSYMBOL(GLBSUPDEF,SIXBIT '..GFL.',1,PSABS);	! Give it the value of 1

![2455] Output the global symbols FLGV. (if /FLAG:VMS) and FLG77. (if
![2306] /FLAG:STANDARD).  These globals tell FOROTS that there is Compatibility
![2306] flagging to do at runtime.

%2455%	IF FLAGVMS
%2306%	THEN ZSYMBOL(GLBSUPDEF,SIXBIT 'FLGV.',-1,PSABS);
%2306%	IF FLAGANSI
%2306%	THEN ZSYMBOL(GLBSUPDEF,SIXBIT 'FLG77.',-1,PSABS);

! Dump the local labels now

	DECR I FROM LASIZ-1 TO 0 DO
	BEGIN
	  IF (SYMPTR _ .LABTBL[.I]) NEQ 0 THEN
		BEGIN
		  DO BEGIN
%636%			IF .SYMPTR[SNDEFINED]
%636%			THEN
%636%			BEGIN
				LABL _ 0;
				R1 _ .SYMPTR[SNUMBER];
				LABL<30,6> _ IF .R1 GTR 99999 THEN (R1 _ .R1-99999; SIXBIT "M" ) ELSE SIXBIT "P";
				BLDLABL();	!IN "LABL" BUILD THE SIXBIT FOR
						! THE STMNT NUMBER IN R1 (FOLLOWED BY THE CHAR
						! ALREADY IN "LABL"

%1526%				ZSYMBOL(LOCDEF,.LABL,.SYMPTR[SNADDR],.SYMPTR[SNPSECT])
%636%			END;

		     END WHILE (SYMPTR _ .SYMPTR[CLINK]) NEQ 0;
		END;
	END;

%1274%	! Dump the .Qnnnn variable names

%1274%	SYMPTR = .QANCHOR;	! Start at the beginning (including those used
				!  for statement functions)

%1274%	WHILE .SYMPTR NEQ 0 DO
%1274%	BEGIN
%1512%		ZSYMBOL(LOCDEF,.SYMPTR[IDSYMBOL],.SYMPTR[IDADDR],PSDATA);
%1274%		SYMPTR = .SYMPTR[CLINK]
%1274%	END;

%1406%	! Dump the .Dnnnn variable names

%1406%	SYMPTR = .DANCHOR;	! Start at the beginning

%1406%	WHILE .SYMPTR NEQ 0 DO
%1406%	BEGIN
%1567%		! Only if we want to allocate it.
%1567%		IF NOT .SYMPTR[IDATTRIBUT(NOALLOC)]
%1567%		THEN
%1567%		BEGIN
%1512%			ZSYMBOL(LOCDEF,.SYMPTR[IDSYMBOL],.SYMPTR[IDADDR],
%1512%				PSCODE);
%1567%		END;
%1406%		SYMPTR = .SYMPTR[CLINK]
%1406%	END;

	!DEFINE A LABEL OF THE FORM <STMNT NUMBER>F ON THE LAST WD
	! OF EACH FORMAT STRING
	IF .FLGREG<DBGLABL>
	THEN
	!
	BEGIN
		REGISTER BASE FPTR;	!PTR TO FORMAT STMNT NODE
		FPTR_.FORMPTR<LEFT>;	!1ST FORMAT STMNT IN PROGRAM
		UNTIL .FPTR EQL 0
		DO
		BEGIN
			SYMPTR_.FPTR[SRCLBL];	!STMNT NUMBER TABLE
					! ENTRY FOR THE LABEL ON THE FORMAT
			R1_.SYMPTR[SNUMBER];	!STMNT NUMBER ON THE FORMAT STMNT
			LABL_0;
			LABL<30,6>_SIXBIT"F";
			BLDLABL();	!SET "LABL" TO THE SIXBIT FOR
					! <STMNT NUMBER>F
%1512%			ZSYMBOL(LOCDEF,.LABL,.FPTR[FORADDR]+.FPTR[FORSIZ]-1,PSDATA);	! Address of last word of string
			FPTR_.FPTR[FMTLINK]	!GO ON TO NEXT FORMAT
		END;
	END;
END;	! of DMPSYMTAB
ROUTINE ZSIXBIT(ZVAL)=	!CONVERT ZVAL TO SIXBIT SYMBOL
BEGIN
	R2 _ SIXBIT 'P';
	DECR I FROM 5 TO 0 DO
	BEGIN
		R2 _ .R2^(-6); R2<30,6> _ (.ZVAL MOD 10) + #40; ZVAL _ .ZVAL/10;
		IF .ZVAL EQL 0 THEN EXITLOOP;
	END;
	RETURN .R2
END;	! of ZSIXBIT
%650%	ROUTINE ZDOUTCON(WORD2)=
%650%	BEGIN
%650%		!LIST A DOUBLE WORD CONSTANT IN OCTAL
%650%		!WORD ONE IS IN R2; SECOND WORD IS IN WORD2
%650%	
%650%		STRNGOUT(PLIT ASCIZ '[EXP  ');
%650%	
%650%		DECR I FROM 11 TO 0 DO
%650%		BEGIN
%650%			R1_0; LSHC(R1,3);
%650%			CHR_.R1+#60; LSTOUT();
%650%		END;
%650%	
%650%		CHR_","; LSTOUT();
%650%	
%650%		R2_.WORD2;
%650%		DECR I FROM 11 TO 0 DO
%650%		BEGIN
%650%			R1_0; LSHC(R1,3);
%650%			CHR_.R1+#60; LSTOUT();
%650%		END;
%650%	
%650%		CHR_"]"; LSTOUT();
%650%	END;	! of ZDOUTCON
%650%	ROUTINE ZSOUTCON(ADDR)=
%650%	BEGIN
%650%		!OUTPUT A STRING STARTING FROM ADDR AND BEING NO
%650%		!MORE THAN 10 CHARACTERS.   THE FORMAT WILL BE:
%1224%		!    [ASCIZ /STRING/]
%650%		MAP BASE ADDR;
%650%	
%650%		STRNGOUT(UPLIT ASCIZ '[ASCIZ /');
%1224%		STRNGOUT(ADDR[LIT1]);
%1224%        	STRNGOUT(UPLIT ASCIZ '/]');
%650%	END;	! of ZSOUTCON
ROUTINE ZOUTCON=
BEGIN
	!LIST A CONSTANT IN OCTAL ; R2 CONTAINS VALUE
	CHR _ "["; LSTOUT();
	DECR I FROM 11 TO 0 DO
	BEGIN
		R1 _ 0; LSHC(R1,3);
		CHR _ .R1 + #60; LSTOUT();
	END;
	CHR _ "]"; LSTOUT()
END;	! of ZOUTCON
ROUTINE COMCOM=
!++
! Outputs two commas ",,"
!--
BEGIN
	CHR_",";
	LSTOUT();
	LSTOUT()
END;	! of COMCOM
ROUTINE LSTINST(IPTR)=

!++
! FUNCTIONAL DESCRIPTION:
!
!	Lists the MACRO-10 mnemonics of the instructions being generated
!	in the listing file.
!
! FORMAL PARAMETERS:
!
!	IPTR		Pointer to peephole buffer containing the
!			instruction being output.
!
! IMPLICIT INPUTS:
!
!	Unknown
!
! IMPLICIT OUTPUTS:
!
!	Unknown
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Instruction line is output to the listing file.
!
!--


BEGIN

MACRO
	IISN	= (@IPTR)<FULL>$,	!LINENUMBER OF INSTRUCTION
	ILABEL	= (@IPTR+1)<LEFT>$,
	IADDRPTR	= (@IPTR+1)<RIGHT>$,
	IOPCODE	= (@IPTR+2)<27,9>$,
	IAC	= (@IPTR+2)<23,4>$,
	IINDIR = (@IPTR+2)<22,1>$,
	IINDEX = (@IPTR+2)<18,4>$,
	IEFFADDR = (@IPTR+2)<RIGHT>$;

MACRO	HEADRSW = CODELINES<LEFT>$;

LOCAL	OPPOINT;

BIND	ZADDR = IADDRPTR;
MAP	BASE ZADDR,
	BASE R2;

	ROUTINE ZLABLMAK(ILABLPT)=
	BEGIN
		! R1 contains label in binary
		MAP BASE ILABLPT;

		R1_.ILABLPT[SNUMBER];
		IF .R1 GTR 99999 THEN R1 _ .R1-99999;	!REDUCE TO NICE RANGE
		ZOUDECIMAL();			!OUTPUT VALUE OF R1 IN DECIMAL
		IF .ILABLPT[SNUMBER] GTR 99999
		THEN CHR _ "M"
		ELSE CHR _ "P";
		LSTOUT();
		.VREG

	END;	!Of ZMAKLABL

%734%	LOCAL DINSTF; !DOUBLE WORD INSTRUCTION FLAG


	IF .HEADRSW NEQ #777777
	THEN
	BEGIN
		CODELINES _ 0;
		HEADRSW _ #777777
	END;

	CRLF;
	HEADCHK();
	IF (R1 _ .IISN) GEQ 0
	THEN IF .R1 EQL 0
		THEN
		BEGIN
			CHR _ "*";
			LSTOUT()
		END
		ELSE ZOUDECIMAL();

	CHR _ #11;
	LSTOUT(); !TAB
	IF .IADDRPTR EQL PBFENTRY
	THEN
	BEGIN
		!ENTRY NAME TAKES UP ONE LISTING LINE - ACCOUNT FOR IT
%645%		CRLF;
%645%		PAGELINE_.PAGELINE-1;
%645%		CHR_#11;
%645%		LSTOUT();
		R2 _ .IEFFADDR;
		R2 _ .R2[IDSYMBOL];
		ZOUTSYM();
		CHR _ ":";
		LSTOUT();
		RETURN
	END;

	!GEN THE RELATIVE LOCATION (OCTAL)

	R2<LEFT> _ .CODELINES<RIGHT>;
	ZOUTOCT();
	CHR _ #11;
	LSTOUT();	! TAB
	CODELINES _ .CODELINES + 1;

	IF .ILABEL NEQ 0 	!LIST A LABEL
	THEN
	BEGIN
		LOCAL BASE LABPT;
		LABPT _ .ILABEL;
		DO
		BEGIN
			ZLABLMAK(.LABPT);
			CHR _ ":";
			LSTOUT();
			CRLF;
			HEADCHK();
			CHR _ #11;
			LSTOUT();
			LSTOUT(); !TAB
		END
		WHILE (LABPT _ .LABPT[SNNXTLAB]) NEQ 0;
	END;

	! IF THE USER SPECIFIED  THE "DEBUG" SWITCH  THEN IF THIS  INSTR
	! STARTS A STMNT, LIST AN "L" LABEL ON THIS INSTR

	IF (R1_.IISN) GTR 0 AND .FLGREG<DBGLABL>
	THEN ZOUDLB();


	CHR _ #11;
	LSTOUT();	!TAB
%734%	DINSTF_0;

	! Now do the instruction listing

	IF .IOPCODE NEQ 0
	THEN
	BEGIN
		!First mnemonic is now GFAD (#103)
%761%		OPPOINT _ (OPMNEM-#103)[.IOPCODE]<0,6>;	!MNEMONIC TABLE POINTER
		INCR I FROM 0 TO 5 DO
		BEGIN		
			CHR _SCANI(OPPOINT,CHR);	!GET A CHARACTER
			IF(CHR _ .CHR + #40 ) LEQ #100 THEN EXITLOOP;
			! PICK UP FIRST CHAR OF INSTRUCTION
%734%			IF .I EQL 0 THEN DINSTF_.CHR;
			LSTOUT()
		END
	END;

	CHR _ #11;
	LSTOUT();	!TAB

	!AC field

%2337%	OCTOUT(.IAC);

	CHR _ ",";
	LSTOUT();

	! Output address field of instruction.  Do it differently if  we
	! have an EFIWREF.

%2337%	IF .ZADDR[OPRCLS] EQL EFIWREF
%2337%	THEN LSTEFIW(.ZADDR)
%2337%	ELSE
%2337%	BEGIN	! Not EFIWREF

		! Indirect bit.  Output "@".

		IF .IINDIR NEQ 0
		THEN
		BEGIN
			CHR _ "@";
			LSTOUT();
		END;

		!Address field in instruction

		IF .IADDRPTR GTR PBF2LABREF
		THEN
		BEGIN
			IF SYMBOL(ZADDR)
			THEN
			BEGIN	! Symbol
				R2 _ .ZADDR[IDSYMBOL];
				ZOUTSYM()
			END
			ELSE
			BEGIN	! Not symbol

				IF .ZADDR[OPERSP] EQL CONSTANT
				THEN
				BEGIN	! Constant

					IF .ZADDR[DBLFLG]
					  OR .ZADDR[VALTYPE] EQL REAL
					THEN
					BEGIN	! Double prec or real

						IF .ZADDR[CONADDR] EQL .IEFFADDR
%650%						THEN
						BEGIN
							! 1st word of constant
							R2 _ .ZADDR[CONST1];

%734%							! Only print as  double
%734%							! octal if  instruction
%734%							! is  double  word,  i.
%734%							! e.,     the     first
%734%							! character begins with
%734%							! "D"  or  "G"   (avoid
%734%							! CAMxx).

%761%							IF .ZADDR[DBLFLG] AND
%761%							   (.DINSTF EQL "D"
%761%							 OR .DINSTF EQL "G")
%761%							THEN RETURN ZDOUTCON(.ZADDR[CONST2])
						END
						ELSE R2 _ .ZADDR[CONST2]

					END	! Double prec or real
					ELSE R2 _ .ZADDR[CONST2]; ! INTEGER or LOGICAL or BYTE

					RETURN ZOUTCON();
	
				END	! Constant
				ELSE
				BEGIN	! Not constant
					R2_.ZADDR[IDSYMBOL];
					ZOUTSYM();
				END;

			END;	! Not symbol

%1251%			IF (R1 _ EXTSIGN(.IEFFADDR -.ZADDR[IDADDR])) NEQ 0
%2311%			THEN ZOUSMOFFSET();	!OUTPUT 18 BIT OFFSET

		END
		ELSE IF .IADDRPTR GTR 3 
			THEN BEGIN END
			ELSE IF .IADDRPTR GTR 2
				THEN
				BEGIN
					MAP BASE R2;
					R2_.IEFFADDR;
					R2 _ .R2[IDSYMBOL];
					ZOUTSYM()
				END
				ELSE IF .IADDRPTR GTR 1
					THEN !DOTTED FUNCTION NAME
					BEGIN
					  	R2 _@(.IEFFADDR);
						ZOUTSYM()
					END
					ELSE  IF .IADDRPTR GTR 0	!NO SYMBOLIC ADDR
						THEN
						BEGIN
							R2<LEFT> _ .IEFFADDR;
							ZOUTOCT() !IMMEDIATE MODE VALUE
						END
						ELSE  ZLABLMAK(.IEFFADDR);


		!Index field  "(register)"

		IF .IINDEX NEQ 0 
%2337%		THEN
%2337%		BEGIN
%2337%			CHROUT("(");
%2337%			OCTOUT(.IINDEX);	! Register to use
%2337%			CHROUT(")");
%2337%		END;

%2337%	END;	! Not EFIWREF

END;	! of LSTINSTF
ROUTINE  LINEMAP (IPTR) =
!LIST ON LISTING DEVICE A LINE-NUMBER/OCTAL-LOCATION MAP IF
! NO MACRO LISTING WAS REQUESTED

BEGIN


MACRO	  IISN		= (@IPTR)<FULL>$,
	  IADDRPTR	= (@IPTR+1)<RIGHT>$,
	  HEADRSW	= CODELINES<LEFT>$;

	IF .HEADRSW NEQ #777777
	THEN
	BEGIN
		CODELINES _ 0;
		HEADRSW _ #777777;
	END;

	IF .IADDRPTR EQL PBFENTRY
	  THEN RETURN;

	IF .IISN GTR 0
		AND .LMLINO LSS .IISN	! BEWARE 1 LINE NUM FOR >1 OCTAL LOC
	THEN
	BEGIN
	    DO
	      BEGIN
		IF (LMCONO _ .LMCONO + 1) EQL 10
		  THEN BEGIN
		    LMCONO _ 0;
		    CRLF;
		    HEADCHK ();
		    CHR _ "0";
		    IF (LMRONO _ (.IISN DIV 10) - 1) LSS 999
		      THEN BEGIN
			LSTOUT ();
			IF .LMRONO LSS 99
			  THEN BEGIN
			    LSTOUT ();
			    IF .LMRONO LSS 9
			      THEN LSTOUT ();
			  END
		      END;
		    R1 _ LMRONO _ .LMRONO + 1;
		    ZOUDECIMAL ();
		    CHR _ "0";
		    LSTOUT ();
		    CHR _ " ";
		    LSTOUT ();
		    CHR _ ":";
		    LSTOUT ();
		    CHR _ " ";
		    LSTOUT ();
		    LMLINO _ .LMRONO * 10 - 1;
		  END
		  ELSE CHROUT("?I")
	      END
	      WHILE  (LMLINO _ .LMLINO + 1) LSS .IISN;
	    R2<LEFT> _ .CODELINES<RIGHT>;
	    ZOUTOCT ();
	  END;
	CODELINES _ .CODELINES + 1;
END;	! of LINEMAP
ROUTINE ROUIMFUN(FUNCPTR,FUNAME)=	!OUTPUT FUNCTION REQUEST GLOBAL
BEGIN
	RDATWD = .FUNCPTR<LEFT>^18;
%1526%	ZCODE(PSABS,PSCODE);		! Output PUSHJ P,0 to .CODE.

! Output a chained global  fixup request so that  LINK will place  the
! address of the start of the named  routine in the right half of  the
! PUSHJ instruction when the global symbol named in FUNAME is defined.

%1512%	ZSYMBOL(GLB18CHNFIX,.FUNAME,.HILOC,PSCODE)
END;	! of ROUIMFUN
ROUTINE ROURLABEL(LABLPTR)=
BEGIN
MAP
	BASE LABLPTR;
REGISTER
%1526%	MYPSECT;	! Psect to relocate the RH of the reference by

	RDATWD<LEFT> _ .LABLPTR<LEFT>;

! Instructions that  reference  labels are  either  defined  (backward
! references) or not  defined (forward references).   If the label  is
! defined, then it is in .CODE. unless it is for a FORMAT statement in
! .DATA.  ASSIGN statements that reference FORMATs come through  here,
! while I/O argument blocks are done right in OUTMDA.  If the label is
! not  defined,  then  the  first  reference  to  the  label  gets  an
! unrelocated 0 put out to mark the end of a fixup chain and the  rest
! of the references become the address of the previous instruction  in
! the .CODE. psect.

%1526%	IF .LABLPTR[SNSTATUS] EQL OUTPBUFF	! Is the label defined ?
%1526%	THEN MYPSECT = .LABLPTR[SNPSECT]	! Yes, use its psect
%1526%	ELSE IF .LABLPTR[SNDEFINED]		! No, first reference ?
%1526%	THEN MYPSECT = PSCODE			! No, the fixup uses .CODE. 
%636%	ELSE					! Yes, the first reference in a
%636%	BEGIN					!  chain contains absolute 0
%1526%		MYPSECT = PSABS;		! So don't relocate it
%636%		LABLPTR[SNADDR]_0;		! Store the zero
%636%		LABLPTR[SNDEFINED]_TRUE		! Say SNADDR is valid
%636%	END;

	 RDATWD<RIGHT> _ .LABLPTR[SNADDR];

! At this point RDATWD<RIGHT> contains  either 0 (if first time  label
! referenced) or  a hiseg  chain address  if not  first reference  and
! still undefined or the hiseg or  lowseg address of the location  the
! label defines.  The value OUTPBUFF means the label has been  defined
! to the loader.

%1526%	ZCODE(.MYPSECT,PSCODE);			! Relocate with the right psect

%636%	IF  .LABLPTR[SNSTATUS] NEQ OUTPBUFF
%636%	THEN
%636%	BEGIN
%636%		LABLPTR[SNADDR] _ .HILOC;	!CHAIN THE REQUEST
%636%		LABLPTR[SNDEFINED]_TRUE;
%636%	END;
END;	! of ROURLABEL
ROUTINE ROUEFIW(INSTRUCTION, EFIW) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Output an instruction or arg block which references an EFIW.
!
!	Clear the index field and set the indirect bit so that the
!	EFIW will be used as an indirect word.
!
!	Place a fixup backpointer to previous EFIW references in the
!	instruction's Y field and relocate it by .CODE.  If this is
!	the first reference to the EFIW, use unrelocated zero instead.
!
!	Update the header of the fixup chain in the EFIW table entry's
!	TARGADDR field to point to the current instruction.
!
! FORMAL PARAMETERS:
!
!	INSTRUCTION	Instruction word to be output.
!
!	EFIW		Pointer to EFIW table entry for instruction.
!			This is used to find the representative EFIW,
!			which holds the head of the fixup chain.
!
! IMPLICIT INPUTS:
!
!	HILOC		Unrelocated object address of the instruction
!			to be output to .CODE.
!
! IMPLICIT OUTPUTS:
!
!	EFIW[EFREP][TARGADDR]
!			Representative's TARGADDR gets updated with
!			the new head of this EFIW's fixup chain.
!
!	RDATWD		Destroyed.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Can flush main rel buffer to the object file.
!
!--


BEGIN	![2321] New

MAP
	BASE EFIW;			! Points to an EFIW table entry

	RDATWD = .INSTRUCTION;		! Get instruction for object file
	RDATWD[OTSIND] = 1;		! Set indirect bit
	RDATWD[OTSINX] = 0;		! Clear out index register field

	EFIW = .EFIW[EFREP];		! Find the representative EFIW
	RDATWD[OBJADDR] = .EFIW[TARGADDR];	! Point at the most recent
						!  reference, or 0 if none
	IF .EFIW[TARGADDR] EQL 0	! Is there a fixup chain?
	THEN ZCODE(PSABS,PSCODE)	! No, this is the start, absolute 0
	ELSE ZCODE(PSCODE,PSCODE);	! Yes, back pointer points to hiseg

	EFIW[TARGADDR] = .HILOC;	! Remember where the most recent
					!  reference to the EFIW is
END;	! of ROUEFIW
ROUTINE ROUSYM(INSTRUCTION,INSADDR,INARGBLOCK)=
BEGIN
	! Relocatable symbolic output

	MACRO ADD=3$,SUBT=4$;

	MAP BASE R2;
	LOCAL BASE SYMPTR; SYMPTR _ .INSADDR<RIGHT>;

%2321%	IF .SYMPTR[OPRCLS] EQL EFIWREF	! Is it an EFIW?
%2321%	THEN				! Yes, process specially
%2321%	BEGIN	! EFIWREF
%2321%		ROUEFIW(.INSTRUCTION, .SYMPTR);	! Emit the EFIW reference
%2321%		RETURN;			! Punt immediately
%2321%	END	! EFIWREF
%2321%	ELSE IF NOT SYMBOL(SYMPTR)	! No, is it a CONSTANT or TEMPORARY ?
	THEN				! Yes
	BEGIN
		RDATWD = .INSTRUCTION;
%1526%		IF .SYMPTR[OPERATOR] EQL CHARCONST	! Character constant ?
%1526%		THEN ZCODE(PSCODE,PSCODE)	! Yes, descriptor is in hiseg
%1526%		ELSE ZCODE(PSDATA,PSCODE);	! No, data is in lowseg
		RETURN
	END
%1562%	ELSE IF .SYMPTR[OPRCLS] EQL TYPECNV
%1562%	THEN	! Type convert node above .Qnnnn TEMPORARY
%1562%	BEGIN
%1562%		RDATWD = .INSTRUCTION;
%1562%		ZCODE(PSDATA, PSCODE);	! TEMPORARY is in the lowseg
%1562%		RETURN			! Done
%1562%	END;

	! Now check for subroutine or function call

	IF .SYMPTR[OPRSP1] EQL FNNAME1
	THEN IF (NOT .SYMPTR[IDATTRIBUT(FENTRYNAME)])
	THEN IF (NOT .SYMPTR[IDATTRIBUT(DUMMY)])
%1434%	THEN IF NOT (.SYMPTR[IDATTRIBUT(INEXTERN)] AND
%1434%		.SYMPTR[VALTYPE] EQL CHARACTER AND .INARGBLOCK EQL 1)
	THEN
	BEGIN
		ROUIMFUN(.INSTRUCTION,.SYMPTR[IDSYMBOL]);
		RETURN
	END;

! Here if  not a  function call  or subroutine  call, unless  it is  a
! character external function in an argument block since they now have
! descriptors.

	RDATWD _ .INSTRUCTION;

%1245%	! Don't try to output polish for character descriptors

%1245%	IF .SYMPTR[IDPSECT] EQL PSCODE
%1245%	THEN
%1245%	BEGIN
%1526%		ZCODE(PSCODE,PSCODE);
%1245%		RETURN
%1245%	END;

! Does an array offset look like a hiseg address ?

	IF EXTSIGN(.INSTRUCTION<RIGHT>) LSS -#400
%1525%		AND NOT EXTENDED	! Don't need kludge for psects
	THEN				! Yes, do polish fixup for instruction
	BEGIN
		RDATWD<RIGHT> _ 0;
%1526%		ZCODE(PSABS,PSCODE);

		IF NOT .SYMPTR[IDATTRIBUT(INCOM)]	! In common ?
		THEN			! No, normal fixup
%1245%		BEGIN
%1245%			RDATWD _ ADD^18+1;	!MEANS NEXT WD IS FULL WD OPERAND
%1245%			ZOUTBLOCK(RPOLISH,RELN);
%1245%			RDATWD _ EXTSIGN(.INSTRUCTION<RIGHT>);	!FULL WORD
%1245%			ZOUTBLOCK(RPOLISH,RELN);
%1245%			RDATWD _ 0;
%1245%			ZOUTBLOCK(RPOLISH,RELRI);
%1526%			RDATWD _ #777777^18 + (.HILOC+.HIORIGIN);	! Right half chained fixup,,address
%1245%			ZOUTBLOCK(RPOLISH,RELRI)
		END
	   	ELSE			! Operand is in common, additive global
		BEGIN			!  fixup needed
			RDATWD _ ADD^18+2;	!NEXT WD IS GLOBAL REQUEST
			ZOUTBLOCK(RPOLISH,RELN);
			R2 _ .SYMPTR[IDCOMMON]; R2 _ .R2[COMNAME];
			RDATWD _ RGLOBDEF + RADIX50();  !A GLOBAL REQUEST POLISH FIXUP
			ZOUTBLOCK(RPOLISH,RELN);
			RDATWD _ #1777777;	!1^18 + -1
			ZOUTBLOCK(RPOLISH,RELN);
			RDATWD _ .INSTRUCTION<RIGHT>^18+#777777;
			ZOUTBLOCK(RPOLISH,RELN);
%1526%			RDATWD _ (.HILOC+.HIORIGIN)^18;
			ZOUTBLOCK(RPOLISH,RELL)  ! Emit the fixup address
		END
	END		! So much for strange polish
	ELSE IF .SYMPTR[IDATTRIBUT(INCOM)]	! In common ?
	THEN				! Yes, need additive global fixup
	BEGIN
%1526%		ZCODE(PSABS,PSCODE);	! Output the instruction
		R2 _ .SYMPTR[IDCOMMON];	! Get pointer to common block

! Add the address  of the common  block to the  RH of the  instruction
! when LINK defines it.

%1512%		ZSYMBOL(GLB18ADDFIX,.R2[COMNAME],.HILOC,PSCODE)
	END
%1526%	ELSE ZCODE(.SYMPTR[IDPSECT],PSCODE)	! Not in common, normal case
END;	! of ROUSYM
ROUTINE OUTMOD(CODEPTR,COUNT)=
BEGIN

! Generates the  relocatable  binary instructions  for  the  compiler.
! Also responsible for calling routines  that generate the macro  code
! listing and the  routines that generate  symbol information for  the
! loader.   The  arguments  are  a  pointer  to  the  peephole  buffer
! containing code to be generated,  and the number of peephole  buffer
! entries to emit code for.

MAP
	PEEPHOLE CODEPTR,
	BASE R2;
REGISTER
	CODEBLOCK;

	CODEBLOCK = .CODEPTR<RIGHT>;

! Output line-number/octal-location map only if no macro listing

	IF .FLGREG<LISTING>
	THEN INCR I FROM 0 TO .COUNT-1
	    DO IF .FLGREG<MACROCODE>
		THEN LSTINST ((.CODEBLOCK)[.I*3])
		ELSE IF .FLGREG<MAPFLG>
		    THEN LINEMAP ((.CODEBLOCK)[.I*3]);

! Start relocatable binary generation if requested

	IF .FLGREG<OBJECT>
	THEN INCR I FROM 0 TO (.COUNT-1)
	DO
	BEGIN
		IF .CODEPTR[.I,PBFSYMPTR] GTR PBFENTRY	! Symbolic reference ?
%1434%		THEN ROUSYM(.CODEPTR[.I,PBFINSTR],.CODEPTR[.I,PBFSYMPTR],0)
		ELSE CASE .CODEPTR[.I,PBFSYMPTR] OF
		SET

! Either not symbolic, or label or  function call or call to a  dotted
! library function

		! Label address - pointer to label in RH of instruction
% PBFLABREF %	ROURLABEL(.CODEPTR[.I,PBFINSTR]);

		! No symbolic address, output the instruction
% PBFNOSYM %	BEGIN
			RDATWD = .CODEPTR[.I,PBFINSTR];
%1526%			ZCODE(PSABS,PSCODE)
		END;

		! Implicitly called function, RH points directly to SIXBIT name
% PBFIMFN %	ROUIMFUN(.CODEPTR[.I,PBFINSTR],@(.CODEPTR[.I,PBFADDR]));

		! Explicitly called function, RH points to STE for name
% PBFEXFN %	BEGIN
			R2 = .CODEPTR[.I,PBFADDR];
			ROUIMFUN(.CODEPTR[.I,PBFINSTR],.R2[IDSYMBOL])
		END;

		! Used in OUTMDA, not here
% PBF2LABREF %	BEGIN
		END;

		! Used in OUTMDA, not here
% PBF2NOSYM %	BEGIN
		END;

		! Used in OUTMDA, not here
% PBFFORMAT %	BEGIN
		END;

		! Used in OUTMDA, not here
% PBFLLABREF %	BEGIN
		END;

		! A global entry symbol definition
% PBFENTRY %	BEGIN

! Special case for global entry definitions (generates no data or instructions)

			GMULENTRY(.CODEPTR[.I,PBFADDR]);

! Decrement HILOC to make  up for the increment  coming at end of  the
! INCR loop so that the next instruction will have the same address as
! that assigned to the entry symbol

			HILOC = .HILOC-1
		END

		TES;

! If there are labels on the present peephole buffer entry, output them

		IF .CODEPTR[.I,PBFLABEL] NEQ 0
		THEN
		BEGIN	REGISTER BASE LINLABEL;

			LINLABEL = .CODEPTR[.I,PBFLABEL];

			DO		! Loop over all labels
			BEGIN
%636%				IF .LINLABEL[SNDEFINED]
				THEN
				BEGIN
					RDATWD = .LINLABEL[SNADDR]^18+.HILOC;
					ZOUTBLOCK(RLOCAL,RELB)
				END;

				LINLABEL[SNSTATUS] = OUTPBUFF;	!DEFINE IT (HAS
								!  PASSED THRU
								!  PBUFF)
				LINLABEL[SNADDR] = .HILOC;	!DEFINING THE
								! SYMBOL NOW
%636%				LINLABEL[SNDEFINED] = TRUE
			END WHILE (LINLABEL = .LINLABEL[SNNXTLAB]) NEQ 0
		END;

! If this instruction starts a source line and the user specified  the
! /DEBUG:LABELS switch, output a label for this instruction.

		IF .CODEPTR[.I,PBFISN] GTR 0 AND .FLGREG<DBGLABL>
		THEN DEFISN(.CODEPTR[.I,PBFISN]);

		HILOC = .HILOC + 1	!INCREMENT HISEG AVAILABLE LOCATION

	END;	!END OF INCR LOOP

	.VREG
END;	! of OUTMOD
GLOBAL ROUTINE OUTMDA(ARPTR,ARCOUNT)=
BEGIN

!++
! FUNCTIONAL DESCRIPTION:
!
!	Outputs to the REL file the  arg blocks for all statements that  use
!	them.  These  include I/O  lists,  function or  subroutine  argument
!	lists, and other arg lists.
!
!	The call to this routine is made with a pointer to the argument code
!	words and a count of the number of words to generate.  The format of
!	the block of words is the similar  to that used in a call to  OUTMOD
!	to output instructions.
!
! FORMAL PARAMETERS:
!
!	Unknown
!
! IMPLICIT INPUTS:
!
!	Unknown
!
! IMPLICIT OUTPUTS:
!
!	Unknown
!
! ROUTINE VALUE:
!
!	Unknown
!
! SIDE EFFECTS:
!
!	Unknown
!
!--


MAP
	BASE R1:R2;
MACRO
	ILABEL = (@ARPTR)[.I+1]<LEFT>$,
	IADDRPTR = (@ARPTR)[.I+1]<RIGHT>$,
	ILADDR = (@ARPTR)[.I+2]<LEFT>$,
	IRADDR = (@ARPTR)[.I+2]<RIGHT>$,
	IARGWD = (@ARPTR)[.I+2]<FULL>$;

LOCAL
%2337%	BASE CNODE;

	INCR I FROM 0 TO (.ARCOUNT-1)*3 BY 3
	DO
	BEGIN
		IF .FLGREG<LISTING>
		THEN IF .FLGREG<MACROCODE>
		THEN
		BEGIN
			CRLF;
			HEADCHK();
			CHROUT("?I");

! Subroutine SIXBIT name should not print location 0 (none at all!)

%646%			IF .CODELINES<RIGHT> NEQ 0
%646%			THEN
%646%			BEGIN
%646%				R2<LEFT> = .CODELINES<RIGHT>;
%646%				ZOUTOCT()
%646%			END;
%646%			CHROUT("?I");
			CODELINES = .CODELINES+1;

			IF .ILABEL NEQ 0
			THEN
			BEGIN
				ZLABLMAK(.ILABEL);
				CHROUT(":")
			END;
			CHROUT("?I")
		END
		ELSE IF .FLGREG<MAPFLG>
		THEN CODELINES = .CODELINES+1;	! Update octal location counter
						!  for entry points

		SELECT .IADDRPTR OF NSET
	PBFLABREF:	EXITSELECT
			(
			IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE>  THEN
			BEGIN
			 R2<LEFT> = .ILADDR; ZOUTOCT();
			 COMCOM(); ! ",,"
			 ZLABLMAK(.IRADDR); 
			END;
			IF .FLGREG<OBJECT> THEN
				ROURLABEL(.IARGWD);
			);

	PBFNOSYM:	EXITSELECT
			(
			IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE>  THEN
			BEGIN
			 R2<LEFT> = .ILADDR; ZOUTOCT();
			 COMCOM();
			 R2<LEFT> = .IRADDR; ZOUTOCT();
			END;
			IF .FLGREG<OBJECT> THEN
%1526%			 (RDATWD = .IARGWD; ZCODE(PSABS,PSCODE));
			);
	PBF2NOSYM:	EXITSELECT
			(
			IF .FLGREG<LISTING>
			THEN IF .FLGREG<MACROCODE>
			THEN
			BEGIN
				R2<LEFT> = .ILADDR; ZOUTOCT();
				COMCOM();
				R2<LEFT> = .IRADDR; ZOUTOCT();
			END;
			IF .FLGREG<OBJECT>
			THEN
			BEGIN
				RDATWD = .IARGWD;
%1526%				ZCODE(PSABS,PSCODE)
			END;

			);
	PBFIMFN:	EXITSELECT
			(
			IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE>  THEN
			BEGIN
			 R2<LEFT> = .ILADDR; ZOUTOCT();
			 COMCOM();
			 R2 = @.IRADDR; ZOUTSYM();
			END;
			IF .FLGREG<OBJECT> THEN
			  ROUIMFUN(.IARGWD,@.IRADDR);

			);
	PBFEXFN:	EXITSELECT
			(
			IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE>  THEN
			BEGIN
			 R2<LEFT> = .ILADDR; ZOUTOCT();
			 COMCOM();
			 R2 = .IRADDR; R2 = .R2[IDSYMBOL]; ZOUTSYM();
			END;
			IF .FLGREG<OBJECT> THEN
			 (R2 = .IRADDR; ROUIMFUN(.IARGWD,.R2[IDSYMBOL]));
			);
	PBF2LABREF:	EXITSELECT
%1526%			(CGERR(); ! Label,,label is no longer used as of V6
!			IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE>  THEN
!			BEGIN
!			 ZLABLMAK(.ILADDR); COMCOM(); ZLABLMAK(.IRADDR);
!			END;
!			IF .FLGREG<OBJECT> THEN
!			 (R1 = .ILADDR; R2 = .IRADDR;
!			  RDATWD = .R1[SNADDR]^18 +  .R2[SNADDR];
!			  ZOUTBLOCK(RCODE,RELB);
!			 );
			);
	PBFFORMAT:	EXITSELECT
			BEGIN
			  REGISTER BASE TPTR;	!TEMPORARY PTR
			  IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE>  THEN
			   BEGIN
				R2<LEFT> = .ILADDR; ZOUTOCT();
				COMCOM();
				!TYPE THE P LABEL FOR THE RIGHT HALF
				TPTR = .IRADDR;	!PTR TO THE FORMAT STMNT
				TPTR = .TPTR[SRCLBL];	!STMNT NUMBER TABLE ENTRY FOR THE LABEL
				R1 = .TPTR[SNUMBER]; ZOUDECIMAL();	!THE STMNT NUMBER OF THE FORMAT

				CHROUT("P");	!FOLLOWED BY "P"
			   END;
			  IF .FLGREG<OBJECT> THEN
			   BEGIN
				TPTR = .IRADDR;	!PTR TO FORMAT STMNT
				RDATWD = .ILADDR^18	!LEFT HALF OF OUTPUT WD COMES DIRECTLY FROM PBUFF
					+ .TPTR[FORADDR];	!RIGHT HALF IS REL ADDR OF THE FORMAT STMNT
%1526%				 ZCODE(PSDATA,PSCODE)
			   END;
			END;
	OTHERWISE:
		BEGIN
			IF .FLGREG<LISTING> THEN IF .FLGREG<MACROCODE>  
			THEN
			BEGIN	! /LIST/MACRO

				CNODE = .IADDRPTR;

%2337%				IF .CNODE[OPRCLS] EQL EFIWREF
%2337%				THEN
%2337%				BEGIN	! EFIW
%2337%
%2337%					MAP OBJECTCODE R2;
%2337%
%2337%					R2<LEFT> = .ILADDR;
%2337%					R2[OTSIND] = 1;	! Indirect
%2337%					R2[OTSINX] = 0;	! No register
%2337%					ZOUTOCT();	! Arg in R2<LEFT>
%2337%					COMCOM();	! ",,"
%2337%
%2337%					LSTEFIW(.CNODE); ! List EFIW
%2337%
%2337%				END	! EFIW
%2337%				ELSE
%2337%				BEGIN	! Not EFIW

					R2<LEFT> = .ILADDR;
					ZOUTOCT();
					COMCOM();

					R2 = .IADDRPTR;
					IF .R2[OPERSP] EQL CONSTANT
%650%					THEN
%650%					BEGIN	! Constant

						![650] IN ARGUMENT LISTS,  TAKE
						![650] CARE OF ARGUMENTS  BASED
						![650] ON THEIR TYPE.
%650%						LOCAL TMP;

						TMP = .(@ARPTR)[.I+2]<23,4>;

						! Output constant depending
						! on what type it is.

%650%						IF .TMP EQL #17
%1245%						THEN	ZSOUTCON(.R2)	! Hollerith
%1245%						ELSE	IF .TMP EQL #15
%1245%							THEN 
%1245%							BEGIN	! Character
%1245%
%1245%								STRNGOUT(UPLIT
%1245%									ASCIZ
%1245%									'.HSCHD');
%1245%								R1 = .R2[IDADDR]
%1245%									- .CHDSTART;
%2311%								ZOUSMOFFSET(); !OUTPUT 18 BIT OFFSET
%1245%							END
%1245%							ELSE
%650%							IF .R2[DBLFLG]
%650%							THEN
%650%							BEGIN	!DP OR COMPLEX CONSTANT
%650%								TMP = .R2[CONST2];
%650%								R2 = .R2[CONST1];
%650%								ZDOUTCON(.TMP)
%650%							END
%650%							ELSE
%650%							BEGIN
%650%								IF .R2[VALTYPE] EQL REAL
%650%								THEN R2 = .R2[CONST1]
%650%								ELSE R2 = .R2[CONST2];
%650%								ZOUTCON();
%650%							END;
%650%
%650%					END	! Constant
					ELSE
					BEGIN	! Not constant

						R2 = .R2[IDSYMBOL];
						ZOUTSYM();
						R2 = .IADDRPTR;
%2311%				 		!Output offset
%1251%						IF (R1 = EXTSIGN(.IRADDR
%1251%							- .R2[IDADDR])) NEQ 0
%2311%						THEN ZOUSMOFFSET();

					END;	! Not constant

%2337%				END;	! Not EFIW

			END;	! /LIST/MACRO

%1434%			IF .FLGREG<OBJECT> THEN ROUSYM(.IARGWD,.IADDRPTR,1);

		END;

		TESN;

		IF .FLGREG<OBJECT>
		THEN
		BEGIN	! Create .REL file

			IF .ILABEL NEQ 0
			THEN
			BEGIN
				REGISTER BASE LABENT;
				LABENT = .ILABEL;

%636%				IF .LABENT[SNDEFINED]
				THEN
				BEGIN
					RDATWD = .LABENT[SNADDR]^18+.HILOC;
					ZOUTBLOCK(RLOCAL,RELB)
				END;

				LABENT[SNSTATUS] = OUTPBUFF;	!THRU THE OUTPUT BUFFFER
				LABENT[SNADDR] = .HILOC;	!DEFINING THE SYMBOL NOW
%636%				LABENT[SNDEFINED] = TRUE;
			END;
			HILOC = .HILOC + 1;	!INCREMENT HISEG AVAILABLE LOCATION

		END;	! Create .REL file

	END; !Of INCR I DO

END;	! of OUTMDA
GLOBAL ROUTINE ZENDALL(STADDR) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Finishes output of REL file for current program unit.  Dumps
!	symbol table.  Defines global symbol(s) for start of main
!	program.  Flushes symbol, local fixup and main rel buffers.
!	Outputs type 1120 (argument descriptor), type 7 (start), type
!	23 (psect break) and type 5 (end) rel blocks.  Puts LINK
!	switches in the object file in ASCII.
!
! FORMAL PARAMETERS:
!
!	STADDR		Start address (relative to beginning of hiseg)
!
! IMPLICIT INPUTS:
!
!	ENTADDR		Address of the entry vector (relative to
!			beginning of lowseg).  This contains valid
!			data only under /EXTEND.
!
!	F2<EXTENDFLAG>	Flag for /EXTEND.
!
!	FLGREG<PROGTYP>	Distinguishes main programs from other kinds
!			of program units.
!
!	PROGNAME	Name of main program from PROGRAM statement
!
!	PSECTS		Relocation counters of all the psects.  Output
!			as the psect breaks in type 23 blocks.
!
! IMPLICIT OUTPUTS:
!
!	RDATWD		Smashed numerous times by output to REL buffer.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Outputs many kinds of REL blocks to the object file.
!
!--


BEGIN

BIND
%1564%	PDVTEXT = PLIT(ASCIZ '/SYMSEG:PSECT:.DATA./PVBLOCK:PSECT:.CODE.');

! Note: The length  of every  PLIT (in words)  is stored  as the  word
! preceding the PLIT.  Hence, in the last example, .PDVTEXT[-1] = 9.

MAP RELBUFF
	SYMRLBF:	! Holds type 2 and 1070 symbol data
	LOCRLBF:	! Holds type 10 local fixup data
	MAINRLBF;	! Holds all other types of data

LOCAL
%1525%	MYRELBUF[3];	! Holds type 22 block for E/A


	! Dump the symbol  table to  REL file. This  merely stuffs  data
	! into SYMRLBF,  it  does not  guarantee  that the  symbols  are
	! output to the rel file yet.

	DMPSYMTAB();


	! Dump any local requests, global requests, and symbol 	definitions
	! that are still in their buffers

	DMPMAINRLBF();	! Must output any code blocks to the REL file
			!  before dumping local and global requests
			! (This routine call only dumps MAINRLBF)

	! Put out a  global symbol  for main  program so  LINK can  warn
	! about two main programs.

	IF .FLGREG<PROGTYP> EQL MAPROG THEN
	BEGIN
%1512%		ZSYMBOL(GLBDEF,SIXBIT 'MAIN.',.STADDR,PSCODE);

	![705] If a real program name was  given to the program, use  it
	![705] as an entry point for the main program - this is the only
	![705] way (short of a MACRO program) to get this effect.

%705%		IF .PROGNAME NEQ SIXBIT 'MAIN.'
%1512%		THEN ZSYMBOL(GLBDEF,.PROGNAME,.STADDR,PSCODE)
	END;

	IF .SYMRLBF[RDATCNT] NEQ 0
	THEN
%1512%	BEGIN
%1512%		IF .SYMRLBF[RTYPE] EQL RSYMBOL
%1512%		THEN DMPRLBLOCK(SYMRLBF,.SYMRLBF[RDATCNT]+2)
%1512%		ELSE DMPRLBLOCK(SYMRLBF,.SYMRLBF[RDATCNT]+1)
%1512%	END;


%1614%	! Output the argument checking rel blocks for subprogram  calls.
%1614%	! We output it  here so  that Link  will have  the symbol  table
%1614%	! values for better error message diagnostics.

%2433%	ZARGCHECK();


	IF .LOCRLBF[RDATCNT] NEQ 0	! Anything left in the fixup buffer ?
	THEN				! Yes, dump it
	BEGIN
		! We always set the default psect index every time  we
		! output a block which depends on it.  This is because
		! LINK is suspected  of destroying  the variable  that
		! holds the  default during  the processing  for  some
		! blocks.  It  will work  if it  is set  before  every
		! block that depends on it, however.

%1525%		IF EXTENDED		! Psected object code ?
%1525%		THEN			! Yes, set the default psect index
%1525%		BEGIN
%1525%			MYRELBUF[0] = RPSECTORG^18 OR 1;
%1525%			MYRELBUF[1] = 0;	! No relocation
%1525%			MYRELBUF[2] = PXCODE;	! All local fixups are for code
%1525%			DMPRLBLOCK(MYRELBUF,3)
%1525%		END;

		DMPRLBLOCK(LOCRLBF,.LOCRLBF[RDATCNT]+2)
	END;

	IF .FLGREG<PROGTYP> EQL MAPROG
	THEN
	BEGIN
%1525%		IF EXTENDED	! If doing psected object code, then set the
%1525%		THEN		!  default psect index.  See comment above
%1525%		BEGIN		!  about why we always set the index
%1564%			DMPRLBLOCK(PDVTEXT,.PDVTEXT[-1]); ! Pass LINK switches

%2334%			RDATWD = PXDATA;		! Relocate by .DATA.
%1525%			ZOUTBLOCK(RPSECTORG,RELN);
%2334%			RDATWD = ENTVECSIZE^18 OR .ENTADDR	! Entry vector
%1525%		END
%1526%		ELSE RDATWD = .STADDR + .HIORIGIN;	! Not psected, hisegize
							!  the start address

		ZOUTBLOCK(RSTART,RELRI) ! Start address block
	END;


	! Time to output the segment breaks or psect breaks (type 5 or 23)

%1525%	IF EXTENDED	! Psected REL file ?
%1525%	THEN		! Yes, output psect breaks
%1525%	BEGIN		! Psected REL files tell LINK where their psects end
%1525%
%1525%		RDATWD = PXCODE;	! Psect index
%1525%		ZOUTBLOCK(RPSECTEND,RELN);
%1525%		RDATWD = .HILOC;	! Psect break
%1525%		ZOUTBLOCK(RPSECTEND,RELRI);
%1525%		DMPMAINRLBF();		! Only one psect per block
%1525%
%1525%		RDATWD = PXDATA;	! Again for .DATA.
%1525%		ZOUTBLOCK(RPSECTEND,RELN);
%1525%		RDATWD = .LOWLOC;
%1525%		ZOUTBLOCK(RPSECTEND,RELRI);
%1525%		DMPMAINRLBF();
%1525%
%1525%		RDATWD = PXLARGE;	! And again for .LARG.
%1525%		ZOUTBLOCK(RPSECTEND,RELN);
%1525%		RDATWD = .LARGELOC;
%1525%		ZOUTBLOCK(RPSECTEND,RELRI);
%1525%		DMPMAINRLBF();
%1525%
%1525%		! Even though we  have an entirely  psected REL  file,
%1525%		! the signal that LINK expects  to recieve to tell  it
%1525%		! that it is done with  a program unit is the  reading
%1525%		! of a type 5 END block.   So we will output one,  but
%1525%		! it will only give the lower segment break, and  that
%1525%		! will be 0.  (Just putting out header and  relocation
%1525%		! words would be better, but it gets LINK upset).
%1525%
%1525%		RDATWD = 0;		! Say as little as possible
%1525%		ZOUTBLOCK(REND,RELN)	! Output the block
%1525%	END
%1525%	ELSE	! NOT EXTENDED
%1525%	BEGIN
%1526%		RDATWD = .HILOC+.HIORIGIN;
		ZOUTBLOCK(REND,RELRI);
		RDATWD = .LOWLOC;
		ZOUTBLOCK(REND,RELRI)
%1525%	END;

	IF .MAINRLBF[RDATCNT] NEQ 0
	THEN DMPRLBLOCK(MAINRLBF,.MAINRLBF[RDATCNT]+2)

END;	! of ZENDALL
ROUTINE GMULENTRY(MULSYM)=
BEGIN

! Generate a global definition in  rel file for multiple entry  names.
! OUTMOD must have already been called to dump any code in PBUFF.

MAP BASE MULSYM;

%1512%	ZSYMBOL(GLBDEF,.MULSYM[IDSYMBOL],.HILOC,PSCODE)
END;	! of GMULENTRY
GLOBAL ROUTINE LSTFORMATS=

!*** [1433]  Rewritten to print multiple words of format text per line

%(***************************************************************************
	Routine to list all the format stmnts in a program.
	Assumes that the global "FORMPTR" points to the 1st
	FORMAT stmt.  Each FORMAT stmt is linked to the
	next by the "FMTLINK" field.
***************************************************************************)%
BEGIN

	!(*** Define some handy macros:			***)
	!(***	TAB	outputs a tab			***)

	MACRO	TAB	  = CHROUT(#11) $;

	BIND	LINEWIDTH = 55;	!Number of characters of format text per line


	LOCAL CHARSLEFT;	!Number of chars left to print in format text
	LOCAL LISTLABEL;	!Flag controling the printing of the label
				!   on the first line of format text
	LOCAL BASE SNENTRY;	!The stmt number table entry for the stmt
				!   number for a given format stmt
	REGISTER BASE FORMAT;	!Ptr to the format stmt being printed
	REGISTER RLOC;		!Relative loc in low seg of the wd being listed
	REGISTER TEXTPTR;	!Byte ptr to the character in the string
				!   to be listed


	!(*** If there are no format stmnts in this program ***)%
	IF (FORMAT_.FORMPTR<LEFT> ) EQL 0
	THEN RETURN;

	%(*** Print header ***)%
	IF ( PAGELINE_.PAGELINE-4) LEQ 0
	THEN	( HEADING();  PAGELINE_.PAGELINE-4);
	STRNGOUT(PLIT ASCIZ'?M?J?M?JFORMAT STATEMENTS (IN LOW SEGMENT):?M?J?M?J');


	%(*** List all format stmts in program ***)%
	UNTIL .FORMAT EQL 0
	DO 
	BEGIN	!Loop to list all format stmts in program

		!(*** The first line for this format--the size word ***)
		DECOUT(.FORMAT[SRCISN]);    !ISN line number of the format stmt
		TAB;
		OCTOUT(.FORMAT[FORADDR]-1); !Relative address of the count of
					    ! the number of words in the format
		TAB;
		TAB;
		OCTOUT(.FORMAT[FORSIZ]);    !Count of number of words in format
		CRLF;
		HEADCHK();


		!(*** Second through N lines--Format text ***)
		TEXTPTR = (.FORMAT[FORSTRING])<36,7>; !Byte pointer to fmt text
		CHARSLEFT = .FORMAT[FORSIZ] * 5;      !Five chars per word
		LISTLABEL = TRUE;		      !Label goes on 1st line
		RLOC = .FORMAT[FORADDR];

		!(*** Loop while there is text in this format to be listed ***)
		WHILE .CHARSLEFT GTR 0
		DO
		BEGIN	! While text to print in this format

			TAB;
			OCTOUT(.RLOC);	!Relative address of the 1st wd of the
					! format text
			TAB;

			!(*** If this is the first line of text for this ***)
			!(***  then list the stmt label of the format    ***)
			IF .LISTLABEL
			THEN
			BEGIN	! List the statement label
				!(*** Get the label table entry for format ***)
				!(*** Print the stmt number followed by a  ***)
				!(*** "P" and a colon.			   ***)
				SNENTRY_.FORMAT[SRCLBL];
				DECOUT(.SNENTRY[SNUMBER]);
				CHROUT("P");
				CHROUT(":");

				!(*** Any other lines of text for this ***)
				!(*** format do have stmt labels       ***)
				LISTLABEL = FALSE;
			END;	! of list the statement label


			TAB;


			!(*** Output the at least 'LINEWIDTH' chars of ***)
			!(*** format text			       ***)
			DECR I FROM (IF LINEWIDTH LSS .CHARSLEFT THEN LINEWIDTH ELSE .CHARSLEFT) TO 1
			DO
			BEGIN
				CHR = SCANI(TEXTPTR);
				IF .CHR NEQ 0 THEN CHROUT(.CHR);
			END;

			CRLF;
			HEADCHK();

			CHARSLEFT = .CHARSLEFT - LINEWIDTH;
			RLOC = .RLOC + LINEWIDTH / 5;
		END;	! of while text to print in this format

		FORMAT_.FORMAT[FMTLINK];     !Go on to the next format stmt

	END;	! of loop to list all format stmts in program

END;	! of LSTFORMATS
ROUTINE LSTEFIW(EFIW)=		![2337] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Output EFIW references to the listing file.  (/MACRO is assumed
!	to have been given).
!
!	Format:
!
!	"@[.EFIW " [ name ] [ ( "+" | "-" ) offset ] [ "(" register ")" ] "]"
!
! FORMAL PARAMETERS:
!
!	EFIW		The EFIW reference to output.
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	CHR		Global argument to LSTOUT in CHROUT.
!
!	R1		Global argument to ZOUOFFSET.
!
!	R2		Global argument to ZOUTSYM.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	An EFIW reference is output to the listing file.
!
!--


BEGIN
	MAP 	BASE EFIW,
		BASE R2;
	REGISTER
		BASE SYMTAB;	! Pointer to the symbol table reference.


	SYMTAB = .EFIW[EFSYMPTR];	! Symbol table pointer

	STRNGOUT(UPLIT ASCIZ '@[.EFIW ');	! Indirection through literal

	! Output symbol name

%2464%	IF .EFIW[EFEXTERN] NEQ PSABS	! Absolute reference?
%2464%	THEN				! Nope, output the variable name
%2464%	BEGIN	! NOT PSABS
		R2 = .SYMTAB[IDSYMBOL];		! Symbol; argument to ZOUTSYM
		ZOUTSYM();
%2464%	END;	! NOT PSABS

	IF (R1 = .EFIW[EFY]) NEQ 0	! Does offset exist?
	THEN
	BEGIN	! Has offset

		! If negative,  then  extend  the  sign  of  the
		! offset.

		IF .EFIW[EFYSIGN] THEN R1 = .R1 OR #770000000000;

%2464%		IF .EFIW[EFEXTERN] NEQ PSABS		! Absolute reference?
%2464%		THEN R1 = .R1 - .SYMTAB[IDADDR];	! Nope, subtract base

		! Output ("+" | "-") offset if there still is one.
		IF .R1 NEQ 0 THEN ZOUOFFSET();

	END;	! Has offset

	! Output index field, if it exists

	IF .EFIW[EFX] NEQ 0
	THEN
	BEGIN
		! "(" index ")"

		CHROUT("(");
		OCTOUT(.EFIW[EFX]);	! Index register
		CHROUT(")");
	END;

	CHROUT("]");			! End of literal

END;	! of LSTEFIW

END
ELUDOM