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 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 , TSWF FTERA; TTCALL 3,[ASCIZ " "] PUSHJ PP,STARS JRST PUTMS1 PUTMS2: JRST PUTMS7 ;NO--PUT OUT 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 < 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]