Trailing-Edge
-
PDP-10 Archives
-
BB-H506E-SM
-
cobol/source/cleand.mac
There are 7 other files named cleand.mac in the archive. Click here to see a list.
; UPD ID= 3279 on 12/12/80 at 10:13 AM by NIXON
TITLE CLEAND FOR COBOL V12C
SUBTTL CLEANUP AFTER PHASE D W.NEELY/CAM
SEARCH COPYRT
SALL
COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
SEARCH P
%%P==:%%P
DBMS==:DBMS
DEBUG==:DEBUG
;EDITS
;NAME DATE COMMENTS
;JBB 10-NOV-83 [1503] Fix edit 1466 so WRITE ADV will not get FATAL
; 365. Treat default recording mode as legit.
;JEH 02-MAY-83 [1466] Give error 365 in COBOLD under WRITE stmt,
; not by FD, and include standard ASCII in error
;SMI 15-OCT-82 [1417] FIX 68274 CONVERSION OF WRITE
;DAW 14-Nov-80 [1074] "?Catastrophe in PHASE D" if "DYNAMIC"
; in ACCESS MODE clause is misspelled.
;JEH 27-JUN-80 [1032] STORE EBCDIC MODE IN KEY DESCRIPTOR
;JEH 03-APR-80 [1006] PULL OUT CODE TESTING ON USE PROCEDURE CONFLICTS
;DMN 24-OCT-79 [747] COBOL-74 BAD TABLE LINK IF MISSING ISAM RECORD KEY
;CLRH 14-SEP-79 [735] GIVE ERROR IF RECORD KEY NOT DEFINED IN RIGHT FD
;V12A SHIPPED
;DAW 23-APR-79 [677] FIX PROBLEM WITH TABLES EXPANDING THAT
; CAN MESS UP DBMS USE PROCEDURES
;EHM 17-SEP-78 [552] GIVE ERROR IF DECLARITIVES AND NO END DECL.
;V10*****************
; 10-AUG-76 [435] FIX UP USE PROCEDURE TABLE FOR DBMS
; 18-FEB-76 [407] FIX WRITING BEFORE/AFTER FOR STD ASCII
;DPL 01/29/76 [401] SET DBONLY OFF(=0) IF ONLY USE PROC IS DBMS
;ACK 14-JAN-74 GENERATE POINTERS IN THE FILE TABLE FOR FILE
; STATUS STUFF AND SIMULTANEOUS ACCESS STUFF.
;DBT 1/22/74 CHANGE THE PERF. UUO GENERATION TO GENERATE
; A PUSHJ 17,PERF.
;********************
;[236] /ACK COBOLC.MAC, CLEAND.MAC
; RESERVE SPACE FOR LABEL RECORD IF LARGER THAN FD
; BUT DONT CHANGE FILE TABLE MAX-REC-SIZE
; EDIT 171 MAKES ENTER COBOL EQUIVELENT TO CALL.
; EDIT 137 GIVE ERROR MESSAGE IF SUBSCRIPT IS IN LINKAGE
; SECTION OF IF SUBSCRIPTED IS SUBSCRIPTED.
; EDIT 165 FIXES COMPILER LOOP IF RIGHT PAREN
; MISSING FOR SUBSCRIPTED DATA-NAME.
; EDIT 155 FIXES "ADDRESS CHECK" WHEN SORT FILE SHARES SAME BUFFER AREA.
; EDIT 151 FIXES UNBALL PAREN PROBLEM IN COMPUTE STATEMENT.
; EDIT 111 FIXES COMPILER LOOP FOR SEARCH ALL... AT END STOP RUN.
; EDIT 110 OPEN STATEMENT DOES NOT GIVE PERIOD ASSUMED MESSAGE
; IF A PERIOD IS MISSING AND STATEMENT IS LAST ONE IN A PARA.
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
ENTRY CLEAND,CLENTA,PRFSUB
SUBTTL CLEAND:; GENERATE OBJECT FILE TABLES
CLEAND: TSWTZ INDECL ;[552] STILL IN DECLARITIVES?
JRST CLND0 ;[552] NO, OK
LDB LN,[POINT 13,DECLR.##,28] ;[552] GET LINE NUMBER
LDB CP,[POINT 7,DECLR.,35] ;[552] AND CHAR. POS.
MOVEI DW,E.608 ;[552] GET ERROR MESSAGE CODE
PUSHJ PP,FATAL ;[552] WARN USER
CLND0: MOVE TA,EAS1PC##
MOVEM TA,FILTBL##
SETZM EAS1PC
MOVE TA,FILLOC##
CAMN TA,FILNXT##
JRST ECLND ;NO FILTAB ENTRIES
HRRZI TA,SZ.DEV
ADDM TA,FILTBL
HRRZI TA,CD.FIL*1B20+1
CLND: HRLZM TA,CURFIL##
PUSHJ PP,LNKSET##
HRRM TA,CURFIL
SETZM TBLOCK+20
LDB TB,FI.FDD##
JUMPN TB,CC0.
SETOM TBLOCK+20
PUSHJ PP,CLE12. ;NO FD
HRRZ TA,CURFIL
CC0.: LDB TB,FI.NDV## ;NUMBER OF DEVICES
JUMPG TB,CC0.1
PUSHJ PP,CLE1. ;SHOULD BE AT LEAST ONE
CC0.1: HRRZ TA,CURFIL
LDB TB,FI.IRM## ;INTERNAL RECORDING MODE
CAIE TB,%%RM
JRST CC1. ;SPECIFIED
HRRZI TB,%RM.6B
DPB TB,FI.IRM ;ASSUME SIXBIT
CC1.: LDB TC, FI.PSN## ;GET POSITIONING
LDB TD, FI.ADV## ; AND ADVANCING FLAGS.
JUMPE TD, CC1.D ;IF THEY ARE BOTH ON,
JUMPE TC, CC1.H ; COMPLAIN.
PUSHJ PP, CLE18. ;IF EITHER IS ON, TURN
CC1.D: DPB TC, FI.ADV## ; ON ADVANCING.
CC1.H: IORI TC, (TD) ;GET ADV FLAG FOR LATER.
LDB TD, FI.ERM## ;GET EXTERNAL RECORDING MODE.
CAIN TD,%RM.7B ;[1466] [407] IF IT IS ASCII
;[1466] CAIN TD,%RM.SA ; [407] STANDARD ASCII
JRST CC2. ; [407] GO ON
TRNN TC, 1 ;IS ADVANCING ON?
JRST CC2. ;NO, USE WHAT'S SPECIFIED OR DEFAULT TO SIXBIT
MOVEI TD,%RM.7B ;YES, MAKE IT ASCII.
DPB TD,FI.ERM## ;SET THE EXTERNAL RECORDING MODE.
;[1503] LDB TB,FI.RM2## ;WAS IT SPECIFIED?
;[1503] JUMPE TB,CC2. ;NO, OK
;[1466] PUSHJ PP,CLE13. ;YES, GIVE ERROR
;IF LABELS ARE NON STANDARD ON EBCDIC TAPES GIVE AN ERROR.
CC2.: LDB TB, FI.ERM## ;GET THE EXTERNAL RECORDING MODE.
CAIE TB, %RM.EB ;IF IT'S NOT EBCDIC
JRST CC3. ; ALL IS WELL.
LDB TB, FI.LBL## ;GET THE FILE'S LABEL TYPE.
CAIE TB, %LBL.N ;IF IT'S NOT NON-STANDARD
JRST CC3. ; ALL IS WELL.
PUSHJ PP, CLE28. ;OTHERWISE COMPLAIN.
HRRZ TA, CURFIL ;RESTORE THE FILE TABLE'S ADDRESS.
CC3.: LDB TB,FI.DRL## ;DATA RECORD LINK
JUMPN TB,.+3
PUSHJ PP,CLE2. ;NO DATA RECORDS
HRRZ TA,CURFIL
LDB TB,FI.DSD##
JUMPN TB,CFGEN ;SORT-FILE
LDB TB,FI.LBL## ;TYPE OF LABELS
LDB TC,FI.VID## ;VALUE-OF-ID
LDB TD,FI.VDW## ;VALUE-OF-DATE-WRITTEN
JRST .+1(TB)
JRST CC5. ;[157] OMITTED
JRST CC4. ;STANDARD
JRST CC5. ;[157] NON-STANDARD
HRRZI TB,%LBL.S ;NOT SPECIFIED
DPB TB,FI.LBL ;ASSUME STANDARD
JRST CC4.
CC4.: JUMPN TC,CC5. ;VALUE-OF-ID REQUIRED
PUSHJ PP,CLE4.
HRRZ TA,CURFIL
CC5.: LDB TB,FI.POS ;MULTIPLE FILE TAPE FLAG
JUMPE TB,CC6.
LDB TB,FI.NDV
CAIG TB,1 ;ONLY ONE DEVICE ALLOWED
JRST CC5.2
PUSHJ PP,CLE6.
HRRZ TA,CURFIL
HRRZI TB,1
DPB TB,FI.NDV
CC5.2:
IFN ANS68,<
LDB TB,FI.MLT## ;MULTIPLE REEL/UNIT
JUMPE TB,CC6. ;NOT ALLOWED
PUSHJ PP,CLE7.
HRRZ TA,CURFIL
>
;CHECK BLOCKING FACTOR
CC6.:
IFN ANS74,<
LDB TB,FI.RMS ;IS THIS AN RMS FILE?
JUMPN TB,CC7. ;YES, IGNORE BLOCKING FACTOR
>
LDB TB,FI.BLF## ;BLOCKING FACTOR
JUMPN TB,CC7.
LDB TC,FI.FBS## ;GIVEN BUFFER SIZE INSTEAD?
JUMPE TC,CC6B. ;NO
LDB TB,FI.MRS## ;YES, GET RECORD SIZE
IDIVI TC,(TB) ;SEE HOW MANY FIT
DPB TC,FI.BLF ;THIS IS BLOCKING FACTOR
JUMPN TC,CC7. ;BETTER NOT BE ZERO
PUSHJ PP,CLE30. ;TOO BAD
JRST CC7.
CC6B.: LDB TC,FI.ACC
IFN ANS68,<
CAIN TC,%ACC.R
PUSHJ PP,CLE11. ;MUST NOT BE RANDOM ACCESS
>
IFN ANS74,<
CAIE TC,%ACC.R
JRST CC6A. ;NOT RELATIVE
LDB TB,FI.ERM## ;EXTERNAL RECORDING MODE
MOVE TB,[EXP 6,1,5,4,4](TB) ;BYTES PER WORD
LSH TB,7 ;ASSUME 200 WORD BUFFER
MOVE TC,[200000,,1] ;SEED EXCESS,,BLOCKING FACTOR
MOVSI CH,-4 ;NO. OF PHYSICAL BUFFERS IN LOGICAL BUFFER
CC6L.: MOVE TE,TB ;CHARS. IN 1 BUFFERS
IMULI TE,1(CH) ;NO. IN LOGICAL BUFFER
LDB TD,FI.MRS## ;RECORD SIZE
CAIN TB,5*200 ;ASCII?
ADDI TD,2 ;ALLOW FOR CR-LF
CAIN TB,4*200 ;EBCDIC?
JRST [PUSH PP,TD+1 ;YES, GET FEE AC
LDB TD+1,FI.VLR## ;IS IT VARIABLE LENGTH?
JUMPE TD+1,CC6M. ;NO
ADDI TD,4 ;YES, ACCOUNT FOR 4 BYTE HEADER
JRST CC6M.]
CAIE TB,6*200 ;SIXBIT?
JRST CC6N. ;NO
PUSH PP,TD+1 ;SAVE TD+1
ADDI TD,6+5 ;ROUNDING + CONTROL WORD
IDIVI TD,6 ;NO. WHOLE WORDS
IMULI TD,6 ;NO. OF CHARACTERS OCCUPIED BY RECORD
CC6M.: POP PP,TD+1
CC6N.: IDIVI TE,(TD) ;TE=NUMBER OF RECORDS, TD=REMAINDER
HRL TE,TD ;EXCESS,,BLOCKING FACTOR
IMULI TD,5 ;TRY TO GET 80% FULL
CAIG TD,(TB) ;
JRST CC6K. ;WASTAGE LESS THAN 20% OF 1 BUFFER
CAMGE TE,TC ;BETTER THAN PREVIOUS?
MOVE TC,TE ;YES, SAVE IT
AOBJN CH,CC6L. ;TRY AGAIN
MOVE TE,TC ;GET BLOCKING FACTOR
CC6K.: DPB TE,FI.BLF ;STORE BLOCKING FACTOR
JRST CC7.
CC6A.: CAIN TC,%ACC.I ;IS IT INDEX?
JRST CC6I. ;YES, SET DEFAULT
>
HRRZ TA,CURFIL
LDB TB,FI.IOO##
JUMPE TB,CC7.
IFN ANS68,<
PUSHJ PP,CLE15.
HRRZ TA,CURFIL
>
IFN ANS74,<
CC6I.: MOVEI TB,1 ;USE DEFAULT OF 1
DPB TB,FI.BLF
MOVEI DW,E.733 ;"BLOCK CONTAINS 1 RECORD assumed."
LDB LN,FI.FLN ;POINT TO THE FD
LDB CP,FI.FCP
PUSHJ PP,WARN##
HRRZ TA,CURFIL ;POINT TO FILE AGAIN
>
CC7.: LDB TB,FI.ACC ;ACCESS MODE
;[1417] CAIE TB,%%ACC
;[1417] JRST CC8. ;SPECIFIED
;[1417] HRRZI TB,%ACC.S ;ASSUME SEQUENTIAL
;[1417] DPB TB,FI.ACC
CC8.: JRST .+1(TB)
JRST CFGEN ;SEQUENTIAL
JRST CC12. ;RANDOM
JRST CFGEN ;INDEXED
CC12.:
IFN ANS68,<
LDB TB,FI.NFL## ;NUMBER OF FILE-LIMITS
JUMPG TB,CC14. ;MUST BE SOME
PUSHJ PP,CLE10.
HRRZ TA,CURFIL
CC14.:>
LDB TB,FI.LBL ;LABELS MUST BE
CAIN TB,%LBL.S ;STANDARD
JRST CFGEN
PUSHJ PP,CLE5.
HRRZ TA,CURFIL
; JRST CFGEN ;FALL THRU
CFGEN: HRRZI TC,SZ.DEV
BAK.0: MOVEI CH,1
HRLI CH,AS.OCT## ;PUT
PUSHJ PP,PUTAS1## ; OUT
SETZ CH, ; 'OCT 0'
PUSHJ PP,PUTAS1
SOJG TC,BAK.0
MOVE TC,EAS1PC
HRRZ TA,CURFIL
DPB TC,FI.OFT##
ADDI TC,SZ.DEV
MOVEM TC,EAS1PC
IFN ANS74,<
LDB TA,FI.LCP## ;SEE IF LINAGE-COUNTER
JUMPE TA,B0.1 ;NO
PUSHJ PP,LNKSET
HRRZ TC,FI.LCP ;GET COMPILE TIME OFFSET
ADD TC,FILTBL ;PLUS BASE OF FILE TABLE
SUBI TC,SZ.DEV-4 ;RUN TIME OFFSET, DON'T COUNT SZ.DEV TWICE
ADD TC,EAS1PC ;DEPTH IN FILTBL
DPB TC,DA.LOC ;STORE INCORE LOCATION
HRRZ TA,CURFIL
LDB TC,FI.LPP##
TRNE TC,700000
JRST B0.0
LDB TC,FI.WFA##
TRNE TC,700000
JRST B0.0
LDB TC,FI.LAT##
TRNE TC,700000
JRST B0.0
LDB TC,FI.LAB##
TRNN TC,700000
JRST B0.1
B0.0: PUSHJ PP,GETTAG ;GET NEXT TAG
HRRZ TA,CURFIL
DPB CH,FI.LCI## ;STORE IT
B0.1: HRRZ TA,CURFIL
>
MOVE TC,[TBLOCK,,TBLOCK+1]
SETZM TBLOCK##
BLT TC,TBLOCK+4
LDB TB,FI.NAM## ;NAMTAB LINK
ADD TB,NAMLOC##
MOVNI TC,5
MOVEM TC,CTR##
B1: ADDI TB,1
MOVE TD,(TB) ;SIX CHARACTERS OF NAME
TLNN TD,600000
JRST B2 ;NEXT ENTRY
MOVEM TD,TBLOCK+5(TC)
AOJL TC,B1
B2: HRLZI CH,AS.SIX##
HRRI CH,5 ;5-WORD SIXBIT LITERAL
PUSHJ PP,PUTAS1
MOVE TA,[POINT 6,TBLOCK]
HRRZI TD,5
B3: HRRZI TC,6
MOVE TB,[POINT 6,CH]
SETZ CH,
B3.1: ILDB TE,TA
JUMPE TE,B3.2
CAIN TE,":"-40
HRRZI TE,"-"-40
CAIN TE,";"-40
HRRZI TE,"."-40
B3.2: IDPB TE,TB
SOJG TC,B3.1
PUSHJ PP,PUTAS1
SOJG TD,B3
HRLZI CH,AS.XWD## ;XWD
HRRI CH,5 ;WORDS 6-10
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB CH,FI.NDV
LDB TB,FI.DSD
SKIPE TB
TRO CH,(1B7) ;THIS IS A SORT FILE
LDB TB,FI.RM2## ;[1503]
SKIPN TB ;IF RECORDING MODE WAS NOT SET
TRO CH,(1B8) ;SET FLAG FOR LIBOL
MOVSS CH ;NUMBER OF DEVICES IN LEFT HALF
MOVSI TB,(POINT 6,0,11) ;GET COBOL VERSION #
HRRI TB,.JBVER##
LDB TC,TB
DPB TC,[POINT 6,CH,5]
HRRI CH,AS.CNB##
PUSHJ PP,PUTAS1 ;LEFT HALF OF WORD 6
HRRZ TA,CURFIL
LDB CH,FI.VAL##
JUMPE CH,B4.1 ;NULL LINK
HRRZ TA,CH
PUSHJ PP,REFTAG## ;REFERENCE IF TAG
PUSHJ PP,PUTAS1
JRST B4.2
B4.1: HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
B4.2: HRRZI CH,AS.CNB
HRRZ TA,CURFIL
LDB TB,FI.POS##
DPB TB,[POINT 6,CH,17] ;POSITION
IFN ANS68,<
LDB TB,FI.NFL
DPB TB,[POINT 5,CH,4] ;NUMBER OF FILE-LIMITS
>
IFN ANS74,<
LDB TB,FI.FAM
SKIPE TB ;LEAVE DEFAULT AS SEQENTIAL
SUBI TB,1 ;LIBOL USES 0,1,2 FOR MODES
DPB TB,[POINT 2,CH,4] ;FILE ACCESS MODE
>
PUSHJ PP,PUTAS1
LDB CH,FI.NXT## ;POINTER TO NEXT
JUMPE CH,B4.3 ;FILE TABLE ENTRY
IFN CD.FIL-4,<
ANDI CH,077777
IORI CH,AS.FIL
>
PUSHJ PP,PUTAS1
JRST B4.4
B4.3: HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
B4.4: MOVE TA,CURFIL
SETZ CH, ;WORD 8
LDB TB,FI.NBF## ;NUMBER OF BUFFERS
DPB TB,[POINT 6,CH,5]
LDB TB,FI.MRS## ;MAXIMUM RECORD SIZE
DPB TB,[POINT 12,CH,17]
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB CH,FI.RCT## ;RE-RUN COUNT
MOVSS CH
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL ;WORD 9
SETZ CH,
LDB TB,FI.ERM ;RECORDING MODE
CAIE TB, %RM.SA ;STANDARD ASCII?
JRST B4.4D ;NO, GO ON.
LDB TC, FI.RD## ;GET DENSITY.
CAIE TC, %RD.2 ;ONLY 800, 1600 AND DEFAULT
CAIN TC, %RD.5 ; DENSITY ARE ALLOWED.
PUSHJ PP, CLE19. ;COMPLAIN.
B4.4D: LDB TC,FI.ACCOC ;ACCESS MODE
;[1417] CAIN TC,%%ACC ;DO WE HAVE AN ACCESS MODE?
;[1417] MOVEI TC,%ACC.S ;NO, MAKE IT SEQUENTIAL.
;[1417] DPB TC,FI.ACC##
CAIE TC,%ACC.I ;INDEXED?
JRST .+3 ;NO
CAIN TB,%RM.BN ;YES, MAY NOT BE BINARY.
PUSHJ PP,CLE24 ;BAD NEWS
DPB TB,[POINT 3,CH,9]
DPB TC,[POINT 2,CH,17]
LDB TB,FI.VLR## ;VARIABLE LENGTH.
DPB TB,[POINT 1,CH,0]
LDB TB,FI.LBL ;LABELS
CAIN TB,%%LBL ;WERE THEY OMITTED (ON A SORT FILE)?
MOVEI TB,%LBL.S ;YES, MAKE THEM STANDARD.
DPB TB,FI.LBL
DPB TB,[POINT 2,CH,3]
LDB TB,FI.RER## ;RE-RUN END OF REEL
DPB TB,[POINT 1,CH,10]
LDB TB,FI.RRC## ;RE-RUN ON COUNT
DPB TB,[POINT 1,CH,11]
LDB TB,FI.OPT##
DPB TB,[POINT 1,CH,13]
LDB TB,FI.IRM ;INTERNAL MODE
DPB TB,[POINT 2,CH,15]
HRRI CH,AS.CNB
LDB TB,FI.IOO
JUMPE TB,.+2
TLO CH,4000
PUSHJ PP,PUTAS1
SETZ CH, ;WORD 9, RIGHT HALF
HRRZ TA,CURFIL
LDB CH,FI.DRL ;DATA RECORD LINK
JUMPN CH,B4.6
B4.5: HRRZI CH,AS.CNB ;NULL
PUSHJ PP,PUTAS1
JRST B4.7
B4.6: LDB TB,[POINT 3,CH,20] ;TYPE CODE
CAIE TB,CD.DAT
JRST B4.5
IFN CD.DAT-1,<
ANDI CH,LMASKB
IORI CH,AS.DAT
>
PUSHJ PP,PUTAS1
B4.7: SETZ CH, ;WORD 10
HRRZ TA,CURFIL
LDB CH,FI.LRS## ;MAXIMUM LABEL RECORD SIZE
MOVSS CH
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB CH,FI.SDL##
JUMPE CH,B4.8 ;NULL
LDB TB,[POINT 3,CH,20]
CAIE TB,CD.FIL
JRST B4.8 ;NOT A FILE
IFN CD.FIL-4,<
IFN CD.FIL,<
ANDI CH,LMASKS
>
IORI CH,AS.FIL##
>
PUSHJ PP,PUTAS1
JRST B4.13
B4.8: HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
B4.13: MOVE CH,[XWD AS.XWD,1]
PUSHJ PP,PUTAS1 ;WORD 11
HRRZI CH,AS.CNB ;LEFT HALF
LDB TB,FI.BLF
DPB TB,[POINT 12,CH,17] ;BLOCKING FACTOR
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB CH,FI.ACK## ;ACTUAL KEY
IFN ANS68,<
JUMPN CH,B4.13B
>
IFN ANS74,<
JUMPE CH,B4.13Z
LDB TB,[POINT 3,CH,20] ;GET CODE
CAIE TB,AC.MSC## ;SPECIAL?
JRST B4.13B ;NO, OUTPUT KEY
HRLZ CH,CH ;PUT INCREMENT IN LHS
TLZ CH,AS.MSC##
TLO CH,AS.PAR## ;RELATIVE TO %PARAM
HRRI CH,AS.MSC## ;SIGNAL MISC.
JRST B4.13B ;OUTPUT IT
B4.13Z:>
LDB TB,FI.ACC##
CAIE TB,%ACC.R ;RANDOM FILE?
JRST B4.13A ;NO, PUT OUT A ZERO
IFN ANS74,<
LDB TB,FI.FAM## ;GET ACCESS MODE
CAIG TB,%FAM.S ;SEQUENTIAL DOESN'T NEED KEY
JRST B4.13A ;SO PUT OUT A ZERO
HRRZI DW,E.727 ;?RELATIVE KEY MUST BE SUPPLIED
>
IFN ANS68,<
HRRZI DW,E.240 > ;?NO ACTUAL KEY
HRRZ TA,CURFIL
LDB LN,FI.LN## ;POINT TO THE "SELECT"
LDB CP,FI.CP##
PUSHJ PP,FATAL
B4.13A: HRRZI CH,AS.CNB
B4.13B: PUSHJ PP,PUTAS1
LDB CH,FI.VID ;VALUE OF ID
HRRZ TA,CH
SKIPE TA
PUSHJ PP,REFTAG## ;REFERENCE IF A TAG
HRRZ TA,CURFIL
PUSHJ PP,PUTBYT ;WORD 12
HRRZ TA,CURFIL
LDB CH,FI.VDW
PUSHJ PP,PUTBYT ;WORD 13
HRLZI CH,AS.XWD
HRRI CH,5
PUSHJ PP,PUTAS1
MOVE TA,FI.SBA##
MOVEM TA,PNTR##
HRRZ TA,CURFIL
LDB CH,PNTR ;SAME BUFFER AREA LINK
JUMPE CH,B4.14Z ;NULL
LDB TB,[POINT 3,CH,20]
CAIE TB,CD.FIL
JRST B4.14Z
IFN CD.FIL-4,<
IFN CD.FIL,<
ANDI CH,077777>
IORI CH,AS.FIL
>
PUSHJ PP,PUTAS1
JRST B4.15
B4.14Z: HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
B4.15: SETZB TD,CTR
B4.15L: HRRZ TA,CURFIL
ILDB CH,PNTR ;'USE' POINTER
JUMPE CH,B4.15Z ;NULL
LDB TB,[POINT 3,CH,20]
CAIE TB,CD.PRO
JRST B4.15Z ;NOT PROTAB
REPEAT 0,< ;[1006] CODE TESTED ON CONFLICTING USE
HRRZ TD,CTR ;[1006] PROCEDURES, NO LONGER NECESSARY
IMULI TD,3
SETZ TE,
SKIPE TC,USES##(TD)
PUSHJ PP,CLE14.
SKIPE TC,USES+1(TD)
PUSHJ PP,CLE14.
SKIPE TC,USES+2(TD)
PUSHJ PP,CLE14.
JUMPN TE,B4.15Z
>
MOVE TA,CH
PUSHJ PP,PUTPRF
HRRZ TA,CH
PUSHJ PP,REFTAG## ;GETS THE FILE USE-PROCEDURE TAGS
JRST B4.15A
B4.15Z: HRRZI CH,AS.CNB
B4.15A: PUSHJ PP,PUTAS1
AOS TC,CTR
IFN ANS68,<
CAIGE TC,11
JRST B4.15L
>
IFN ANS74,<
B4.16: HRRZ TA,CURFIL
ILDB CH,PNTR
TRNN CH,(1B2)
TRZN CH,(1B0) ;IS IT USER NAME
JRST B4.16A ;NO
ADD CH,NAMLOC ;GET POINTER TO NAME
HRRZ CH,(CH) ;GET DATAB PTR.
DPB CH,PNTR ;STORE BACK
SETOM RELKEY## ;SIGNAL PHASE E TO JUMP ROUND DECLARATIVES
B4.16A: TRNE CH,700000 ;TYPE SET?
JRST B4.16B ;YES
MOVS CH,CH ;PUT VALUE IN LHS AND
HRRI CH,AS.CNB ;OUTPUT AS CONST.
B4.16B: PUSHJ PP,PUTAS1
AOS TC,CTR
CAIGE TC,11
JRST B4.16 ;LOOP FOR ALL LINAGE STUFF
>
MOVE CH,[AS.XWD,,1] ;WORD 19
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL ;LEFT HALF
HRRZI CH,AS.CNB
LDB TB,FI.RD## ;RECORD DENSITY
DPB TB,[POINT 3,CH,2]
LDB TB,FI.RP## ;RECORD PARITY
LSH TB,-1 ;CONVERT 1 TO 0, 2 TO 1 FOR REAL FILE TABLE
DPB TB,[POINT 1,CH,3]
LDB TB,FI.DFR## ;GET DEFERRED OUTPUT ISAM BIT
DPB TB,[POINT 1,CH,5] ;SET ACCORDINGLY
LDB TB,FI.ENT## ;GET ERROR-PROC-ON-OPEN BIT
DPB TB,[POINT 1,CH,6] ;SET RUN-TIME ACCORDINGLY
LDB TB,FI.RMS## ;GET RMS BIT
DPB TB,[POINT 1,CH,7]
LDB TB,FI.BM## ;GET BYTE MODE BIT
LDB TC,FI.ERM ;GET RECORDING MODE
CAIN TC,%RM.BN ;CANNOT BE BINARY
JUMPN TB,CLE29. ;AND BYTE MODE
DPB TB,[POINT 1,CH,8]
B4.16D: LDB TB,FI.CKP## ;GET CHECKPOINT BIT
DPB TB,[POINT 1,CH,9]
LDB TB,FI.CRC## ;GET CHECKPOINT RECORD COUNT
DPB TB,[POINT 8,CH,17]
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL ;RIGHT HALF
LDB CH,FI.VPP## ;PPN LINK
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL ;WORDS 20-21
LDB TC,FI.ACC ;ISAM FILE?
CAIE TC,%ACC.I
JRST B4.P ;NO, OUTPUT OCTAL 0'S IN WORDS 20-22
IFN ANS74,<
LDB TB,FI.RKY ;MAKE SYMBOLIC KEY = RECORD KEY
DPB TB,FI.SKY## ;AS EASIEST WAY TO FAKE OUT ISAM
>
IFN ANS68,<
LDB TB,FI.SKY## ;SYMBOLIC KEY
JUMPE TB,CLE26. ;NO SYMBOLIC KEY
B4.IX1:
>
LDB TC,FI.RKY## ;RECORD KEY
JUMPE TC,CLE27. ;NO RECORD KEY
B4.IX2: MOVE TD,[TBLOCK+1,,TBLOCK+2] ;CLR STORAGE
MOVEM TB,TBLOCK ;SAVE KEYS
SETZM TBLOCK+1
BLT TD,TBLOCK+4
MOVEM TC,TBLOCK+5
CAIN TC,100001 ;[1074] IF DUMMY ENTRY (ERRORS EARLIER ON),
JRST B4.SK5 ;[1074] SKIP THIS
HRRZI TA,(TB) ;MAKE PTR TO SYMBOLIC KEY
PUSHJ PP,LNKSET
LDB TB,DA.CLA## ;CLASS
MOVEM TB,TBLOCK+1
LDB TB,DA.USG## ;USAGE
MOVEM TB,TBLOCK+2
LDB TB,DA.INS## ;SIZE
MOVEM TB,TBLOCK+3
LDB TB,DA.NDP## ;# OF DECIMAL PLACES
MOVEM TB,TBLOCK+4
IFN ANS68,< ;IF -74 WE KNOW THEY ARE THE SAME
HRRZ TA,TBLOCK+5 ;COMPARE RECORD KEY INFO
PUSHJ PP,LNKSET
LDB TB,DA.INS ;GET SIZE OF RECORD KEY
JUMPE TB,B4.SK5 ;WE HAVE AN ERROR, BYPASS REST OF TESTS
SKIPN TBLOCK+3 ;IF NO SIZE TO SYMBOLIC KEY
JRST B4.SK5 ;THEN WE HAVE AN ERROR SO BYPASS REST OF TESTS
LDB TB,DA.CLA
CAME TB,TBLOCK+1
JRST CLE20 ;CLASS NOT SAME AS SYMBOLIC KEY
B4.SK1: LDB TB,DA.USG
CAME TB,TBLOCK+2
JRST CLE21 ;USAGE NOT SAME
B4.SK2: LDB TB,DA.INS
CAME TB,TBLOCK+3
JRST CLE22 ;SIZE NOT SAME
B4.SK3: LDB TB,DA.NDP
CAME TB,TBLOCK+4
JRST CLE23 ;# DEC. PLACES NOT SAME
B4.SK4:
>;END IFN ANS68
LDB TB,DA.DFS## ;RECORD KEY IN RECORD?
JUMPE TB,CLE25 ;NO
B4.SK6: LDB TB,DA.POP## ;[735] FIND FILENAME
LDB TE,[POINT 3,TB,20] ;[735] GET TYPE
CAIN TE,CD.FIL ;[735] FILENAME?
JRST B4.SK7 ;[735] YES - SEE IF ITS THE ONE
MOVE TA,TB ;[735] NOT AT TOP YET
PUSHJ PP,LNKSET ;[735] UP TO NEXT LEVEL...
JRST B4.SK6 ;[735] LOOP UNTIL WE GET TO FILE
B4.SK7: HLRZ TA,CURFIL ;[735] GET CURRENT FILE
CAMN TA,TB ;[735] SAME FILE?
JRST B4.SK5 ;[735] YES -- GO ON
JRST CLE25 ;[735] NO - RECORD KEY IN WRONG FILE
B4.SK5: MOVE CH,TBLOCK ;OUTPUT SYMBOLIC KEY BYTE PTR (WD 20)
PUSHJ PP,PUTBYT
HRLZI CH,AS.BYT## ;OUTPUT RECORD KEY BYTE PTR (WD 21)
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
HRRZ TA,TBLOCK+5
PUSHJ PP,LNKSET
LDB CH,DA.LOC## ;REL. LOC OF KEY IN RECORD
PUSHJ PP,PUTBX
HRLZI CH,AS.XWD ;WORD 22
HRRI CH,1
PUSHJ PP,PUTAS1
MOVE TA,TBLOCK+1 ;GET CLASS OF KEY
CAIE TA,%CL.NU ;NUMERIC
SETZM TBLOCK+1 ;NON-NUMERIC -- SET TYPE = 0
HRRZ TA,TBLOCK+5 ;GET PTR TO RECORD KEY
PUSHJ PP,LNKSET
HRRZM TA,TBLOCK+5
LDB TB,DA.EDT## ;EDITING BIT ON?
SKIPE TB
SETZM TBLOCK+1 ;IF NUMERIC EDITED SET TYPE = 0
SKIPN TBLOCK+1 ;IF TYPE = 0, SKIP NUMERIC STUFF
JRST B4.C2
MOVE TA,TBLOCK+2 ;USAGE
CAIE TA,%US.C1 ;FLOATING?
CAIN TA,%US.C2
TRNA
JRST .+3 ;NO
HRRZI TA,5 ;YES, SET TYPE = 5
JRST B4.C1
CAIE TA,%US.C3 ;COMP-3?
JRST .+3 ;NO
HRRZI TA,7 ;YES, SET TYPE = 7
JRST B4.C1 ;NOTE: IF SIZE IF >10, TYPE IS SET TO 10
CAIGE TA,%US.1C ;FIXED PT?
JRST .+3 ;NO
HRRZI TA,3 ;YES, SET TYPE = 3
JRST B4.C1
HRRZI TA,1 ;MUST BE DISPLY
B4.C1: MOVEM TA,TBLOCK+1 ;STORE TYPE
MOVE TA,TBLOCK+3 ;GET SIZE
CAILE TA,^D10 ;MORE THAN 10 DIGITS?
AOS TBLOCK+1 ;YES, ADD 1 TO TYPE
HRRZ TA,TBLOCK+5 ;PTR TO REC. KEY
LDB TB,DA.SGN## ;GET SIGN FLAG
SETCA TB, ;COMPLEMENT IT
DPB TB,[POINT 1,TBLOCK+3,20]
B4.C2: HRRZ TA,CURFIL ;GET MODE
LDB TB,FI.ERM
SETZ TC, ;ASSUME SIXBIT
CAIN TB,%RM.7B
MOVEI TC,2 ;[1032] ASCII
CAIN TB,%RM.EB ;[1032] TEST FOR EBCDIC
MOVEI TC,1 ;[1032]
DPB TC,[POINT 2,TBLOCK+3,19] ;[1032]
HRRZI CH,AS.CNB ;OUTPUT LEFT HALF OF WD 22
HRL CH,TBLOCK+1 ;TYPE CODE
PUSHJ PP,PUTAS1
HRRZI CH,AS.CNB ;RT. HALF
HRL CH,TBLOCK+3 ;OTHER CODES
PUSHJ PP,PUTAS1
JRST B4.Q
B4.P: MOVEI TA,3 ;OCTAL 0'S TO WDS 20-22
MOVEM TA,CTR
B4.S: MOVE CH,[AS.OCT,,1]
PUSHJ PP,PUTAS1
SETZ CH,
PUSHJ PP,PUTAS1
SOSLE CTR
JRST B4.S
B4.Q:
;WORD 23 LOOKS LIKE:
; BITS 0-8 OWNER ACCESS.
; BITS 9-17 OTHER ACCESS.
; BITS 18-35 COUNT OF RECORDS RETAINED.
HRRZ TA, CURFIL ;POINT AT THE CURRENT FILE TABLE.
MOVE CH, [AS.XWD,,1] ;A SINGLE XWD SHOULD SUFFICE.
PUSHJ PP, PUTAS1
LDB TB, FI.OWA## ;OWNER ACCESS.
DPB TB, [POINT 9,CH,8]
LDB TB, FI.OTA## ;OTHER ACCESS.
DPB TB, [POINT 9,CH,17]
HRRI CH, AS.CNB
PUSHJ PP, PUTAS1
LDB CH, FI.RTC## ;COUNT OF RECORDS RETAINED.
MOVSS CH, CH
HRRI CH, AS.CNB
PUSHJ PP, PUTAS1
;WORDS 24 THROUGH 31 ARE THE FILE STATUS WORDS.
MOVE TD, FI.SPT## ;POINTER TO THEM IN THE FILE TABLE.
;WORD 24 - FILE STATUS.
; BITS 0-5 BYTE RESIDUE.
; BITS 6-11 BYTE SIZE.
; BITS 12-17 FIELD SIZE.
; BITS 18-35 ADDRESS.
HRREI TE, -10
PUSHJ PP, PPTR
;WORD 25 - ERROR NUMBER.
; BITS 0-5 BYTE RESIDUE.
; BITS 6-11 BYTE SIZE.
; BITS 12-17 FIELD SIZE.
; BITS 18-35 ADDRESS.
AOJGE TE, FSDN
PUSHJ PP, PPTR
;WORD 26 - ACTION CODE.
; BITS 0-17 0
; BITS 18-35 ADDRESS.
AOJGE TE, FSDN
PUSHJ PP, PIDX
;WORD 27 - VALUE OF ID.
; BITS 0-5 BYTE RESIDUE.
; BITS 6-11 BYTE SIZE.
; BITS 12-17 FIELD SIZE.
; BITS 18-35 ADDRESS.
AOJGE TE, FSDN
PUSHJ PP, PPTR
;WORD 28 - BLOCK NUMBER.
; BITS 0-17 0
; BITS 18-35 ADDRESS.
AOJGE TE, FSDN
PUSHJ PP, PIDX
;WORD 29 - RECORD NUMBER.
; BITS 0-17 0
; BITS 18-35 ADDRESS.
AOJGE TE, FSDN
PUSHJ PP, PIDX
;WORD 30 - FILE NAME.
; BITS 0-5 BYTE RESIDUE.
; BITS 6-11 BYTE SIZE.
; BITS 12-17 FIELD SIZE.
; BITS 18-35 ADDRESS.
AOJGE TE, FSDN
PUSHJ PP, PPTR
;WORD 31 - FILE TABLE ADDRESS.
; BITS 0-17 0
; BITS 18-35 ADDRESS.
AOJGE TE, FSDN
PUSHJ PP, PIDX
JRST FSDN
;ROUTINE TO PUT OUT A FILE STATUS POINTER FOR DISPLAY ITEMS.
PPTR: JSP TB, PINT ;SET UP.
LDB TB, DA.RES## ;RESIDUE.
DPB TB, [POINT 6,CH,5]
LDB TB, DA.USG## ;USAGE.
CAIN TB, %US.D6 ;SIXBIT.
MOVEI TC, 6
CAIN TB, %US.D7 ;ASCII.
MOVEI TC, 7
CAIN TB, %US.EB ;EBCDIC.
MOVEI TC, 11
DPB TC, [POINT 6,CH,11]
LDB TB, DA.EXS## ;SIZE.
DPB TB, [POINT 6,CH,17]
HRRI CH, AS.CNB
PPTR1: PUSHJ PP, PUTAS1
HRRZ TA, CURFIL ;POINT AT THE CURRENT FILE TABLE AGAIN.
LDB CH, TD ;LOCATION.
JRST PUTAS1 ;WRITE IT AND RETURN.
;ROUTINE TO PUT OUT A FILE STATUS POINTER FOR INDEX ITEMS.
PIDX: JSP TB, PINT ;SET UP.
HRRZI CH, AS.CNB ;NOTHING IN THE LEFT HALF.
JRST PPTR1
;INITIALIZATION ROUTINE.
PINT: HRRZ TA, CURFIL
ILDB TA, TD ;NEXT LINK.
JUMPN TA, PINT2 ;JUMP IF THER IS ONE.
PINT1: MOVE CH, [AS.OCT,,1] ;NONE, WRITE OUT ZEROES.
PUSHJ PP, PUTAS1
SETZ CH,
PUSHJ PP, PUTAS1
AOJL TE, PINT1
POPJ PP,
PINT2: LDB TC, LNKCOD## ;GET ITS CODE.
CAIE TC, CD.DAT ;DATAB?
JRST PINT1 ;NO, MUST HAVE BEEN AN ERROR IN
; CLEANC.
ANDI TA, 077777 ;GET THE OFFSET.
ADD TA, DATLOC## ;MAKE IT ABSOLUTE.
MOVE CH, [AS.XWD,,1] ;ONE XWD.
PUSHJ PP, PUTAS1
JRST (TB) ;RETURN.
FSDN: MOVEI TB,SZ.OFT
ADDM TB,EAS1PC ;ADD IN THE FIXED PART OF THE FILE TABLE
IFN ANS68,<
HRRZ TA,CURFIL
LDB TB,FI.NFL ;NUMBER OF FILE-LIMITS
JUMPE TB,B5
ADDI TA,SZ.FIL
HRLI TA,442200
MOVEM TA,PNTR ;BYTE POINTER
HRLZI CH,AS.XWD
HRRZI TE,(TB) ;NO. FILE LIMIT CLAUSES
IMULI TE,3 ;NO. WORDS NEEDED
HRRI CH,(TE)
ASH TB,1 ;NO. HALFWORDS FOR LIMITS
MOVEM TB,CFLM##
ADDM TE,EAS1PC
PUSHJ PP,PUTAS1
B4.16: ILDB CH,PNTR ;NEXT FILE-LIMIT
JUMPE CH,B4.18
LDB TB,[POINT 3,CH,20] ;TYPE CODE
CAIE TB,CD.DAT
JRST B4.17
IFN CD.DAT-1,<
ANDI CH,077777
IORI CH,AS.DAT
>
PUSHJ PP,PUTAS1
JRST B4.19
B4.17: CAIE TB,CD.TAG
JRST B4.18
PUSHJ PP,PUTAS1
JRST B4.19
B4.18: HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
B4.19: MOVE TB,PNTR
TLNE TB,770000
JRST B4.20 ;NEED ANOTHER LIMIT
HRRZI TB,4
HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
SOJG TB,.-2 ;4 HALFWORDS
B4.20: SOSLE CFLM
JRST B4.16
>
B5: HRRZ TA,CURFIL
LDB TD,FI.LRS ;[236] GET LABEL RECORD SIZE
SKIPN TD ;[236]
MOVEI TD,^D80 ;[236] 80. CHARS IF STANDARD LABELS
LDB TE,FI.MRS
CAMGE TE,TD ;[236]
MOVE TE,TD ;[236] USE THE LARGER
LDB TD,FI.IRM
CAIN TD,%RM.6B
JRST B5.1
CAIE TD,%RM.7B
SKIPA TD,[EXP 4]
MOVEI TD,5
TRNA
B5.1: MOVEI TD,6
IDIVI TE,(TD)
CAIE TD,0
HRRZI TE,1(TE)
HRRZM TE,TBLOCK ;RECORD AREA IN WORDS
B5.2: LDB TB,FI.SRA##
JUMPE TB,B5.3 ;NO SAME RECORD AREA
HLRZ TC,CURFIL
CAIN TC,(TB)
JRST B5.3
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TB,FI.ADR##
JUMPN TB,B5.5 ;RECORD AREA DEFINED
LDB TE,FI.MRS
LDB TD,FI.LRS
CAIGE TE,(TD)
HRRZI TE,(TD)
LDB TD,FI.IRM
CAIN TD,%RM.6B
JRST .+5
CAIE TD,%RM.7B
SKIPA TD,[EXP 4]
MOVEI TD,5
TRNA
MOVEI TD,6
IDIVI TE,(TD)
CAIE TD,0
HRRZI TE,1(TE)
CAMLE TE,TBLOCK
HRRZM TE,TBLOCK
JRST B5.2
B5.3: MOVE TA,CURFIL
B5.4: LDB TB,FI.SAL##
JUMPE TB,B5.6 ;NO SAME AREA LINK
HLRZ TC,CURFIL
CAIN TB,(TC)
JRST B5.6 ;NO MORE
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TB,FI.ADR
JUMPN TB,B5.5 ;RECORD AREA DEFINED
LDB TE,FI.MRS
LDB TD,FI.LRS
CAIGE TE,(TD)
HRRZI TE,(TD)
LDB TD,FI.IRM
CAIN TD,%RM.6B
JRST .+5
CAIE TD,%RM.7B
SKIPA TD,[EXP 4]
MOVEI TD,5
TRNA
MOVEI TD,6
IDIVI TE,(TD)
CAIE TD,0
HRRZI TE,1(TE)
CAMLE TE,TBLOCK
HRRZM TE,TBLOCK
JRST B5.4
B5.5: LDB TB,FI.LOC## ;LOCATION OF RECORD AREA
B5.51: HRRZ TA,CURFIL
DPB TB,FI.LOC
SETO TC,
DPB TC,FI.ADR
JRST B6
;PUT OUT 'RELOC .+<SIZE OF RECORD>
B5.6: MOVEI CH,AS.MSC##
HRLI CH,1+AS.REL##
PUSHJ PP,PUTAS1
HRRZ CH,TBLOCK
ANDI CH,077777
HRRZ TA,CURFIL
LDB TB,FI.LBL
CAIE TB,%LBL.S
JRST B5.61
CAIGE CH,^D21
HRRZI CH,^D21
HRRZM CH,TBLOCK
B5.61: IORI CH,AS.DOT##
PUSHJ PP,PUTAS1
HRRZ TB,EAS1PC
HRRZ TC,TBLOCK
ADDM TC,EAS1PC
ADD TB,FILTBL
HRRZI TB,-SZ.DEV(TB)
JRST B5.51
B6: HRRZ TA,CURFIL
LDB TA,FI.NXT ;NEXT FILTAB ENTRY
JUMPN TA,CLND
;ALL DONE WITH FILE TABLES - FALL THROUGH
;SEE IF WE HAVE TO ADJUST THE SIZE OF DEBUG-CONTENTS
IFN ANS74,<
MOVE TA,MAXDBC## ;GET MAX. RECORD SIZE
SUBI TA,^D30/6 ;MINUS WHAT WE HAVE
JUMPLE TA,ECLND ;NOTHING TO DO
MOVEM TA,MAXDBC ;SAVE DIFFERENCE
PUSH PP,FLGSW## ;SAVE CURRENT SETTING
SETZM FLGSW ;TURN IT OFF TO AVOID SPURIOUS DEBUG-ITEM ERRORS
MOVE TB,[SIXBIT /DEBUG:/]
MOVEM TB,NAMWRD##
MOVE TB,[SIXBIT /ITEM/]
MOVEM TB,NAMWRD+1
SETZM NAMWRD+2
MOVE TB,[NAMWRD+2,,NAMWRD+3]
BLT TB,NAMWRD+5
PUSHJ PP,TRYNAM## ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,6
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
MOVE TB,[SIXBIT /CONTEN/]
MOVEM TB,NAMWRD+1
MOVSI TB,'TS '
MOVEM TB,NAMWRD+2
PUSHJ PP,TRYNAM ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,6
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
MOVE TB,[SIXBIT /TS:DIS/]
MOVEM TB,NAMWRD+2
MOVE TB,[SIXBIT /PLAY:6/]
MOVEM TB,NAMWRD+3
PUSHJ PP,TRYNAM ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,6
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
AOS NAMWRD+3 ;DEBUG-CONTENTS-DISPLAY-7
PUSHJ PP,TRYNAM ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,5
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
MOVEI TB,2
ADDM TB,NAMWRD+3
PUSHJ PP,TRYNAM ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,4
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
ECLND1: POP PP,FLGSW ;RESTORE FIPS FLAGGER
>
;SET 'USEBAS' AND PREPARE TO PUT OUT 'USE' TABLE
ECLND: SKIPE TA,EAS1PC
SUBI TA,SZ.DEV ;FILTBL POINTS AROUND
; FIRST DEVICE TABLE
MOVEM TA,USEBAS##
SETZM EAS1PC
IFN ANS74,<
SKIPE RELKEY## ;NEED %PARAM+0 FOR CONVERSION?
AOS IMPPAR ;YES, RESERVE IT
>
IFN DBMS,<
SETZM DBONLY## ;[401] START IN OFF POSITION
SETZM TBLOCK+7 ;CLR CTR OF ERROR-STATUS DECL. PROCS.
>
IFN ANS74!DBMS,<
PUSHJ PP,CUSETB ;SET UP PERFORMS FOR EACH E-S PROCEDURE
>
MOVEI TC,0 ;TC IS # OF WORDS PUT OUT
MOVE TA,[XWD -USES.L##,USES##] ;IF NO
SKIPN (TA) ;ENTRIES
AOBJN TA,.-1 ;IN USE TABLE,
JUMPGE TA,EC1.B ;DON'T PUT OUT ANYTHING
IFN DBMS,<SETOM DBONLY##> ;[401] TURN ON SINCE AT LEAST ONE USE IS NON-DBMS
MOVE CH,[XWD AS.XWD,SZ.OUS] ;PREPARE TO WRITE THE USES TABLE
PUSHJ PP,PUTAS1 ;WRITE HEADER WORD
;EACH HALFWORD WILL BE WRITTEN OUT IN THE SAME ORDER THAT IT APPEARS
; IN USES, FOR EACH OF THE 20 WORDS.
SETZB TA,CTR
EC1: HLRZ TA,USES(TA) ;GET LH
PUSHJ PP,CHKUSE ;DO IT
MOVE TA,CTR
HRRZ TA,USES(TA) ;GET RH
PUSHJ PP,CHKUSE ;WRITE IT
AOS TA,CTR ;COUNT WORDS WRITTEN
CAIGE TA,SZ.OUS ;EXIT WHEN WROTE THEM ALL
JRST EC1 ;ELSE LOOP
IFN ANS74,< ;COPY USE PROCEDURE ADDRESSES FOR PHASE E
MOVEI TC,0 ;PTR TO USP.XXXX
MOVE TA,USES ;INPUT
PUSHJ PP,PUTPTE ;PUT TAG FOR PHASE E
MOVE TA,USES+5 ;OUTPUT
PUSHJ PP,PUTPTE
MOVE TA,USES+^D10 ;I-O
PUSHJ PP,PUTPTE
MOVE TA,USES+^D15 ;EXTEND
PUSHJ PP,PUTPTE
>
HRRZI TC,SZ.OUS ;# WORDS WRITTEN
EC1.B:
IFN DBMS,<ADD TC,TBLOCK+7> ;ADD IN COUNT OF ERROR-STATUS PROCEDURES
EXCH TC,IMPPAR##
MOVEM TC,EAS1PC
MOVE CH,[AS.REL+1,,AS.MSC]
PUSHJ PP,PUTAS1
HRRZI CH,AS.DAT##
PUSHJ PP,PUTAS1
JUMPLE TC,CPOPJ##
HRRZ CH,TC ;NUMBER OF EXIT WORDS USED
HRLI CH,AS.XWD
PUSHJ PP,PUTAS1
HRRZI CH,AS.CNB
EC1.L: PUSHJ PP,PUTAS1
PUSHJ PP,PUTAS1
SOJG TC,EC1.L
POPJ PP,
;CHECK TO SEE IF USE PROCEDURE IN TA HAS A TAG, IF NOT,
; CREATE A PERFORM AND OUTPUT A TAG REFERENCE.
CHKUSE: HRRZI CH,AS.CNB
JUMPE TA,PUTAS1 ;NO USE PROCEDURE, OUTPUT 0
LDB TC,LNKCOD##
CAIN TC,CD.PRO
PUSHJ PP,PUTPRF
PUSH PP,TA ;NEED TO SAVE TA
HRRZ TA,CH
PUSHJ PP,REFTAG## ;REFERENCE IF IT'S A TAG
POP PP,TA
JRST PUTAS1
IFN ANS74!DBMS,<
;SCAN USETAB FOR DEBUG AND ERROR-STATUS ENTRIES --
; FOR EACH ONE SET UP A PERFORM OF THAT PROCEDURE, AND
; REMEMBER TAG OF THE PERFORM
CUSETB: SETZM TBLOCK+5 ;[677] INIT DYNAMIC USETAB PTR AT TOP
HRRZ TB,USELOC## ;[677] GET PTR TO START OF TABLE
HRRZ TA,USENXT## ;GET PTR TO END OF USETAB
SUB TA,TB ;[677] GET RELATIVE ADDRESS
MOVEM TA,TBLOCK+6 ;[677] SAVE PTR TO END OF TABLE
CUSET1: AOS TA,TBLOCK+5 ;BUMP USETAB PTR TO NEXT ENTRY
CAMLE TA,TBLOCK+6 ;PAST END?
POPJ PP, ;YES, RETURN
ADD TA,USELOC## ;[677] MAKE ABSOLUTE ADDR.
LDB TB,US.TYP## ;GET TYPE CODE
IFN ANS74,<
CAIN TB,%UT.DB ;DEBUGGING?
JRST CUSET6 ;YES
>
IFN DBMS,<
CAIE TB,%UT.ES ;THIS AN ERROR-STATUS ENTRY?
>
JRST CUSET4 ;NO
IFN DBMS,<
LDB TB,US.XTR## ;ANY EXTRA WORDS ALLOCATED?
JUMPE TB,CUSET1 ;NO, MUST HAVE BEEN A BAD ENTRY
AOS TBLOCK+7 ;BUMP ERROR-STATUS PROC COUNTER
>
IFN ANS74,<CUSET6:>
HRRZ TB,USELOC## ;[677] GET ABS. START OF TABLE
HRRZ TC,TA ;[677] TC:= ABS. PLACE IN TABLE
SUB TC,TB ;[677] GET RELATIVE PLACE
PUSH PP,TC ;[677] AND SAVE IT
LDB TA,US.PRO## ;GET PROTAB LINK OF E-S SECTION
PUSHJ PP,PUTPR2 ;ENTER PUTPRF ROUTINE
POP PP,TA ;RESTORE USETAB PTR
ADD TA,USELOC ;[677] MAKE ABS. POINTER
DPB CH,US.PRO ;SAVE TAG ADDR OF PERFORM OF THAT SECTION
IFN ANS68,<
JRST CUSET3
>
IFN ANS74,<
LDB TB,US.TYP
CAIE TB,%UT.DB ;IF DEBUG WE MAY NOT BE FINISHED
JRST CUSET3
SKIPN TB,DBPARM## ;HAVE WE ALLOCATED %PARAM+N YET?
JRST [AOS TB,IMPPAR ;NO, ALLOCATE IT
SOJA TB,.+1] ;BUT USE PREVIOUS
MOVEM TB,DBPARM
LDB TB,US.XTR## ;ANY EXTRA WORDS?
JUMPE TB,CUSET1 ;NO, WE ARE DONE
LDB TC,US.CNT## ;YES, GET THE COUNT
MOVNI TC,-1(TC) ;BUT NOT THE FIRST EXTRA WORD
HRLZ TC,TC
HRRI TC,2(TA) ;AOBJN POINTER TO USETAB
CUSET5: HLRZ TA,(TC) ;GET FLOTAB POINTER
ADD TA,FLOLOC##
LDB TA,FL.PRO## ;GET PROTAB LINK
ANDI TA,077777
ADD TA,PROLOC##
MOVE TB,TBLOCK+5 ;GET USETAB LINK
DPB TB,PR.DEB## ;SAVE IT IN PROTAB
HRRZ TA,(TC) ;GET FLOTAB POINTER
JUMPE TA,CUSET7 ;ALL DONE
ADD TA,FLOLOC##
LDB TA,FL.PRO## ;GET PROTAB LINK
ANDI TA,077777
ADD TA,PROLOC##
MOVE TB,TBLOCK+5 ;GET USETAB LINK
DPB TB,PR.DEB## ;SAVE IT IN PROTAB
CUSET7: AOBJN TC,CUSET5 ;LOOP
MOVE TA,TBLOCK+5
ADD TA,USELOC
LDB TC,US.CNT ;GET EXTRA WORDS
ADDM TC,TBLOCK+5
JRST CUSET1
>
CUSET4: LDB TC,US.XTR## ;ANY EXTRA WORDS?
JUMPE TC,CUSET1 ;NO
CUSET3: LDB TC,US.CNT## ;GET COUNT OF EXTRA WORDS IN USETAB ENTRY
;[435] THE USE TABLE LOOKS LIKE
;[435] CNT OF ERROR-STATUS,,ERROR-STATUS-1
;[435] ERROR-STATUS-2,,ERROR-STATUS-3 ETC
LSH TC,-1 ;[435] DIVIDE # OF ERROR-STATUS VALUES BY 2
AOS TC ;[435] ROUND UP TO GET NUMBER OF WORDS NEEDED
ADDM TC,TBLOCK+5 ;[435] ADD TO DYNAMIC USETAB PTR
JRST CUSET1 ;TRY NEXT ENTRY
>
CLE1.: HRRZI DW,E.202 ;NO DEVICES
JRST CLER2.
CLE2.: HRRZI DW,E.201 ;NO DATA RECORDS
JRST CLER.
CLE4.: HRRZI DW,E.199 ;VAL-ID AND VAL-DW REQUIRED
JRST CLER.
CLE5.: HRRZI DW,E.198 ;LABELS MUST BE STANDARD
JRST CLER.
CLE6.: HRRZI DW,E.197 ;ONLY ONE DEVICE ALLOWED
JRST CLER2.
IFN ANS68,<
CLE7.: HRRZI DW,E.196 ;MULTIPLE REEL/UNIT NOT ALLOWED
JRST CLER.
CLE10.: HRRZI DW,E.193 ;FILE-LIMITS REQUIRED
JRST CLER2.
CLE11.: HRRZI DW,E.192 ;'BLOCK CONTAINS N RECORDS' MUST BE SPECIFIED
JRST CLER.
>
CLE12.: HRRZI DW,E.97 ;NO FD
HRRZ TA,CURFIL
LDB LN,FI.LN## ;POINT TO THE "SELECT"
LDB CP,FI.CP##
JRST FATAL##
CLE13.: HRRZI DW,E.365 ;FILE MUST BE ASCII IF WRITE ADV BIT ON
JRST CLER2.
IFN ANS68,<
CLE14.: LDB TB,[POINT 3,TC,20]
CAIE TB,CD.PRO
JRST CLE14A
MOVEM CH,TBLOCK+11
MOVEM TC,TBLOCK+12
MOVEM TD,TBLOCK+13
MOVEM TE,TBLOCK+14
HRRZ TA,CH
PUSHJ PP,LNKSET
LDB TA,PR.FLO##
ADD TA,FLOLOC##
LDB LN,FL.LN##
LDB CP,FL.CP##
HRRZI DW,E.505 ;CONFLICTING USES
PUSHJ PP,FATAL##
MOVE DW,TBLOCK+12
PUSHJ PP,PUTERA##
MOVE CH,TBLOCK+11
MOVE TC,TBLOCK+12
MOVE TD,TBLOCK+13
SKIPA TE,TBLOCK+14
CLE14A: SETZM USES(TD)
POPJ PP,
CLE15.: HRRZI DW,E.301
JRST CLER2. ;BLOCKING FACTOR MUST BE GT. 0 FOR I-O USE
>
CLE18.: HRRZI DW,E.579 ;ADVANCING AND POSITIONING FOR THE SAME FILE.
PJRST CLER2.
CLE19.: HRRZI DW,E.585 ;ONLY DENSITIES OF 800 AND 1600 BPI
PJRST CLER2. ; ARE ALLOWED ON STANDARD ASCII FILES.
IFN ANS68,<
CLE20: HRRZI DW,E.374 ;SYMBOLIC KEY & REC KEY NOT SAME CLASS
PUSHJ PP,CLER2.
JRST B4.SK1
CLE21: HRRZI DW,E.375 ;SYMBOLIC KEY & REC KEY NOT SAME USAGE
PUSHJ PP,CLER2.
JRST B4.SK2
CLE22: HRRZI DW,E.376 ;SYMBOLIC KEY & REC KEY NOT SAME SIZE
PUSHJ PP,CLER2.
JRST B4.SK3
CLE23: HRRZI DW,E.377 ;SYMBOLIC KEY & REC KEY NOT SAME # DEC PLACES
PUSHJ PP,CLER2.
JRST B4.SK4
>
CLE24: HRRZI DW,E.378 ;INDEXED FILE MUST BE 6BIT OR ASCII
JRST CLER2.
CLE25: HRRZI DW,E.379 ;RECORD KEY NOT IN RECORD
HRRZ TA,CURFIL
LDB LN,FI.LN## ;POINT TO THE "SELECT"
LDB CP,FI.CP##
PUSHJ PP,FATAL##
JRST B4.SK5
IFN ANS68,<
CLE26.: HRRZI DW,E.393 ;SYMBOLIC KEY REQUIRED
PUSHJ PP,CLER2.
MOVEI TB,100001 ;DUMMY DATAB ENTRY
JRST B4.IX1
>
CLE27.: HRRZI DW,E.394 ;RECORD KEY REQUIRED
PUSHJ PP,CLER2.
MOVEI TC,100001 ;DUMMY DATAB ENTRY
IFN ANS74,<
MOVEI TB,100001 ;[747] DUMMY DATAB ENTRY
>
JRST B4.IX2
CLE28.: HRRZI DW,E.566 ;EBCDIC FILES MAY NOT
PJRST CLER2. ;HAVE NON-STANDARD LABELS.
CLE29.: HRRZI DW,E.596 ;CAN NOT BE BYTE MODE AND BINARY
PUSHJ PP,CLER2.
JRST B4.16D ;SO IGNORE BYTE MODE
CLE30.: HRRZI DW,E.623 ;BLOCKING FACTOR TOO SMALL
PJRST CLER2.
CLER.: SKIPE TBLOCK+20
POPJ PP,
CLER2.: HRRZ TA,CURFIL
LDB LN,FI.FLN## ;POINT TO THE FD
LDB CP,FI.FCP##
JRST FATAL##
PUTBYT: JUMPE CH,PBYT0
LDB TB,[POINT 3,CH,20]
CAIE TB,CD.DAT
JRST VALBYT
HRRZM CH,CURDAT##
ANDI CH,077777
IORI CH,AS.DAT
HRLI CH,AS.BYT
PUSHJ PP,PUTAS1
SETZ CH,
HRRZ TA,CURDAT
PUSHJ PP,LNKSET
PUTBX: LDB TB,DA.RES##
DPB TB,[POINT 6,CH,5]
;** Note: 3-APR-80 /DAW:
; Keys that are not DISPLAY get a 9-bit byte pointer
; by the nature of the code below. Code in CBLIO will not check
; the left half of the byte pointer when the compare against
; the file parameter is done for COMP keys.
HRRZI TC,6
LDB TB,DA.USG
CAIN TB,%US.D6 ;IS IT DISPLAY-6?
JRST .+4 ;YES, GO ON.
CAIN TB,%US.D7 ;HOW ABOUT DISPLAY-7?
AOJA TC,.+2 ;YES, MAKE IT SEVEN BITS.
HRRZI TC,^D9 ;MUST BE EBCDIC THEN.
DPB TC,[POINT 6,CH,11]
JRST PUTAS1
VALBYT: CAIE TB,CD.TAG
JRST PBYT0
HRLI CH,AS.BYT ;BYTE POINTER
PUSHJ PP,PUTAS1
HRLZI CH,440600
JRST PUTAS1
PBYT0: MOVE CH,[XWD AS.OCT,1]
PUSHJ PP,PUTAS1
SETZ CH,
JRST PUTAS1
IFN ANS74,<
; FOR EACH DECLARATIVE PROCEDURE, STORE THE TAG FOR PHASE E
;CALLED WITH TC= INDEX INTO USP.I BLOCK
; TA= PARAGRAPH
;EXIT WITH TAG STORED IN USP.I BLOCK, TC INCREMENTED
PUTPTE: JUMPE TA,PUTPT2 ;JUMP IF NONE THERE
PUSHJ PP,PUTPRF ;GET THE TAG
HRRZM CH,USP.I##(TC) ;STORE THE INFO
AOJA TC,CPOPJ ;INCREMENT TC AND RETURN
PUTPT2: SETZM USP.I(TC) ;CLEAR LOCATION
AOJA TC,CPOPJ ;INCREMENT TC AND RETURN
>;END IFN ANS74
;FOR EACH DECLARATIVE PROCEDURE, GENERATE THE FOLLOWING CODE:
; %TAG: PERF. %PARAM-LOC
; JRST DECL-PROC
; POPJ PP,
PUTPRF: MOVEM TC,TBLOCK+10
JUMPE TA,PFZOUT
LDB TB,LNKCOD
CAIE TB,CD.PRO
JRST PFZOUT
IFN ANS74!DBMS,<
PUTPR2: ;ENTER HERE FOR DEBUGGING AND ERROR-STATUS PROCEDURES>
HRLZM TA,CURPRO##
PUSHJ PP,LNKSET
HRRM TA,CURPRO
LDB CH,PR.PRF##
JUMPN CH,PRFOUT
IFN ANS74,<
LDB CH,PR.SFI ;DID WE PREVIOUSLY ALLOCATE A TAG#?
SKIPN CH ;YES, JUST USE IT
>
PUSHJ PP,GETTAG##
HRRZ TA,CURPRO
DPB CH,PR.PRF
IFN ANS74,<
DPB CH,PR.SFI## ;SO ERROR USE CAN FIND LABEL
>
PUSHJ PP,PRFSUB
PRFOUT: HRRZ TA,CURPRO
LDB CH,PR.PRF
MOVE TC,TBLOCK+10
POPJ PP,
PFZOUT: HRRZI CH,AS.CNB
MOVE TC,TBLOCK+10
POPJ PP,
PRFSUB: HRRZ TA,CURPRO
LDB TB,PR.XTW##
JUMPN TB,PRFXTW
HRRZ TB,IMPPAR
ANDI TB,077777
IORI TB,AS.PAR##
DPB TB,PR.XTW
AOS IMPPAR
PRFXTW: SETO TB,
DPB TB,PR.EXR## ;TURN ON EXIT REQUIRED FLAG
HRLI CH,AS.%X##
PUSHJ PP,PUTAS2##
HRRZ TB,EAS2PC##
ANDI CH,077777
HRRZ TD,CH
ADD TD,TAGLOC##
HRRM TB,(TD)
MOVE CH,[XWD 201700,AS.MSC] ;MOVEI 16,%PARAM-LOC
PUSHJ PP,PUTAS2
LDB CH,PR.XTW
PUSHJ PP,PUTAS2
MOVE CH,[XWD 113740,PERF%##] ;PUSHJ 17,PERF.
PUSHJ PP,PUTAS2
HLRZ CH,CURPRO
ANDI CH,077777
IORI CH,AS.PRO##
HRLI CH,076000 ;JRST
PUSHJ PP,PUTAS2
HRLZI CH,137740 ;POPJ 17,
PUSHJ PP,PUTAS2
MOVEI TB,4
ADDM TB,EAS2PC
POPJ PP,
SUBTTL CLEAN UP TABLES AND WRITE NAMTAB
CLENTA: PUSHJ PP,CLEANT## ;CLEAN UP TABLES
IFN DEBUG,<
MOVE TA,CORESW## ;CK SWITCHES
TLNE TA,%KILL##
POPJ PP, ;DON'T DUMP NAMTAB IF /K ON
>
MOVE TE,NAMNXT## ;COMPUTE SIZE OF NAMTAB
SUB TE,NAMLOC
MOVEI TE,1(TE)
ADD TE,NM12SZ## ;ADD SIZE OF NAMTAB
MOVNS TE
HRL TE,NM2LOC## ;FORM THE NAMTAB I/O LIST
MOVSM TE,NAMIOL##
SOS NAMIOL
SETZM NAMIOL+1
OUT NAM,NAMIOL
JRST CLENTB ;NO ERRORS
OUTSTR [ASCIZ "%Couldn't write NAMTAB, compilation continuing without maps or object listing
"]
SWOFF FMAP!FOBJEC
CLENTB: CLOSE NAM,
HRRZ TE,FREESP## ;REDUCE SIZE OF IMPURE AREA
IORI TE,1777
CORE TE,
JRST CLENTE ;IGNORE ERRORS
IFN DEBUG,<EXTERN LSTMES,PUTLST,LCRLF
MOVE TE,[POINT 7,[ASCIZ "Reduced memory to "]]
PUSHJ PP,LSTMES
HRRZ TE,.JBREL
ADDI TE,1
LSH TE,-^D9
PUSHJ PP,CLENTD
MOVEI CH,"P"
PUSHJ PP,PUTLST
PUSHJ PP,LCRLF
>
CLENTE: MOVE TE,.JBREL##
ADDI TE,1
HRRZM TE,TOPLOC##
SUB TE,FREESP
HRLM TE,FREESP
POPJ PP,
IFN DEBUG,<
CLENTD: IDIVI TE,^D10
HRLM TD,(PP)
SKIPE TE
PUSHJ PP,CLENTD
HLRZ CH,(PP)
ADDI CH,"0"
JRST PUTLST
>
END