Google
 

Trailing-Edge - PDP-10 Archives - BB-H506D-SM_1983 - cobol/source/cobolf.mac
There are 14 other files named cobolf.mac in the archive. Click here to see a list.
; UPD ID= 3530 on 5/7/81 at 11:02 AM by WRIGHT                          
TITLE	COBOLF FOR COBOL V12B
SUBTTL	PHASE F - LISTING 	AL BLACKINGTON/CAM



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1974, 1981 BY DIGITAL EQUIPMENT CORPORATION


	SEARCH	P
	%%P==:%%P
	ONESEG==:ONESEG
	DEBUG==:DEBUG
	MCS==:MCS
	TCS==:TCS

;EDITS
;NAME	DATE		COMMENTS
;V12A****************
;JEH	23-SEP-80	[1054] PRINT MESSAGE WHEN WARNINGS BEING DUMPED
;DMN	21-AUG-79	[725] MAKE SURE FFATAL IS ON IF FATAL ERRORS EXIST.
;DMN	17-APR-79	[676] FIX EDIT 517, GET LISTING RIGHT WHEN SPACE IN COLUMN 7
;DMN	 9-FEB-79	[633] GIVE BETTER WARNING ON LINE NUMBER WRAP-AROUND
;V12*****************
;MDL	03-SEP-77	[517] IMPROVE READABILITY OF .LST FILE
;V10*****************
;DBT	12/1/74		REMOVE REGO REFERENCE
;ACK	12-JAN-75	ADD CAPABILITY TO HAVE DIAGS UP TO 1023.
;ACK	13-MAR-75	COMP-3/EBCDIC IN THE MAPS.
;********************

; EDIT 351 CLEAR LAST WORD IN HEADER TO PREVENT LISTING GARBAGE.
; EDIT 302 FIX DATE75 SOURCE DATE IN LISTING
; EDIT 263 RECOGNIZE TALLY FOR WARNING MESSAGES [263]

TWOSEG
RELOC	400000

	SALL

	ENTRY	COBOLF

	EXTERNAL GETCPY,PUTLST,HDROUT,SETDN,LCRLF
	EXTERNAL KILL,LNKSET,SETCPY,LSTMES
	EXTERNAL RDATLK,RENLOC,RENNXT
	EXTERNAL RN.01,RN.66
COBOLF:	SETFAZ	F;

	HLLZS	SW		;CLEAR FLAGS

	PUSHJ	PP,CLENTA	;CLEAN UP TABLES, GET NAMTAB

	SKIPE	TE,NAMNXT	;CLEAR FIRST EMPTY WORD IN NAMTAB
	SETZM	1(TE)		;  UNLESS THERE IS NO NAMTAB

	SKIPE	SEQIN		;ANY SEQUENCE NUMBERS?
	SWONS	FSEQ		;YES
	SWOFF	FSEQ		;NO
;SET UP THE DIAGNOSTIC FOR NUMBER ERRORS

	MOVE	TA,SETFAK
	HRRZ	TB,TA
	HRRI	TA,FAKERA
	BLT	TA,FAKERA-1(TB)


;SET UP HEADING LINE

	PUSHJ	PP,SETHDR


;SET UP DIAGNOSTIC FILE

	PUSHJ	PP,SETERA
	MOVE	DT,LITLOC
	MOVEM	DT,ERATAB

	SETZM	COUNTW
	SETZM	COUNTF
IFN ANS74,<
	SETZM	COUNTV##
>
;BRING IN DIAGNOSTICS

GTDIAG:	PUSHJ	PP,GETERA	;PICK UP A DIAG WORD
	JUMPL	DW,GDIAG4	;END OF FILE?

	HRRZI	TD,7		;INSURE THAT POSITION IS IN-BOUNDS
	LDB	TE,ERAPOS
	CAIGE	TE,7		;TOO SMALL?
	DPB	TD,ERAPOS	;YES
	MOVEI	TD,CPMAXN
	CAILE	TE,CPMAXN	;TOO BIG?
	DPB	TD,ERAPOS	;YES

	MOVE	TB,DW		;GET FIRST CHARACTER OF MESSAGE
	PUSHJ	PP,SETDN
	LDB	TA,TE
	CAIN	TA,"F"		;FATAL DIAG?
	IORI	DW,DWFATL	;YES
	TRNE	DW,DWFATL	;IS FATAL FLAG ON?
	JRST	GDIAG0		;YES
	CAIN	TA,"A"		;NO--"A"?
	TLO	DW,DWIMBD	;SET "NO IMBED"

	AOSA	COUNTW		;NO

GDIAG0:	AOS	COUNTF
	MOVEM	DW,(DT)		;STASH IN TABLE

	LDB	TE,DWNUMB	;DID THAT DIAG NEED APPENDED DATA?
	CAIG	TE,LASTHI
	CAIGE	TE,FRSTHI
	JRST	GDIAG2		;NO

IFN ANS74,<
	CAIE	TE,E.507	;FLAGGER VIOLATION MESSAGE?
	JRST	.+3		;NO
	AOS	COUNTV		;YES
	SOS	COUNTW		;GET THE COUNTS CORRECT
>
	PUSHJ	PP,GETERA	;YES--GET NEXT WORD
	AOBJN	DT,GDIAG1	;ROOM FOR IT?
	SUBI	DT,2		;NO--THROW IT AWAY
	HRLI	DT,-2
	JRST	GTDIAG

GDIAG1:	MOVEM	DW,(DT)		;PUT IT IN WORK AREA

GDIAG2:	AOBJN	DT,GTDIAG	;LOOP IF ROOM FOR MORE
;THE TABLE FOR ERRORS IS FULL.  THROW AWAY WARNINGS IN AN ATTEMPT
;	TO GET MORE ROOM.

	OUTSTR [ASCIZ /Error table full, warnings being removed
/]				;[1054] ALERT USER THAT SOME WARNINGS WILL BE LOST
	MOVE	TA,DT		;SAVE DT
	MOVE	DT,ERATAB	;SET DT TO TOP OF TABLE
	HRRZ	TB,DT		;ALSO TB

GDIG3A:	CAIL	TB,(TA)		;DONE?
	JRST	GTDIAG		;YES--RETURN

	MOVE	TC,(TB)		;NO--IS THIS A FATAL ONE?
	TRNN	TC,DWFATL
	JRST	GDIG3B		;NO--DISCARD IT

	MOVEM	TC,(DT)		;YES--SAVE IT
	AOBJP	DT,GDIG3C
	LDB	TE,TCNUMB	;ANY APPENDED DATA?
	CAIG	TE,LASTHI
	CAIGE	TE,FRSTHI
	AOJA	TB,GDIG3A	;NO
	MOVE	TC,1(TB)	;YES--SAVE NEXT WORD ALSO
	MOVEM	TC,(DT)
	ADDI	TB,2
	AOBJN	DT,GDIG3A	;ANY ROOM LEFT?
	SOJA	DT,GDIG3C	;NO

GDIG3B:	LDB	TE,TCNUMB	;ADDITIONAL DATA?
	CAIG	TE,LASTHI
	CAIGE	TE,FRSTHI
	AOJA	TB,GDIG3A	;NO, LOOP.
	ADDI	TB,1		;YES--THROW IT AWAY

	AOJA	TB,GDIG3A	;LOOP

;NO ROOM TO BE SQUEEZED OUT.  SKIP OVER AND COUNT REMAINING DIAGS.

GDIG3C:	SUBI	DT,1		;MAKE ROOM FOR END-TABLE WORD

GDIG3D:	PUSHJ	PP,GETERA
	JUMPL	DW,GDIAG4
	TRNN	DW,DWFATL
	AOSA	COUNTW
	AOS	COUNTF
	LDB	TE,DWNUMB
	CAIG	TE,LASTHI
	CAIGE	TE,FRSTHI
	JRST	GDIG3D
IFN ANS74,<
	CAIE	TE,E.507	;FLAGGER VIOLATION MESSAGE?
	JRST	.+3		;NO
	AOS	COUNTV		;YES
	SOS	COUNTW		;GET THE COUNTS CORRECT
>
	PUSHJ	PP,GETERA
	JRST	GDIG3D
;ALL DIAGS ARE IN

GDIAG4:	MOVSI	TA,377777	;JAM HIGH LINE #
	MOVEM	TA,(DT)
	PUSHJ	PP,SRTERA	;SORT DIAGS

	MOVE	DT,ERATAB	;RESET DT TO TOP

	TSWT	FTERA		;ARE WE TYPING ERRORS?
	JRST	GDIAG5		;NO

	SKIPN	COUNTW		;WE ALWAYS GO THROUGH
	SKIPE	COUNTF		;  LISTING IF
	JRST	GDIAG6		;  THERE ARE ANY DIAGS
IFN ANS74,<
	SKIPE	COUNTV		;OR FLAGGER VIOLATIONS
	JRST	GDIAG6	
>

GDIAG5:	TSWF	FNOLST		;ANY LISTING?
	JRST	MAPOUT		;NO--ADJUST RELOCS AND QUIT

GDIAG6:	PUSHJ	PP,SETCPY	;SET UP CPYFIL
	PUSHJ	PP,GETCPY	;GET FIRST PRINTER CONTROL
;COMPARE LINE NUMBERS OF CPYFIL AND ERAFIL

COMPLN:	LDB	LN,CPYLN	;GET SOURCE LINE NUMBER
	CAIN	LN,17777	;END OF INPUT?
	JRST	LSTGBG		;YES

	PUSH	PP,CH		;SAVE PRINTER CONTROL

	MOVE	DW,(DT)		;IS NEXT DIAG FOR THIS OR PREVIOUS LINE?
	LDB	TA,ERALNA
	CAMG	TA,LN
	SWONS	FERALN		;YES--SET FLAG TO PUT OUT DIAGS
	SWOFF	FERALN		;NO

	POP	PP,CH		;GET BACK PRINTER CONTROL

;GET READY TO PUT OUT SOURCE LINE

	MOVEI	TA,HDROUT
	CAIN	CH,$FF
	SOSA	PAGCNT
	MOVEI	TA,LCRLF
	CAIN	CH,$VT		;DO WE HAVE "/" IN COL 7?
	SETOM	PAGCNT		;YES, FORCE NEW PAGE
	PUSHJ	PP,(TA)		;PUT OUT LINE-  OR FORM-FEED

	LDB	LN,CPYLNA	;GET ALL 14 BITS OF LINE NUMBER
	PUSHJ	PP,GETCPY	;SKIP OVER LINE NUMBER
	PUSHJ	PP,GETCPY

	PUSHJ	PP,PUTLN	;PRINT LINE NUMBER

	MOVEI	TA,1		;TURN OFF "LINE-NUMBER" FLAG
	ANDCAM	TA,@CPYBHI+1

	MOVEI	CP,1		;ASSUME THERE ARE SEQUENCE NUMBERS
	TSWF	FSEQ		;ARE THERE?
	JRST	LSTOUT		;YES

	MOVEI	CP,6		;NO--SKIP OVER FIRST 6 CHARACTERS

CMPLN5:	PUSHJ	PP,GETCPY
	MOVE	TA,@CPYBHI+1
	TRNE	TA,1
	JRST	LSTO4
	SOJG	CP,CMPLN5

	PUSHJ	PP,GETCPY
	MOVEI	CP,7
	JRST	LSTO1A
;PUT OUT THE SOURCE LINE

LSTOUT:	MOVEI	CH," "
	CAIN	CP,1
	PUSHJ	PP,LSTO3
