Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-10 - 43,50517/rpgiif.mac
There is 1 other file named rpgiif.mac in the archive. Click here to see a list.
TITLE	RPGIIF FOR RPGII 1
SUBTTL	PHASE F - LISTING 	AL BLACKINGTON/CAM/BOB CURRIER

;THIS PROGRAM USED TO BE
;COPYRIGHT 1974, DIGITAL EQUIPMENT CORP., MAYNARD, MA.
;BUT THEN IT WAS MODIFIED EXTENSIVLY (SIC) TO THE RPGII
;VERSION BY BOB CURRIER  AUGUST 7, 1975  23:44:33
;

TWOSEG
RELOC	400000

	EXTERNAL GETERA,GETCPY,PUTLST,SRTERA,HDROUT,SETDN,LCRLF
	EXTERNAL KILL, LNKSET,SETCPY,SETERA,LSTMES,SRTNAM


RPGIIF:	PORTAL	.+1			; ENABLE CONCEALED MODE
	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

	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
;BRING IN DIAGNOSTICS

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

	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

	TLO	DW,DWIMBD	; DON'T IMBED WARNINGS
	AOSA	COUNTW

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

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.

GDIAG3:	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
	AOJA	TB,GDIG3A	;NO--DISCARD IT

	MOVEM	TC,(DT)		;YES--SAVE IT
	AOBJP	DT,GDIG3C
	AOJA	TB,GDIG3A	;NO
;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
	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

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
	CAIE	CH,12
	SOSA	PAGCNT
	MOVEI	TA,LCRLF
	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,5		;NO--SKIP OVER FIRST 5 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
	AOJA	CP,LSTO1	;NO--NO NEED FOR THE EXTRA SPACE

