Trailing-Edge
-
PDP-10 Archives
-
ap-c800d-sb
-
cobolf.mac
There are 14 other files named cobolf.mac in the archive. Click here to see a list.
; UPD ID= 2008 on 8/21/79 at 11:19 AM by N:<NIXON>
TITLE COBOLF FOR COBOL V12
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, 1979 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
ONESEG==:ONESEG
DEBUG==:DEBUG
;EDITS
;NAME DATE COMMENTS
;V12A****************
;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 GETERA,GETCPY,PUTLST,SRTERA,HDROUT,SETDN,LCRLF
EXTERNAL KILL, LNKSET,SETCPY,SETERA,LSTMES,SRTNAM
COBOLF: JRST 1,.+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
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
;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
CAIL TE,7
CAILE TE,CPMAXN
DPB TD,ERAPOS
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
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
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.
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
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
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,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
CAIN TA," " ;[676] WAS IT SPACE?
PUSHJ PP,LSTO3 ;[676] YES, PRINT IT
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?
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
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;
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
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,<
IFN MCS,<
SKIPE FINITL## ;DITTO FOR MCS INITIALIZATION.
>
IFN TCS,<
SKIPE CSSEEN##
>
ADDI TA,2
>
IFN CSTATS,<
SKIPE METRSW## ;ANOTHER ONE IF METER POINT
ADDI TA,1
>
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.LN ;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
SUBI DT,1
ADDI DT,1 ;YES--SKIP OVER IT
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
;PUT OUT SOME DIAGNOSTICS (CONT'D).
;PUT OUT UP-ARROWS.
MOVEI CH,11 ;PUT OUT A TAB
PUSHJ PP,PUTMS4
TSWF FSEQ ;SEQUENCED INPUT?
PUSHJ PP,PUTMS4 ;YES--ANOTHER TAB
MOVEI CH," "
PUSHJ PP,PUTMS4
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 SPACE AFTER COL 7
PUSHJ PP,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
MOVEI CH," " ;IF
CAIN CP,7 ; COLUMN 7
PUSHJ PP,PUTMS4 ; PUT OUT EXTRA SPACE
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
CAMN TC,CP ;NO--NEXT PLACE?
JRST ERAO7 ;YES
AOJA CP,ERAO5 ;NO--LOOP
;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: 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,
;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 T(ROUGH 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
RELOC4: LDB TE,LNKCOD
CAIE TE,TB.DAT
RELOC5: POPJ PP,
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 TA,DA.SON
PUSHJ PP,RELOC4
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
;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;
TTCALL 1,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
>
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: LDB TE,TBNUMB ;WORD TO BE ADDED?
CAIG TE,LASTHI
CAIGE TE,FRSTHI
CAIA
PUSHJ PP,NAMWRD ;YES--PRINT IT
LDB TE,TBNUMB ;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
TTCALL 3,[ASCIZ "
"]
JRST LCRLF
IFN ANS74,<
PUTMSA: MOVEI CH,"0"(TE)
MOVE TE,TE+1
>
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,
;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: 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 6,MONTBL] ;MONTH
ADDI TA,(TC)
PUSHJ PP,SIXIT
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: '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)
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 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
IFE ONESEG,<
CLENTX:>
IFN ONESEG,<
CLENTQ:>
XWD CLENTT-.,CLENTT
IFE ONESEG,< INTERNAL CLENTX>
IFN ONESEG,<INTERNAL CLENTQ>
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 "EXPANDED CORE TO "]]
PUSHJ PP,LSTMES
MOVE TE,TOPLOC
LSH TE,-^D10
PUSHJ PP,DECANY
MOVEI CH,"K"
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: TTCALL 3,[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 "]
;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
WARNW:
>
IFN ONESEG,<
INTERNAL WARNQ
WARNQ:
>
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
TBPOS: POINT 7,TB,21 ;POSITION FIELD IN TB
TBLN: POINT 14,TB,14 ;LINE NUMBER FIELD IN TB
TBNUMB: POINT 9,TB,35 ;DIAG # FIELD IN TB
TCNUMB: POINT 9,TC,35 ;DIAG # FIELD IN TC
DWNUMB: POINT 9,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,PROGID,STDATE,STTIME,VERZUN,HDRPAG,LINPAG,CPMAXN,SEQIN
EXTERNAL PHASEN,SUBPAG
EXTERNAL CPYBHI,ERATAB,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,FRSTHI,LASTHI,PRODSW
EXTERNAL EXTCNT,FIXEDS,NUMEXT,RESDNT,NONRES,DATBAS
EXTERNAL FI.LN,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.FIL,TB.DAT,TB.MNE,TB.CON,TB.PRO
END COBOLF