Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
cobol-source/cobolb.mac
There are 14 other files named cobolb.mac in the archive. Click here to see a list.
; UPD ID= 1417 on 11/11/83 at 3:18 PM by HOFFMAN
TITLE COBOLB FOR COBOL V13
SUBTTL ID AND ED CONTROL PROGRAM W.NEELY/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
DEBUG==:DEBUG
IFN TOPS20,<SEARCH MONSYM,MACSYM>
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
;EDITS
;V12*****************
;NAME DATE COMMENTS
;SMI 23-Sep-82 [1407] Fix COPY REPLACING in ID-DIVISION.
;DMN 21-Jun-82 [1363] Fix errors in handling alphabet-name in SPECIAL-NAMES.
;DMN 1-Jan-82 [1332] Fix PROGRAM COLLATING SEQUENCE not to advance too far.
;JEH 1-Jan-82 [1330] Add warning for invalid memory size clause.
;JEH 17-Dec-81 [1325] Shut of DCCFLG so source is not lost with DATE-COMPILED comment.
;DMN 16-MAY-80 [1021] FIX ERROR CAUSE BY LOWER CASE LITERAL IN PROGRAM-ID.
;DMN 26-SEP-79 [740] FIX SOURCE-COMPUTER. WITH NO COMMENT ENTRY
;DMN 30-APR-79 [702] LIST COMMENTS IN DATE-COMPILED PARAGRAPH.
;EHM 17-SEP-78 [553] GIVE WARNING IF RECORDS/RERUN TO LARGE
;V10*****************
;NAME DATE COMMENTS
; 27-JUL-77 [505] ADD CHECKS SO "KEY" TYPE MATCHES ACCESS MODE
;EHM 3-JUN-77 [501] ENFORCE NO PRINTER CHANNEL GREATER THAN 8
; 6-APR-76 [422] FIX LOSS OF FIRST CHAR IN DATE=COMPILED OR SOURCE-COMPUTER STATEMENTS
;ACK 12-JAN-75 ADDED ROUTINES FOR:
; 1. RECORDING MODE IS STANDARD-ASCII/F/V.
; 2. RECORDING DENSITY IS 1600.
; 3. I/O ERROR RECOVERY.
;********************
; EDIT 355 ALLOW FOR 1 BUFFER, ALSO CHECK FOR MAX OF 62 ALTERNATE AREAS.
; EDIT 277 FIX CODE FOR OBJECT AND SOURCE COMPUTER STATEMENTS TO HANDLE LC LETTERS.
; EDIT 175 FIXES ERROR RECOVERY FOR SELECT STATEMENTS ERRORS
; EDIT 153 FIXES NUMERIC DATA IN DATE-WRITTEN SKIPPING NEXT PARA.
ENTRY COBOLB
EXTERN BTREE
EXTERN FNDLNK,KILL,LITVAL
EXTERN SAVETA,SAMSRT
EXTERN CTR,GETVAL
EXTERN PNTR
EXTERN TRYNAM,CPYBHO
EXTERN CFLM,FI.SDL
EXTERN LNKSET
EXTERN PROGID
EXTERN NAMWRD,NAMADR,BLDNAM,GETENT,PUTLNK,OBJSIZ
EXTERN DOLLR.,STDATE,PUTCPY,GETITM
EXTERN FILLOC,TBLOCK,ESIZE,VALADR,CURNAM
EXTERN LSIZE,MNETYP,SKPSRC
EXTERN CURVAL
EXTERN FI.LNC,FI.ERM,FI.LBL,FI.ORG,FI.RCT
EXTERN FI.IRM,FI.NXT,FI.OPT,FI.NDV,FI.VAL,FI.NBF
EXTERN FI.SRA,FI.RRC,FI.RER,FI.SAL,FI.POS
EXTERN FI.RM2,FI.RD,FI.RP
EXTERN FI.RMS
EXTERN CURAKT,AK.DUP,AK.FLK
EXTERN ISVPTR,INDPTR,CURFIL,LSTFIL
EXTERN SQURL.,SEGLIM
EXTERN KILL
EXTERN CURHLD,HL.NAM,HL.COD,HL.LNC,HL.QAL,HL.LNK
EXTERN HLDLOC
IFN DEBUG,<
EXTERN CORESW
>
COBOLB: SETFAZ B; ;INIT PHASE B
MOVE SAVPTR,ISVPTR ;INITIALIZE SAVE LIST POINTER
MOVE NODPTR,INDPTR ;INITIALIZE NODE POINTER
IFN DEBUG,<
MOVE TE,CORESW
SWOFF FNDTRC ;CLR TRACE REQUEST
TRNE TE,TRACEI ;TRACE ID NODES?
SWON FNDTRC ;YES, TURN ON TRACER
>
HRRZI TA,62 ;50 DECIMAL IS SEGLIM INITIAL VALUE
MOVEM TA,SEGLIM
HRRZI TA,ID0.## ;AIM AT FIRST ID NODE
PUSH NODPTR,TA
SETZM CURFIL ;INIT FILE TABLE PTRS
SETZB W2,LSTFIL
SETZM ABSEEN## ;INIT APPLY BASIC-LOCKING SEEN FLAG
PUSHJ PP,SQURL. ;START SCAN
OUTSTR [ASCIZ "COBOLB--lost; too many POPJ's
"]
JRST KILL
SUBTTL ACTIONS FOR ID AND ED SYNTAX PROCESSING
;CHECK FOR PERIOD, THEN SKIP TO END OF PARAGRAPH
;MUST ALSO WATCH FOR THERE BEING NOTHING TO SKIP
INTER. IA0A.
IA0A.: SETOM NOIDHY## ;SET HYPHEN CONTINUATION NOT ALLOWED
;HACK TO PREVENT FIRST WORD OF PARAGRAPH FROM GOING TO THE CREF LISTING.
PUSH PP,CREFSW## ;SAVE THE STATE OF THE CREF SWITCH.
SETZM CREFSW## ;DON'T CREF WHILE CHEKING FOR PERIOD.
PUSHJ PP,CKPERI ;CHECK FOR PERIOD.
POP PP,CREFSW## ;RESTORE THE CREF SWITCH TO IT'S ORIGINAL STATE.
IA0.S: TRNN TYPE,AMRGN. ;A-MARGIN?
PUSHJ PP,IA0. ;NO, SKIP TO END OF PARAGRAPH
SETZM NOIDHY ;TURN IT BACK ON
SETZM DCCFLG ;OUT OF DATE-COMPILED NOW
POPJ PP,
;SKIP TO END OF PARAGRAPH, PASSING DATA TO LISTING FILE
INTER. IA0.
IA0.: TSWF FRTST ;[1407] COPY REPLACING?
JRST IA0.C ;[1407] YES
SWOFF FNOCPY ;TURN OFF 'NO LISTING' FLAG
SWOFF FGTPER ;[153] DON'T GET PERIOD FROM GETITM
PUSHJ PP,SKPPGF## ;SKIP TO END OF PARAGRAPH
SETZM DCCFLG ;[1325] OUT OF DATE-COMPILED STATEMENT NOW
IA0.N: PUSHJ PP,GETITM ;GET A SOURCE ITEM
SKPNAM
;SET TO REGET LAST ITEM SEEN
INTER. IA0.R
IA0.R: SWON FREGWD ;SET REGET WORD BIT
POPJ PP,
;TURN OFF REGET WORD FLAG
INTER. IA0.A
IA0.A: SWOFF FREGWD;
POPJ PP,
IA0.C: PUSHJ PP,GETITM ;[1407] SKIP NEXT WORD
JRST IA0.N ;[1407]
;ADVANCE TO NEXT WORD
INTER. IA0.G
IA0.G: SWOFF FREGWD ;CLR REGET WORD FLAG
PJRST GETITM ;GET NEXT ITEM
;FLAG MISSING IDENTIFICATION DIVISION, THEN TRY ITEM AGAIN
INTER. IA0E1.
IA0E1.: EWARNW E.1 ;NO IDENTIFICATION DIV.
SWON FREGWD ;CAN'T CONTINUE
JRST IA0.ID ; UNLESS WE ASSUME WE DID SEE IT
INTER. IA0E2.
IA0E2.: EWARNW E.7 ;MIS-SPELLED 'IDENTIFICATION'?
JRST IA0.A ;SEE IF 'DIVISION' FOLLOWS
;IF /S NOT SEEN, SET /S AND TRY AGAIN, GIVE WARNING
INTER. IA0S1.
IA0S1.: MOVE TA,SAVECP## ;GET CHARACTER POSITION
SUBI TA,7 ;SUBTRACT 7 SINCE WE THREW 7 SPACES OUT
MOVEM TA,SAVECP## ; TO PUT FIRST SOURCE WORD AT COLUMN 8
TSWFS FSEQ ;WAS /S SEEN
EWARNJ E.1 ;YES, GIVE OLD MESSAGE
EWARNJ E.601 ;NO, GIVE NEW MESSAGE
INTER. IA0.ID
IA0.ID: MOVSI TE,'ID ' ;ID IS NOT ANSI STANDARD
CAMN TE,NAMWRD ;SO IF THATS WHAT WE SAW
FLAGAT NS ;FLAG IT
MOVE TA,[CD.PRG,,SZ.PRG]
PUSHJ PP,GETENT ;GET A PROGRAM TABLE ENTRY
AOS TB,PRGLVL## ;INCREMENT CONTAINED PROGRAM LEVEL
DPB TB,PG.LVL## ;SAVE LEVEL
SOJN TB,IA0ID1 ;JUMP IF CONTAINED
MOVEM TA,CURPRG## ;SAVE POINTER TO CURRENT PROGRAM
POPJ PP,
IA0ID1: EXCH TA,CURPRG ;GET POINTER TO FATHER LINK
HLRZ TB,TA
ADD TB,PRGLOC## ;CALCULATE ADDRESS AGAIN
HRR TA,TB ; TA IS NOW SETUP
LDB TB,PG.SON## ;IS THIS THE FIRST PROGRAM CONTAINED IN THIS ONE?
HLRZ TC,CURPRG ;GET SON POINTER
DPB TC,PG.SON ;LINK FATHER TO SON
JUMPN TB,IA0ID2 ;NO, LINK TO BROTHER
HLRZ TB,TA ;GET FATHER POINTER
MOVE TA,CURPRG
DPB TB,DA.POP## ;AND LINK THIS WAY
SETO TB,
DPB TB,PG.FAL## ;SET FATHER POINTER BIT
POPJ PP,
IA0ID2: MOVE TA,CURPRG
DPB TB,DA.BRO## ;LINK BROTHER TO SON
POPJ PP,
;FOUND 'IDENTIFICATION', BUT NOT WHERE WE EXPECTED
INTER. IA0.ER
IA0.ER: EWARNW E.341 ;ID. NOT IN 'A' MARGIN
JRST IA0.ID ;NOW ACT AS THOUGH IT IS
;FLAG ILLEGAL PARAGRAPH, THEN SKIP TO NEXT PARAGRAPH
INTER. IA0E7.
IA0E7.: EWARNW E.7 ;'ILLEGAL PARAGRAPH NAME'
JRST IA0.
;FLAG ILLEGAL SECTION, THEN SKIP TO NEXT PARAGRAPH
INTER. IA0E43
IA0E43: EWARNW E.43 ;'ILLEGAL SECTION NAME'
JRST IA0.
;STOP SOURCE FROM GOING TO LISTING FOR DATE-COMPILED
INTER. IA1.
IA1.: FLAGAT HI
SWON FNOCPY ;SET NO LISTING BIT
POPJ PP,
;OBJECT COMPUTER, SEE WHAT IT WAS
INTER. IA3.
IA3.: CAIG TYPE,ENDIT.+AMRGN. ;[740] SEE IF RESERVED WORD
TRNN TYPE,AMRGN. ;[740] IN THE "A" MARGIN
JRST IA3A ;[740] NO
MOVEI NODE,ED269.## ;[740] YES, SET RETURN ADDRESS
MOVEM NODE,0(NODPTR) ;[740] SO WE CAN RECOVER CORRECTLY
SWON FREGWD ;[740] MAKE SURE WE REGET THIS WORD
POPJ PP, ;AND RETURN
IA3A: CAILE TYPE,ENDIT. ;IS IT A RESERVED WORD?
JRST IA0.A ;RETURN, MAKE SURE REGET WORD BIT IS OFF
SWON FREGWD ;SET REGET WORD BIT AND GIVE WARNING
EWARNJ E.5 ;'DECSYSTEM-10/20 ASSUMED'.
;GET NEXT ITEM & VERIFY THAT IT IS A PERIOD
;IF NOT A PERIOD, FLAG IT
CKPERI: PUSHJ PP,GETITM ;READ FOR PERIOD
LDB TA,[POINT 10,TYPE,35] ;GET TYPE OF ITEM
CAIN TA,PRIOD. ;IS IT A PERIOD?
JRST IA0.N ;IF PERIOD THERE GET NEXT ITEM FOR CONSISTENCY
SKPNAM ;NO, GIVE PERIOD ASSUMED MSG
INTER. BE125.
BE125.: MOVE LN,BLNKLN##
MOVE CP,BLNKCP##
HRRZI DW,E.125 ;DIAGNOSTIC 125
SWON FREGWD ;READ THAT AGAIN LATER
JRST WARN## ;WARNING ONLY
;SKIP TO START OF NEXT WORD
;THE TRICK IS TO FIND A CHARACTER IN THE A-FIELD OR B-FIELD THAT IS NOT
;EITHER A SPACE, TAB, OR HYPHEN
;(ASTERISKS ARE FILTERED OUT AT A MUCH EARLIER STAGE)
SKPNW.: PUSHJ PP,SKPSRC ;GET NEXT SOURCE CHAR.
CAIN CP,7 ;ALREADY AT COLUMN 7?
JRST SKPNW2 ;YES, WHAT KIND OF CHAR.?
JRST SKPNW4 ;MUST BE IN A-FIELD OR B-FIELD
SKPNW1: PUSHJ PP,SKPSRC ;GET CHARACTER
SKPNW2: TSWF FEOF ;END-OF-FILE?
JRST END2## ;EOF FOUND
CAIN CP,7 ;COLUMN 7?
CAIE CH," " ;YES, SPACE?
JRST SKPNW1 ;NO, MUST BE A HYPHEN OR NOT COL. 7
SKPNW3: PUSHJ PP,SKPSRC ;GET CHARACTER
TSWF FEOF ;END-OF-FILE?
JRST END2 ;YES
SKPNW4: CAIN CH," " ;IS IT A SPACE?
JRST SKPNW3 ;YES
CAIL CH,"a" ;ABOVE LOWER CASE A?
MOVEI CH,-40(CH) ;YES MOVE IT INTO THE UPPER CASE SET.
CAIL CH,"A" ;IS IT ALPHABETIC?
CAILE CH,"Z"
JRST SKPNW2 ;NOT A LETTER
JRST END2 ;REGET LAST CHARACTER
;GET PROGRAM TITLE
;PROGRAM-ID is a literal
INTER. IA2.L
IA2.L: MOVE TD,[POINT 6,NAMWRD] ;SET PTRS TO MOVE THE
MOVE TE,[POINT 7,LITVAL] ;LITERAL INTO THE NAMWRD TABLE
LDB TB,GWVAL## ;GET # OF CHARS
CAILE TB,6 ;IF LESS THAN OR = SIX, USE IT
MOVEI TB,6 ;SET CTR FOR 1ST 6 CHARS
IA2.11: ILDB TA,TE ;GET LITERAL CHARACTER
JUMPE TA,IA2.12 ;END OF LITERAL
CAIL TA,"a" ;[1021] CHECK FOR LOWER CASE
CAILE TA,"z" ;[1021]
TRNA ;[1021]
SUBI TA,40 ;[1021] AND CONVERT TO UPPER CASE
CAIL TA,"0" ;LETTER OR DIGIT?
CAILE TA,"Z"
JRST IA2110 ;NO
CAILE TA,"9"
CAIL TA,"A"
TRNA ;YES
IA2110: HRRZI TA,":" ;CHANGE NON-LETTER/DIGIT TO POINT (:)
HRRZI TA,-40(TA) ;CONVERT TO SIXBIT
IDPB TA,TD ;PUT IN NAMWRD
SOJG TB,IA2.11 ;CONT. IN LOOP UNTIL 6 CHARS MOVED
SKPNAM
;PROGRAM-ID is a user-name
INTER. IA2.
IA2.: SKIPE PROGID ;'PROGRAM-ID' SEEN ALREADY?
EWARNJ E.3 ;YES, DUPLICATE PARAGRAPH
IA2.12: SETZ TD, ;INIT AC FOR RESULT
MOVEI TB,6 ;CTR FOR 6 CHARS
MOVE TA,[POINT 6,NAMWRD]
IFN TOPS20,<
TSWF FDSKC
PUSH PP,T1 ;IF CCL SAVE T1 AS ITS USED BY PBOUT%'s
>
IA2.N2: ILDB TC,TA ;GET 6BIT CHAR
CAIN TC,32 ;IS IT A COLON (WHICH AROSE FROM A HYPHEN, ETC)?
MOVEI TC,16 ;YES, CHANGE IT TO A DOT
LSH TD,6 ;SHIFT PREVIOUS RESULT LEFT 6
OR TD,TC ;MERGE IN NEW CHAR
TSWT FDSKC ;CCL OR COMMAND FILE?
JRST IA2.N3 ;NO, DONT PRINT NAME
IFE TOPS20,<
ADDI TC,40 ;CONVERT 6BIT TO ASCII
OUTCHR TC ;PRINT CHAR
>
IFN TOPS20,<
MOVEI T1,40(TC) ;CONVERT TO ASCII
PBOUT%
>
IA2.N3: SOJG TB,IA2.N2 ;CONT. THRU 6 CHARS.
PJRST IA2SUB
;No name given so use MAIN
INTER. IA2.M
IA2.M: SKIPE PROGID ;'PROGRAM-ID' SEEN ALREADY?
EWARNJ E.3 ;YES, DUPLICATE PARAGRAPH
IA2.2: MOVE TD,[SIXBIT /MAIN/] ;NO ID THERE
MOVEM TD,NAMWRD ;SO GIVE IT A DUMMY NAME
IFE TOPS20,<
TSWF FDSKC ;CCL?
OUTSTR [ASCIZ /MAIN/]
>
IFN TOPS20,<
TSWT FDSKC ;CCL?
JRST IA2SUB ;NO
PUSH PP,T1
HRROI T1,[ASCIZ /MAIN/]
PSOUT%
>
IA2SUB: MOVEM TD,PROGID ;STORE RESULT
TSWT FDSKC ;CCL OR CMD FILE?
JRST IA2SU3 ;NO
IFN TOPS20,<
HRROI T1,[ASCIZ / [/] ;PRINT "[FILNAM.EXT]"
PSOUT%
>
IFE TOPS20,<
OUTSTR [ASCIZ / [/] ;PRINT "[FILNAM.EXT]"
MOVEI TA,'.' ;PUT A DOT WHERE THERE IS A SPACE
DPB TA,[POINT 6,SRCFIL+1,5]
MOVE TA,[POINT 6,SRCFIL##]
MOVEI TB,^D10
IA2SU2: ILDB TC,TA
ADDI TC,40 ;CONVERT TO ASCII
CAIE TC,40 ;SPACE?
OUTCHR TC ;NO, PRINT IT
SOJG TB,IA2SU2
SETZ TA, ;CLR '.' AGAIN
DPB TA,[POINT 6,SRCFIL+1,5]
OUTSTR [ASCIZ /]
/]
>
IFN TOPS20,<
PUSH PP,T2 ;SAVE OTHER 2 ACCS
PUSH PP,T3
MOVEI T1,.PRIOU ;OUTPUT TO TERMINAL
MOVE T2,SRCJFN## ;GET THE JFN
MOVX T3,FLD(.JSAOF,JS%NAM)+FLD(.JSAOF,JS%TYP)+JS%PAF
JFNS% ;OUTPUT NAME.EXT
ERJMP .+1
HRROI T1,[ASCIZ /]
/]
PSOUT%
POP PP,T3
POP PP,T2
POP PP,T1
>
IA2SU3: SETZM NAMWRD+1
MOVE TA,[NAMWRD+1,,NAMWRD+2]
BLT TA,NAMWRD+5
PUSHJ PP,TRYNAM ;PROGRAM-ID A RESERVED WORD?
JRST .+3 ;NO
EWARNW E.315 ;YES
JRST IA2.2 ;TRY IT WITH "MAIN"
PUSHJ PP,BLDNAM ;MAKE NAMTAB ENTRY
HLRS TA
DPB TA,[POINT 15,W2,15] ;SAVE NAMTAB LINK
MOVE TA,PRGLVL ;SEE IF TOP LEVEL PROGRAM
SOJN TA,IA2SU4 ;NO, SO DON'T MAKE EXTERN
MOVE TA,[CD.EXT,,SZ.EXT] ;PUT PROGRAM-ID IN EXTAB
PUSHJ PP,GETENT
HLRM TA,PIDLNK## ;SAVE EXTAB LINK
LDB TB,[POINT 15,W2,15]
IORI TB,<CD.EXT>B20 ;EXT FLAG + NAMTAB LINK
MOVSM TB,(TA) ;TO 1ST WORD OF ENTRY
SETO TC, ;SET PROG-ID FLAG
DPB TC,EX.PID##
DPB TC,EX.ENT## ;ALSO SET ENTRY FLAG
HRRI TA,(TB) ;LINK NAMTAB TO EXTAB
PUSHJ PP,PUTLNK
IA2SU4: MOVE TA,CURPRG ;TABLES CANNOT HAVE MOVED YET
LDB TB,[POINT 15,W2,15]
DPB TB,PG.NAM## ;SAVE NAMTAB LINK
POPJ PP,
;Here for COMMON program
INTER. IA2.C
IA2.C: FLAGAT 8
MOVE TA,PRGLVL ;GET PROGRAM LEVEL
CAIG TA,1 ;NOT LEGAL IF NOT CONTAINED
EWARNJ E.834 ;SO TELL USER
MOVE TA,CURPRG##
SETO TB,
DPB TB,PG.COM## ;SET COMMON FLAG
EWARNJ E.899 ;CONTAINED PROGRAMS NOT SUPPORTED
;Here for INITIAL program
INTER. IA2.I
IA2.I: FLAGAT 8
MOVE TA,CURPRG##
SETO TB,
DPB TB,PG.INI## ;SET INITIAL FLAG
SETOM PROGIF## ;SET INITIAL PROGRAM FLAG
POPJ PP,
;REPLACE DATE-COMPILED COMMENTS WITH TODAY'S DATE
INTER. IA4.
IA4.: SETOM NOIDHY## ;SET HYPHEN CONTINUATION NOT ALLOWED
PUSHJ PP,IA5SUB ;PUT SPACE AFTER 'DATE-COMPILED.'
MOVE TA,[POINT 7,STDATE]
MOVEM TA,PNTR ;POINTER FOR DATE
MOVEI TB,11 ;9 CHARACTERS
MOVEM TB,CTR
IA4.G: ILDB CH,PNTR ;GET CHARACTER
PUSHJ PP,PUTCPY ;PUT ON LISTING
SOSLE CTR
JRST IA4.G
HRRZI CH,"." ;PUT A PERIOD AFTER DATE
PUSHJ PP,PUTCPY
SWON FNOCPY ;[702] TURN ON NO LISTING FLAG
PUSHJ PP,GETSRC## ;[702] READ NEXT CHARACTERS
CAIE CH,12 ;[702] <CR-LF>
JRST .-2 ;[702] NO, LOOK FOR END OF LINE
SWOFF FNOCPY ;[702] RE-ENABLE LISTING
SWON FREGCH ;[702] GET EOL AGAIN
SETOM DCCFLG## ;SIGNAL IN DATE-COMPILED COMMENT ENTRY.
JRST IA0.S ;AND SKIP REST OF PARAGRAPH
;REENABLE LISTING, SEE IF LAST CHAR OUTPUT TO IT WAS "."
;IF SO, PUT A SPACE AFTER THE "."
;IF NOT, REPLACE WHATEVER IT WAS BY SPACE
IA5SUB: SWOFF FNOCPY ;ENABLE OUTPUT TO LISTING
HRRZI CH," " ;GET A SPACE
LDB TA,CPYBHO+1 ;GET LAST CHAR PUT ON LISTING
CAIN TA,"." ;WAS IT A "."
JRST PUTCPY ;YES, PUT SPACE AFTER "."
DPB CH,CPYBHO+1 ;NO, REPLACE IT BY SPACE
POPJ PP,
INTER. IA7.
IA7.: FLAGAT LI
SETOM DEBSW## ;SET DEBUG MODULE WANTED
POPJ PP,
;PUT SAVED INTEGER INTO OBJECT-COMPUTER MEMORY SIZE WORD
INTER. IA8.
IA8.: POP SAVPTR,TB ;GET INTEGER FROM SAVE LIST
IA8.1: CAMN TB,OBJSIZ ;IF INTEGER=OBJSIZ, IGNORE IT
POPJ PP,
SKIPE OBJSIZ ;OBJSIZ=0?
EWARNJ E.6 ;NO, 'MORE THAN 1 OBJ-COMPUTR PARA'
CAILE TB,777777 ;[1330] MAX SIZE IN WORDS = 777777
EWARNJ E.657 ;[1330] TOO BIG - GIVE WARNING
MOVEM TB,OBJSIZ ;PUT INTEGER IN OBJSIZ
POPJ PP,
;CONVERT #MODULES TO #WORDS & PUT INTO OBJSIZ
INTER. IA9.
IA9.: POP SAVPTR,TB ;GET SAVED INTEGER
IMULI TB,^D1024 ;#MODULES * 1K WORDS EACH
JRST IA8.1
;CONVERT #CHARACTERS (SIXBIT) TO #WORDS & PUT INTO OBJSIZ
INTER. IA10.
IA10.: POP SAVPTR,TB ;GET SAVED INTEGER
ADDI TB,5 ;FORCE ROUNDING UPWARD
IDIVI TB,6 ;N CHARS = N+5/6 WORDS
JRST IA8.1
;TURN OFF 'FILE OPTIONAL' FLAG
INTER. IA12.
IA12.: SWOFF FOPT ;OFF
SETZM RSLNCP## ;CLEAR ANY PREVIOUS SAVED LN & CP
SETZM ASLNCP## ;...
POPJ PP,
;TURN ON 'FILE OPTIONAL' FLAG
INTER. IA13.
IA13.: FLAGAT HI
SWON FOPT ;ON
POPJ PP,
;PUT SELECTED FILE-NAME IN FILE TABLE
INTER. IA14.
IA14.: TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
PUSHJ PP,PUTCRF##
TLNE W1,GWNOT ;IS NAME IN NAMTAB?
JRST IA14.B ;NO--PUT IN
HLRZ TA,W2 ;YES, GET NAMTAB RELATIVE ADDR.
LSH TA,-2
HRLZM TA,NAMADR ;SAVE IT
JRST IA14.C ;NOT FOUND--CREATE
IA14.B: PUSHJ PP,BLDNAM ;ENTER NAME IN NAMTAB
MOVEM TA,NAMADR ;SAVE ADDRESS
IA14.C: MOVE TA,CURFIL ;CURRENT FILE ENTRY ADDRESS
MOVEM TA,LSTFIL ;SAVE IT
MOVE TA,[XWD CD.FIL,SZ.FIL] ;GET 15-WORD FILTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURFIL ;SAVE ADDRESS OF CURRENT FILTAB ENTRY
HLLZ TB,NAMADR ;NAMTAB ENTRY REL.ADDR.
MOVEM TB,(TA) ;TO WORD 1 OF FILTAB ENTRY
DPB W2,FI.LNC ;LINE NUMBER, CHARACTER POSITION
HRRZI TB,%%RM ;INITIALIZE OPTIONS AS NOT YET DECLARED
DPB TB,FI.ERM ;EXT. RECORDING MODE
DPB TB,FI.IRM ;AND INT. RECORDING MODE
MOVEI TB,%%ACC ;MORE DEFAULTS
DPB TB,FI.LBL ;LABELS
DPB TB,FI.ORG ;ACCESS MODE
TSWF FOPT ;TEST WHETHER OPTIONAL FILE
DPB TB,FI.OPT ;SET FLAG IF IT IS
AOS TB,NFILES## ;GET # OF THIS FILE; BUMP COUNTER
DPB TB,FI.NUM## ;STORE FIELD IN COMPILER'S FILE-TABLE
HLRZ TA,LSTFIL ;REL.ADDR.OF LAST FILTAB ENTRY
JUMPE TA,IA14.D ;NULL PREVIOUS ENTRY
HRRZ TB,FILLOC ;STARTING ADDRESS OF FILTAB
ADD TA,TB ;ABS.ADDR. OF LAST FILTAB ENTRY
HLRZ TB,CURFIL ;REL. ADDR. OF CURRENT FILTAB ENTRY
DPB TB,FI.NXT ;'NEXT ENTRY' LINK
IA14.D: HLLZ TA,CURFIL ;ENTRY REL. ADDR.
HLR TA,NAMADR ;NAMTAB ENTRY REL. ADDR.
JRST PUTLNK ;LINK FILTAB & NAMTAB
;GET VALUE OF INTEGER & PUT ON SAVLST
INTER. IA16.
IA16.: PUSHJ PP,IA16S. ;GET VALUE OF INTEGER
HRRZI TC,1 ;ERROR -- ASSUME VALUE OF 1
IA16.A: MOVE LN,WORDLN## ;[553] GET LINE & CHAR POS. OF THE
MOVE CP,WORDCP## ;[553] INTEGER - SO WE CAN POINT TO
MOVEM LN,SAVPLN## ;[553] IT IF IT IS OUT OF
MOVEM CP,SAVPCP## ;[553] RANGE
PUSH SAVPTR,TC ;SAVE INTEGER VALUE ON SAVLST
POPJ PP,
;GET VALUE OF NUMERIC LITERAL
;CALL: PUSHJ PP,IA16S.
; ERROR RETURN (MESSAGE BE25. GIVEN)
; NORMAL RETURN (VALUE IN TC)
IA16S.: HLRZ TB,W1 ;L.H. OF FIRST GETWRD PARAMETER
TRNE TB,GWNLIT ;IS THIS A NUMERIC LITERAL?
TRNE TB,GWDP ;YES, IS IT AN INTEGER?
EWARNJ E.25 ;NO, 'POSITIVE INTEGER REQUIRED' -- EXIT
HRRZI TA,LITVAL ;ADDRESS OF INTEGER (ASCII STRING FORM)
ANDI TB,000777 ;LENGTH OF STRING
MOVEM TB,CTR
AOS (PP) ;SKIP RETURN
PJRST GETVAL ;GET VALUE OF INTEGER
INTER. IA16C.
IA16C.: PUSHJ PP,IA16. ;[501] GET THE VALUE
CAIL TC,11 ;[501] IF GREATER THAN 8
EWARNW E.99 ;[501] TROUBLE
POPJ PP,
INTER. IA17.
IA17.: SKIPN FLGSW## ;NEED FIPS FLAGGER?
POPJ PP, ;NO
SKIPE TB,RSLNCP ;SEEN ORGANIZATION TYPE ALREADY?
JRST @[TST.HI ;SEQUENTIAL
TST.HI ;RELATIVE
TST.H]-1(TB) ;INDEXED
HRLZM LN,RSLNCP ;NO, SAVE FOR LATER
HRRM CP,RSLNCP
POPJ PP,
INTER. IA17A.
IA17A.: SKIPN FLGSW ;NEED FIPS FLAGGER?
POPJ PP, ;NO
SKIPE TB,ASLNCP ;SEEN ORGANIZATION TYPE ALREADY?
JRST @[TST.L ;SEQUENTIAL
TST.LI ;RELATIVE
TST.H]-1(TB) ;INDEXED
HRLZM LN,ASLNCP ;NO, SAVE FOR LATER
HRRM CP,ASLNCP
POPJ PP,
;GET DEVICE NAME
INTER. IA18.
IA18.: TLNE W1,GWLIT ;LITERAL?
JRST IA18.A ;YES
TLNE W1,GWHYF ;HYPHEN IN DEV-NAME?
EWARNW E.83 ;YES, 'IMPROPER DEVICE NAME'
SETZM NAMWRD+1 ;DELETE ALL BUT 6 CHARS
MOVE TA,[POINT 6,NAMWRD] ;PTR TO SIXBIT NAME
MOVE TB,[POINT 7,TBLOCK,13] ;PTR TO ASCII NAME STORE
MOVNI TD,6 ;6 CHAR CTR
IA18.L: ILDB TC,TA ;GET CHARACTER OF NAME
JUMPE TC,IA18.M ;END OF NAME
ADDI TC,40 ;CONVERT SIxBIT TO ASCII
IDPB TC,TB ;SAVE CHARACTER
AOJL TD,IA18.L ;CONTINUE UNTIL 6 CHARS
IA18.M: ADDI TD,6 ;GET # OF CHARS IN NAME
IA18.N: DPB TD,[POINT 14,TBLOCK,13]
ADDI TD,2+4
IDIVI TD,5 ;GET LENGTH OF VALTAB ENTRY (INCL CHAR CNT)
MOVEM TD,ESIZE ;SAVE ENTRY SIZE
HRLI TD,CD.VAL ;VALTAB CODE
MOVE TA,TD
PUSHJ PP,GETENT ;FIND VALTAB ENTRY
MOVEM TA,VALADR ;SAVE ADDRESS
MOVE TD,TBLOCK ;MOVE WORD OF NAME
MOVEM TD,(TA) ;TO VALTAB
MOVE TD,TBLOCK+1 ;POSSIBLE 2ND WORD OF NAME
SOSLE ESIZE ;1 OR 2 WORDS NEEDED?
MOVEM TD,1(TA) ;2, STORE 2ND WORD
HRRZ TA,CURFIL ;ABS. ADDR. OF FILTAB ENTRY
LDB TB,FI.NDV ;DEVICE COUNT FOR CURRENT FILE
ADDI TB,1 ;SET DEV COUNT UP BY 1
DPB TB,FI.NDV ;DEPOSIT NEW DEVICE COUNT
LDB TB,FI.VAL ;VALTAB LINK TO UNIT NAME
JUMPN TB,CPOPJ ;EXIT IF ALREADY SET
HLRZ TB,VALADR ;VALTAB POINTER
DPB TB,FI.VAL ;PUT LINK IN ENTRY
POPJ PP,
IA18.A: MOVE TA,[POINT 7,LITVAL] ;PTR TO LITERAL NAME
MOVE TB,[POINT 7,TBLOCK,13] ;PTR TO ASCII NAME STORE
LDB TD,GWVAL ;GET SIZE
CAILE TD,6 ;6 CHAR AT MOST
MOVEI TD,6
PUSH PP,TD ;SAVE COUNT FOR LATER
IA18.B: ILDB TC,TA ;GET CHARACTER OF NAME
CAIN TC,":" ;TEST FOR END OF DEVICE
JRST IA18.C ;YES IT IS
CAIL TC,"0" ;LETTER OR DIGIT?
CAILE TC,"Z"
JRST IA18.E ;NO, 'IMPROPER DEVICE NAME'
CAILE TC,"9"
CAIL TC,"A"
TRNA ;YES
JRST IA18.E ;NO, 'IMPROPER DEVICE NAME'
IDPB TC,TB ;SAVE CHARACTER
SOJG TD,IA18.B ;CONTINUE UNTIL 6 CHARS
POP PP,TD ;GET EXACT COUNT BACK
JRST IA18.N
IA18.E: EWARNW E.83 ;NO, 'IMPROPER DEVICE NAME'
IA18.C: MOVN TD,TD ;GET MINUS WHATS LEFT
POP PP,TC ;CLEAN UP STACK
JRST IA18.M
;GET THE "NUMBER OF AREAS TO RESERVE" (I.E. ABSOLUTE NUMBER OF BUFFERS TO ALLOCATE).
INTER. IA19.
IA19.: PUSHJ PP,IA16S. ;GET VALUE OF INTEGER IN TC
POPJ PP, ;NOT AN INTEGER
JUMPLE TC,[EWARNJ E.643] ;MUST BE POSITIVE INTEGER
CAIG TC,^D63 ; [355] IF LESS THAN OR EQUAL TO 63
JRST IA19A ; [355] OK, GO ON.
EWARNW E.587 ; [355] OTHERWISE WARN USER.
MOVEI TC,^D63 ; [355] SET TO MAX.
IA19A: HRRZ TA,CURFIL ;FILTAB ENTRY ABSOLUTE ADDRESS
LDB TB,FI.NBF ;GET NUMBER OF BUFFERS FIELD
JUMPE TB,IA19.P ;RESERVE CLAUSE SEEN ALREADY?
CAIE TB,(TC) ;YES, IS THIS THE SAME VALUE?
JBE16.: EWARNJ E.16 ;NO, 'DUPLICATE CLAUSE' MSG
POPJ PP,
IA19.P: DPB TC,FI.NBF ;INSERT NO. OF BUFFERS IN FILTAB ENTRY
POPJ PP,
;CHECK FOR MORE THAN 1 ORGANIZATION MODE SETTING PER FILE
INTER. IA21.
IA21.: PUSHJ PP,IA21F. ;TEST FIPS FLAGGER
HRRZ TA,CURFIL ;AIM AT CURRENT FILTAB ENTRY
LDB TB,FI.ORG ;GET CURRENT SETTING OF ACCESS MODE BITS
CAIN TB,3 ;IS IT AT INITIAL VALUE?
POPJ PP, ;YES
HRRZI TA,ED12.## ;AFTER DOING BE16., GO TO SYNTAX NODE ED12.
MOVEM TA,(NODPTR)
EWARNJ E.16 ;'DUPLICATE CLAUSE'
;TEST FOR LEVEL 1 SYNTAX (I.E. SEQ 1, REL 1, IDX 1)
INTER. IA21F.
IA21F.: SKIPN FLGSW## ;NEED FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[TST.L## ;SEQUENTIAL
TST.LI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;TEST FOR LEVEL 2 SYNTAX (I.E. SEQ 2, REL 2, IDX 2)
INTER. IA21G.
IA21G.: SKIPN FLGSW## ;NEED FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[TST.HI ;SEQUENTIAL
TST.HI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;SAVE RECORD KEY CODE FOR HLDTAB
INTER. IA22R.
IA22R.: FLAGAT H
HRRZI TB,%HL.RC ;GET CODE
JRST IA24X.
;HERE WHEN PARSED "ALTERNATE.." AND EXPECTING "RECORD KEY IS.."
INTER. IA22K.
IA22K.: FLAGAT H
MOVE TA,CURFIL
LDB TB,FI.ORG ;GET FILE ORGANIZATION
CAIE TB,%ACC.I ;MAKE SURE THIS IS AN INDEXED FILE
CAIN TB,%%ACC ;OR NOT SPECIFIED YET
CAIA ;ALL OK
EWARNJ E.624 ;"ALTERNATE KEY ONLY ALLOWED WITH INDEXED FILES"
SETOB TB,RMSFLS## ;MAKE SURE RMS BIT IS SET, AND SET "RMS FILES" FLAG
DPB TB,FI.RMS##
DPB TB,FI.AKS## ;SET "ALTERNATE KEYS SPECIFIED" FOR THIS FILE
POPJ PP, ;RETURN OK
;SAVE RELATIVE KEY CODE FOR HLDTAB
INTER. IA24.
IA24.: FLAGAT LI
HRRZ TA,CURFIL ;[505] ABS. ADDR. OF FILTAB ENTRY
LDB TB,FI.ORG ;[505] GET ACCESS MODE
CAIE TB,%%ACC ;[505] IS IT "DEFAULT"?
CAIN TB,%ACC.R ;[505] NO, IS IT RANDOM?
JRST IA24A. ;[505] YES, OK
MOVEI DW,E.595 ;[505] NO, ERROR - WRONG TYPE KEY
PUSHJ PP,FATALW## ;[505] FLAG IT
HRRZI TB,%HL.SY ;[505]
SKIPA ;[505]
IA24A.: HRRZI TB,%HL.AK ;[505] GET CODE
IA24X.: MOVEM TB,CTR ;STORE CODE IN HLDTAB
POPJ PP,
;SET SEQUENTIAL ORGANIZATION/ACCESS FLAG
INTER. IA25.
IA25.: HRRZI TB,%ACC.S ;ACCESS MODE SEQUENTIAL CODE
JRST IA27.X ;INSERT IN FILTAB ENTRY
;SET INDEXED-SEQUENTIAL ORGANIZATION/ACCESS MODE
INTER. IA26.
IA26.: FLAGAT H
HRRZI TB,%ACC.I ;ACCESS MODE IS ISAM CODE
JRST IA27.X ;INSERT IN FILTAB ENTRY
;SET RMS BIT
INTER. IA26R.
IA26R.: FLAGAT NS
HRRZ TA,CURFIL ;ABS. ADDR OF FILTAB ENTRY
SETOB TB,RMSFLS## ;SET FLAG "RMS FILES USED"
DPB TB,FI.RMS ;SET RMS BIT
POPJ PP, ;DONE, RETURN
;SET RANDOM ORGANIZATION/ACCESS FLAG
INTER. IA27.
IA27.: FLAGAT LI
HRRZI TB,%ACC.R ;ACCESS MODE RANDOM CODE
IA27.X: HRRZ TA,CURFIL ;ABS. ADDR. OF FILTAB ENTRY
LDB TC,FI.AKS ;WERE ALTERATE KEYS SPECIFIED?
JUMPN TC,IA27X1 ;JUMP IF YES
IA27X0: DPB TB,FI.ORG ;DEPOSIT IN FILTAB ENTRY
SKIPN FLGSW ;NEED FIPS FLAGGER?
POPJ PP, ;NO
LDB LN,FI.LN## ;GET LN & CP OF FD
LDB CP,FI.CP##
MOVE TA,[%LV.L ;SEQUENTIAL
%LV.LI ;RELATIVE
%LV.H](TB) ;INDEXED
PUSHJ PP,FLG.ES ;FLAG FD IF REQUIRED
ADDI TB,1 ;CONVERT 0 TO 1 ETC.
SKIPN RSLNCP ;HAVE WE SEEN [RESERVE N AREAS] YET?
JRST [MOVEM TB,RSLNCP ;NO, SAVE ORGANIZATION +1
JRST IX27X1] ;IN CASE WE SEE IT LATER
HLRZ LN,RSLNCP ;YES, SET LN
HRRZ CP,RSLNCP ; & CP
MOVE TA,[%LV.HI ;SEQUENTIAL
%LV.HI ;RELATIVE
%LV.H]-1(TB) ;INDEXED
PUSHJ PP,FLG.ES## ;TEST FIPS LEVEL
IX27X1: SKIPN ASLNCP ;HAVE WE SEEN ASSIGN CLAUSE YET?
JRST [MOVEM TB,ASLNCP ;NO, SAVE ORGANIZATION +1
POPJ PP,] ;IN CASE WE SEE IT LATER
HLRZ LN,ASLNCP ;YES, SET LN
HRRZ CP,ASLNCP ; & CP
MOVE TA,[%LV.L ;SEQUENTIAL
%LV.LI ;RELATIVE
%LV.H]-1(TB) ;INDEXED
PJRST FLG.ES## ;TEST FIPS LEVEL
IA27X1: CAIN TB,%ACC.I ;SETTING ORGANIZATION TO INDEXED IS OK
JRST IA27X0
EWARNW E.624 ;"ONLY INDEXED FILES MAY HAVE ALTERNATE KEYS"
HRRZ TA,CURFIL ;POINT AT CURRENT FILE AGAIN
MOVEI TB,%ACC.I ;PRETEND HE SAID "INDEXED"
JRST IA27X0 ;GO SET IT
;CHECK FOR MORE THAN 1 ACCESS MODE SETTING PER FILE
INTER. IA25X.
IA25X.: HRRZ TA,CURFIL ;AIM AT CURRENT FILTAB ENTRY
LDB TB,FI.FAM ;GET CURRENT SETTING OF ACCESS MODE BITS
JUMPN TB,JBE16. ;'DUPLICATE CLAUSE'
POPJ PP, ;AT INITIAL SETTING
;SET SEQUENTIAL ACCESS MODE
INTER. IA25S.
IA25S.: MOVEI TB,%FAM.S
SKIPN FLGSW## ;NEED FIPS FLAGGER?
JRST IA25.X ;NO
PUSHJ PP,IA25.X ;SETS UP TA = CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[CPOPJ ;SEQUENTIAL
TST.LI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
IA25.X: HRRZ TA,CURFIL
DPB TB,FI.FAM## ;STORE IN FILTAB
POPJ PP,
;SET RANDOM ACCESSS MODE
INTER. IA25R.
IA25R.: MOVEI TB,%FAM.R
SKIPN FLGSW## ;NEED FIPS FLAGGER?
JRST IA25.X ;NO
PUSHJ PP,IA25.X ;SETS UP TA = CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[CPOPJ ;SEQUENTIAL
TST.LI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;SET DYNAMIC ACCESS MODE
INTER. IA25D.
IA25D.: MOVEI TB,%FAM.D
SKIPN FLGSW## ;NEED FIPS FLAGGER?
JRST IA25.X ;NO
PUSHJ PP,IA25.X ;SETS UP TA = CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[CPOPJ ;SEQUENTIAL
TST.HI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;PUT KEY DATA-NAME IN HLDTAB
INTER. IA28C.
IA28C.: PUSHJ PP,IA24.
SKPNAM
INTER. IA28.
IA28.: PUSHJ PP,IA59S. ;SAVE NAMTAB ADDR
PUSHJ PP,IA28S. ;SET UP HLDTAB ENTRY
HRRZ TB,CTR ;GET KEY CODE
DPB TB,HL.COD ;& PUT IT IN HLDTAB
HLRZ TB,CURFIL ;STORE FILTAB LINK IN HLDTAB
DPB TB,HL.LNK
POPJ PP,
;SET UP HLDTAB ENTRY
IA28S.: MOVE TA,[XWD CD.HLD,SZ.HLD] ;GET A HLDTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURHLD ;SAVE ADDR
HLRZ TB,CURNAM ;PUT LINK TO NAMTAB IN HLDTAB
DPB TB,HL.NAM
DPB W2,HL.LNC ;ALSO POSITION OF ITEM IN SOURCE
SETZ TB, ;CLR # OF QUALIFIERS
DPB TB,HL.QAL
POPJ PP,
;STORE ALTERNATE RECORD KEY DATA-NAME
INTER. IA28A.
IA28A.: PUSHJ PP,IA59S. ;SAVE NAMTAB ADDR
PUSHJ PP,IA28SK ;SETUP ALTERNATE KEY ENTRY
PUSHJ PP,IA28S. ;SET UP HLDTAB ENTRY
HRRZI TB,%HL.KA ;GET KEY CODE
DPB TB,HL.COD ;& PUT IN HLDTAB
HLRZ TB,CURAKT ;GET CURRENT ALTERNATE KEY
DPB TB,HL.LNK ;STORE AKTTAB LINK IN HLDTAB
POPJ PP, ;RETURN
;SET UP AKTTAB ENTRY
IA28SK: MOVE TA,[XWD CD.AKT,SZ.AKT] ;GET AN AKTTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURAKT ;SAVE ADDR
HLRZ TB,CURFIL ;PUT FILTAB ADDR IN AKTTAB
DPB TB,AK.FLK
POPJ PP, ;RETURN
;SET "DUPLICATES" BIT
INTER. IA28D.
IA28D.: HRRZ TA,CURAKT ;GET CURRENT ACTUAL KEY TABLE ADDR
SETO TB, ;TURN ON "DUPLICATES" BIT
DPB TB,AK.DUP
POPJ PP, ;RETURN
;GET VALUE OF INTEGER & PUT INTO SEGMENT LIMIT WORD
INTER. IA35.
IA35.: PUSHJ PP,IA16S. ;GET VALUE OF INTEGER
POPJ PP, ;ITEM NOT AN INTEGER
JUMPL TC,JBE19. ;<0 IS ILLEGAL
CAILE TC,^D49 ;>=50 IS ILLEGAL
JBE19.: EWARNJ E.19 ;'IMPROPER SEGMENT LIMIT' -- EXIT
JUMPG TC,IA35.B ;0 IS A SPECIAL CASE
SKIPGE AS7482 ;ILLEGAL IN STRICT COBOL-74
JRST JBE19. ;SO GIVE ERROR STILL
FLAGAT 8 ;OTHERWISE FLAG AT 8x LEVEL
MOVEI TC,1 ;AND TURN INTO 1 FOR NOW
IA35.B: MOVE TA,SEGLIM ;GET PREVIOUS LIMIT
CAIN TA,^D50 ;50 IS INITIAL VALUE
JRST IA35.A ;HAS NOT YET BEEN RESET
CAMN TC,TA ;RESETTING TO SAME VALUE?
POPJ PP, ;YES, IGNORE IT
EWARNJ E.16 ;NO, 'CLAUSE DUPLICATED'
IA35.A: MOVEM TC,SEGLIM ;STORE NEW SEGMENT LIMIT
POPJ PP,
;SAME RECORD AREA (ONLY) FOR FILES IN LIST
INTER. IA36.
IA36.: SWON FSAME ;SET FLAG
MOVEM W2,SRALNC## ;SAVE LN & CP OF "SAME RECORD"
POPJ PP,
;SAME AREA (REC. AREA & BUFRS) FOR FILES IN LIST
INTER. IA37.
IA37.: SWOFF FSAME ;CLR SAME-REC-AREA FLAG
POPJ PP,
;SAVE PTR TO FIRST FILE IN SAME-AREA CLAUSE
INTER. IA38.
IA38.: SKIPE SAMSRT ;IF 'SAME SORT' CLAUSE, DON'T DO ANYTHING
POPJ PP,
PUSHJ PP,IA38S. ;GET PTR TO FILTAB ENTRY FOR THIS FILE
SKIPE FLGSW ;NEED FIPS FLAGGER
PUSHJ PP,IA38.F ;YES
HLRZ TC,TB ;GET FILTAB ENTRY REL. ADDR.
PUSH SAVPTR,TC ;PUT ON SAVLST
PUSH SAVPTR,TC ;TWICE
HRRZ TA,TB ;GET FILTAB ENTRY ABS. ADDR.
LDB TB,FI.SAL ;EXAMINE SAME-AREA LINK
TSWF FSAME ;IS THIS A SAME-AREA OR A SAME-REC-AREA CLAUSE?
LDB TB,FI.SRA ;THE LATTER -- EXAMINE SAME-REC-AREA LINK
JUMPE TB,CPOPJ## ;IF NOT ON, RETURN
TSWF FSAME ;'SAME REC. AREA'?
EWARNW E.173 ;YES, 'FILE ALREADY IN SAME RECORD AREA CLAUSE'
TSWT FSAME ;'SAME AREA'?
EWARNW E.174 ;YES, 'FILE ALREADY IN SAME AREA CLAUSE'
HRRZI NODE,ED135.## ;NEXT SYNTAX NODE WILL BE ED135.
MOVEM NODE,0(NODPTR)
JRST IA62. ;RESET SAVE LIST POINTER
;GET PTR TO FILTAB ENTRY
IA38S.: HLRZ TA,W2 ;GET NAMTAB REL. ADDR
LSH TA,-2
HRRZI TB,CD.FIL ;FIND FILTAB ENTRY FOR THIS NAME
PUSHJ PP,FNDLNK
JRST IA38.E ;NONE FOUND
POPJ PP,
IA38.E: OUTSTR [ASCIZ /IA38S.: TYPE=file-name but no FILTAB link found.
/]
JRST KILL
IA38.F: HRRZ TA,TB ;GET CURFIL
TSWF FSAME ;IF SAME RECORD
SKIPA TC,SRALNC ;GET LN & CP OF "SAME RECORD"
MOVE TC,SAMLNC ;GET LN & CP OF "SAME"
DPB TC,FI.ALC## ;STORE THEM INCASE ITS A SORT FILE
SETO TC,
TSWF FSAME ;IF [RECORD]
DPB TC,FI.RLC## ;SET FLAG
LDB TA,FI.ORG ;GET ORGANIZATION
CAIN TA,%%ACC ;IGNORE THE DEFAULT
SETZ TA,
CAMLE TA,CURORG## ;BIGGER THAN ONE WE LAST SAW?
MOVEM TA,CURORG ;NO, STORE NEW ONE
POPJ PP,
;LINK THIS FILE TO PREVIOUS FILE IN SAME AREA CLAUSE
;AND SAVE PTR TO THIS FILE IN CASE THERE ARE MORE
INTER. IA38A.
IA38A.: SKIPE SAMSRT ;IF 'SAME SORT' CLAUSE, DONT DO ANYTHING
POPJ PP,
PUSHJ PP,IA38S. ;GET PTR TO FILTAB ENTRY FOR THIS FILE
SKIPE FLGSW ;NEED FIPS FLAGGER
PUSHJ PP,IA38.F ;YES
MOVE TD,(SAVPTR) ;GET PTR TO PREVIOUS FILE
HRRZ TA,FILLOC
ADD TA,TD ;ABS. ADDR. OF THAT FILTAB ENTRY
HLRS TB ;GET LINK TO THIS FILE
TSWT FSAME ;SAME-AREA OR SAME-REC-AREA?
JRST IA38AA ;SAME-AREA
LDB TE,FI.SRA ;GET SAME-REC-AREA LINK
JUMPN TE,JBE173 ;IF NOT 0, 'FILE ALREADY IN SAME-REC-AREA CLAUSE'
DPB TB,FI.SRA ;STORE LINK TO THIS FILE IN THAT FILE'S ENTRY
JRST IA38AB
IA38AA: LDB TE,FI.SAL ;GET SAME-AREA LINK
JUMPN TE,JBE174 ;IF NOT 0, 'FILE ALREADY IN SAME-AREA CLAUSE'
DPB TB,FI.SAL ;STORE LINK TO THIS FILE IN THAT FILE'S ENTRY
IA38AB: MOVEM TB,(SAVPTR) ;SAVE POINTER TO THIS FILE
POPJ PP,
JBE173: EWARNJ E.173
JBE174: EWARNJ E.174
;LINK LAST FILE IN SAME-AREA CLAUSE TO THE FIRST
INTER. IA39.
IA39.: SKIPE SAMSRT ;IF 'SAME SORT' CLAUSE, DONT DO ANYTHING
POPJ PP,
HRRZ TA,0(SAVPTR) ;REL. ADDR. OF LAST FILE IN GROUP
PUSHJ PP,LNKSET ;GET ABS. ADDR.
HRRZ TB,-1(SAVPTR) ;REL. ADDR. OF FIRST FILE IN GROUP
TSWF FSAME ;SAME-REC AREA?
DPB TB,FI.SRA ;YES, STORE LINK
TSWT FSAME ;SAME-AREA?
DPB TB,FI.SAL ;YES, STORE LINK
SKIPN FLGSW ;NEED FIPS FLAGGER?
JRST IA62. ;NO, RESET SAVE LIST POINTER
LDB LN,[POINT 13,SAMLNC,28] ;GET LN & CP
LDB CP,[POINT 7,SAMLNC,35] ;OF SAME
MOVE TA,CURORG ;GET ORGANIZATION OF "HIGHEST" FILE
MOVE TA,[%LV.L ;SEQUENTIAL
%LV.LI ;RELATIVE
%LV.H](TA) ;INDEX
PUSHJ PP,FLG.ES ;FLAG IF REQUIRED
TSWT FSAME ;WAS [RECORD] SEEN?
JRST IA62. ;NO
LDB LN,[POINT 13,SRALNC,28] ;GET LN & CP
LDB CP,[POINT 7,SRALNC,35] ;OF RECORD
MOVE TA,CURORG ;GET ORGANIZATION OF "HIGHEST" FILE
MOVE TA,[%LV.HI ;SEQUENTIAL
%LV.HI ;RELATIVE
%LV.H](TA) ;INDEX
PUSHJ PP,FLG.ES ;FLAG IF REQUIRED
JRST IA62. ;RESET SAVE LIST POINTER
;SAVE PTR TO FILE FOR SAME-DEVICE LINKAGE
INTER. IA40.
IA40.: PUSHJ PP,IA38S. ;GET PTR TO FILTAB ENTRY FOR THIS FILE
HRRZI TA,1 ;SAVE POSITION 1 (DEFAULT POS.)
PUSH SAVPTR,TA
PUSH SAVPTR,TB ;SAVE FILTAB ENTRY ADDR
MOVE TA,TB ;GET NO. OF DEVICES FOR THIS FILE
LDB TB,FI.NDV
CAIE TB,1 ;MUST BE 1
EWARNJ E.197 ;'ONLY ONE DEVICE ALLOWED'
LDB TC,FI.SDL ;GET SAME-DEVICE LINK
JUMPN TC,CPOPJ ;IF ON, LEAVE IT ALONE
HLRZ TB,TA ;GET REL ADDR OF FILTAB ENTRY
DPB TB,FI.SDL ;MAKE FILE POINT TO ITSELF IF NOWHERE ELSE
POPJ PP,
;GET POSITION OF FILE ON TAPE & STORE IN FILTAB ENTRY
INTER. IA41.
IA41.: PUSHJ PP,IA16S. ;GET VALUE OF INTEGER
POPJ PP, ;NOT AN INTEGER
IA41.A: MOVEM TC,TBLOCK ;SAVE POSITION
HLRZ TA,(SAVPTR) ;GET FILTAB ENTRY REL. ADDR.
PUSHJ PP,LNKSET ;GET ABS. ADDR
MOVE TC,TBLOCK ;GET POSITION ON TAPE
LDB TB,FI.POS ;EXAMINE TAPE POSITION FIELD
JUMPE TB,IA41.P ;ON?
CAIE TB,(TC) ;YES, SAME AS NEW ONE?
EWARNJ E.16 ;NO, 'DUPLICATE CLAUSE'
MOVEM TC,-1(SAVPTR) ;YES, PUT ON SAVE LIST AS POSITION
POPJ PP,
IA41.P: DPB TC,FI.POS ;PUT INTEGER IN POSITION FIELD
MOVEM TC,-1(SAVPTR) ;AND ON SAVE LIST
POPJ PP,
;NO POSITION CLAUSE
;GET POSITION FROM SAVLST & STORE IN FILTAB ENTRY
INTER. IA42.
IA42.: MOVE TC,-1(SAVPTR) ;GET SAVED INTEGER
JRST IA41.A
;CHAIN SAME-DEVICE LINKS
;AND CHECK NEW FILE FOR SAME DEVICE AS PREVIOUS
INTER. IA43.
IA43.: PUSHJ PP,IA38S. ;GET PTR TO FILTAB ENTRY FOR THIS FILE
MOVE TA,TB ;FILTAB ENTRY ADDR.
LDB TB,FI.NDV ;NO. OF DEVICES FOR THIS FILE
CAIE TB,1 ;MUST BE 1
EWARNJ E.197 ;'ONLY ONE DEVICE ALLOWED'
MOVEM TA,TBLOCK ;SAVE POINTER TO CURRENT FILTAB ENTRY
LDB TA,FI.VAL ;VALTAB LINK
PUSHJ PP,LNKSET ;GET ABS. ADDR.
MOVEM TA,SAVETA ;AND SAVE ADDR OF DEVICE NAME
HRRZ TA,(SAVPTR) ;GET SAVED FILE FILTAB ADDR
LDB TA,FI.VAL ;VALTAB LINK
PUSHJ PP,LNKSET ;GET ABS. ADDR. OF DEVICE NAME OF PREV. FILE
HLRZ TC,(TA)
LSH TC,-13 ;LENGTH OF ENTRY IN CHARACTERS
IDIVI TC,5
ADDI TC,1 ;AND IN WORDS, ROUNDED UP
MOVE TB,SAVETA ;CURRENT FILE VALTAB ADDRESS
IA43.L: MOVE TD,(TA) ;COMPARE WORD OF DEVICE NAMES
CAME TD,(TB)
JRST IA43.E ;DIFFERENT DEVICES
ADDI TA,1 ;GO TO NEXT WORD
ADDI TB,1
SOJG TC,IA43.L ;ALL WORDS DONE?
AOS -1(SAVPTR) ;YES, DEFAULT TAPE POS. IS NEXT ON TAPE
HRRZ TA,(SAVPTR) ;FILTAB ADDR OF LAST FILE IN LIST
LDB TC,FI.SDL ;GET REL ADDR OF 1ST FILE IN LIST
HRRZ TA,TBLOCK ;STORE LINK TO 1ST FILE IN NEW FILE ENTRY
DPB TC,FI.SDL
HLRZ TC,TBLOCK ;REL. FILTAB ADDR OF NEW FILE
HRRZ TA,(SAVPTR) ;STORE LINK TO NEW FILE IN OLD FILE ENTRY
DPB TC,FI.SDL
MOVE TA,TBLOCK ;SAVE ADDR OF NEW FILE
MOVEM TA,(SAVPTR)
POPJ PP,
IA43.E: HRRZI TA,ED158.## ;AFTER ERROR MSG, GO TO SYNTAX NODE ED158.
MOVEM TA,(NODPTR)
EWARNJ E.23 ;'NOT SAME DEV. AS PREV. FILE'
;GET MNEMONIC-NAME FOR CONSOLE
INTER. IA44.
IA44.: HRLZI TA,MTCONS ;GET CONSOLE TYPE FLAG
;ENTER HERE TO STORE NAME IN MNETAB
;TA SHOULD CONTAIN APPROPRIATE TYPE FLAG
IA44.D: MOVEM TA,MNETYP ;STORE TYPE FLAG
JUMPGE W1,IA44.A ;IS THIS NAME IN NAMTAB?
TLNE W1,30000 ;IS IT A LITERAL OR RESERVED WORD?
EWARNJ E.24 ;YES, 'ILLEGAL MNEMONIC-NAME'
TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
PUSHJ PP,PUTCRF
PUSHJ PP,BLDNAM ;PUT IN NAMTAB
IA44.C: MOVEM TA,CURNAM ;SAVE NAMTAB PTR
IA44.B: MOVE TA,[XWD CD.MNE,SZ.MNE] ;GET MNETAB ENTRY
PUSHJ PP,GETENT
HLRZM TA,CURMNE## ;SAVE POINTER TO IT
HLRZ TC,CURNAM ;GET NAMTAB POINTER
ORI TC,700000 ;SET MNETAB FLAG
MOVSM TC,(TA) ;PUT NAMTAB LINK IN MNETAB
MOVE TC,MNETYP ;GET TYPE FLAG
TLNE TC,MTSW!MTSON!MTSOFF!MTCHAN!MTCODE ;SKIP IF NOT SWITCH, CHANNEL, CODE, OR STATUS
HRR TC,(SAVPTR) ;GET SWITCH OR CHANNEL NUMBER
MOVEM TC,1(TA) ;TO WORD 2 OF ENTRY
HLR TA,CURNAM ;NAMTAB REL. ADDR.
PJRST PUTLNK ;LINK NAMTAB TO MNETAB
IA44.A: TLNE TA,MTALPA ;ALPHABET-NAME?
JRST IA44.E ;YES
HLRZ TA,W2 ;GET NAMTAB PTR
LSH TA,-2
HRRZI TB,CD.MNE ;MNETAB FLAG
HRLZM TA,CURNAM ;SAVE NAMTAB REL. ADDR.
PUSHJ PP,FNDLNK ;FIND MNETAB LINK
JRST IA44.B ;NOT FOUND
EWARNJ E.28 ;'MNEMONIC-NAME ALREADY IN USE'
IA44.E: TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
PUSHJ PP,PUTCRF
PUSHJ PP,TRYNAM ;GET NAME
PUSHJ PP,BLDNAM ;BUT WE REALLY KNOW IT IS
JRST IA44.C ;SAVE POINTER AND CONTINUE
;GET MNEMONIC-NAME FOR LPT CHANNEL
INTER. IA46.
IA46.: HRLZI TA,MTCHAN ;GET CHANNEL TYPE FLAG
JRST IA44.D
;GET MNEMONIC-NAME FOR HARDWARE SWITCH
INTER. IA47.
IA47.: HRLZI TA,MTSW ;GET SWITCH TYPE FLAG
JRST IA44.D
;SET SWITCH-ON STATUS FLAG
INTER. IA48.
IA48.: SWON FSTAT ;ON
POPJ PP,
;SET SWITCH-OFF STATUS FLAG
INTER. IA49.
IA49.: SWOFF FSTAT ;OFF
POPJ PP,
;GET MNEMONIC-NAME FOR SWITCH STATUS
INTER. IA50.
IA50.: TSWT FSTAT;
HRLZI TA,MTSOFF ;'OFF STATUS'
TSWF FSTAT;
HRLZI TA,MTSON ;'ON STATUS'
JRST IA44.D
;GET CHARACTER FOR CURRENCY SIGN
INTER. IA51.
IA51.: TLNE W1,200000 ;IS ITEM A LITERAL?
TLNE W1,174000 ;SIMPLE ALPHANUMERIC?
EWARNJ E.27 ;NO, 'MUST BE A 1 CHAR NON-NUMERIC LITERAL'
TLNE W1,000776 ;IS ITS LENGTH 1?
EWARNJ E.27 ;NO
LDB TA,[POINT 7,LITVAL,6] ;YES, GET THAT CHARACTER
SKIPN DOLLR. ;CURR. SIGN ALREADY GIVEN?
JRST IA51.P ;NO
CAMN TA,DOLLR. ;YES, IS NEW ONE THE SAME?
POPJ PP, ;YES
EWARNJ E.16 ;NO, 'DUPLICATE CLAUSE'
IA51.P: MOVEI TB,-40(TA) ;CONVERT TO SIXBIT
CAIL TB,1 ;IN SIXBIT RANGE & NOT SPACE?
CAIL TB,100
EWARNJ E.175 ;NO, INVALID CHARACTER
MOVE TD,[POINT 6,CSL] ;AIM AT LIST OF ILLEGAL CHARS
IA51.R: ILDB TC,TD ;GET A CHAR FROM LIST
JUMPE TC,IA51.Q ;END OF LIST -- ALL IS WELL
CAIN TB,(TC) ;IS THIS A MATCH?
EWARNJ E.175 ;YES, INVALID CHARACTER
JRST IA51.R ;NO, TRY NEXT
IA51.Q: MOVEM TA,DOLLR. ;STASH NEW CURRENCY SIGN
POPJ PP,
;ITEMS ILLEGAL AS CURRENCY SIGN
;(SPACE MARKS END OF LIST)
CSL: SIXBIT '0123456789*+-,.;()"=/ABCDLPRSVXZ '
;SWITCH FUNCTIONS OF COMMA AND DECIMAL POINT
INTER. IA52.
IA52.: MOVE TA,COMA.
CAIN TA,"."
EWARNW E.16 ;DUPLICATE CLAUSE
MOVEI TA,"." ;COMMA = .
MOVEM TA,COMA.##
MOVEI TA,"," ;DEC.PT. = ,
MOVEM TA,DCPNT.##
POPJ PP,
;MISSING INTEGER -- WARN AND ASSUME 0
INTER. IA54E.
IA54E.: EWARNW E.25 ;'POSITIVE INTEGER REQUIRED'
SKPNAM
;PUT A ZERO VALUE ON THE SAVLST
INTER. IA54.
IA54.: SETZ TC, ;PUT 0 ON SAVE LIST
JRST IA16.A
;SET RERUN FLAG & COUNT FOR FILE
INTER. IA55.
IA55.: PUSHJ PP,IA38S. ;GET PTR TO FILTAB ENTRY FOR THIS FILE
SKIPN FLGSW ;NEED FIPS FLAGGER?
JRST IA55.F ;NO
HLRZ LN,CURLNC ;RESTORE LN
HRRZ CP,CURLNC ; & CP
HRRZ TA,TB ;GET CURFIL
LDB TA,FI.ORG## ;GET FILE ORGANIZATION
MOVE TA,[%LV.L ;SEQUENTIAL
%LV.LI ;RELATIVE
%LV.H](TA) ;INDEXED
PUSHJ PP,FLG.ES ;FLAG FD IF REQUIRED
IA55.F: HRRZ TA,TB ;FILTAB ENTRY ABS. ADDR.
POP SAVPTR,TC ;GET SAVED INTEGER
JUMPE TC,IA55.A ;RERUN END-OF-REEL
CAIG TC,177777 ;[553] TOO BIG TO FIT?
JRST IA55.0 ;[553] NO, STASH IT
MOVE LN,SAVPLN## ;[553] YES - RESTORE THE LINE NO. &
MOVE CP,SAVPCP## ;[553] CHARACTER POS. OF INTEGER
MOVEI DW,E.609 ;[553] GET CORRECT ERROR NUMBER
PUSHJ PP,WARN ;[553] GIVE USER WARNING
MOVEI TC,177777 ;[553] ASSUME THE MAXIMUM
IA55.0: DPB TC,FI.RCT ;[553] RERUN COUNT
HRRZI TC,1
DPB TC,FI.RRC ;SET RERUN ON COUNT FLAG
POPJ PP,
IA55.A: HRRZI TC,1
DPB TC,FI.RER ;SET RERUN END-OF-REEL FLAG
POPJ PP,
;SET SPECIAL-NAMES PARAGRAPH FLAG
INTER. IA56.
IA56.: SETZM SPNMCP## ;CLEAR PERIOD FLAG
TSWFS FSPNAM ;ALREADY SEEN A SPECIAL-NAMES PARA?
EWARNJ E.30 ;YES, 'DUPLICATE PARAGRAPH'
POPJ PP, ;NO, BUT NOW WE HAVE
;WIPE LAST ENTRY OFF SAVLST
INTER. IA57.
IA57.: POP SAVPTR,TA ;LOSE SAVE LIST ENTRY
POPJ PP,
;SET FLAG TO SHOW WE HAVE SEE THE LAST CLAUSE IN SPECIAL NAMES.
;THIS IS SO WE CAN GIVE AN ERROR IF USER TYPES ANOTHER CLAUSE.
INTER. IA58.
IA58.: HRLZM LN,SPNMCP ;SAVE LN
HRRM CP,SPNMCP ; AND CP
POPJ PP, ;AS A FLAG
;IF SPNMCP IS NON-ZERO PRINT A WARNING POINTING TO THE PREVIOUS PERIOD.
INTER. IA58A.
IA58A.: SKIPN SPNMCP ;DID WE JUST SEE A PERIOD?
POPJ PP, ;NO
HLR LN,SPNMCP ;YES, POINT TO IT
HRR CP,SPNMCP
MOVEI DW,E.621
SETZM SPNMCP ;CLEAR FLAG
JRST WARN ;AND WARN USER
;PUT DATA-NAME QUALIFIER IN NEXT WORD OF HLDTAB
INTER. IA59.
IA59.: PUSHJ PP,IA59S. ;SAVE NAMTAB ADDR
MOVE TA,CURHLD ;GET # OF QUALIFIERS BEFORE THIS
LDB TB,HL.QAL
AOJ TB, ;INCREMENT COUNT
DPB TB,HL.QAL ;& PUT BACK
ROT TB,-1 ;DIV BY 2
HLRZ TC,CURNAM ;GET NAMTAB LINK
JUMPL TB,IA59.A ;IF BIT0 ON, USE ODD HALF-WORD
ADDI TA,1(TB) ;PTR TO EVEN HALF-WORD
HRRM TC,(TA) ;STORE IN EVEN HALF
POPJ PP,
IA59.A: PUSH PP,CURHLD ;SAVE PTR TO HLDTAB ENTRY
MOVE TA,[XWD CD.HLD,1] ;GET ONE MORE WORD FOR THE ENTRY
PUSHJ PP,GETENT
HLRZ TC,CURNAM ;GET NAMTAB LINK
HRLZM TC,(TA) ;STORE NAMTAB LINK IN ODD HALF
POP PP,CURHLD ;RESTORE HLDTAB PTR
POPJ PP,
;STORE NAMTAB RELATIVE ADDRESS FOR NEW NAME
IA59S.: TLNN W1,GWNOT ;NAME IN NAMTAB?
JRST IA59SA ;YES
PUSHJ PP,BLDNAM ;NO, BUILD NAMTAB ENTRY
MOVEM TA,CURNAM ;SAVE ADDR
HLRZS TA ;LEAVE LINK IN RIGHT HALF
DPB TA,[POINT 15,W2,15] ;& IN W2
POPJ PP,
IA59SA: LDB TA,[POINT 15,W2,15] ;GET NAMTAB REL ADDR
HRLZM TA,CURNAM ;& SAVE
POPJ PP,
;ILLEGAL DATA-NAME IN FILE-LIMIT CLAUSE
INTER. IA61.
IA61.: HLRZ TA,CFLM ;GET CURRENT FILE LIMIT POINTER
PUSHJ PP,LNKSET ;GET ABS. ADDR.
HLRS (TA) ;MAKE HIGH-LIMIT=LOW-LIMIT
EWARNJ E.17 ;'ILLEGAL DATA NAME'
;RERUN - SAVE POINTER TO IT
INTER. IA62F.
IA62F.: HRLZM LN,CURLNC## ;SAVE LN & CP
HRRM CP,CURLNC ;IN CASE WE SEE A FILE NAME
JRST IA62.
;MULTIPLE FILE TAPE
INTER. IA62M.
IA62M.: FLAGAT HI
SKPNAM
;REFRESH SAVLST
;(SAVLST IS USED FOR TEMPORARY STORAGE)
INTER. IA62.
IA62.: MOVE SAVPTR,ISVPTR ;RESET SAVE LIST
POPJ PP,
INTER. IA62X.
IA62X.: MOVE SAVPTR,ISVPTR
JRST IA58A. ;CHECK SPECIAL NAMES CLAUSES
;INIT MISSING ENVIRONMENT DIVISION, THEN GO TO COBOLC
INTER. IA63E.
IA63E.: PUSHJ PP,IA67. ;DO ENV. DIV. INITS
SKPNAM
;CLEAN-UP AT END OF PHASE B, AND THEN CALL IN COBOLC
INTER. IA63.
IA63.: SWON FREGWD ;REGET 'DATA' OR WHATEVER
;INIT MISSING ENVIRONMENT ITEMS
SKIPN OBJSIZ ;MEMORY SIZE = 0?
SETOM OBJSIZ ;IF SO, SET TO -1
MOVEI TA,"$" ;DEFAULT DOLLAR SIGN IS "$"
SKIPN DOLLR. ;HAS HE SET ONE?
MOVEM TA,DOLLR. ;NO
SKIPN PROGID ;DID HE SET PROGRAM-ID?
PUSHJ PP,IA2.2 ;NO, NAME IT "COBOL."
SKIPN DEFDSP ;DEFAULT DISPLAY MODE GIVEN?
AOS DEFDSP ;NO, SO MAKE IS DISPLAY-6
PUSHJ PP,IA210. ;CLEANUP ALPHABET-NAMES
ENDFAZ B; ;CLOSE OUT PHASE B & GO TO COBOLC
;INITIALIZE ENVIRONMENT DIVISION
INTER. IA67.
IA67.:
IFN DEBUG,<
MOVE TE,CORESW
SWOFF FNDTRC ;CLR OLD TRACE REQUEST
TRNE TE,TRACEE ;TRACE ED NODES?
SWON FNDTRC ;YES, TURN ON TRACER
>
MOVE TA,[XWD CD.DAT,SZ.DAT] ;MAKE A DUMMY DATAB ENTRY
PUSHJ PP,GETENT ;FOR DATA-DIV. BREAK
HRRZI TB,CD.DAT
DPB TB,[POINT 3,(TA),2] ;ENTER DATTAB CODE
POPJ PP,
;RECORDING MODE CLAUSE
;ASCII
INTER. IA69.
IA69.: HRRZI TB,%RM.7B ;ASCII RECORDING MODE BITS
IA69.X: HRRZ TA,CURFIL ;AIM AT FILE ENTRY
LDB TC,FI.RM2 ;ENTERED ALREADY?
JUMPN TC,JBE16. ;YES, ERROR
DPB TB,FI.ERM ;NO, ENTER IT
SETO TB, ;SAY IT IS ENTERED
DPB TB,FI.RM2
POPJ PP,
;STANDARD ASCII
INTER. IA69A.
IA69A.: HRRZI TB,%RM.SA
JRST IA69.X
;BYTE MODE
INTER. IA69B.
IA69B.: HRRZ TA,CURFIL ;AIM AT FILE ENTRY
SETO TB,
DPB TB,FI.BM## ;SET BYTE MODE FLAG
POPJ PP,
;SIXBIT
INTER. IA70.
IA70.: HRRZI TB,%RM.6B ;SIXBIT RECORDING MODE BITS
JRST IA69.X
;BINARY
INTER. IA71.
IA71.: HRRZI TB,%RM.BN ;BINARY
JRST IA69.X
;SEE IF IT IS F OR V.
INTER. IA72.
IA72.: HLRZ TC, NAMWRD ;SEE WHAT WE GOT.
CAIE TC, (SIXBIT /F/) ;WAS IT F OR
CAIN TC, (SIXBIT /V/) ; V?
JRST IA72FV ;YES.
HRRZI TB, ED271.## ;FAKE SQUIRL OUT BY MAKING IT
MOVEM TB, (NODPTR) ; LOOK LIKE WE WERE ALWAYS AT
JRST IA0.R ; ED271. AND REGETTING THE ITEM.
IA72FV: SWOFF FREGWD ;DON'T REGET THE ITEM.
HRRZ TA, CURFIL ;GET THE FILE TABLE ADR.
LDB TB, FI.RM2 ;DID WE ALREADY GET A RECORDING MODE?
JUMPN TB, JBE16. ;YES, ERROR.
SETO TB, ;GET SOME ONES.
CAIN TC, (SIXBIT /V/) ;WAS IT V?
DPB TB, FI.VLR## ;YES, TURN ON THE VLR FLAG.
HRRZI TB,%RM.EB ;SET EBCDIC MODE
JRST IA69.X
;RECORDING MODE CLAUSE
;DENSITY
INTER. IA73.
IA73.: PUSHJ PP,IA16S. ;GET THE INTEGER
POPJ PP, ;NOT AN INTEGER
HRRZ TA, CURFIL ;GET THE FILE TABLE'S ADR.
LDB TB, FI.RD ;GET THE RECORDING DENSITY.
JUMPN TB, JBE16. ;ALREADY SAW ONE - DUP CLAUSE.
CAIN TC, ^D200 ;200 BPI?
HRRZI TB, %RD.2
CAIN TC, ^D556 ;556 BPI?
HRRZI TB, %RD.5
CAIN TC, ^D800 ;800 BPI?
HRRZI TB, %RD.8
CAIN TC, ^D1600 ;1600 BPI?
HRRZI TB, %RD.16
CAIN TC, ^D6250 ;6250 BPI?
HRRZI TB, %RD.62
DPB TB, FI.RD ;PUT IT IN THE FILE TABLE.
JUMPN TB, CPOPJ ;RETURN IF IT WAS VALID.
EWARNJ E.327 ;OTHERWISE GIVE AN ERROR MSG.
;ODD PARITY
INTER. IA74.
IA74.: HRRZI TB,%RP.OD ;ODD PARITY BITS
IA74.X: HRRZ TA,CURFIL ;AIM AT FILE ENTRY
LDB TC,FI.RP ;DECLARED ALREADY?
JUMPN TC,JBE16. ;YES, ERROR
DPB TB,FI.RP ;NO, ENTER IT
POPJ PP,
;EVEN PARITY
INTER. IA75.
IA75.: HRRZI TB,%RP.EV ;EVEN PARITY BITS
JRST IA74.X
;SET SAME SORT AREA CLAUSE FLAG
INTER. IA76.
IA76.: FLAGAT H
SETOM SAMSRT
POPJ PP,
;INIT SAME <RECORD, SORT> AREA CLAUSE
INTER. IA77.
IA77.: SETZM SAMSRT ;CLEAR SAME SORT AREA FLAG
MOVEM W2,SAMLNC## ;SAVE LN & CP OF "SAME"
SETZM CURORG ;NO FILES SEEN YET
JRST IA62. ;CLR SAVLST
;STASH LITERAL FOR CODE UNTIL MNEMONIC SEEN
INTER. IA78.
IA78.: FLAGAT 68 ;OLD 68 REPORT WRITER STUFF
LDB TC,GWVAL ;GET LITERAL SIZE
CAIE TC,2 ;MUST BE 2 CHAR IN 74 AND LATER
EWARNW E.746
HLRZ TA,LITVAL ;GET LITERAL
LSH TA,-4 ;CUT DOWN TO 2 CHARS RIGHT JUSTIFIED
MOVEM TA,(SAVPTR) ;PUT HERE FOR IA44.
JRST IA58A. ;CHECK SPECIAL NAMES CLAUSES
;GET LITERAL FOR REPORT CODE
INTER. IA79.
IA79.: HRLZI TA,MTCODE ;"CODE" FLAG
JRST IA44.D ;MAKE A CODE MNETAB ENTRY
;DEFERRED OUTPUT ISAM
INTER. IA80.
IA80.: FLAGAT NS
HRRZ TA,CURFIL ;AIM AT FILTAB ENTRY
MOVEI TB,1 ;SET DEFERRED BIT
DPB TB,FI.DFR##
POPJ PP,
;RMS I/O
INTER. IA81.
IA81.: FLAGAT NS
HRRZ TA,CURFIL ;AIM AT FILTAB ENTRY
MOVEI TB,1 ;SET RMS BIT
DPB TB,FI.RMS##
SETOM RMSFLS## ;SET "RMS USED"
POPJ PP,
;CHECKPOINT OUTPUT FILE EVERY N RECORDS
INTER. IA82.
IA82.: FLAGAT NS
HRRZ TA,CURFIL ;AIM AT FILTAB ENTRY
MOVEI TB,1 ;SET CHECKPOINT BIT
DPB TB,FI.CKP##
POPJ PP,
INTER. IA83.
IA83.: PUSHJ PP,IA16S. ;GET VALUE OF INTEGER
SETZ TC, ;ERROR, USE 0
HRRZ TA,CURFIL ;AIM AT FILTAB ENTRY
CAILE TC,377 ;CHECK SIZE
EWARNJ E.634 ;TOO BIG
DPB TC,FI.CRC## ;SET CHECKPOINT RECORD COUNT
JUMPE TC,CPOPJ ;ZERO MEANS PHYSICAL BLOCK
SETZ TB, ;OTHERWISE
DPB TB,FI.CKP ;CLEAR PHYSICAL CHECKPOINT BIT
POPJ PP,
;SAW "FILE-STATUS"
INTER. IA100.
IA100.: PUSHJ PP,IA21F. ;TEST FIPS FLAGGER
HRRZ TA, CURFIL ;GET FILTAB ABS ADR.
LDB TB, FI.PFS## ;GET FIRST STATUS WORD LINK.
JUMPN TB, IA100A ;IF WE ALREADY HAVE ONE - DUP CLAUSE.
MOVE TB, FI.SPT## ;GET BYTE POINTER TO ENTRIES.
MOVEM TB, SAVLST## ;SAVE IT.
HRREI TB, -11 ;-MAXIMUM NUMBER OF NAMES ALLOWED.
MOVEM TB, SAVLST+1 ;SAVE IT.
POPJ PP, ;GO LOOK FOR NAMES.
;DUPLICATE CLAUSE - SKIP TO NEXT NON USER-NAME
IA100A: MOVEI TB, 1
MOVEM TB, SAVLST+1 ;FORCE SKIPPING.
JRST JBE16. ;GO GIVE ERROR MSG.
;SAW THE NAME OF A FILE STATUS ITEM.
INTER. IA101.
IA101.: AOSGE TA, SAVLST+1 ;DO WE HAVE AN ERROR CONDITION.
JRST IA101A ;NO.
JUMPN TA, CPOPJ## ;FIRST TIME?
EWARNJ E.227 ;YES, TOO MANY NAMES.
IA101A: PUSHJ PP, IA59S. ;GET THE NAMTAB ADDRESS.
PUSHJ PP, IA28S. ;SET UP THE HLDTAB ENTRY.
MOVE TA, CURHLD ;GET THE HLDTAB ADDRESS.
MOVEI TB, %HL.ER ;I AM A FILE-STATUS.
DPB TB, HL.COD ;PUT IT IN HLDTAB.
MOVS TB, CURFIL ;GET THE FILTAB ADDRESS.
DPB TB, HL.LNK ;FILTAB LINK TO HLDTAB.
EXCH TA, TB
MOVSS TA, TA
MOVSS TB, TB
IDPB TB, SAVLST ;HLDTAB LINK TO APPROPRIATE
; FILTAB LOCATION.
SKIPN FLGSW## ;NEED TO FLAG EXTENSIONS?
POPJ PP, ;GO LOOK FOR MORE NAMES OR FOR
; SOME QUALIFICATION.
HRRZ TB,SAVLST+1 ;SEE IF SECOND TIME THROUGH
CAIN TB,-7 ;SO WE GIVE ERROR ONLY ONCE
FLAGAT NS ;FLAG AS NON-STANDARD EXTENSION
POPJ PP, ;NO
;SAW SOME QUALIFICATION.
INTER. IA102.
IA102.: SKIPLE SAVLST+1 ;DO WE HAVE AN ERROR CONDITION?
POPJ PP, ;YES, IGNORE QUALS.
JRST IA59. ;GO SAVE THE QUALS.
;DISPLAY IS DISPLAY-6/9/9
INTER. IA106.
IA106.: MOVEI TC,%US.D6 ;DISPLAY-6
SKIPL DEFDSP## ;DON'T CHANGE IF SET BY SWITCH
HRRM TC,DEFDSP ;SET RHS
POPJ PP,
INTER. IA107.
IA107.: MOVEI TC,%US.D7 ;DISPLAY-7
SKIPL DEFDSP ;DON'T CHANGE IF SET BY SWITCH
HRRM TC,DEFDSP
POPJ PP,
INTER. IA109.
IA109.: MOVEI TC,%US.EB ;DISPLAY-9
HRROM TC,DEFDSP ;SET LHS -1 TO MAKE TESTS EASIER LATER
POPJ PP,
INTER. IA110.
IA110.: MOVSI TC,(SW.STB) ;SUPPRESS TRAILING BLANKS
IA110A: IORM TC,COBXSW## ;STORE FOR CODE GENERATION
POPJ PP,
INTER. IA112.
IA112.: SKIPN AS7482## ;ALREADY SET BY /V SWITCH?
PUSHJ PP,IA16S. ;NO, GET VALUE OF LITERAL
POPJ PP, ;ERROR, E.25 ALREADY GIVEN, OR RETURN
CAIN TC,^D74 ;ANS-74?
JRST [SETOM AS7482 ;YES
MOVSI TC,(SW.A74)
JRST IA110A]
CAIE TC,^D82 ;OR ANS-82
EWARNJ E.745 ;NO, MUST BE 74 OR 82
AOS AS7482 ;YES
MOVSI TC,(SW.A82)
JRST IA110A
INTER. IA200.
IA200.: HRLZM LN,COLNCP## ;STORE LINE NUMBER
HRRM CP,COLNCP ;AND CHAR POSITION INCASE OF ERROR
TLNN W1,GWLIT!GWRESV ;CANNOT ALLOW EITHER LIT OR RESERVED WORD
JUMPL W1,IA200A ;AND BETTER NOT BE IN NAMTAB YET
MOVEI DW,E.709
PUSHJ PP,FATAL##
SETZ W1, ;STORE NO COLLATING SEQUENCE
JRST IA201.
IA200A: PUSHJ PP,BLDNAM## ;CREATE NAMTAB ENTRY
HLRZ W1,TA ;SAVE NAMTAB ENTRY
SKPNAM
INTER. IA201.
IA201.: SKIPE COLSEQ## ;ALREADY DEFINED?
EWARNJ E.30 ;YES, DUPLICATED
MOVEM W1,COLSEQ ;STORE RESERVED WORD
POPJ PP, ;[1332]
INTER. IA201N
IA201N: SKIPGE DEFDSP ;IS DEFAULT EBCDIC?
JRST IA201E ;YES
SKPNAM
INTER. IA201S
IA201S: MOVEI W1,%AN.AS
JRST IA201.
INTER. IA201E
IA201E: MOVEI W1,%AN.EB
JRST IA201.
;PUT ALPHABET-NAME IN MNETAB
INTER. IA202.
IA202.: HRLZ TA,LN ;SAVE LINE NUMBER
HRR TA,CP ;AND CHARACTER POSITION
PUSH PP,TA ;FOR LATER
MOVSI TA,MTALPA ;ALPHABET-NAME
PUSHJ PP,IA44.D ;PUT IN MNETAB
MOVE TA,[CD.MNE,,1] ;NEED ONE MORE WORD
PUSHJ PP,GETENT
POP PP,(TA) ;SAVE LN,,CP
JRST IA58A. ;CHECK SPECIAL NAMES CLAUSES
INTER. IA202A
IA202A: JRST IA58A. ;CHECK SPECIAL NAMES CLAUSES
;SET ALPHABET-NAME TO BE NATIVE (EITHER ASCII OR EBCDIC)
INTER. IA203N
IA203N: SKIPGE DEFDSP ;IS DEFAULT EBCDIC?
JRST IA203E ;YES
SKPNAM
;SET ALPHABET-NAME TO BE STANDARD-1, STANDARD-2, OR ASCII
INTER. IA203S
IA203S: HRRZ TA,CURMNE ;GET TABLE ADDRESS
PUSHJ PP,LNKSET ;TURN INTO ABS. ADDRESS
HRRZ TB,1(TA) ;GET TYPE
JUMPN TB,JBE16. ;DUPLICATE
MOVEI TB,%AN.AS ;SET TYPE BIT
IORM TB,1(TA)
POPJ PP,
;SET ALPHABET-NAME TO BE EBCDIC
INTER. IA203E
IA203E: HRRZ TA,CURMNE ;GET TABLE ADDRESS
PUSHJ PP,LNKSET ;TURN INTO ABS. ADDRESS
HRRZ TB,1(TA) ;GET TYPE
JUMPN TB,JBE16. ;DUPLICATE
MOVEI TB,%AN.EB ;SET TYPE BIT
IORM TB,1(TA)
POPJ PP,
;SET ALPHABET-NAME TO BE LITERAL AND STORE FIGCON
INTER. IA203F
IA203F: FLAGAT HI
HRRZ TA,CURMNE ;GET TABLE ADDRESS
PUSHJ PP,LNKSET ;TURN INTO ABS. ADDRESS
HRRZ TB,1(TA) ;GET TYPE
JUMPN TB,JBE16. ;DUPLICATE
JRST IA204F ;COPY FIRST FIGCON
;SET ALPHABET-NAME TO BE LITERAL AND STORE FIRST INTEGER
INTER. IA203I
IA203I: FLAGAT HI
HRRZ TA,CURMNE ;GET TABLE ADDRESS
PUSHJ PP,LNKSET ;TURN INTO ABS. ADDRESS
HRRZ TB,1(TA) ;GET TYPE
JUMPN TB,JBE16. ;DUPLICATE
JRST IA204I ;COPY FIRST LITERAL
;SET ALPHABET-NAME TO BE LITERAL AND STORE FIRST LITERAL
INTER. IA203L
IA203L: FLAGAT HI
HRRZ TA,CURMNE ;GET TABLE ADDRESS
PUSHJ PP,LNKSET ;TURN INTO ABS. ADDRESS
HRRZ TB,1(TA) ;GET TYPE
JUMPN TB,JBE16. ;DUPLICATE
SKPNAM ;COPY FIRST LITERAL
;STORE LITERAL IN MNETAB
INTER. IA204.
IA204.: LDB TA,GWVAL ;GET LITERAL SIZE
HRLI TA,CD.MNE
PUSHJ PP,GETENT
LDB TB,GWVAL
MOVE TC,[POINT 7,LITVAL]
IA204L: ILDB TD,TC
SKIPGE DEFDSP ;IS DEFAULT IS DISPLAY-9
PUSHJ PP,IA205C ;YES, CONVERT TO EBCDIC
MOVEM TD,(TA)
ADDI TA,1
SOJG TB,IA204L ;COPY LITERAL INTO MNETAB
POPJ PP,
;STORE FIGCON IN MNETAB
INTER. IA204F
IA204F: MOVE TA,[CD.MNE,,1]
PUSHJ PP,GETENT
PUSHJ PP,GETFCN
MOVEM TD,(TA)
POPJ PP,
;STORE INTEGER IN MNETAB
INTER. IA204I
IA204I: PUSHJ PP,IA16S. ;GET VALUE
JFCL ;ERROR RETURN
CAILE TC,^D256 ;IS IT IN RANGE?
JRST IA205E ;NO
SOSN TC ;REDUCE TO INDEX
TRO TC,MTZERO ;SO ZERO WILL WORK
PUSH PP,TC ;SAVE VALUE
MOVE TA,[CD.MNE,,1]
PUSHJ PP,GETENT
POP PP,(TA)
POPJ PP,
;STORE THRU LITERAL IN MNETAB
INTER. IA205.
IA205.: LDB TA,GWVAL ;GET LITERAL SIZE
CAIE TA,1
JRST IA206E
HRLI TA,CD.MNE
PUSHJ PP,GETENT
LDB TD,[POINT 7,LITVAL,6]
SKIPGE DEFDSP ;IS DEFAULT DISPLAY-9
PUSHJ PP,IA205C ;YES, CONVERT TO EBCDIC
TRO TD,1B18 ;SET THRU FLAG
MOVEM TD,(TA)
POPJ PP,
;STORE THRU INTEGER IN MNETAB
INTER. IA205I
IA205I: PUSHJ PP,IA16S. ;GET VALUE
JFCL ;ERROR RETURN
CAILE TC,^D256 ;IS IT IN RANGE?
JRST IA205E ;NO
SUBI TC,1
TRO TC,1B18 ;SET THRU FLAG
PUSH PP,TC ;SAVE VALUE
MOVE TA,[CD.MNE,,1]
PUSHJ PP,GETENT
POP PP,(TA)
POPJ PP,
;STORE ALSO LITERAL IN MNETAB
INTER. IA206.
IA206.: LDB TA,GWVAL ;GET LITERAL SIZE
CAIE TA,1
JRST IA206E
HRLI TA,CD.MNE
PUSHJ PP,GETENT
LDB TD,[POINT 7,LITVAL,6]
SKIPGE DEFDSP ;IS DEFAULT DISPLAY-9
PUSHJ PP,IA205C ;YES, CONVERT TO EBCDIC
TRO TD,1B19 ;SET ALSO FLAG
MOVEM TD,(TA)
POPJ PP,
;STORE ALSO FIGCON IN MNETAB
INTER. IA206F
IA206F: MOVE TA,[CD.MNE,,1]
PUSHJ PP,GETENT
PUSHJ PP,GETFCN
TRO TD,1B19 ;SET ALSO FLAG
MOVEM TD,(TA)
POPJ PP,
;STORE ALSO INTEGER IN MNETAB
INTER. IA206I
IA206I: PUSHJ PP,IA16S. ;GET VALUE
JFCL ;ERROR RETURN
CAILE TC,^D256 ;IS IT IN RANGE?
JRST IA205E ;NO
SUBI TC,1
TRO TC,1B19 ;SET ALSO FLAG
PUSH PP,TC ;SAVE VALUE
MOVE TA,[CD.MNE,,1]
PUSHJ PP,GETENT
POP PP,(TA)
POPJ PP,
GETFCN: LDB TB,GWVAL ;GET WHICH
SETO TD, ;MAKE IT
CAIN TB,HIVAL. ;HIGH-VALUE?
MOVEI TD,177
CAIN TB,LOVAL. ;LOW-VALUE?
SETZ TD,
CAIN TB,QUOTE. ;QUOTE?
MOVEI TD,42
CAIN TB,SPACE. ;SPACE?
MOVEI TD," "
CAIN TB,ZERO. ;ZERO?
MOVEI TD,"0"
JUMPGE TD,CPOPJ ;VALID CHAR, RETURN
POP PP,(PP)
JRST JBE16. ;MUST BE ILLEGAL
IA205E: MOVEI DW,E.720
PJRST FATAL
IA206E: MOVEI DW,E.712
PJRST FATAL
IA205C: ;ROUTINE TO CONVERT AN ASCII CHAR TO EBCDIC.
ROT TD,-2 ;FORM THE INDEX INTO THE TABLE.
JUMPL TD,IA205D ;LEFT OR RIGHT HALF?
HLR TD,ASEBC.(TD) ;LEFT.
CAIA
IA205D: HRR TD,ASEBC.(TD) ;RIGHT.
TLNN TD,(1B1) ;IS THE CHAR RIGHT JUSTIFIED?
LSH TD,-^D9 ;IT IS NOW.
ANDI TD,377 ;CLEAR JUNK
POPJ PP,
;Error recovery for bad alphabet-name
INTER. IA207S
IA207S: MOVEI DW,E.654 ;GUESS THAT I-O IS MIS-SPELLED
JRST IA207.
INTER. IA207D
IA207D: MOVEI DW,E.655 ;GUESS THAT DATA IS MIS-SPELLED
IA207.: HRRZ TA,CURMNE ;GET TABLE ADDRESS
PUSHJ PP,LNKSET ;GET ABS. ADDRESS
HLRZ LN,2(TA) ;GET LN
HRRZ CP,2(TA) ;GET CP
JRST FATAL ;TELL USER
;Here to set up program collating sequence
IA210.: HRRZ TA,MNELOC##
ADDI TA,1 ;BYPASS ZERO
IA210L: MOVE TB,1(TA) ;GET 2'ND WORD
TLNE TB,MTSYMB ;SYMBOLIC CHARACTER?
AOJA TA,IA210E ;YES, ACCOUNT FOR LN & CP
TLNN TB,MTALPA ;[1363] ALPHABET-NAME?
JRST IA210E ;[1363] NO, IGNORE IT
TRNE TB,%AN.AS+%AN.EB ;YES, BUT IS IT A LITERAL?
AOJA TA,IA210E ;NO, BUT ACCOUNT FOR <LN,,CP> WORD
HRRZ TB,TA ;SETUP AOBJP COUNTER
SKIPLE TC,3(TB) ;START OF NEXT ENTRY OR TABLE
JRST [TRZE TC,MTZERO ;NO, CLEAR ZERO MARKER
MOVEM TC,3(TB) ;PUT LIT VALUE BACK
AOBJP TB,.-1] ;NOT YET
HLRZ TB,TB ;GET COUNT OF ITEMS
HRRM TB,1(TA) ;STORE COUNT
HLRZ TC,(TA) ;GET FIRST WORD
ANDI TC,77777 ;GET INDEX TO MNETAB
CAMN TC,COLSEQ ;IS IT SAME AS PROGRAM COL. SEQ.?
HRLM TA,COLSEQ ;YES, STORE MNETAB LOCATION
ADDI TA,1(TB) ;ACCOUNT FOR <LN,,CP> WORD + SIZE OF TABLE
IA210E: ADDI TA,SZ.MNE ;ADD IN NORMAL SIZE
HRRZ TB,MNENXT##
CAIGE TA,(TB) ;FINISHED?
JRST IA210L ;NO
HLRZ TA,COLSEQ ;DO WE HAVE A PROGRAM COLLATING SEQUENCE
JUMPE TA,CPOPJ ;NO
;YES
;USE CODE TAKEN FROM COBOLE TO SETUP THE PROGRAM COLLATING SEQUENCE
;THIS IS NEEDED HERE SO THAT LOW-VALUES AND HIGH-VALUES CAN BE SETUP CORRECTLY
HRRZS COLSEQ ;RESTORE COLSEQ
MOVE TB,1(TA) ;GET 2'ND WORD
TLNN TB,MTALPA ;ALPHABET-NAME?
POPJ PP, ;NO
ANDI TB,777 ;YES, BUT IS IT A LITERAL?
JUMPE TB,CPOPJ ;NO
MOVE TC,[PRGCOL##,,PRGCOL+1]
SETOM PRGCOL
BLT TC,PRGZRL## ;INITIALIZE ALL OF TABLE
MOVN TB,TB
HRL TA,TB ;SETUP AOBJN POINTER
SETO TC, ;STORE POINTER (INCREMENTED BEFORE STORE)
SETZB TD,ILCSIX## ;ALSO COUNT AND SIXBIT OFFSET
SETZM EXCEBC## ;CLEAR EBCDIC ONLY COUNT
CSMNEN: MOVE TB,3(TA) ;GET LITERAL
TRZE TB,MTTHRU ;THRU?
JRST CSMNET ;YES
TRZE TB,MTALSO ;ALSO?
JRST CSMNEA ;YES
ADDI TC,1(TD) ;IN CASE ALSO
SETZ TD,
PUSHJ PP,CSMTST ;STORE IF FIRST TIME
JRST CSMNEJ ;GET NEXT
CSMNEA: PUSHJ PP,CSMTST ;STORE IF FIRST TIME
AOJA TD,CSMNEJ ;GET NEXT
CSMNET: ADDI TC,0(TD) ;INCASE ANY ALSO
MOVE TD,TB ;SAVE THRU LIT
MOVE TB,2(TA) ;GET PREVIOUS LITERAL
SUBM TB,TD ;GET -NO. TO DO
JUMPG TD,CSMNER ;ORDER IS REVERSED
ADDI TB,1 ;GET NEXT
HRL TB,TD ;AOBJN POINTER
SETZ TD,
CSMNEU: ADDI TC,1 ;POINT TO CURRENT
PUSHJ PP,CSMTST ;STORE IF FIRST TIME
AOBJN TB,CSMNEU ;LOOP
JRST CSMNEJ
CSMNER: SUBI TB,(TD) ;GET OTHER END
MOVN TD,TD ;GET - LENGTH
HRL TB,TD ;AOBJN LOOP PTR
MOVN TD,TD ;+ SIZE
ADDI TC,1(TD) ;GET LAST FIRST
SUBI TD,1 ;WHAT TO ADD ON WHEN FINISHED
CSMNEV: SUBI TC,1 ;POINT TO CURRENT
PUSHJ PP,CSMTST ;STORE IF FIRST TIME
AOBJN TB,CSMNEV ;LOOP
CSMNEJ: AOBJN TA,CSMNEN ;NOT YET
;NOW LOOP THROUGH TABLE FILLING IN MISSING VALUES
ADDI TC,1(TD) ;IN CASE ANY ALSO'S LEFT
MOVSI TA,-40 ;SCAN FIRST PART OF TABLE
PUSH PP,TC ;SAVE NUMBER KNOWN
CSMNEH: SKIPL PRGCOL(TA)
JRST CSMNEI
HRLM TC,PRGCOL(TA) ;STORE ASCII ONLY
AOS ILCSIX ;ACCOUNT FOR NO SIXBIT HERE
ADDI TC,1
CSMNEI: AOBJN TA,CSMNEH
HRLI TA,-100 ;SCAN REST OF SIXBIT TABLE
CSMNEF: SKIPL PRGCOL(TA) ;ALREADY SET
JRST CSMNEG ;YES
HRLM TC,PRGCOL(TA) ;STORE NEW VALUE
SUB TC,ILCSIX ;REMOVE EFFECT OF NO SIXBIT
HRLM TC,PRGCOL+200(TA)
ADD TC,ILCSIX
ADDI TC,1
CSMNEG: AOBJN TA,CSMNEF ;TRY NEXT
HRLI TA,-40 ;SCAN LAST PART OF TABLE
CSMNEK: SKIPL PRGCOL(TA)
JRST CSMNEM
HRLM TC,PRGCOL(TA) ;NO SIXBIT
ADDI TC,1
CSMNEM: AOBJN TA,CSMNEK
POP PP,TC ;RESTORE COUNT
MOVSI TA,-400 ;SCAN EBCDIC TABLE
CSMNEO: HRRE TB,PRGCOL(TA) ;GET EBCDIC PART
JUMPGE TB,CSMNEP ;ALREADY SET UP
HRRM TC,PRGCOL(TA)
ADDI TC,1
CSMNEP: AOBJN TA,CSMNEO
;NOW LOOP THROUGH LOOKING FOR LOW-VALUES AND HIGH-VALUES
SETOB TB,COHVLV## ;INITIALIZE TABLE
MOVE TC,[COHVLV,,COHVLV+1]
BLT TC,COHVLV+5 ;TO LOWEST VALUE
MOVSI TA,-200 ;ASCII
HVLVA: HLRZ TC,PRGCOL(TA)
JUMPN TC,HVLVA1 ;NOT LOW-VALUES
SKIPGE COHVLV+4 ;FIRST TIME?
HRRZM TA,COHVLV+4 ;YES, STORE CHARACTER
HVLVA1: CAMGE TC,TB ;HIGH-VALUE
JRST HVLVA2 ;NO
HRRZM TA,COHVLV+1 ;YES, STORE LATEST CANDIDATE
MOVE TB,TC ;UPDATE CURRENT HIGHEST
HVLVA2: AOBJN TA,HVLVA
MOVSI TA,-100 ;SIXBIT
SETO TB,
HVLVS: HLRZ TC,PRGCOL+240(TA)
JUMPN TC,HVLVS1 ;NOT LOW-VALUES
SKIPGE COHVLV+3 ;FIRST TIME?
HRRZM TA,COHVLV+3 ;YES, STORE CHARACTER
HVLVS1: CAMGE TC,TB ;HIGH-VALUE
JRST HVLVS2 ;NO
HRRZM TA,COHVLV ;YES, STORE LATEST CANDIDATE
MOVE TB,TC ;UPDATE CURRENT HIGHEST
HVLVS2: AOBJN TA,HVLVS
MOVSI TA,-400 ;EBCDIC
SETO TB,
HVLVE: HRRZ TC,PRGCOL(TA)
JUMPN TC,HVLVE1 ;NOT LOW-VALUES
SKIPGE COHVLV+5 ;FIRST TIME?
HRRZM TA,COHVLV+5 ;YES, STORE CHARACTER
HVLVE1: CAMGE TC,TB ;HIGH-VALUE
JRST HVLVE2 ;NO
HRRZM TA,COHVLV+2 ;YES, STORE LATEST CANDIDATE
MOVE TB,TC ;UPDATE CURRENT HIGHEST
HVLVE2: AOBJN TA,HVLVE
POPJ PP,
CSMTST: SKIPGE DEFDSP ;IS DEFAULT DISPLAY-9
JRST CSMSTX ;YES
SKIPL PRGCOL(TB) ;ALREADY SETUP?
POPJ PP, ;YES, ERROR WILL BE CAUGHT BY COBOLE
PUSH PP,TB ;SAVE TB
CSMSTR: CAIL TB,200 ;IN ASCII RANGE?
SOJA TC,CSMSNA ;NO
HRLM TC,PRGCOL(TB) ;STORE NEW ASCII VALUE
HRRZ TB,TB ;INCASE AOBJN PTR
CAIL TB,40 ;IS IT IN SIXBIT RANGE?
CAIL TB,140 ;...
JRST CSMSNS ;NO
SUB TC,ILCSIX ;REMOVE NON-SIXBIT COUNT
HRLM TC,PRGCOL+200(TB) ;STORE SIXBIT
ADD TC,ILCSIX ;RESTORE COUNT
CSMSTE: SKIPGE DEFDSP ;IS DEFAULT DISPLAY-9
JRST CSMSTZ ;YES, WE'RE ALL DONE
;ROUTINE TO CONVERT AN ASCII CHAR TO EBCDIC.
CAIL TB,200 ;IS IT OUTSIDE ASCII RANGE?
JRST CSMSTG ;YES, USE AS IS
ROT TB,-2 ;FORM THE INDEX INTO THE TABLE.
JUMPL TB,CSMSTF ;LEFT OR RIGHT HALF?
HLR TB,ASEBC.##(TB) ;LEFT.
CAIA
CSMSTF: HRR TB,ASEBC.##(TB) ;RIGHT.
TLNN TB,(1B1) ;IS THE CHAR RIGHT JUSTIFIED?
LSH TB,-^D9 ;IT IS NOW.
ANDI TB,377 ;CLEAR JUNK
CSMSTG: ADD TC,EXCEBC ;ADD IN EXCESS COUNT
HRRM TC,PRGCOL(TB) ;STORE EBCDIC
SUB TC,EXCEBC
CSMSTZ: POP PP,TB ;RESTORE
POPJ PP,
CSMSNA: AOSA EXCEBC ;ONE MORE THAT IS ONLY EBCDIC
CSMSNS: AOS ILCSIX ;ONE MORE THAT ISN'T SIXBIT
JRST CSMSTE ;TRY EBCDIC
CSMSTX: HRL TC,PRGCOL(TB) ;GET CURRENT CHAR.
JUMPGE TC,CPOPJ ;ALREADY EXISTS
HRRZ TC,TC ;CLEAR LHS.
ADD TC,EXCEBC ;ADD EXCESS
HRRM TC,PRGCOL(TB) ;SAVE EBCDIC CHAR
SUB TC,EXCEBC
PUSH PP,TB ;SAVE CHAR
HRRZ TB,TB ;INCASE AOBJN PTR
;ROUTINE TO CONVERT AN EBCDIC CHAR TO ASCII.
ROT TB,-2 ;FORM THE INDEX INTO THE TABLE.
JUMPL TB,CSMSTY ;LEFT OR RIGHT HALF?
HLR TB,EBASC.##(TB) ;LEFT.
CAIA
CSMSTY: HRR TB,EBASC.##(TB) ;RIGHT.
TLNN TB,(1B1) ;IS THE CHAR RIGHT JUSTIFIED?
LSH TB,-^D9 ;IT IS NOW.
ANDI TB,177 ;CLEAR JUNK
CAIE TB,134 ;\ IS SPECIAL
JRST CSMSTR ;NOW STORE ASCII
HRRZ TB,0(PP) ;AS IT MIGHT BE ILLEGAL CHAR
CAIE TB,340 ;UNLESS EBCDIC \
SOJA TC,CSMSNA ;ILLEGAL SO DON'T STORE
MOVEI TB,134 ;RESTORE \
JRST CSMSTR ;AND STORE IT
; SET FLAGS FOR APPLY BASIC-LOCKING ON FILENAME ...
INTER. IA222.
IA222.: SETOM ABSEEN## ;SET APPLY BASIC-LOCKING SEEN FLAG
POPJ PP, ; AND RETURN
; SET FLAG TO SAY BASIC-LOCKING TO BE DONE ON THIS FILE
INTER. IA223.
IA223.: PUSHJ PP,IA38S. ;GET PTR TO FILTAB ENTRY FOR THIS FILE
HRRZ TA,TB ;GET ABSOLUTE ADDRESS OF FILTAB INTO AC16
LDB TB,FI.RMS ;GET FILE'S RMS FLAG
JUMPE TB,IA223E ;NOT ON, GIVE FATAL DIAG
; SETO TB,
DPB TB,FI.ABL## ;YES, TURN ON APPLY BASIC-LOCKING FLAG
POPJ PP, ; AND RETURN
IA223E: EWARNJ E.830 ;APPLY BASIC LOCKING ONLY FOR RMS FILES
;COBOL-82 SYNTAX
INTER. IA300.
IA300.: LDB TB,GWVAL ;GET SIZE OF LITERAL
TLNN W1,GWNLIT ;MUST BE NON-NUMERIC
CAIE TB,1 ;AND 1 CHAR.
EWARNW E.27
LDB TB,[POINT 7,LITVAL,6]
IA300X: HRRZ TA,CURFIL ;POINT TO CURRENT FILE
LDB TC,FI.PAD
JUMPN TC,JBE16. ;DUPLICATE CLAUSE
DPB TB,FI.PAD## ;STORE PADDING CHARACTER
POPJ PP,
INTER. IA300A
IA300A: TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
PUSHJ PP,PUTCRF
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM ;PUT IN NAMTAB
HLRZ TB,TA ;GET NAMTAB LINK
JRST IA300X
INTER. IA300B
IA300B: PUSHJ PP,GETFCN ;GET LEGAL FIGCON INTO TD
MOVE TB,TD ;INTO TB
JRST IA300X
INTER. IA300C
IA300C: HRRZ TA,W1 ;GET MNETAB LINK
PUSHJ PP,LNKSET ;GET ABS ADDRESS
LDB TB,MN.SCV## ;GET CHAR VALUE
JRST IA300X
INTER. IA301.
IA301.: TLNE W1,GWNLIT ;IS ITEM NUMERIC LITERAL?
TLNE W1,GWDP ;YES, IS IT INTEGER?
JRST IA301E ;NO
LDB TB,GWVAL ;NO. OF CHARACTERS
MOVEM TB,CTR##
HRRZI TA,LITVAL##
PUSHJ PP,GETVAL
MOVEM TC,0(SAVPTR)
POPJ PP,
IA301E: SETZB TC,0(SAVPTR)
EWARNJ E.25
INTER. IA302.
IA302.: SETZ TC,
PUSH SAVPTR,TC
PUSHJ PP,IA301.
POP SAVPTR,TC
CAML TC,0(SAVPTR)
MOVEM TC,0(SAVPTR)
POPJ PP,
INTER. IA303.
IA303.: SETZ TB,
EXCH TB,0(SAVPTR)
CAIL TB,^D4096 ;REQUIRE BLK FACTOR .LE. 4095
EWARNJ E.2 ;IT ISN'T
SKIPE TA,CURFIL
DPB TB,FI.BLF##
POPJ PP,
INTER. IA304.
IA304.: SETZ TB,
EXCH TB,(SAVPTR)
SKIPE TA,CURFIL
DPB TB,FI.FBS## ;BUFFER SIZE
POPJ PP,
;Initialize the storage for SYMBOLIC CHARACTER clause
INTER. IA309.
IA309.: FLAGAT 8
SETZM SYCHVF## ;CLEAR ADDRESS IN CASE ALPHABET-NAME SEEN
SETZM SYCHTC## ;CLEAR TOTAL COUNT
SETZM SYCHAD## ;CLEAR ADDRESS OF MNETAB ITEM
SETZM SYCHNO## ;AND COUNT OF SYMBOLIC CHARACTERS
HRLZM LN,SYLNCP## ;SAVE LN
HRRM CP,SYLNCP ; AND CP
JRST IA58A. ;CHECK SPECIAL NAMES CLAUSES
;Reinitialize the storage for SYMBOLIC CHARACTER clause
INTER. IA310.
IA310.: SETZM SYCHAD## ;CLEAR ADDRESS OF MNETAB ITEM
SETZM SYCHNO## ;AND COUNT OF SYMBOLIC CHARACTERS
POPJ PP,
;Generate a NAMTAB and MNETAB entry for each SYMBOLIC CHARACTER and link them together.
INTER. IA311A
IA311A: EWARNW E.814 ;DUPLICATE NAME
SKPNAM
INTER. IA311.
IA311.: MOVSI TA,MTSYMB ;SYMBOLIC CHARACTER TYPE
PUSHJ PP,IA44.D ;LINK MNETAB TO NAMTAB
MOVE TA,CURMNE ;GET MNETAB POINTER
SKIPN SYCHAD ;IF THIS THE FIRST TIME?
MOVEM TA,SYCHAD ;YES, STORE IT
SKIPN SYCHVF ;IF THIS THE FIRST TIME?
MOVEM TA,SYCHVF ;YES, STORE IT
MOVE TA,[CD.MNE,,1] ;NEED ONE EXTRA WORD FOR LN & CP
PUSHJ PP,GETENT ; IN CASE OF ERROR LATER
SUBI TA,SZ.MNE ;BACKUP TO START OF MNETAB ITEM
DPB W2,MN.LNC## ;STORE LN & CP
AOS SYCHNO ;COUNT ONE MORE
AOS SYCHTC ;...
POPJ PP,
;Store the integer value back in the MNETAB entry for the corresponding SYMBOLIC CHARACTER.
INTER. IA312.
IA312.: SOSGE SYCHNO ;TOO MANY?
EWARNJ E.812 ;YES, GIVE UP
PUSHJ PP,IA16S. ;GET VALUE OF LITERAL
SETZ TC, ;STORE -1 ON ERROR
CAIG TC,400 ;RANGE CHECK LITERAL
JUMPG TC,IA312A ; BETWEEN 1 AND 400
EWARNJ E.811 ;NOT IN RANGE
IA312A: SUBI TC,1 ;ASCII CHAR = ORDINAL-1
MOVE TA,SYCHAD ;GET TABLE BASE
PUSHJ PP,LNKSET ;GET REAL ADDRESS
HRRM TC,1(TA) ;STORE LITERAL VALUE
MOVEI TA,SZ.MNE+1
ADDM TA,SYCHAD ;POINT TO NEXT ENTRY
POPJ PP,
;Handle the case of alphabet-name clause.
INTER. IA313.
IA313.: HRRZ TA,W1 ;GET ALPHABET-NAME
PUSHJ PP,LNKSET ;POINT TO MNETAB
MOVE TB,1(TA) ;GET SECOND WORD
TRNE TB,%AN.AS ;IF ASCII
POPJ PP, ;ALL DONE
TRNE TB,%AN.EB ;IF EBCDIC
JRST IA313E ;SPECIAL
LDB TB,MN.NAM## ;GET NAME OF ALPHABET
PUSH PP,COLSEQ ;SAVE REAL COLLATING SEQ.
MOVEM TB,COLSEQ ;FAKE IT SO WE CAN GET ALPHABET
PUSHJ PP,IA210. ; INTO PRGCOL
POP PP,COLSEQ
;The table in PRGCOL is the inverse of what we want
;that is each location contains the converted character
;what we want is the converted sequence containing the original ascii char
MOVSI TA,-200 ;AOBJN POINTER
IA313A: HLRZ TB,PRGCOL(TA) ;GET CONVERTED CHARACTER
HRRM TA,PRGCOL(TB) ;STORE ORIGINAL ASCII CHAR
AOBJN TA,IA313A ;LOOP
IA313B: SOSGE SYCHTC ;ALL DONE?
POPJ PP, ;YES
MOVE TA,SYCHVF ;GET TABLE ADDRESS
PUSHJ PP,LNKSET ;GET REAL ADDRESS
LDB TB,MN.SCV## ;GET VALUE
HRRZ TB,PRGCOL(TB) ;GET CHARACTER IN ALPHABET
DPB TB,MN.SCV
MOVEI TA,SZ.MNE+1
ADDM TA,SYCHVF ;ADVANCE POINTER
JRST IA313B ;DO NEXT
IA313E: SOSGE SYCHTC ;ALL DONE?
POPJ PP, ;YES
MOVE TA,SYCHVF ;GET TABLE ADDRESS
PUSHJ PP,LNKSET ;GET REAL ADDRESS
SETO TB,
DPB TB,MN.ESC## ;TURN ON EBCDIC FLAG
MOVEI TA,SZ.MNE+1
ADDM TA,SYCHVF ;ADVANCE POINTER
JRST IA313E ;DO NEXT
INTER. IA327.
IA327.: HRLZM LN,RCLNCP## ;SAVE LN
HRRM CP,RCLNCP ; AND CP
POPJ PP, ;SO WE CAN FLAG IT RIGHT
INTER. IA328.
IA328.: FLAGAT H
HRRZI TB,%HL.RC ;GET DEFERRED CODE
MOVEM TB,CTR ;STORE CODE IN HLDTAB
SKIPN FLGSW ;NEED FIPS FLAGGER?
JRST IA28. ;NO, JUST STORE DATA-NAME
PUSHJ PP,IA28.
MOVEI TA,%LV.H
JRST IA329A
INTER. IA329.
IA329.: SKIPN FLGSW ;NEED FIPS FLAGGER?
POPJ PP, ;NO
MOVEI TA,%LV.VX
IA329A: HLRZ LN,RCLNCP##
HRRZ CP,RCLNCP
JRST FLG.ES
END COBOLB