LSTO3:	TSWT	FTERA		;ARE WE TYPING ERRORS ON TTY?
	JRST	PUTLST		;NO
	TSWF	FERALN		;YES--ERRORS FOR THIS LINE?
	TTCALL	1,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
	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	MAPOUT		;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;
	TTCALL	3,[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
;PRINT OUT MAPS

;SET UP RESDNT, NONRES TO THEIR TRUE VALUES

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

	MOVE	TB,RESDNT##	;YES
	MOVEM	TB,NONRES##
	MOVEI	TA,STRTS##	;ADD SIZE OF START-UP CODE
	MOVEM	TA,FIXEDS	;SAVE THE OFFSET
	ADDI	TA,400000	;IT WILL BE HI-SEG
	MOVEM	TA,RESDNT

MAPOT1:	MOVEI	TA,GETSGC##	;LEAVE ROOM FOR 'GETSEG' CODE
	MOVEM	TA,FIXEDS
	ADDM	TA,RESDNT
	ADDM	TA,NONRES
	ADDM	TA,LITBAS##
	ADDM	TA,PROGST##
	ADDM	TA,TEMBAS##	; [247] update TEMBAS

MAPOT5:	JRST	ENDF		;  GO TO PHASE-END

;END OF PHASE F

ENDF:	ENDFAZ	F;
;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


ERAO2:	ADDI	DT,1		;GET NEXT DIAGNOSTIC
	MOVE	DW,(DT)

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

	LDB	TB,ERAPOS	;YES--SAME POSITION?
	CAMN	TB,TC
	JRST	ERAO1		;YES

	ADDI	TC,1		;NO--NEXT POSITION?
	CAMN	TB,TC
	JRST	ERAO1		;YES

	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,15		;PUT OUT CARRIAGE-RETURN
	PUSHJ	PP,PUTMS4
	MOVEI	CH,12
	PUSHJ	PP,PUTMS4

	SOS	PAGCNT
	PUSH	PP,DT		;SAVE POINTER TO END OF DIAGS
;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

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:	PUSHJ	PP,PUTMES

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.>
	TTCALL	3,[ASCIZ "
"]
	POP	PP,DT
	POP	PP,TE		;THROW AWAY ONE ENTRY
	POPJ	PP,
;PRINT OUT ASSIGNED LINE NUMBER

PUTLN:	MOVEI	TA,4		;PUT OUT 4 SPACES
	MOVEI	CH," "
	PUSHJ	PP,PUTLNE
	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;
	TTCALL	1,CH
	JRST	PUTLST
;PRINT THE DIAGNOSTIC MESSAGE

PUTMES:	PUSHJ	PP,SETDN	;"TE" _ BYTE POINTER TO MESSAGE

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

	CAIN	CH,15		;IGNORE CARRIAGE-RETURNS
	JRST	PUTMS1

	CAIN	CH,12		;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;
	TTCALL	3,[ASCIZ "	"]
	PUSHJ	PP,STARS
	JRST	PUTMS1

PUTMS2:	JRST	PUTMS7		;NO--PUT OUT <C.R.> AND RETURN

PUTMS4:	TSWF	FTERA		;IF ERRORS ARE BEING TYPED,
	TTCALL	1,CH		;  TYPE CHARACTER
	JRST	PUTLST

PUTMS5:	PUSHJ	PP,PUTMS4
PUTMS6:	ILDB	CH,TE
	JUMPN	CH,PUTMS5
	POPJ	PP,

PUTMS7:	TSWF	FTERA;
	TTCALL	3,[ASCIZ "
"]
	JRST	LCRLF
;PUT OUT 3 STARS FOLLOWED BY 4 TABS

STARS:	PUSH	PP,TE
	MOVE	TE,[POINT 7,[ASCIZ "***				"]]
	PUSHJ	PP,LSTMES
	MOVEI	CH,11		;PUT OUT
	TSWF	FSEQ		;  TAB IF
	PUSHJ	PP,PUTLST	;  SEQUENCED INPUT
	POP	PP,TE
	POPJ	PP,
;SET UP HEADER FOR PRINT LINE.

SETHDR:	MOVE	TB,[POINT 7,HEADER]
	PUSHJ	PP,SPA4		;PUT OUT 4 SPACES
	MOVE	TA,[POINT 6,[SIXBIT "PROGRAM"]]
	PUSHJ	PP,SPACIT
	IDPB	CH,TB		;PUT OUT 2 SPACES
	IDPB	CH,TB

	MOVE	TE,PRGID	;PUT OUT "P R G I D "
	MOVEI	TD,0
	MOVE	TA,[POINT 6,TE]
	PUSHJ	PP,SPACIT
	MOVEI	TC,11		;PUT OUT 2 TABS
	IDPB	TC,TB
	IDPB	TC,TB

	MOVE	TA,[POINT 6,[SIXBIT "RPGII"]]	;PRINT "RPGII"
	PUSHJ	PP,SIXIT
	IDPB	CH,TB		;ANOTHER SPACE
	MOVEI	TC,"%"		; MAKE A FANCY VERSION NUMBER
	IDPB	TC,TB		; A PUT IN HEADING
	MOVE	TA,[POINT 6,VERZUN] ;VERSION NUMBER
	PUSHJ	PP,SIXIT

SETHD4:	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
	AOS	HDRPAG		;NOW SET IT TO ONE
	SETOM	SUBPAG		;SET SUB-PAGE TO -1
	SETZM	PAGCNT		;BE SURE TOP-OF-FORM WORKS
;PUT OUT 2ND LINE OF PAGE HEADING

	MOVE	TB,[POINT 7,HEADR2##]
	PUSHJ	PP,SPA4		;PUT OUT 4 SPACES
	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	TA,[POINT 3,SRCFIL+1,18]	; GET HIGH ORDER DATE
	LSH	TA,^D12		; SHIFT IT OVER
	ADD	TD,TA		; CONCATENATE WITH LOW ORDER
	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 6,MONTBL]	;MONTH
	ADDI	TA,(TC)
	PUSHJ	PP,SIXIT
	MOVEI	CH,"-"
	IDPB	CH,TB
	ADDI	TD,^D64		;YEAR
	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

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:	'JAN',,0
	'FEB',,0
	'MAR',,0
	'APR',,0
	'MAY',,0
	'JUN',,0
	'JUL',,0
	'AUG',,0
	'SEP',,0
	'OCT',,0
	'NOV',,0
	'DEC',,0
;PRINT OUT A USER NAME APPENDED TO DIAGNOSTIC MESSAGE

NAMWRD:	ADDI	DT,1		;GET LINK
	HRRZ	TA,(DT)
	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


NAMWD2:	MOVE	TE,[POINT 7,[ASCIZ " ??UNKNOWN??"]]
	JRST	PUTMS6
;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	LITLOC
	EXP	VALLOC
	EXP	OCHLOC
	EXP	EXTLOC
	EXP	ICHLOC
	EXP	INDLOC
SUBTTL CLEAN UP TABLES AND RECALL NAMTAB

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

	DEFINE TABSET (A,B,C,D,E,F),<

	IFDIF <A><NAM><
	XWD A'LOC,F
	EXTERNAL A'LOC
	>

	>

CLENTT:	TABLES
CLENTX:
	XWD CLENTT-.,CLENTT

	INTERNAL CLENTX


CLENTA:	PUSHJ	PP,CLEANT	;CLEAN UP TABLES
	POPJ	PP,

;THIS ROUTINE HAD BETTER NOT BE CALLED

	INTERNAL WARNW
WARNW:	TTCALL	3,[ASCIZ "?COMPILER ERROR--'WARNW' CALLED IN PHASE F
"]
	POPJ	PP,

;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
TBLN:	POINT	14,TB,14	;LINE NUMBER FIELD IN TB
TBNUMB:	POINT	10,TB,35	;DIAG # 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 - /

EXTERNAL HEADER,PRGID,STDATE,STTIME,VERZUN,HDRPAG,LINPAG,CPMAXN
EXTERNAL PHASEN,ERAHDR,CPYHDR,LSTBUF,SUBPAG
EXTERNAL CPYBHI,ERATAB,ERALNA,VALLOC,LITLOC
EXTERNAL ERALN,ERAPOS,ERANUM,PAGCNT
EXTERNAL NAMLOC,NAMNXT,NM2LOC,FILLOC,DATLOC,FILNXT,DATNXT
EXTERNAL EXTLOC,EXTNXT
EXTERNAL SETFAK,FAKERA,COUNTW,COUNTF,PRODSW
EXTERNAL EXTCNT,FIXEDS,NUMEXT,DATBAS

EXTERNAL LNKCOD

	END	RPGIIF			; [266]