LSTO1:	PUSHJ	PP,GETCPY	;GET SOURCE CHARACTER

LSTO1A:	MOVE	TA,@CPYBHI+1	;SEQUENCE WORD?
	TRNE	TA,1
	JRST	LSTO4		;YES--SEE IF DIAG TO GO OUT

	JUMPE	CH,LSTO1	;IGNORE NULLS

	PUSHJ	PP,LSTO3	;PUT OUT CHARACTER
	CAIN	CP,6
	JRST	LSTO2

	CAIE	CP,7		;[517] COLUMN 7?
	AOJA	CP,LSTO1	;[517] NO, INCREMENT COLUMN COUNTER
IFN ANS74,<
	CAIN	CH,"\"		;IF IT IS \D
	AOJA	CP,LSTO1	;DON'T WANT EXTRA SPACE
>
	PUSH	PP,CH		;[517] SAVE CHAR
	MOVEI	CH,11		;[517] A TAB TO CAUSE PROPER LEFT
	PUSHJ	PP,LSTO3	;[517] MARGIN ALIGNMENT
	MOVEI	CH," "		;[517] IF CHAR IN COL. 7 = * OR -
	POP	PP,TA		;[517] THEN OUTPUT BLANK TO CAUSE
	CAIE	TA,"-"		;[517] PROPER ALIGNMENT NOW THAT
	CAIN	TA,"*"		;[517] "-" OR "*" HAS BEEN SHIFTED
	PUSHJ	PP,LSTO3	;[517] TO THE LEFT
	CAIE	TA,"/"		;SAME FOR "/" IN COL 7
	CAIN	TA," "		;[676] WAS IT SPACE?
	PUSHJ	PP,LSTO3	;[676] YES, PRINT IT
IFN ANS74,<
	CAIE	TA,"D"		;CHECK FOR D IN COL 7
	CAIN	TA,"d"		;ALSO LOWER CASE
	PUSHJ	PP,LSTO3	;YES, THEN PUT IT OUT
>
	AOJA	CP,LSTO1	;[517] INCREMENT COLUMN COUNTER

LSTO2:	MOVEI	CH," "		;YES--PUT OUT AN EXTRA SPACE
	PUSHJ	PP,LSTO3
	AOJA	CP,LSTO1

LSTO3:	TSWT	FTERA		;ARE WE TYPING ERRORS ON TTY?
	JRST	PUTLST		;NO
	TSWF	FERALN		;YES--ERRORS FOR THIS LINE?
	OUTCHR	CH		;YES--TYPE CHARACTER
	JRST	PUTLST

LSTO4:	TSWF	FERALN		;ERRORS FOR THIS LINE?
	PUSHJ	PP,ERAOUT	;YES--PUT THEM OUT
	JRST	COMPLN		;NOW BACK FOR NEXT LINE
;ALL SOURCE IS OUT.
;IF ANY NON-WARNINGS LEFT, PUT THEM OUT HERE.

LSTGBG:	PUSH	PP,DT		;SAVE ADDRESS OF FIRST ONE
LGBG01:	MOVE	DW,(DT)		;GET DIAG
	CAIE	LN,37777	;IF NO MORE,
	TLNE	DW,DWIMBD	;  OR IF THIS IS WARNING,
	JRST	LGBG03		;  FINISH UP

	MOVEI	TD,"1"		;SET LINE NUMBER TO '1'
	DPB	TD,ERALN
	MOVEI	TE,7
	DPB	TE,ERAPOS
	MOVEM	DW,(DT)		;RESTORE DIAG

	LDB	TE,DWNUMB	;IF IT HAS
	CAIG	TE,LASTHI
	CAIGE	TE,FRSTHI	;  APPENDED DATA,
	AOJA	DT,LGBG01
	ADDI	DT,1		;  SKIP A WORD

	AOJA	DT,LGBG01	;LOOP

LGBG03:	CAME	DT,0(PP)	;DID WE PROCESS ANY?
	JRST	LGBG04		;YES
	POP	PP,DT		;NO--BACK OFF STACK
	JRST	LSTWRN

LGBG04:	MOVEI	TE,LSTWRN	;PUT EXIT ADDRESS
	EXCH	TE,0(PP)	;  ON STACK
	PUSH	PP,TE		;  PLUS START OF DIAGS TO GO
	PUSH	PP,DT		;  PLUS END OF DIAGS TO GO
	JRST	ERAO9		;PUT OUT DIAGS, THEN GO TO LSTWRN
;PUT OUT WARNING DIAGNOSTICS

