Trailing-Edge
-
PDP-10 Archives
-
decuslib20-06
-
decus/20-153/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]