Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
cobol-source/cobolf.mac
There are 14 other files named cobolf.mac in the archive. Click here to see a list.
; UPD ID= 1309 on 7/1/83 at 12:35 PM by HOFFMAN
TITLE COBOLF FOR COBOL V13
SUBTTL PHASE F - LISTING AL BLACKINGTON/CAM
SEARCH COPYRT
SALL
;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, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
ONESEG==:ONESEG
DEBUG==:DEBUG
MCS==:MCS
IFN TOPS20,<SEARCH MONSYM,MACSYM>
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
;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]
ENTRY COBOLF
EXTERNAL GETCPY,PUTLST,HDROUT,SETDN,LCRLF
EXTERNAL KILL,LNKSET,SETCPY,LSTMES
EXTERNAL RDATLK,RENLOC,RENNXT
EXTERNAL RN.01,RN.66
IFN TOPS20,<
EXTERN GETERA,SETERA,SETNAM
>
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
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
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
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
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
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
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: TSWF FTERA ;ARE WE TYPING ERRORS ON TTY?
TSWT FERALN ;YES--ERRORS FOR THIS LINE?
JRST PUTLST ;NO
IFE TOPS20,<
OUTCHR CH ;YES--TYPE CHARACTER
>
IFN TOPS20,<
EXCH CH,T1
PBOUT%
EXCH CH,T1
>
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
IFE TOPS20,<
TSWF FTERA;
OUTSTR [ASCIZ "
"]
>
IFN TOPS20,<
TSWT FTERA;
JRST LWRN0
OUTSTR [ASCIZ "
"]
LWRN0:>
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,<
IFE TOPS20,<
SKIPE FINITL## ;DITTO FOR MCS INITIALIZATION.
>
IFN TOPS20,<
SKIPE CSSEEN##
>
ADDI TA,2
>
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
MOVE TE,[POINT 7,[ASCIZ" "]] ;
PUSHJ PP,LSTMES ;
MOVEI CH,"N" ;
LDB TB,FI.RMS## ;IS IT AN RMS FILE?
SKIPE TB ;NO
MOVEI CH,"Y" ;YES
PUSHJ PP,PUTLST ;PRINT FILE TYPE
MOVE TE,[POINT 7,[ASCIZ" "]] ;
PUSHJ PP,LSTMES ;
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
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 ORGANIZATION 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?
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: PUSH PP,TD ;SAVE NO. OF DIFFERENT DIAGS
PUSHJ PP,PUTMES
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:
IFE TOPS20,<
TSWF FTERA ;IF WE ARE TYPING ERRORS, TYPE <C.R.>
OUTSTR [ASCIZ "
"]
>
IFN TOPS20,<
TSWT FTERA ;IF WE ARE TYPING ERRORS, TYPE <C.R.>
JRST ERAO15
OUTSTR [ASCIZ "
"]
ERAO15:>
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
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: TSWF FTERA;
TSWT FLWARN!FERALN;
JRST PUTLST
IFE TOPS20,<
OUTCHR CH
>
IFN TOPS20,<
EXCH CH,T1
PBOUT%
EXCH CH,T1
>
JRST PUTLST
;PRINT THE DIAGNOSTIC MESSAGE
PUTMES: 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.>
IFE TOPS20,<
TSWF FTERA;
OUTSTR [ASCIZ " "]
>
IFN TOPS20,<
TSWT FTERA;
JRST PUTMS8
OUTSTR [ASCIZ " "]
PUTMS8:>
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:
IFE TOPS20,<
TSWF FTERA; ;PUT OUT CARRIAGE-RETURN AND RETURN
OUTSTR [ASCIZ "
"]
>
IFN TOPS20,<
TSWT FTERA; ;PUT OUT CARRIAGE-RETURN AND RETURN
JRST LCRLF
OUTSTR [ASCIZ "
"]
>
JRST LCRLF
PUTMSA: MOVEI CH,"0"(TE)
MOVE TE,TE+1
PUTMS4:
IFE TOPS20,<
TSWF FTERA ;IF ERRORS ARE BEING TYPED,
OUTCHR CH ; TYPE CHARACTER
>
IFN TOPS20,<
TSWT FTERA
JRST PUTLST
EXCH CH,T1
PBOUT%
EXCH CH,T1
>
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,
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 compatible COBOL/]
POINT 7,[ASCIZ /COBOL-8x/]
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]
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
SKIPE PRODSW ;UNLESS BIS /P
SKIPN OPTSW ;AND /O
CAIA ;NO
PUSHJ PP,SPA4P ;SKIP TAB AND GIVE 4 SPACES INSTEAD
IDPB TC,TB
MOVE TA,[POINT 6,[SIXBIT "COBOL"]] ;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
SKIPL AS7482## ;SPECIFIC COMPILER REQUIRED?
SKIPA TA,[POINT 6,[SIXBIT "/V:8X"]]
MOVE TA,[POINT 6,[SIXBIT "/V:74"]]
SKIPE AS7482 ;DON'T BOTHER
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
IFN TOPS20,<
MOVE T1,[POINT 7,HEADR2##]
SKIPN T2,SRCJFN##
POPJ PP, ;GIVE UP IF NO FILE NAME
MOVE T3,[FLD(.JSSSD,JS%DEV)+FLD(.JSAOF,JS%DIR)+FLD(.JSAOF,JS%NAM)+FLD(.JSAOF,JS%TYP)+FLD(.JSSSD,JS%GEN)+JS%TMP+JS%CDR+JS%PSD+JS%PAF]
JFNS%
ERJMP .+1
POPJ PP,
>
IFE TOPS20,<
SKIPN SRCFIL ;IF NO FILE NAME
POPJ PP, ;DON'T PUTOUT GARBAGE LINE
MOVE TB,[POINT 7,HEADR2##]
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] COMBINE 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
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)
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
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
IFE TOPS20,<
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
DMOVE TE,ERAHDR ;SET UP "LOOKUP" PARAMETERS
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 TD,FREESP ;NO FREE SPACE
MOVEM TD,FREESP ; NEEDED
HRRM TD,NAMIOL ;NAMTAB GOES HERE (+1)
IFE TOPS20,<
HLRE TE,NAMIOL ;COMPUTE
>
IFN TOPS20,<
MOVM TE,NAMIOL##+1 ;COMPUTE
>
JUMPE TE,CLENTZ ; AMOUNT OF
IFE TOPS20,<
MOVMS TE ;
>
ADDI TE,1(TD) ; CORE NEEDED
IFE TOPS20,<
IORI TE,1777 ;ROUND UP TO 1K BREAK
CAMN TE,.JBREL## ;IF NO CHANGE,
JRST CLENTC ; NO NEED FOR $CORE
CALLI TE,$CORE ;GET CORE
>
IFN TOPS20,<
PUSHJ PP,GETCOR##
>
JRST CLENTZ ;TROUBLE
IFE TOPS20,<
HRRZ TA,.JBREL
ADDI TA,1
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:
IFE TOPS20,<
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
>
IFN TOPS20,<
AOS TE,NAMIOL ;ACCOUNT FOR +1 IN TOPS-10 IOWD
SETZM -1(TE) ;NAMLOC+0 = 0
PUSHJ PP,SETNAM## ;RECOVER NAMTAB
JRST CLENTZ ;FAILED
>
CLENTD: MOVE TE,FREESP
ADDI TE,1
HRRM TE,NM2LOC
ADD TE,NM12SZ
HRRM TE,NAMLOC
IFE TOPS20,<
HLRE TD,NAMIOL
MOVMS TD
>
IFN TOPS20,<
MOVM TD,NAMIOL+1
>
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 " RELATIVE "]
POINT 7,[ASCIZ " INDEXED "]
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 RMS FILE RECORDING BLOCKING
LINE FILE NAME FILE ORGANIZATION 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,
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.ERM,FI.BLF,FI.LBL,FI.NXT,FI.LOC,FI.DRL,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
IFE TOPS20,<
EXTERNAL DEVDED
EXTERNAL ERABHI,ERABLK,ERADEV,ERAHDR,ERABUF
>
END COBOLF