LSTWRN:	TSWF	FTERA		;TYPING ERRORS ON CONSOLE?
	SWON	FLWARN		;YES--SET 'WE ARE DOING WARNINGS'

	MOVE	DW,(DT)		;GET NEXT DIAGNOSTIC
	LDB	LN,ERALNA	;ANY LEFT?
	CAIN	LN,37777
	JRST	LWRN2		;[633] NO

	MOVSI	TE,(ASCIZ "W")	;SET PAGE NUMBER
	MOVEM	TE,HDRPAG	;  TO 'W'
	SETZM	SUBPAG		;SET SUB-PAGE TO ZERO
	SETZM	PAGCNT		;BE SURE TOP-OF-FORM WORKS
	PUSHJ	PP,HDROUT	;SKIP TO NEXT PAGE
	TSWF	FTERA;
	OUTSTR	[ASCIZ "
"]
	MOVE	TE,[POINT 7,[ASCIZ "WARNINGS:"]]
	PUSHJ	PP,PUTMS6
	PUSHJ	PP,PUTMS7
	PUSHJ	PP,PUTMS7

LWRN1:	ANDI	LN,17777	;PUT OUT LINE NUMBER
	PUSHJ	PP,PUTLN

	MOVE	TB,(DT)		;PUT OUT MESSAGE
	PUSHJ	PP,PUTMES

	ADDI	DT,1		;GET NEXT DIAG
	MOVE	DW,(DT)
	LDB	LN,ERALNA	;TERMINATING?
	CAIE	LN,37777
	JRST	LWRN1		;NO--LOOP

LWRN2:	SKIPN	WRAPNO##	;[633] DID LINE NUMBER WRAP AROUND?
	JRST	MAPOUT		;[633] NO
	MOVE	TE,[POINT 7,WRAPMS]	;[633] LONG WARNING MESSAGE
	PUSHJ	PP,PUTMS6	;[633] TO USER
;PRINT OUT MAPS

;SET UP RESDNT, NONRES TO THEIR TRUE VALUES

MAPOUT:	SETZ	TA,
	TSWT	FREENT;		;IS THIS FOR RE-ENTRANT PROGRAM?
	JRST	MAPOT1		;NO

	MOVE	TB,RESDNT	;YES
	MOVEM	TB,NONRES

MAPOT1:	SKIPN	SLASHJ##	;FORCE START ADDR?
	SKIPN	SUBPRG##	;NO, THIS A SUBPROGRAM?
	SKIPA	TA,[STRTS##]	;NO, ADD SIZE OF START-UP CODE
	JRST	MAPOT2		;YES, OMIT THE START-UP CODE
IFN DBMS,<
	SKIPE	SCHSEC##	;IF WE HAVE TO DO DBMS INITIALIZATION
	ADDI	TA,2		; WE WILL NEED TWO MORE LOC'S.
>
IFN MCS!TCS,<
 IFE TOPS20,<
	SKIPE	FINITL##	;DITTO FOR MCS INITIALIZATION.
 >
 IFN TOPS20,<
	SKIPE	CSSEEN##
 >
	ADDI	TA,2
>
IFN CSTATS,<
	SKIPE	METRSW##	;ANOTHER ONE IF METER POINT
	ADDI	TA,1
>
IFN ANS74,<
	SKIPE	DEBSW##		;DEBUG MODULE INVOKED?
	SKIPN	DBPARM##	;AND DEBUGGING ON PROCEDURE NAMES?
	CAIA			;NO
	ADDI	TA,3		;YES, EXTRA CODE TO STORE START-UP LINE #
>
MAPOT2:	MOVEM	TA,FIXEDS	;SAVE THE OFFSET
	TSWT	FREENT;		;IS THIS FOR RE-ENTRANT PROGRAM?
	JRST	MAPOT3		;NO
	MOVE	TA,RESDNT	;GET TOP OF LOW SEGMENT
	ADDI	TA,.JBDA##+COMSIZ##	;PLUS JOBDAT AND LIBOL DATA
	IORI	TA,777		;ROUND UP TO TOP OF PAGE
	ADDI	TA,1		;START NEXT
	CAIGE	TA,400000	;IF ITS BIGGER THAN NORMAL, USE IT
	MOVEI	TA,400000	;ELSE USE 400000 AS HI-SEG ORIGIN
	ADD	TA,FIXEDS	;NOT SURE WHY ITS NEEDED
	MOVEM	TA,RESDNT

	MOVEI	TA,0
	PUSHJ	PP,COUNTE

	JRST	MAPOT5

MAPOT3:	ADDM	TA,RESDNT
	ADDM	TA,NONRES

	MOVEI	TA,NUMEXT
	PUSHJ	PP,COUNTE
	ADDM	TD,NONRES

MAPOT5:	PUSHJ	PP,RELOCF	;RELOCATE ALL ENTRIES IN DATA DIVISION
	SKIPE	PRODSW		;IF '/P' TYPED,
	TSWF	FMAP		;  AND NO
	SKIPA			;  MAP NEEDED,
	JRST	ENDF		;  GO TO PHASE-END

	SKIPE	NAMNXT		;IF WE HAVE A NAME TABLE,
	PUSHJ	PP,SRTNAM	;  SORT IT

	TSWT	FMAP		;IF NO MAP WANTED,
	JRST	ENDF		;  GO TO PHASE END

	MOVSI	TE,(ASCIZ "M")	;SET PAGE NUMBER TO 'M'
	MOVEM	TE,HDRPAG
	SETZM	SUBPAG
	SETZM	PAGCNT		;BE SURE TOP-OF-FORM WORKS
	PUSHJ	PP,HDROUT	;PUT OUT HEADER LINE
;PUT OUT FILE MAP

	MOVE	TA,FILLOC	;SET DT TO FIRST FILE TABLE
	CAMN	TA,FILNXT	;ANYTHING THERE?
	JRST	MAPDAT		;NO--NO FILES

	ADDI	TA,1

MAPF1:	MOVE	TE,PAGCNT	;ARE WE AT THE TOP OF AN OUTPUT PAGE?
	CAIE	TE,LINPAG
	JRST	MAPF2		;NO

	MOVE	TE,[POINT 7,FILHDR]	;YES--PUT OUT PROHDR
	PUSHJ	PP,LSTMES
	MOVNI	TE,3
	ADDM	TE,PAGCNT

MAPF2:	LDB	TE,FI.FLN	;PRINT SOURCE LINE
	PUSHJ	PP,DECFOR
	MOVEI	CH,11
	PUSHJ	PP,PUTLST

	PUSHJ	PP,MAPNAM	;PRINT OUT FILE NAME
	LDB	TB,FI.ACC	;GET ACCESS MODE
	LDB	TD,FI.DSD	;IF THIS
	SKIPE	TD		;  IS AN SD,
	SKIPA	TE,AMODE-1	;  USE SPECIAL MESSAGE
	MOVE	TE,AMODE(TB)
	PUSHJ	PP,LSTMES	;PRINT ACCESS MODE

	JUMPN	TD,MAPF4	;IF THIS IS SD, NO MORE ON LINE
	LDB	TB,FI.ERM	;GET RECORDING MODE
	MOVE	TE,RMODE(TB)
	PUSHJ	PP,LSTMES	;PRINT RECORDING MODE

	LDB	TE,FI.BLF	;GET BLOCKING FACTOR
	MOVEI	CH," "
	CAIG	TE,^D99
	PUSHJ	PP,PUTLST
	CAIG	TE,^D9
	PUSHJ	PP,PUTLST
	PUSHJ	PP,DECANY
	MOVE	TE,[POINT 7,[ASCIZ "      "]]
	PUSHJ	PP,LSTMES

	LDB	TB,FI.LBL	;PRINT OUT LABEL DEFINITION
	MOVE	TE,LBLDEF(TB)
	PUSHJ	PP,LSTMES

MAPF4:	PUSHJ	PP,LCRLF
	LDB	TA,FI.NXT	;GET NEXT FILE TABLE
	PUSHJ	PP,GETLNK
	JUMPN	TA,MAPF1	;IF MORE--LOOP

;FALL INTO DATA MAPPER
	;PRINT OUT MAPS (CONT'D).

;PUT OUT DATA DIVISION MAP

MAPDAT:	MOVE	TA,DATLOC	;ANY DATAB ENTRIES?
	CAME	TA,DATNXT
	JRST	MAPD1		;YES
	MOVE	TA,CONLOC	;NO--ANY CONTAB ENTRIES?
	CAME	TA,CONNXT
	JRST	MAPD1		;YES
	MOVE	TA,MNELOC	;NO--ANY MNETAB ENTRIES?
	CAMN	TA,MNENXT
	JRST	MAPPRO		;NO

MAPD1:	PUSHJ	PP,HDROUT	;YES--PUT OUT HEADER
	HRRZ	LN,NM2LOC	;SET LN TO START OF NM2TAB

MAPD2:	SKIPN	TB,(LN)		;DONE?
	JRST	MAPPRO		;YES--GO PRINT PROCEDURE MAP

	ADD	TB,NAMLOC	;NO--SET TB TO NAMTAB ENTRY
	HRRZ	TA,0(TB)	;ANY LINK TO A TABLE?
	JUMPE	TA,MAPD5

MAPD3:	LDB	TC,LNKCOD
	PUSHJ	PP,GETLNK	;YES--RESOLVE IT
	JUMPE	TA,MAPD5

	CAIN	TC,TB.MNE	;MNETAB?
	JRST	MAPD8		;YES
	CAIN	TC,TB.DAT	;NO--DATAB?
	JRST	MAPD13		;YES
	CAIN	TC,TB.CON	;NO--CONTAB?
	JRST	MAPD6		;YES

MAPD4:	HRRZ	TA,0(TA)	;NO--GET "SAME NAME" LINK
	JUMPN	TA,MAPD3	;LOOP IF NOT EMPTY

MAPD5:	AOJA	LN,MAPD2	;LOOP TO NEXT NM2TAB ENTRY
;PUT OUT MAPS (CONT'D).

;PUT OUT DATA DIVISION MAP (CONT'D).
;ITEM IS A CONDITION NAME.

MAPD6:	PUSHJ	PP,DHDR
	MOVEI	CH,11		;PRINT 2 TABS
	PUSHJ	PP,PUTLST
	PUSHJ	PP,PUTLST

	PUSHJ	PP,MAPNAM
	MOVE	TE,[POINT 7,[ASCIZ "CONDITION-NAME"]]
	PUSHJ	PP,LSTMES

MAPD7:	PUSHJ	PP,LCRLF
	JRST	MAPD4


;ITEM IS A MNEMONIC-NAME

MAPD8:	PUSHJ	PP,DHDR
	MOVEI	CH,11		;PRINT 2 TABS
	PUSHJ	PP,PUTLST
	PUSHJ	PP,PUTLST

	PUSHJ	PP,MAPNAM	;PRINT THE NAME

	MOVE	TD,1(TA)	;IS IT SOME KIND OF SWITCH?
	TLNE	TD,MTSW!MTSON!MTSOFF
	JRST	MAPD9		;YES

	TLNE	TD,MTCONS	;NO--IS THE USER'S CONSOLE?
	JRST	MAPD11		;YES

	TLNE	TD,MTCHAN	;NO--IS IT A PRINTER CHANNEL?
	JRST	MAPD12		;YES

	MOVE	TE,[POINT 7,[ASCIZ "REPORT CODE"]]
	PUSHJ	PP,LSTMES
	JRST	MAPD7
;PRINT OUT MAPS  (CONT'D).

;PUT OUT DATA DIVISION MAP (CONT'D).

;ITEM IS A MNEMONIC-NAME  (CONT'D).

;ITEM IS A SWITCH, AND PERHAPS ON OR OFF STATUS

MAPD9:	MOVE	TE,[POINT 7,[ASCIZ "SWITCH ("]]
MAPD9A:	PUSHJ	PP,LSTMES
	MOVE	TE,TD
	ANDI	TE,77
	PUSHJ	PP,DECANY
	MOVEI	CH, ")"
	PUSHJ	PP,PUTLST

	MOVE	TD,1(TA)
	TLNE	TD,MTSON
	JRST	MAPD10
	TLNN	TD,MTSOFF
	JRST	MAPD7

;ITEM IS SWITCH OFF STATUS

	SKIPA	TE,[POINT 7,[ASCIZ " OFF STATUS"]]

;ITEM IS SWITCH ON STATUS

MAPD10:	MOVE	TE,[POINT 7,[ASCIZ " ON STATUS"]]
	PUSHJ	PP,LSTMES
	JRST	MAPD7

;ITEM IS THE CONSOLE.

MAPD11:	MOVE	TE,[POINT 7,[ASCIZ "CONSOLE"]]
	PUSHJ	PP,LSTMES
	JRST	MAPD7

;ITEM IS A PRINTER CHANNEL

MAPD12:	MOVE	TE,[POINT 7,[ASCIZ "CHANNEL ("]]
	JRST	MAPD9A
;PRINT OUT MAPS  (CONT'D).

;PUT OUT DATA DIVISION MAP (CONT'D).

;ITEM IS A DATA NAME.

MAPD13:	LDB	TE,DA.DEF	;IF ITEM IS NOT DEFINED,
	JUMPE	TE,MAPD4	;  IGNORE IT

	SETZM	LNKSEC##	;DEFAULT IS NON-LINKAGE ITEM
	LDB	TD,DA.LKS##	;IS LINKAGE SECT. BIT ON?
	JUMPE	TD,.+2		;NO
	SETOM	LNKSEC		;YES, SET FLAG FOR THIS ITEM
	PUSHJ	PP,DHDR
	LDB	TE,DA.LN	;PRINT SOURCE LINE NUMBER
	PUSHJ	PP,DECFOR
	MOVEI	CH,11
	PUSHJ	PP,PUTLST

	MOVEI	CH," "
	PUSHJ	PP,PUTLST
	LDB	TE,DA.LVL
	CAIN	TE,77
	MOVEI	TE,^D77
	CAIN	TE,76
	MOVEI	TE,^D66
	PUSHJ	PP,DECTWO
	MOVEI	CH,11
	PUSHJ	PP,PUTLST

	PUSHJ	PP,MAPNAM

	LDB	TE,DA.USG
	MOVE	TE,USGTAB(TE)
	PUSHJ	PP,LSTMES

	HRRZ	TE,1(TA)
	SKIPN	LNKSEC		;IF LINKAGE, DONT ADD IN BASE
	ADD	TE,DATBAS
	PUSHJ	PP,LOCOUT
	SKIPN	LNKSEC		;LINKAGE ITEM?
	JRST	.+3		;NO
	MOVEI	CH,"'"		;YES, PUT APOSTROPHE AFTER LOC
	PUSHJ	PP,PUTLST
	LDB	TE,DA.USG	;IS ITEM DISPLAY?
	CAILE	TE,3
	CAIN	TE,	%US.C3	; OR COMP-3?
	CAIA
	JRST	MAPD14		;NO

	MOVEI	CH," "		;YES--PRINT BIT POSITION

	SKIPN	LNKSEC		;SKIP 1ST SPACE IF LINKAGE ITEM
	PUSHJ	PP,PUTLST
	PUSHJ	PP,PUTLST

	LDB	TD,DA.RES
	MOVEI	TE,^D36
	SUB	TE,TD
	PUSHJ	PP,DECTWO
	JRST	MAPD15
;PRINT OUT DATA-DIVISION MAP (CONT'D).
;ITEM IS A DATA-NAME  (CONT'D).

MAPD14:	MOVEI	CH,11
	PUSHJ	PP,PUTLST

MAPD15:	MOVEI	CH,11
	PUSHJ	PP,PUTLST
	LDB	TE,DA.INS
	LDB	TD,DA.EDT	;IF
	SKIPE	TD		;  EDITED,
	LDB	TE,DA.EXS	;  USE EXTERNAL SIZE
	PUSHJ	PP,DECSIX
	LDB	TE,DA.CLA
	CAIE	TE,2
	JRST	MAPD7

	MOVEI	CH,11
	PUSHJ	PP,PUTLST
	LDB	TE,DA.NDP
	LDB	TD,DA.DPR
	SKIPE	TD
	MOVNS	TE
	PUSHJ	PP,DECFOR

	JRST	MAPD7
;PRINT OUT MAPS  (CONT'D).

;PRINT OUT PROCEDURE DIVISION MAP

MAPPRO:	MOVE	TE,PROLOC	;ANY PROCEDURE NAMES?
	CAMN	TE,PRONXT
	JRST	ENDF		;NO--GO TO NEXT PHASE

	PUSHJ	PP,HDROUT	;PRINT HEADER
	HRRZ	LN,NM2LOC

MAPP2:	SKIPN	TB,(LN)		;DONE?
	JRST	ENDF		;YES--GO TO NEXT PHASE

	ADD	TB,NAMLOC	;NO--GET NAMTAB ENTRY
	HRRZ	TA,0(TB)

MAPP3:	LDB	TC,LNKCOD
	PUSHJ	PP,GETLNK	;NO--GET TABLE ENTRY
	JUMPE	TA,MAPP5

	CAIN	TC,TB.PRO
	JRST	MAPP6		;YES

MAPP4:	HRRZ	TA,0(TA)	;NO--ANY "SAME NAME"?
	JUMPN	TA,MAPP3
MAPP5:	AOJA	LN,MAPP2	;NO--LOOP


MAPP6:	HLRZ	TE,0(TA)	;IF
	ANDI	TE,77777	;  NAME
	ADD	TE,NAMLOC	;  STARTS
	HRLI	TE,600		;  WITH
	ILDB	TE,TE		;  "-",
	CAIN	TE,":"-40	;  FORGET
	JRST	MAPP4		;  IT

	PUSHJ	PP,PHDR		;PRINT OUT PROCEDURE HEADER, IF NECESSARY
	PUSH	PP,TA		;SAVE ADDRESS
	LDB	TA,PR.FLO	;GET FLOTAB LINK
	ANDI	TA,77777
	ADD	TA,FLOLOC
	LDB	TE,FL.LN	;GET LINE NUMBER
	PUSHJ	PP,DECFOR	;PRINT IT OUT
	MOVEI	CH,11
	PUSHJ	PP,PUTLST

	POP	PP,TA		;RESTORE PROTAB ADDRESS
	PUSHJ	PP,MAPNAM	;PRINT OUT THE NAME
	MOVEI	CH, " "
	PUSHJ	PP,PUTLST
	PUSHJ	PP,PUTLST
	PUSHJ	PP,PUTLST
;PRINT OUT MAPS  (CONT'D).

;PRINT OUT PROCEDURE DIVISION MAP (CONT'D).

;PRINT OUT PRIORITY AND SECTION

	LDB	TE,PR.PRI	;GET PRIORITY
	JUMPN	TE,MAPP7	;ZERO?
	MOVE	TE,[POINT 7,[ASCIZ "RES      "]];YES--PRINT "RES"
	PUSHJ	PP,LSTMES
	JRST	MAPP8

MAPP7:	PUSHJ	PP,DECTWO	;NO--PRINT PRIORITY NUMBER
	MOVEI	CH," "		;PRINT 7 SPACES
	MOVEI	TE,7
	PUSHJ	PP,PUTLST
	SOJG	TE,.-1

MAPP8:	LDB	TE,PR.PRI	;IS THIS A RESIDENT PROCEDURE?
	SKIPE	TE
	SKIPA	TE,NONRES	;NO--OFFSET BY NONRES BASE
	MOVE	TE,RESDNT	;YES--OFFSET BY RESDNT BASE
	ADD	TE,1(TA)
	PUSHJ	PP,LOCOUT	;PRINT THE LOCATION
	MOVEI	CH," "
	PUSHJ	PP,PUTLST
	PUSHJ	PP,PUTLST
	PUSHJ	PP,PUTLST

	LDB	TE,PR.SEC	;IF THIS IS A SECTION NAME,
	JUMPE	TE,MAPP10	;  NO NEED FOR IT'S FATHER
	PUSH	PP,TA		;SAVE CURRENT ADDRESS
	HLRZ	TA,1(TA)	;GET SECTION LINK
	JUMPE	TA,MAPP10	;IS IT ZERO?
	ANDI	TA,77777	;NO--CLEAR OFF TABLE CODE
	ADD	TA,PROLOC	;PRINT NAME OF SECTION
	PUSHJ	PP,MAPNAM
	POP	PP,TA		;RESTORE ADDRESS OF PARAGRAPH

MAPP10:	PUSHJ	PP,LCRLF	;PRINT <C.R.>
	JRST	MAPP4
;END OF PHASE F

ENDF:	SKIPE	COUNTF		;[725] ANY FATAL ERRORS?
	SWON	FFATAL		;[725] YES, MAKE SURE ITS ON
	ENDFAZ	F;
;COUNT THE NUMBER OF ITEMS IN EXTAB THAT ARE REFERENCED BY 
;	NON-RESIDENT CODE.

COUNTE:	ADD	TA,EXTLOC
	HRRZS	TA
	HRRZ	TB,EXTNXT
	MOVEI	TD,0

CNTE1:	CAML	TA,TB
	JRST	CNTE2
	MOVE	TE,2(TA)
	TLNE	TE,1B18
	ADDI	TD,1
	ADDI	TA,2
	JRST	CNTE1

CNTE2:	MOVEM	TD,EXTCNT
	POPJ	PP,
;PRINT OUT DATA HEADER FOR MAP, IF NEEDED.

DHDR:	MOVE	TE,PAGCNT
	CAIE	TE,LINPAG
	POPJ	PP,

	MOVE	TE,[POINT 7,DATHDR]
	PUSHJ	PP,LSTMES
	MOVNI	TE,3
	ADDM	TE,PAGCNT
	POPJ	PP,


;PRINT OUT PROCEDURE HEADER FOR MAP, IF NEEDED.

PHDR:	MOVE	TE,PAGCNT
	CAIE	TE,LINPAG
	POPJ	PP,

	MOVE	TE,[POINT 7,PROHDR]
	PUSHJ	PP,LSTMES
	MOVNI	TE,3
	ADDM	TE,PAGCNT
	POPJ	PP,
;SUBROUTINES FOR MAPS

;PRINT OUT "TE" AS TWO DECIMAL DIGITS

DECTWO:	IDIVI	TE,^D10
	MOVEI	CH,"0"(TE)
	PUSHJ	PP,PUTLST
	MOVEI	CH,"0"(TD)
	JRST	PUTLST


;PRINT OUT "TE" AS A DECIMAL NUMBER

DECANY:	IDIVI	TE,^D10
	HRLM	TD,(PP)
	SKIPE	TE
	PUSHJ	PP,DECANY
	HLRZ	CH,(PP)
	ADDI	CH,"0"
	JRST	PUTLST


;PRINT OUT "TE" AS 6 OCTAL DIGITS

LOCOUT:	MOVE	TD,[POINT 3,TE,17]
LOCO1:	ILDB	CH,TD
	ADDI	CH,"0"
	PUSHJ	PP,PUTLST
	TLNE	TD,770000
	JRST	LOCO1

	POPJ	PP,
;PRINT 'TE' AS A FOUR-PLACE DECIMAL NUMBER

DECFOR:	MOVEI	TC,4
	JRST	DEC6A

;PRINT 'TE' AS A SIX-PLACE DECIMAL NUMBER

DECSIX:	MOVEI	TC,6
DEC6A:	MOVEI	TB," "		;ASSUME IT IS POSITIVE
	JUMPGE	TE,DEC6B	;IS IT?
	MOVMS	TE		;NO--FORCE IT TO BE
	MOVEI	TB,"-"		;USE NEGATIVE SIGN

DEC6B:	PUSH	PP,.		;PUSH TERMINATOR FLAG

DEC6C:	IDIVI	TE,^D10		;LOW DIGIT GOES INTO TD
	MOVEI	CH,"0"(TD)	;CONVERT OT DISPLAY DIGIT
	PUSH	PP,CH
	SOJLE	TC,.+2		;IF ALL DIGITS OUT, JUMP
	JUMPN	TE,DEC6C	;IF 'TE' NOT ZERO--LOOP

	PUSH	PP,TB		;STASH SIGN
	JUMPLE	TC,DEC6E	;IF ALL DIGITS OUT, JUMP

DEC6D:	MOVEI	CH," "		;STASH
	PUSHJ	PP,PUTLST	;  LEADING
	SOJG	TC,DEC6D	;  SPACES

DEC6E:	POP	PP,CH		;GET DIGIT
	CAIL	CH,200		;IS IT TERMINATOR?
	POPJ	PP,		;YES--RETURN

	PUSHJ	PP,PUTLST	;NO--PRINT IT
	JRST	DEC6E		;LOOP
;PRINT OUT NAME WHOSE POINTER IS IN ENTRY AT (TA)

MAPNAM:	HLRZ	TE,0(TA)	;GET NAMTAB LINK
	ANDI	TE,77777
	ADD	TE,NAMLOC
	HRRZ	TC,NAMNXT	;IN BOUNDS?
	CAIG	TC,(TE)
	JRST	MAPN3		;NO--ERROR

	HRLI	TE,600		;YES--CREATE A BYTE POINTER
	MOVEI	TC,0
	ILDB	CH,TE
	CAIN	CH,":"-40
	JRST	MAPN2
	SKIPA	TD,[^D30]

MAPN1:	ILDB	CH,TE
	TRNN	CH,60		;DONE?
	JRST	MAPN2		;YES

	ADDI	CH,40		;NO--CONVERT TO ASCII
	CAIN	CH,":"		;REPLACE ":" WITH "-"
	MOVEI	CH,"-"
	CAIN	CH,";"		;REPLACE ";" WITH "."
	MOVEI	CH,"."

	PUSHJ	PP,PUTLST
	SOJLE	TD,MAPN2	;DON'T ALLOW MORE THAN 30 CHARACTERS
	AOJA	TC,MAPN1


MAPN2:	MOVEI	CH,11		;MAKE SURE WE PUT OUT THE
	PUSHJ	PP,PUTLST	;EQUIVALENT OF 32 CHARACTERS
	ADDI	TC,10
	CAIGE	TC,40
	JRST	MAPN2

	POPJ	PP,

MAPN3:	MOVE	TE,[POINT 7,[ASCIZ "??Unknown??"]]
	PUSHJ	PP,LSTMES
	MOVEI	TC,^D11
	JRST	MAPN2
;PUT OUT SOME DIAGNOSTICS.
;BRING IN ALL DIAGS WITH SAME LINE NUMBER.

ERAOUT:	MOVEI	TD,"1"		;SET UP NUMBER AS "1"
	PUSH	PP,DT		;SAVE ADDRESS OF FIRST ERROR
	MOVE	DW,(DT)		;PICK UP DIAG
	LDB	TC,ERAPOS	;PICK UP CHARACTER POSITION

ERAO1:	DPB	TD,DTLNUM	;STASH DIAGNOSTIC COUNT

	LDB	TE,DWNUMB	;WORD TO BE ADDED TO DIAG?
	CAIG	TE,LASTHI
	CAIGE	TE,FRSTHI
	AOSA	DT		;GET NEXT DIAGNOSTIC
	ADDI	DT,2		;YES--SKIP OVER IT
	MOVE	DW,(DT)

	LDB	TB,ERALNA	;SAME LINE NUMBER?
	CAMLE	TB,LN
	JRST	ERAO3		;NO

	LDB	TB,ERAPOS	;YES--SAME POSITION?
IFN ANS68,<
	CAMN	TB,TC
	JRST	ERAO1		;YES
>
IFN ANS74,<
	CAME	TB,TC
	JRST	ERAO2		;NO
	SKIPN	FLGSW##		;YES, FIPS FLAGGER IN EFFECT?
	JRST	ERAO1		;NO, SO WE DON'T CARE
	LDB	TE,DWNUMB	;YES, IS THIS A FLAGGER WARNING
	CAIE	TE,E.507
	JRST	ERAO1		;NO
	LDB	TE,[POINT 10,-2(DT),35]	;IS THE PREVIOUS
	CAIE	TE,E.507
	JRST	ERAO1		;NO
	MOVE	TE,-1(DT)	;YES, GET FIRST LEVEL
	CAME	TE,1(DT)	;ERROR AT SAME LEVEL?
	JRST	ERAO1		;NO, SO GIVE BOTH
	MOVEI	TE,2
	ADDM	TE,(PP)		;ADJUST START OF LIST
	SOS	COUNTV		;COUNT ONE VIOLATION LESS
	JRST	ERAO1		;GET NEXT ONE

ERAO2:>
	ADDI	TC,1		;NO--NEXT POSITION?
	CAME	TB,TC
	JRST	ERAO4		;NO
	CAIE	TC,8		;POSITION 7 AND 8 ARE SPECIAL
	JRST	ERAO1		;NO
				;AS THEY ARE NOT ADJACENT ON THE LISTING

ERAO4:	MOVE	TC,TB		;NO--RESET POSITION
	CAIE	TD,"9"		;NUMBER 9?
	AOJA	TD,ERAO1	;NO--KICK UP BY 1

	MOVEI	TD,"A"		;YES--RESET TO "A"
	JRST	ERAO1


ERAO3:	MOVEI	CH,$CR		;PUT OUT CARRIAGE-RETURN
	PUSHJ	PP,PUTMS4
	MOVEI	CH,$LF
	PUSHJ	PP,PUTMS4

	SOS	PAGCNT
;PUT OUT SOME DIAGNOSTICS  (CONT'D).
;PUT OUT UP-ARROWS.

	MOVEI	CH," "		;PUT OUT SOME SPACES
	MOVEI	CP,5		;5 IF DEC FORMAT
	TSWF	FSEQ		;SEQUENCED INPUT?
	MOVEI	CP,^D13		;13 IF CARD FORMAT
	PUSHJ	PP,PUTMS4
	SOJG	CP,.-1

	PUSH	PP,DT		;SAVE POINTER TO END OF DIAGS
	MOVE	DT,-1(PP)	;RESET TO TOP OF LIST
	MOVEI	CP,7		;SET TO PRINT POSITION 7

	MOVE	TB,(DT)		;GET FIRST ONE
	LDB	TC,TBPOS

ERAO5:	CAMG	TC,CP		;RIGHT PLACE FOR ARROW?
	JRST	ERAO6		;YES
	MOVEI	CH," "		;NO--PUT OUT A SPACE
	PUSHJ	PP,PUTMS4
	CAIN	CP,7		;ACCOUNT FOR TAB AFTER COL 7
	PUSHJ	PP,[PUSHJ PP,PUTMS4
		MOVEI	CH,"	"
		JRST	PUTMS4]
	AOJA	CP,ERAO5	;LOOP

ERAO6:	LDB	CH,TBLN		;GET POSITION NUMBER
	CAIN	TD,"1"		;ONLY ONE ARROW?
	MOVEI	CH," "		;YES--USE SPACE INSTEAD OF NUMBER
	PUSHJ	PP,PUTMS4	;PUT OUT POSITION NUMBER

ERAO7:	MOVEI	CH,"^"		;PUT OUT
	PUSHJ	PP,PUTMS4	;  ARROW

	CAIN	CP,7		;IF COLUMN 7
	PUSHJ	PP,[MOVEI CH,"	"	;  PUT OUT TAB
		JRST	PUTMS4]
	ADDI	CP,1

ERAO8:	ADDI	DT,1		;GET NEXT DIAG
	CAMN	DT,(PP)		;LAST DIAG FOR THIS LINE?
	JRST	ERAO9		;YES

	MOVE	TB,(DT)
	LDB	TC,TBPOS	;SAME PLACE?
	CAMGE	TC,CP
	JRST	ERAO8		;YES
	CAME	TC,CP		;NO--NEXT PLACE?
	AOJA	CP,ERAO5	;NO--LOOP
	CAIE	CP,8		;POSITION 7 AND 8 ARE SPECIAL
	JRST	ERAO7		;NO
	JRST	ERAO6		;AS THEY ARE NOT ADJACENT ON THE LISTING
;PUT OUT SOME DIAGS  (CONT'D).
;DIAGNOSTIC ITSELF IS PUT OUT.

ERAO9:	MOVE	DT,-1(PP)	;RESET DT TO TOP OF LIST
	PUSHJ	PP,PUTMS7	;SPACE DOWN 1 LINE
	PUSHJ	PP,PUTMS7

ERAO10:	PUSHJ	PP,STARS

	MOVE	TB,(DT)		;GET DIAG WORD

	CAIN	TD,"1"		;ONLY ONE DIAG?
	JRST	ERAO11		;YES

	LDB	CH,TBLN		;NO--PUT OUT THE NUMBER
	PUSHJ	PP,PUTMS4
	MOVEI	CH,")"		;PUT OUT ") "
	PUSHJ	PP,PUTMS4
	MOVEI	CH," "
	PUSHJ	PP,PUTMS4

ERAO11:	TRNN	TB,DWFATL	;FATAL DIAG?
	JRST	ERAO12		;NO

	SKIPA	TE,PFATAL	;YES--PUT OUT "FATAL - "
	PUSHJ	PP,PUTMS4
	ILDB	CH,TE
	JUMPN	CH,.-2

ERAO12:
IFN ANS74,<
	PUSH	PP,TD		;SAVE NO. OF DIFFERENT DIAGS
>
	PUSHJ	PP,PUTMES
IFN ANS74,<
	POP	PP,TD
>

ERAO13:	ADDI	DT,1
	CAMN	DT,(PP)		;DONE?
	JRST	ERAO14		;YES--QUIT

	MOVE	TB,-1(DT)	;SAME DIAG?
	CAME	TB,(DT)
	JRST	ERAO10		;NO--PROCESS IT
	TRNN	TB,DWFATL	;YES--FATAL?
	SOSA	COUNTW		;NO--DECREMENT WARNING COUNT
	SOS	COUNTF		;YES--DECREMENT FATAL COUNT
	JRST	ERAO13		;IGNORE IT

ERAO14:	TSWF	FTERA		;IF WE ARE TYPING ERRORS, TYPE <C.R.>
	OUTSTR	[ASCIZ "
"]
	POP	PP,DT
	POP	PP,TE		;THROW AWAY ONE ENTRY
	POPJ	PP,
;GO THROUGH FILE SECTION RELOCATING ALL ITEMS.
;THEY ARE NOW ALLOCATED RELATIVE TO RECORD AREA.

RELOCF:	MOVE	TE,FILLOC	;ARE THERE ANY FILES?
	CAMN	TE,FILNXT
RELOC0:	POPJ	PP,		;NO--QUIT

	MOVEI	TA,1(TE)	;SET TO FIRST FILE TABLE

RELOC1:	LDB	TE,FI.FDD	;IF NOT DEFINED,
	JUMPE	TE,RELOC2	;  FORGET IT

	PUSH	PP,TA
	LDB	TC,FI.LOC	;GET BASE ADDRESS FOR RECORD
	LDB	TA,FI.DRL	;GET DATA RECORD LINK
	PUSHJ	PP,RELOC4	;GO THROUGH RELOCATION PROCESS

	MOVE	TA,(PP)
	LDB	TA,FI.LRL	;GET LABEL RECORD LINK
	PUSHJ	PP,RELOC4	;GO THROUGH RELOCATION PROCESS
	POP	PP,TA

RELOC2:	LDB	TA,FI.NXT	;ANY MORE FILES?
	JUMPE	TA,RELOC0	;NO, IF JUMP
	PUSHJ	PP,LNKSET	;YES--GET ADDRESS OF NEXT ONE
	JRST	RELOC1
;GO THRU FILE TABLE RELOCATING ALL ITEMS (CONT'D).
;RELOCATE ALL SONS AND BROTHERS
;TC= BASE ADDRESS (RUNTIME LOC) OF RECORD

RELOC4:	LDB	TE,LNKCOD
	CAIE	TE,TB.DAT
RELOC5:	POPJ	PP,
	MOVEM	TA,RDATLK	;Save DATAB link incase we need it

	PUSHJ	PP,LNKSET
	HRLM	TA,(PP)

	LDB	TE,DA.DEF	;IF NOT DEFINED,
	JUMPE	TE,RELOC5	;  FORGET IT
	LDB	TE,DA.DFS	;IF NOT DEFINED IN THE FILE SECTION,
	JUMPE	TE,RELOC5	;  FORGET IT
	MOVEI	TE,0		;RESET
	DPB	TE,DA.DFS	;  FLAG
	ADDM	TC,1(TA)	;RELOCATE
	LDB	TE,DA.LVL	;Get level number of item
	CAIN	TE,LVL.01	;Was that an 01-level item?
	 PUSHJ	PP,RLLVL1	;Yes, check for RENAMED items
				; subordinate to it.
	LDB	TA,DA.SON	;Get first son link
	PUSHJ	PP,RELOC4	;Recurse

	HLRZ	TA,(PP)
	LDB	TE,DA.FAL	;IF LINK IS 'FATHER'
	JUMPN	TE,RELOC5	;  POP UP ONE LEVEL

	LDB	TA,DA.BRO	;GET BROTHER LINK
	JRST	RELOC4
;Routine to relocate any renamed items in the file section
; They point to 01-level items, and are put in RENTAB.
;Input: RDATLK/ datab link to 01 item
;Uses TE,TD,TB

RLLVL1:	MOVE	TE,RENLOC	;Any items in the RENAMED table?
	CAMN	TE,RENNXT	; Probably not, renamed items in the FILE
	  POPJ	PP,		;SECTION hasn't ever worked!
	PUSH	PP,TA		;Save current link
	MOVE	TA,RENLOC	;Point to renamed items table
RLLV1A:	LDB	TB,RN.01	;Do we need to relocate this one?
	CAMN	TB,RDATLK	;. .?
	 PUSHJ	PP,RLLVG	;Yes, relocate this item
	ADD	TA,[1,,1]	;Go on to next item
	CAME	TA,RENNXT	;Done?
	 JRST	RLLV1A		;No, continue
	POP	PP,TA		;Restore link to 01-datab entry
	POPJ	PP,		;And return

;Subroutine to relocate this RENTAB item
;Uses TE
RLLVG:	PUSH	PP,TA		;Save link
	LDB	TA,RN.66	;Get DATAB link for renamed item
	PUSHJ	PP,LNKSET
	ADDM	TC,1(TA)	;Relocate
	MOVEI	TE,0		;Clear flag "Defined in file section"
	DPB	TE,DA.DFS	; (not that it matters..)
	POP	PP,TA		;Restore link
	POPJ	PP,		;Return
;PRINT OUT ASSIGNED LINE NUMBER

;	[517] REMOVE THE 4 BLANKS AT THE BEGINNING OF A .LST LINE
PUTLN:
;[517]	MOVEI	TA,4		;PUT OUT 4 SPACES
;[517]	MOVEI	CH," "
;[517]	PUSHJ	PP,PUTLNE
;[517]	SOJG	TA,.-1
	MOVE	TE,LN		;CONVERT LN TO DECIMAL
	TRZ	TE,1B22		;CLIP OFF HI-BIT
	MOVEI	TA,4

PUTLNC:	IDIVI	TE,^D10
	ADDI	TD,"0"
	LSHC	TD,-7
	SOJG	TA,PUTLNC

	MOVEI	TA,4		;PRINT IT OUT
PUTLND:	LSHC	TD,7
	MOVE	CH,TD
	PUSHJ	PP,PUTLNE
	SOJG	TA,PUTLND


	MOVEI	CH," "
	TRZE	LN,1B22
	MOVEI	CH,"C"
	PUSHJ	PP,PUTLNE
	MOVEI	CH," "

PUTLNE:	TSWT	FTERA;
	JRST	PUTLST
	TSWF	FLWARN!FERALN;
	OUTCHR	CH
	JRST	PUTLST
;PRINT THE DIAGNOSTIC MESSAGE

PUTMES:
IFN ANS74,<
	MOVE	TE,[POINT 7,[ASCIZ /CBL/]]
	PUSHJ	PP,PUTMS6
	LDB	TE,TBNUM	;GET DIAGNOSTIC NUMBER
	CAIGE	TE,^D10		;BIGGER THAN 9
	JRST	PUTMSU		;NO
	CAIGE	TE,^D100	;BIGGER THAN 100
	JRST	PUTMST		;NO
	CAIGE	TE,^D1000	;THOUSAND
	JRST	PUTMSH		;NO
	IDIVI	TE,^D1000	;GET THOUSAND
	PUSHJ	PP,PUTMSA
PUTMSH:	IDIVI	TE,^D100	;GET HUNDREDS
	PUSHJ	PP,PUTMSA
PUTMST:	IDIVI	TE,^D10		;GET TENS
	PUSHJ	PP,PUTMSA
PUTMSU:	PUSHJ	PP,PUTMSA	;NOTE NOTHING IN TE+1
	LDB	TE,TBNUM
	MOVEI	CH," "
	PUSHJ	PP,PUTMS4
	CAIGE	TE,^D100
	PUSHJ	PP,PUTMS4
	CAIGE	TE,^D10
	PUSHJ	PP,PUTMS4
	LDB	TE,TBNUM	;GET ERROR #
	CAIN	TE,E.507	;FIPS FLAGGER ERROR?
	JRST	PUTMSF		;YES, ITS SPECIAL
>
	PUSHJ	PP,SETDN	;"TE" _ BYTE POINTER TO MESSAGE

PUTMS1:	ILDB	CH,TE		;GET CHARACTER
	JUMPE	CH,PUTMS2	;JUMP IF NULL

	CAIN	CH,$CR		;IGNORE CARRIAGE-RETURNS
	JRST	PUTMS1

	CAIN	CH,$LF		;END OF A LINE?
	JRST	PUTMS3		;YES

	PUSHJ	PP,PUTMS4	;NO--PRINT THE CHARACTER
	JRST	PUTMS1		;LOOP

PUTMS3:	PUSHJ	PP,PUTMS7	;END OF A LINE--PUT OUT <C.R.>,<L.F.>
	TSWF	FTERA;
	OUTSTR	[ASCIZ "	"]
	PUSHJ	PP,STARS
	JRST	PUTMS1

PUTMS2:	LDB	TE,TBNUM##	;WORD TO BE ADDED?
	CAIG	TE,LASTHI
	CAIGE	TE,FRSTHI
	CAIA
	PUSHJ	PP,NAMWRD	;YES--PRINT IT

	LDB	TE,TBNUM	;WAS THAT DIAG 100 (NOT YET IMPLEMENTED)?
	CAIE	TE,^D100
	JRST	PUTMS7		;NO--PUT OUT <C.R.> AND RETURN

	MOVE	TE,[POINT 7,[ASCIZ " in phase "]]
	PUSHJ	PP,PUTMS6
	LDB	CH,TBFAZ
	IORI	CH,100
	PUSHJ	PP,PUTMS4
PUTMS7:	TSWF	FTERA;		;PUT OUT CARRIAGE-RETURN AND RETURN

	OUTSTR	[ASCIZ "
"]
	JRST	LCRLF

IFN ANS74,<
PUTMSA:	MOVEI	CH,"0"(TE)
	MOVE	TE,TE+1
>
PUTMS4:	TSWF	FTERA		;IF ERRORS ARE BEING TYPED,
	OUTCHR	CH		;  TYPE CHARACTER
	JRST	PUTLST

PUTMS5:	PUSHJ	PP,PUTMS4
PUTMS6:	ILDB	CH,TE
	JUMPN	CH,PUTMS5
	POPJ	PP,
;PUT OUT 3 STARS FOLLOWED BY TAB

STARS:	PUSH	PP,TE
	MOVE	TE,[POINT 7,[ASCIZ "***	"]]
	PUSHJ	PP,LSTMES
	MOVEI	CH,11		;PUT OUT
	TSWF	FSEQ		;  EXTRA TAB IF
	PUSHJ	PP,PUTLST	;  SEQUENCED INPUT
	POP	PP,TE
	POPJ	PP,

IFN ANS74,<
PUTMSF:	ADDI	DT,1
	HRRZ	TE,(DT)		;GET LEVEL IN SECOND WORD
	MOVE	TE,FIPTBL-1(TE)	;GET START OF MESSAGE
	PUSHJ	PP,PUTMS6	;PRINT IT
	MOVE	TE,[POINT 7,[ASCIZ / syntax exceeds requested level./]]
	PUSHJ	PP,PUTMS6	;FINISH IT OFF
	JRST	PUTMS7		;AND END WITH CR-LF

	INTERN	FIPTBL
FIPTBL:	POINT 7,[ASCIZ /FIPS Low Level/]
	POINT 7,[ASCIZ /FIPS Low-Intermediate Level/]
	POINT 7,[ASCIZ /FIPS High-Intermediate Level/]
	POINT 7,[ASCIZ /FIPS High Level/]
	POINT 7,[ASCIZ /Report Writer/]
IFE TOPS20,<
	POINT 7,[ASCIZ /DBMS-10/]
>
IFN TOPS20,<
	POINT 7,[ASCIZ /DBMS-20/]
>
	POINT 7,[ASCIZ /COBOL-68/]
	POINT 7,[ASCIZ /IBM/]
	POINT 7,[ASCIZ /VAX COBOL/]
	POINT 7,[ASCIZ /COBOL-79/]
IFE TOPS20,<
	POINT 7,[ASCIZ /DECsystem-10 Non-Standard COBOL/]
>
IFN TOPS20,<
	POINT 7,[ASCIZ /DECSYSTEM-20 Non-Standard COBOL/]
>

>
;SET UP HEADER FOR PRINT LINE.

SETHDR:	SETZM	HEADER		;[351] ZERO OUT THE FIRST 2 LINES
	MOVSI	TA,HEADER	;[351]  OF THE LISTING TO PREVENT
	HRRI	TA,HEADER+1	;[351]  GARBAGE ON LISTING.
	BLT	TA,HEADR2+6	;[351]
	MOVE	TB,[POINT 7,HEADER]
;[517]	PUSHJ	PP,SPA4		;PUT OUT 4 SPACES
	MOVEI	CH,40		;[517] FOLLOWING IS EXPECTING A BLANK

	MOVE	TA,[POINT 6,[SIXBIT "SUB"]]
	SKIPN	SLASHJ##	;FORCE START ADDR (IE NOT A SUBPROG)?
	SKIPN	SUBPRG##	;NO, IS THIS A SUBPROGRAM?
	SKIPA	TA,[POINT 6,[SIXBIT "PROGRAM"]]	;NO
	PUSHJ	PP,SPACIT	;YES, PUT "S U B " BEFORE "P R O G R A M"

	PUSHJ	PP,SPACIT
	IDPB	CH,TB		;PUT OUT 2 SPACES
	IDPB	CH,TB

	MOVE	TE,PROGID	;PUT OUT "P R O G I D "
	MOVEI	TD,0
	MOVE	TA,[POINT 6,TE]
	PUSHJ	PP,SPACIT
	MOVEI	TC,11		;PUT OUT 2 TABS
	IDPB	TC,TB
IFN BIS,<
	SKIPE	PRODSW		;UNLESS BIS /P
	SKIPN	OPTSW		;AND /O
	CAIA			;NO
	PUSHJ	PP,SPA4P	;SKIP TAB AND GIVE 4 SPACES INSTEAD
>
	  IDPB	TC,TB

IFN ANS68,<
	MOVE	TA,[POINT 6,[SIXBIT "COBOL-68"]]	;PRINT "COBOL"
>
IFN ANS74,<
	MOVE	TA,[POINT 6,[SIXBIT "COBOL-74"]]	;PRINT "COBOL"
>
	PUSHJ	PP,SIXIT
	IDPB	CH,TB		;ANOTHER SPACE
	MOVE	TA,[POINT 6,VERZUN] ;VERSION NUMBER
	PUSHJ	PP,SIXIT

	MOVEI	CH," "
	IDPB	CH,TB		;SPACE
IFN BIS,<
	MOVE	TA,[POINT 6,[SIXBIT "BIS"]]
	PUSHJ	PP,SIXIT
>
	MOVE	TA,[POINT 6,[SIXBIT "/O"]]
	SKIPE	OPTSW##		;OPTIMIZER ON?
	PUSHJ	PP,SIXIT	;YES

	MOVE	TA,[POINT 6,[SIXBIT "/P"]]
	SKIPE	PRODSW		;PRODUCTION COMPILATION?
	PUSHJ	PP,SIXIT	;YES

	MOVEI	TC,11		;PUT OUT TAB
	IDPB	TC,TB
;SET UP HEADER  (CONT'D)

	MOVE	TA,[POINT 7,STDATE];PUT OUT DATE
	ILDB	TC,TA
	CAIN	TC,"0"
	MOVEI	TC," "
	IDPB	TC,TB
	ILDB	TC,TA
	SKIPE	TC
	JRST	.-3

	IDPB	CH,TB		;PUT OUT 2 SPACES
	IDPB	CH,TB

	MOVE	TA,[POINT 7,STTIME];PUT OUT TIME
	ILDB	TC,TA
	IDPB	TC,TB
	TLNE	TA,760000
	JRST	.-3

	MOVEI	TC,11		;PUT OUT 2 TABS
	IDPB	TC,TB
	IDPB	TC,TB

	MOVE	TA,[POINT 6,[SIXBIT "PAGE"]];PUT OUT "PAGE"
	PUSHJ	PP,SIXIT
	IDPB	CH,TB		;PUT OUT SPACE
	MOVEI	TA,0		;PUT OUT NULL
	IDPB	TA,TB

	SETZM	HDRPAG		;SET PAGE NUMBER TO ZERO
	SETOM	SUBPAG		;SET SUB-PAGE TO -1
	SETZM	PAGCNT		;BE SURE TOP-OF-FORM WORKS
;PUT OUT 2ND LINE OF PAGE HEADING

	SKIPN	SRCFIL		;IF NO FILE NAME
	POPJ	PP,		;DON'T PUTOUT GARBAGE LINE
	MOVE	TB,[POINT 7,HEADR2##]
;[517]	PUSHJ	PP,SPA4		;PUT OUT 4 SPACES
	MOVEI	CH,40		;[517] FOLLOWING IS EXPECTING A BLANK
	MOVE	TA,[POINT 6,SRCFIL##]	;PUT OUT SOURCE FILE NAME
	PUSHJ	PP,SIXIT
	MOVEI	CH,"."		;DOT
	IDPB	CH,TB
	MOVE	TA,[POINT 6,SRCFIL+1,5]	;EXTENSION
	PUSHJ	PP,SIXIT
	PUSHJ	PP,SPA4		;4 SPACES
	LDB	TD,[POINT 12,SRCFIL+2,35]	;DATE
	LDB	TC,[POINT 3,SRCFIL+1,35]	; [302] HIGH-ORDER DATE
	DPB	TC,[POINT 3,TD,23]		; [302] COMINE WITH LOW-ORDER DATE
	IDIVI	TD,^D31
	ADDI	TC,1
	PUSH	PP,TD
	MOVEI	TD,(TC)		;DAY
	PUSHJ	PP,DIG2
	MOVEI	CH,"-"
	IDPB	CH,TB
	POP	PP,TD
	IDIVI	TD,^D12
	MOVE	TA,[POINT 7,MONTBL]	;MONTH IN LOWERCASE
	ADDI	TA,(TC)
	TRNA
	IDPB	TC,TB
	ILDB	TC,TA
	JUMPN	TC,.-2
	MOVEI	CH,"-"
	IDPB	CH,TB
	ADDI	TD,^D64		;YEAR
	CAIL	TD,^D100	; [302] CHECK FOR YR 2000+
	SUBI	TD,^D100	; [302] COMPENSATE
	PUSHJ	PP,DIG2
	MOVEI	TC,2		;2 SPACES
	PUSHJ	PP,SPA2
	LDB	TD,[POINT 11,SRCFIL+2,23]	;TIME
	IDIVI	TD,^D60
	PUSH	PP,TC
	PUSHJ	PP,DIG2		;HOURS
	MOVEI	CH,":"
	IDPB	CH,TB
	POP	PP,TD		;MINUTES
	JRST	DIG2
;PUT "X X ..." INTO HEADER

SPCIT1:	ADDI	TC,40
	CAIN	TC,":"
	MOVEI	TC,"-"
	IDPB	TC,TB
	IDPB	CH,TB

SPACIT:	ILDB	TC,TA
	JUMPN	TC,SPCIT1
	POPJ	PP,


;PUT SIXBIT FIELD INTO HEADER

SIXIT1:	ADDI	TC,40
	IDPB	TC,TB

SIXIT:	ILDB	TC,TA
	JUMPN	TC,SIXIT1
	POPJ	PP,

;MAKE SPACES IN HEADER

IFN BIS,<
SPA4P:	AOS	(PP)		;SKIP RETURN
>
SPA4:	MOVEI	TC,4		;PUT OUT 4 SPACES
SPA2:	MOVEI	CH,40
	IDPB	CH,TB
	SOJG	TC,.-1
	POPJ	PP,

;MAKE A 2-DIGIT # IN HEADER

DIG2:	IDIVI	TD,^D10
	ADDI	TD,"0"
	IDPB	TD,TB
	ADDI	TC,"0"
	IDPB	TC,TB
	POPJ	PP,

;TABLE OF MONTHS

MONTBL:	ASCIZ	/Jan/
	ASCIZ	/Feb/
	ASCIZ	/Mar/
	ASCIZ	/Apr/
	ASCIZ	/May/
	ASCIZ	/Jun/
	ASCIZ	/Jul/
	ASCIZ	/Aug/
	ASCIZ	/Sep/
	ASCIZ	/Oct/
	ASCIZ	/Nov/
	ASCIZ	/Dec/
;PRINT OUT A USER NAME APPENDED TO DIAGNOSTIC MESSAGE

NAMWRD:	ADDI	DT,1		;GET LINK
	HRRZ	TA,(DT)
IFN ANS68,<
	CAIN	TA,TALLY.##	; IS IT TALLY [263]
	JRST	NAMTAL		; YES RECOGNIZE IT [263]
>
	TRC	TA,600000	;VALTAB?
	TRCN	TA,600000
	JRST	NAMWD3		;YES
	PUSHJ	PP,GETLNK	;CONVERT TO ADDRESS
	JUMPE	TA,NAMWD2

	HLRZ	TA,(TA)		;GET NAMTAB LINK
	ANDI	TA,77777
	ADD	TA,NAMLOC	;CONVERT TO ADDRESS
	HRRZ	TB,NAMNXT	;IN BOUNDS?
	CAIG	TB,(TA)
	JRST	NAMWD2		;NO

	MOVE	TB,[POINT 6,1(TA)]

	MOVEI	CH,40
	PUSHJ	PP,PUTMS4


NAMWD1:	ILDB	CH,TB		;GET CHARACTER FROM NAMTAB
	TRNN	CH,60		;DONE?
	POPJ	PP,		;YES--EXIT

	CAIN	CH,":"-40	;NO--IS IT ":"?
	MOVEI	CH,"-"-40	;YES--SHOULD BE "-"
	CAIN	CH,";"-40	;LIKEWISE REPLACE ";" WITH "."
	MOVEI	CH,"."-40

	ADDI	CH,40		;CONVERT TO ASCII
	PUSHJ	PP,PUTMS4	;PRINT IT OUT

	JRST	NAMWD1		;LOOP


IFN ANS68,<
NAMTAL:	SKIPA	TE,[POINT 7,[ASCIZ " TALLY"]] ; [263]
>
NAMWD2:	MOVE	TE,[POINT 7,[ASCIZ " ??Unknown??"]]
	JRST	PUTMS6

NAMWD3:	MOVEI	CH," "
	PUSHJ	PP,PUTMS4	;SPACE
	HRRZ	TE,TA
	TRZ	TE,600000
	ADD	TE,VALLOC	;ADD IN BASE
	HRLI	TE,(POINT 7,)	;FORM BYTE POINTER
	ILDB	CH,TE		;GET COUNT
	PUSH	PP,CH		;SAVE IT
NAMWD4:	ILDB	CH,TE		;GET A CHAR
	PUSHJ	PP,PUTMS4	;LIST IT
	SOSLE	(PP)		;ANY MORE?
	JRST	NAMWD4		;YES
	POP	PP,CH		;NO, REMOVE COUNT
	POPJ	PP,
;CONVERT TABLE-LINK TO ADDRESS.
;IF TROUBLE, RETURN WITH ZERO.

GETLNK:	LDB	TE,[POINT 3,TA,20]
	ANDI	TA,77777
	JUMPE	TA,GTLNK8

	ADD	TA,@GTLNK9(TE)
	MOVE	TE,GTLNK9(TE)
	HRRZ	TE,1(TE)
	CAIGE	TE,-1(TA)
	MOVEI	TA,0

GTLNK8:	POPJ	PP,

GTLNK9:	EXP FILLOC
	EXP DATLOC
	EXP CONLOC
	EXP LITLOC
	EXP PROLOC
	EXP EXTLOC
	EXP VALLOC
	EXP MNELOC
SUBTTL	READ IN AN ERAFIL WORD

GETERA:	SOSG	ERABHI+2
	JRST	GETER2
GETER1:	ILDB	DW,ERABHI+1
	POPJ	PP,


GETER2:	AOS	ERABLK
	IN	ERA,
	  JRST	GETER1
	MOVEI	CH,ERADEV
	JRST	DEVDED


SETERA:	MOVE	TA,ERABUF	;SET JOBFF TO A BUFFER AREA
	MOVEM	TA,.JBFF##
	INBUF	ERA,2		;GRAB 2 BUFFERS
	SETZM	ERABLK		;CLEAR BLOCK COUNTER
IFN BIS,<
	DMOVE	TE,ERAHDR	;SET UP "LOOKUP" PARAMETERS
>
IFE BIS,<
	MOVE	TE,ERAHDR	;SET UP "LOOKUP" PARAMETERS
	MOVE	TD,ERAHDR+1
>
	SETZB	TC,TB
	LOOKUP	ERA,TE		;FIND THE FILE
	  JRST	KNOERA		;NOT THERE--CATASTROPHE
	POPJ	PP,

;CANNOT FIND ERAFIL

KNOERA:	[ASCIZ "ERAFIL not found
"]
	JRST	KILL
SUBTTL	SORT DIAGNOSTIC WORDS

;THE DATA CONSISTS OF ONE AND TWO WORD ENTRIES.
;THEY ARE SORTED DISREGARDING DIAGNOSTIC NUMBERS, SUCH THAT
;	ALL DIAGS FOR SAME POSITION WILL BE PRINTED IN THE ORDER
;	THEY WERE WRITTEN ONTO ERAFIL.

;THE DIAGS ARE CURRENTLY IN CORE, "ERATAB" POINTS TO THE FIRST ITEM,
;	"DT" POINTS TO THE LAST.

SRTERA:	HRRZ	TA,ERATAB	;SET TA TO THE FIRST DIAG
	MOVEI	TC,0		;CLEAR FLAG

SRTER1:	CAIN	TA,(DT)		;ARE WE DONE?
	JRST	SRTER8		;YES

	MOVE	TB,0(TA)	;NO--GET FIRST DIAG OF CURRENT PAIR
	ANDI	TB,DIAGNO	;IS IT A DOUBLE-WORD ONE?
	CAIG	TB,LASTHI
	CAIGE	TB,FRSTHI
	TDCA	TB,TB		;SINGLE--TB_0
	SKIPA	TE,2(TA)	;DOUBLE
	SKIPA	TE,1(TA)	;SINGLE
	MOVEI	TB,1		;DOUBLE

	MOVE	TD,TE		;IS SECOND DIAG DOUBLE?
	ANDI	TD,DIAGNO
	CAIG	TD,LASTHI
	CAIGE	TD,FRSTHI
	CAIA
	ADDI	TB,2		;YES--BUMP TB BY 2

	MOVE	TD,0(TA)
	ANDCMI	TD,DIAGNO	;STRIP OFF DIAG NUMBER
	ANDCMI	TE,DIAGNO

	CAMLE	TD,TE		;ARE THEY IN ORDER?
	JRST	@STAB1(TB)	;NO--EXCHANGE
	AOJA	TA,@STAB2(TB)	;YES--NO EXCHANGE

SRTER8:	JUMPN	TC,SRTERA	;ONE PASS DONE--ANY EXCHANGES?
	POPJ	PP,		;NO--THEY ARE ALL IN ORDER
;TABLE OF ROUTINES TO EXCHANGE ITEMS

STAB1:	EXP	SRT10	;SINGLE FOLLOWED BY SINGLE
	EXP	SRT15	;DOUBLE,SINGLE
	EXP	SRT13	;SINGLE,DOUBLE
	EXP	SRT16	;DOUBLE,DOUBLE

;TABLE OF WHERE TO GO IF NO EXCHANGE

STAB2:	EXP	SRTER1	;SINGLE,SINGLE
	EXP	SRT12	;DOUBLE,SINGLE
	EXP	SRTER1	;SINGLE,DOUBLE
	EXP	SRT12	;DOUBLE,DOUBLE

;EXCHANGE ROUTINES

;BOTH ARE SINGLE
SRT10:	MOVE	TB,0(TA)
	EXCH	TB,1(TA)
	MOVEM	TB,0(TA)
SRT11:	MOVNI	TC,1
SRT12:	AOJA	TA,SRTER1

;SINGLE FOLLOWED BY DOUBLE
SRT13:	MOVE	TB,0(TA)
	EXCH	TB,2(TA)
	EXCH	TB,1(TA)
	MOVEM	TB,0(TA)
	AOJA	TA,SRT11

;DOUBLE FOLLOWED BY SINGLE
SRT15:	MOVE	TB,0(TA)
	EXCH	TB,1(TA)
	EXCH	TB,2(TA)
	MOVEM	TB,0(TA)
	MOVNI	TC,1
	AOJA	TA,SRTER1

;BOTH ARE DOUBLES

SRT16:	MOVE	TB,0(TA)
	EXCH	TB,2(TA)
	MOVEM	TB,0(TA)
	MOVE	TB,1(TA)
	EXCH	TB,3(TA)
	MOVEM	TB,1(TA)
	AOJA	TA,SRT11
SUBTTL SORT USER NAMES IN NAMTAB

;PACK POINTERS TO USER NAMES AT TOP OF NM2TAB

SRTNAM:	MOVN	TA,NM12SZ
	MOVSS	TA
	HRR	TA,NM2LOC
	MOVEI	LN,(TA)
	HRRZ	CP,NAMLOC
	MOVSI	TD,CP

SRTN1:	SKIPN	TE,(TA)
	JRST	SRTN2

	HRR	TD,TE
	MOVE	TC,@TD
	TLNN	TC,NAMRSV/1000000
	TRNN	TC,-1
	JRST	SRTN2

	MOVEM	TE,(LN)
	ADDI	LN,1

SRTN2:	AOBJN	TA,SRTN1

;LN NOW POINTS TO LAST ENTRY PLUS 1

	SETZM	(LN)
;SORT NM2TAB ACCORDING TO NAMES IN NAMTAB

	MOVSI	TA,CP
	MOVSI	TB,CP
	PUSH	PP,W1		;[464] SAVE BEFORE THE SORT LOOP

SRTN3:	HRRZ	TC,NM2LOC	;SET TC TO TOP OF TABLE
	MOVEI	DT,0
	SUBI	LN,1

SRTN4:	CAIL	TC,(LN)		;DONE WITH THIS PASS?
	JRST	SRTN9		;YES

	HLRZ	TE,(TC)		;NO--GET SIZE OF ITEM-A
	HLRZ	TD,1(TC)	;GET SIZE OF ITEM-B
	HRR	TA,(TC)		;GET ADDRESS OF ITEM-A
	HRR	TB,1(TC)	;GET ADDRESS OF ITEM-B

SRTN5:	ADDI	TA,1
	ADDI	TB,1

	MOVE	CH,@TA		;GET A WORD FROM ITEM-A
	CAME	CH,@TB		;IS IT EQUAL TO WORD FROM ITEM-B?
	JRST	SRTN8		;NO

	SOJLE	TD,SRTN6	;YES--HAVE WE LOOKED AT ALL OF ITEM-B?
	SOJG	TE,SRTN5	;NO--HAVE WE LOOKED AT ALL OF ITEM-A?

SRTN5A:	AOJA	TC,SRTN4	;YES--THEY ARE EQUAL

SRTN6:	SOJLE	TE,SRTN5A	;HAVE WE LOOKED AT ALL OF ITEM-A?

SRTN7:	MOVE	TE,(TC)		;NO--ITEM-A IS LARGER, SO SWAP POINTERS
	EXCH	TE,1(TC)
	MOVEM	TE,(TC)

	HRROI	DT,-1		;SET FLAG

	AOJA	TC,SRTN4	;LOOP TO LOOK AT NEXT PAIR

SRTN8:	MOVE	W1,CH		;[464] DO NOT DESTROY CP
	XOR	W1,@TB		;[464] DETERMINE IF ONE DATA-ITEM IS POS
				;[464] AND THE OTHER DATA-ITEM IS A LETTER.
	JUMPGE	W1,SRTN8A	;[464] JUMP IF THE SAME TYPES
	CAMLE	CH,@TB		;[464] DIFF TYPES, REVERSE THE TEST
	AOJA	TC,SRTN4	;[464] ITEM-A .LT. ITEM-B
	JRST	SRTN7		;[464] ITEM-B .GT. ITEM-B, SWAP
SRTN8A:				;[464]
	CAMG	CH,@TB		;IS ITEM-A > ITEM-B?
	AOJA	TC,SRTN4	;NO--LOOP TO LOOK AT NEXT PAIR

	JRST	SRTN7		;YES--GO SWAP THEM

SRTN9:	JUMPN	DT,SRTN3	;ANYTHING SWAPPED ON THAT PASS?
	POP	PP,W1		;[464] RESTORE
	POPJ	PP,		;NO--RETURN
SUBTTL CLEAN UP TABLES AND RECALL NAMTAB

EXTERNAL NAMDEV,NAMIOL,NM12SZ,NM2LOC,NAMLOC,NAMNXT
EXTERNAL TOPLOC,FREESP
EXTERNAL CLEANT

CLENTA:	PUSHJ	PP,CLEANT	;CLEAN UP TABLES

	HRRZ	TE,FREESP	;NO FREE SPACE
	MOVEM	TE,FREESP	;  NEEDED
	HRRM	TE,NAMIOL	;NAMTAB GOES HERE (+1)

	HLRE	TD,NAMIOL	;COMPUTE
	JUMPE	TD,CLENTZ	;  AMOUNT
	MOVMS	TD		;  OF
	ADDI	TD,1(TE)	;  CORE NEEDED
	IORI	TD,1777		;ROUND UP TO 1K BREAK
	CAMN	TD,.JBREL##	;IF NO CHANGE,
	JRST	CLENTC		;  NO NEED FOR $CORE

	CALLI	TD,$CORE	;GET CORE
	  JRST	CLENTZ		;TROUBLE

	HRRZ	TA,.JBREL
	MOVEI	TA,1(TA)
	HRRZM	TA,TOPLOC
;RECALL NAMTAB (CONT'D)

	IFN DEBUG,<
	MOVE	TE,[POINT 7,[ASCIZ "Expanding memory to "]]
	PUSHJ	PP,LSTMES
	MOVE	TE,TOPLOC
	LSH	TE,-^D9
	PUSHJ	PP,DECANY
	MOVEI	CH,"P"
	PUSHJ	PP,PUTLST
	PUSHJ	PP,LCRLF
	>

CLENTC:	MOVE	TE,NAMDEV+1	;FILE-NAME
	HLLZ	TD,NAMDEV+2	;EXTENSION
	SETZB	TC,TB
	LOOKUP	NAM,TE
	  JRST	CLENTZ

	IN	NAM,NAMIOL	;GET NAMTAB
	  JRST	CLENTD		;NO ERRORS
	JRST	CLENTZ		;ERRORS

CLENTD:	MOVE	TE,FREESP
	ADDI	TE,1
	HRRM	TE,NM2LOC
	ADD	TE,NM12SZ
	HRRM	TE,NAMLOC

	HLRE	TD,NAMIOL
	MOVMS	TD
	SUB	TD,NM12SZ
	MOVNI	TC,(TD)
	HRLM	TC,NAMLOC
	ADDI	TD,-1(TE)
	HRRM	TD,NAMNXT

	POPJ	PP,

CLENTZ:	OUTSTR	[ASCIZ "%Could not recover Name Table.
Compilation continuing without maps, trace or object listing.
"]
	SWOFF	FMAP!FOBJEC
	SETZM	PRODSW
	SETZM	NAMNXT
	POPJ	PP,
;DATA FOR MAPS

;POINTERS TO USAGE DEFINITIONS FOR DATA-NAMES

USGTAB:	POINT 7,[ASCIZ "?			"]
	POINT 7,[ASCIZ "DISPLAY-6		"]
	POINT 7,[ASCIZ "DISPLAY-7		"]
	POINT 7,[ASCIZ "DISPLAY-9		"]
	POINT 7,[ASCIZ "1-WORD COMP		"]
	POINT 7,[ASCIZ "2-WORD COMP		"]
	POINT 7,[ASCIZ "COMP-1			"]
	POINT 7,[ASCIZ "INDEX			"]
	POINT 7,[ASCIZ "COMP-3			"]
	POINT 7,[ASCIZ "COMP-2			"]


;POINTERS TO ACCESS MODE DEFINITIONS

	POINT 7,[ASCIZ "SORT FILE"]
AMODE:	POINT 7,[ASCIZ "SEQUENTIAL  "]
	POINT 7,[ASCIZ "  RANDOM    "]
	POINT 7,[ASCIZ "   ISAM     "]
	POINT 7,[ASCIZ "    ?       "]

;POINTERS TO RECORDING MODE DEFINITIONS

RMODE:	POINT 7,[ASCIZ " SIXBIT         "]
	POINT 7,[ASCIZ " BINARY         "]
	POINT 7,[ASCIZ " ASCII          "]
	POINT 7,[ASCIZ " EBCDIC         "]

;POINTERS TO LABEL DEFINITIONS

LBLDEF:	POINT 7,[ASCIZ "  OMITTED    "]
	POINT 7,[ASCIZ "  STANDARD   "]
	POINT 7,[ASCIZ "NON-STANDARD "]
	POINT 7,[ASCIZ "     ?       "]
;HEADER LINES FOR FILE SECTION

FILHDR:	ASCIZ "SOURCE					  ACCESS    RECORDING    BLOCKING
 LINE	FILE NAME			   MODE	      MODE        FACTOR        LABELS

"

;HEADER LINES FOR DATA SECTION

DATHDR:
ASCIZ "SOURCE							 	 	 LOCATION		 DECIMAL
 LINE	LEVEL    NAME				USAGE		 	WORD   BIT	   SIZE   PLACES

"

;HEADER LINE FOR PROCEDURE SECTION

PROHDR:	ASCIZ "SOURCE
 LINE	PROCEDURE NAME			PRIORITY   LOCATION  SECTION

"

WRAPMS:	ASCIZ	/
                        ***** NOTA BENE *****
Because of the limitation on line numbers, error messages can refer to
lines  1 through 8189 only.  Therefore, any error shown as occuring on
line K where 0<K<8190 could actually refer to any  line  of  the  form
N*8188+K.   However,  since  the  line  numbers also wrap around it is
sufficient to look at all lines with line number K  to  see  to  which
line the message actually applies.
/
;THIS ROUTINE HAD BETTER NOT BE CALLED

IFE ONESEG,<
INTERNAL WARNW,FATALW
WARNW: FATALW:
>
IFN ONESEG,<
INTERNAL	WARNQ
WARNQ:
>
	OUTSTR	[ASCIZ "?Compiler error--'WARNW' called in phase F
"]
	POPJ	PP,

IFN ANS74,<
E.507==:^D507			;PUT IN GLOB
>

;BYTE POINTERS USED
CPYLN:	POINT	13,@CPYBHI+1,20	;LINE NUMBER IN CPYFIL WORD
CPYLNA:	POINT	14,@CPYBHI+1,20	;SAME AS CPYLN, EXCEPT HI-BIT ALSO
DTLNUM:	POINT	14,(DT),14	;LINE NUMBER FIELD IN DIAG TABLE
TBPOS:	POINT	7,TB,21		;POSITION FIELD IN TB
TBLN:	POINT	14,TB,14	;LINE NUMBER FIELD IN TB
TCNUMB:	POINT	10,TC,35	;DIAG # FIELD IN TC
DWNUMB:	POINT	10,DW,35	;DIAG # FIELD IN DW
TBFAZ:	POINT	4,TB,25		;PHASE NUMBER FIELD IN TB
PFATAL:	POINT	7,LFATAL	;POINTER TO "FATAL - "

LFATAL:	ASCIZ	/FATAL - /

DIAGNO==1777	;MASK FOR DIAG NUMBER

EXTERNAL FRSTHI	;FIRST DIAG WHICH HAS APPENDED DATA (DOUBLE-WORD)
EXTERNAL LASTHI ;LAST DIAG WHICH CAN HAVE APPENDED DATA.
EXTERNAL ERATAB	;WHERE DIAGS ARE
EXTERNAL HEADER,PROGID,STDATE,STTIME,VERZUN,HDRPAG,LINPAG,CPMAXN,SEQIN
EXTERNAL PHASEN,SUBPAG
EXTERNAL CPYBHI,ERALNA,VALLOC,LITLOC
EXTERNAL ERALN,ERAPOS,PAGCNT
EXTERNAL NAMLOC,NAMNXT,NM2LOC,FILLOC,DATLOC,PROLOC,FLOLOC,FILNXT,DATNXT,PRONXT
EXTERNAL EXTLOC,EXTNXT,CONLOC,CONNXT,MNELOC,MNENXT
EXTERNAL SETFAK,FAKERA,COUNTW,COUNTF,PRODSW
EXTERNAL EXTCNT,FIXEDS,NUMEXT,RESDNT,NONRES,DATBAS

EXTERNAL FI.FLN,FI.ACC,FI.ERM,FI.BLF,FI.LBL,FI.NXT,FI.LOC,FI.DRL,FI.LRL,FI.FDD
EXTERNAL FI.DSD,FL.LN
EXTERNAL DA.DEF,DA.LVL,DA.LN,DA.USG,DA.RES,DA.INS,DA.EXS,DA.EDT,DA.NDP,DA.DPR
EXTERNAL DA.CLA,DA.DFS,DA.SON,DA.BRO,DA.FAL
EXTERNAL PR.FLO,PR.PRI,PR.SEC
EXTERNAL LNKCOD,TB.DAT,TB.MNE,TB.CON,TB.PRO
EXTERNAL DEVDED
EXTERNAL ERABHI,ERABLK,ERADEV,ERAHDR,ERABUF

	END	COBOLF