Google
 

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

!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1983
!AUTHOR F.INFANTE/DCE/SJW/JNG/TFV/CKS/RVM/AHM/CDM

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

GLOBAL BIND LISTOV = 7^24 + 0^18 + #1614;	! Version Date:	16-Aug-82

%(

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

***** 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 GMULENTRY;

EXTERNAL
%1614%	ARGCHK,		! If TRUE, then output argument checking rel blocks.
	CHDSTART,
%1526%	CGERR,		! Fatal error message
	CODELINES,
%1547%	COMTSIZ,	! Total size of all common blocks in words
%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,
	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,
	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,
	ZOUTBLOCK,
	ZOUTMSG,
	ZOUTOCT,
	ZOUOFFSET,
	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
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

! 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=
BEGIN
	CHR_",";LSTOUT();LSTOUT()
END;	! of COMCOM
ROUTINE LSTINST(IPTR)=
BEGIN
%
ROUTNE LISTS ON LISTING DEVICE THE MACRO -10 MNEMONICS OF THE INSTRUCTIONS BEING GENERATED
%
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;
!
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 ROUTINE ZMAKLABL

%734%	LOCAL DINSTF; !DOUBLE WORD INSTRUCTION FLAG
IF .HEADRSW NEQ #777777
	THEN(		CODELINES _ 0;
		HEADRSW _ #777777
	    );
CRLF;
HEADCHK();
IF (R1 _ .IISN) GEQ 0
	THEN IF .R1 EQL 0 THEN ( CHR _ "*"; LSTOUT()) ELSE ZOUDECIMAL();
CHR _ #11; LSTOUT(); !TAB
IF .IADDRPTR EQL PBFENTRY
	THEN(MAP BASE R2;
		!ENTRY NAME TAKES UP ONE LISTING LINE - ACCOUNT FOR IT
%645%		CRLF; PAGELINE_.PAGELINE-1; CHR_#11; LSTOUT();
		R2 _ .IEFFADDR; R2 _ .R2[IDSYMBOL]; ZOUTSYM();
		CHR _ ":"; LSTOUT();
		RETURN
	    );
!
!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 	(
	 LOCAL BASE LABPT;
	 LABPT _ .ILABEL;
	 DO
	 (
	 ZLABLMAK(.LABPT);
	 CHR _ ":"; LSTOUT(); CRLF; HEADCHK();
	 CHR _ #11; LSTOUT(); LSTOUT(); !TAB
         ) WHILE (LABPT _ .LABPT[SNNXTLAB]) NEQ 0;
	);

	IF (R1_.IISN) GTR 0 AND .FLGREG<DBGLABL>	!IF THE USER SPECIFIED THE "DEBUG" SWITCH
				! THEN IFTHIS INSTR STARTS A STMNT, LIST
				! AN "L" LABEL ON THIS INSTR
	THEN ZOUDLB();


CHR _ #11; LSTOUT();	!TAB
%734%	DINSTF_0;
!NOW DO THE INSTRUCTION LISTING
!
IF .IOPCODE NEQ 0
THEN(
!First mnemonic is now GFAD (#103)
%761%	OPPOINT _ (OPMNEM-#103)[.IOPCODE]<0,6>;	!MNEMONIC TABLE POINTER
	INCR I FROM 0 TO 5 DO
	  (CHR _SCANI(OPPOINT,CHR);	!GET A CHARACTER
	   IF(CHR _ .CHR + #40 ) LEQ #100 THEN EXITLOOP;
%734%	   IF .I EQL 0 THEN DINSTF_.CHR; ! PICK UP FIRST CHAR OF INSTRUCTION
	   LSTOUT()
	  )
    );
CHR _ #11;	LSTOUT();	!TAB
!AC FIELD
!
IF .IAC LEQ 7 
  THEN (CHR _ .IAC + #60; LSTOUT())
   ELSE (CHR _ "1"; LSTOUT();
	 CHR _ (.IAC + #50); LSTOUT()
 	);
CHR _ ","; LSTOUT();
!
!INDIRECT BIT
!
IF .IINDIR NEQ 0 THEN (CHR _ "@"; LSTOUT());
!
!ADDRESS
!
BEGIN BIND ZADDR = IADDRPTR; MAP BASE ZADDR;
  IF .IADDRPTR GTR PBF2LABREF
    THEN
	(IF SYMBOL(ZADDR)
	  THEN ( R2 _ .ZADDR[IDSYMBOL];
		ZOUTSYM()
		)
	  ELSE IF .ZADDR[OPERSP] EQL CONSTANT
		THEN ( IF .ZADDR[DBLFLG] OR .ZADDR[VALTYPE] EQL REAL
			THEN(IF .ZADDR[CONADDR] EQL .IEFFADDR

![650] IN THE CONSTANT CASE, DISTINGUISH BETWEEN SINGLE AND
![650] DOUBLE WORD CONSTANTS.

%650%				THEN (R2 _ .ZADDR[CONST1];

![734] ONLY PRINT AS DOUBLE OCTAL IF INSTRUCTION IS DOUBLE WORD, I. E.,
![734] THE FIRST CHARACTER BEGINS WITH "D" (AVOID CAMXX).
![761] also if instruction starts with "G" (GFAD, etc.)

%761%					IF .ZADDR[DBLFLG] AND
%761%					   (.DINSTF EQL "D" OR .DINSTF EQL "G")
%761%					THEN RETURN ZDOUTCON(.ZADDR[CONST2]))
				ELSE R2 _ .ZADDR[CONST2]
			    )
			ELSE R2 _ .ZADDR[CONST2]; !ELSE INTEGER OR LOGICAL OR BYTE
			RETURN ZOUTCON()
		     )
		ELSE
			(R2_.ZADDR[IDSYMBOL]; ZOUTSYM(););
%1251%	IF (R1 _ EXTSIGN(.IEFFADDR -.ZADDR[IDADDR])) NEQ 0 THEN ZOUOFFSET();
       )
  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
		  (R2 _@(.IEFFADDR);
		   ZOUTSYM()
		  )
		ELSE  IF .IADDRPTR GTR 0	!NO SYMBOLIC ADDR
			THEN (R2<LEFT> _ .IEFFADDR; ZOUTOCT()) !IMMEDIATE MODE VALUE
			ELSE  ZLABLMAK(.IEFFADDR);
END;
!
!INDEX FIELD
!
IF .IINDEX NEQ 0
  THEN ( CHR _ "("; LSTOUT();
	IF .IINDEX LEQ 7
		THEN (CHR _ .IINDEX +#60; LSTOUT())
		ELSE (CHR _ "1"; LSTOUT();CHR _ .IINDEX +#50; LSTOUT()
		     );
	 CHR _ ")"; LSTOUT();
	);
END;	! of LSTINST
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 ROUSYM(INSTRUCTION,INSADDR,INARGBLOCK)=
BEGIN
	! Relocatable symbolic output

	MACRO ADD=3$,SUBT=4$;

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

	IF NOT SYMBOL(SYMPTR)		! 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

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

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

	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
			(
			 R2<LEFT> = .ILADDR; ZOUTOCT();
			 COMCOM();
			  R2 = .IADDRPTR;
			   IF .R2[OPERSP] EQL CONSTANT

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

%650%	THEN BEGIN
%650%			LOCAL TMP;
			TMP = .(@ARPTR)[.I+2]<23,4>;
%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 ASCIZ '.HSCHD');
%1245%					R1 = .R2[IDADDR] - .CHDSTART;
%1245%					ZOUOFFSET();
%1245%				END
%1245%				ELSE
%650%				IF .R2[DBLFLG] THEN !DP OR COMPLEX CONSTANT
%650%					(TMP = .R2[CONST2];
%650%					R2 = .R2[CONST1];
%650%					ZDOUTCON(.TMP))
%650%				ELSE (IF .R2[VALTYPE] EQL REAL
%650%					THEN R2 = .R2[CONST1]
%650%					ELSE R2 = .R2[CONST2];
%650%					ZOUTCON());
%650%		END
				ELSE (R2 = .R2[IDSYMBOL]; ZOUTSYM();
					R2 = .IADDRPTR;
%1251%					IF (R1 = EXTSIGN(.IRADDR - .R2[IDADDR])) NEQ 0 THEN ZOUOFFSET();
				     );
			);
%1434%			IF .FLGREG<OBJECT> THEN ROUSYM(.IARGWD,.IADDRPTR,1);
			END;
	TESN;
	IF .FLGREG<OBJECT> THEN
	(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; !OF INCR I DO
END;	! of OUTMDA
GLOBAL ROUTINE ZENDALL(STADDR,ENTADDR)=
BEGIN

! Arguments (object addresses which are relative to beginning of hiseg):
!	STADDR - Start address
!	ENTADDR - Address of a one word entry vector
!			(this only contains valid data under /EXTEND)

! Finishes output of REL file for current program unit.  Dumps  symbol
! table.  Dumps newly defined symbols.   Outputs type 7 start, type  5
! END and type 22 psect break  rel blocks.  Puts LINK switches in  the
! object file in ASCII.

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 SYBRLBF,  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.

%1614%	IF .ARGCHK THEN 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

%1525%			RDATWD = PXCODE;
%1525%			ZOUTBLOCK(RPSECTORG,RELN);
%1576%			RDATWD = 1^18 OR .ENTADDR	! One word 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			***)
	!(***	OCTOUT	outputs an octal number		***)
	!(***	DECOUT	outputs a decimal number	***)

	MACRO	TAB	  = CHROUT(#11) $,
		OCTOUT(X) = (R2<LEFT> = X;  ZOUTOCT()) $,
		DECOUT(X) = (R1 = X;  ZOUDECIMAL()) $;

	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


END ELUDOM