Trailing-Edge
-
PDP-10 Archives
-
BB-H580E-SB_1985
-
cobolb.mac
There are 14 other files named cobolb.mac in the archive. Click here to see a list.
; UPD ID= 3507 on 5/4/81 at 10:53 AM by NIXON
TITLE COBOLB FOR COBOL V12C
SUBTTL ID AND ED CONTROL PROGRAM 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
DEBUG==:DEBUG
RPW==:RPW
ISAM==:ISAM
BIS==:BIS
;EDITS
;V12B****************
;MJC 27-MAR-85 [1567] Check if current file is the same as the first
; one in a SAME AREA clause.
;V12*****************
;NAME DATE COMMENTS
;SMI 26-OCT-82 [1425] 68274 Fix RESERVE negative AREAS to be converted
; to RESERVE 1 AREAS.
;SMI 22-OCT-82 [1423] 68274 Fix FILE LIMITS to be commented out
;SMI 19-OCT-82 [1422] 68274 Fix DATE-COMPILED line to be not commented
;SMI 23-SEP-82 [1407] Fix COPY REPLACING in ID-DIVISION.
;DMN 21-JUN-82 [1363] Fix syntaxing of SPECIAL-NAMES when defining
; collating sequences and CHANNEL numbers
;DMN 19-JAN-82 [1332] Fix PROGRAM COLLATING SEQUENCE not to advance
; too far
;JEH 01-JAN-82 [1330] Warning for invalid memory size
;JEH 17-DEC-81 [1325] SHUT OFF DCCFLG SO SOURCE NOT LOST W/ 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.
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
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.ACC
EXTERN FI.RCT,FI.MLT
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
IFN ANS74,<
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,TRACEI,TRACEE
>
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
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
IFN FT68274,<
INTER. IA0B.
IA0B.: SETOM CVTCCF## ;TURN THIS LINE INTO A COMMENT
SETOM CVTCAL## ;AND ALL FOLLOWING ONES
PUSHJ PP,IA0A. ;READ REST OF PARAGRAPH
SETZM CVTCCF ;TURN OF COMMENT FOR THIS LINE
SETZM CVTCAL ;AND FOR REST OF LINES
POPJ PP,
>
INTER. IA0A.
IA0A.:
IFN ANS74!FT68274,<
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:
IFN ANS74!FT68274,<
TRNN TYPE,AMRGN. ;A-MARGIN?
PUSHJ PP,IA0. ;NO, SKIP TO END OF PARAGRAPH
SETZM NOIDHY ;TURN IT BACK ON
IFN ANS74,<
SETZM DCCFLG ;OUT OF DATE-COMPILED NOW
>
POPJ PP,
>
IFN ANS68,<
TRNE TYPE,AMRGN. ;A-MARGIN?
POPJ PP, ;YES, NEW PARAGRAPH.
SKPNAM
>
;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
TRZ FGTPER ;[153] DON'T GET PERIOD FROM GETITM
PUSHJ PP,SKPPGF## ;SKIP TO END OF PARAGRAPH
IFN ANS74 < ;[1325]
SETZM DCCFLG ;[1325] OUT OF DATE-COMPILED STATEMENT
>; ANS74 ;[1325]
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,
INTER. IA0.C ;[1407]
IA0.C: PUSHJ PP,GETITM ;[1407] SKIP NEXT WORD
JRST IA0.N ;[1407]
;TURN OFF REGET WORD FLAG
INTER. IA0.A
IA0.A: SWOFF FREGWD;
POPJ PP,
;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.
JRST IA0.R ;SET TO REGET WORD
;IF /S NOT SEEN, SET /S AND TRY AGAIN, GIVE WARNING
INTER. IA0S1.
IA0S1.: TSWFS FSEQ ;WAS /S SEEN
EWARNJ E.1 ;YES, GIVE OLD MESSAGE
EWARNJ E.601 ;NO, GIVE NEW MESSAGE
IFN ANS74,<
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
POPJ PP,
>
;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.
;OBJECT COMPUTER WASN'T 'DECSYSTEM-10' SEE IF IT'S 'DECSYSTEM-10NN'.
INTER. IA0E5.
IA0E5.: MOVE TA, [SIXBIT /DECSYS/] ;CHECK THE FIRST PART.
MOVE TB, [SIXBIT /TEM:10/]
CAMN TA, NAMWRD##
CAME TB, NAMWRD##+1
JRST IA0E5E ;[740] IT'S NOT 'DECSYSTEM-10', COMPLAIN.
MOVE TA, NAMWRD##+2 ;GET THE NN PART.
SETZI TC,
IA0E5D: SETZI TB,
IMULI TC, ^D10
LSHC TB, 6
CAIL TB, '0'
CAILE TB, '9'
JRST IA0E5H ;IT'S NOT A NUMBER, COMPLAIN.
ADDI TC, -20(TB)
JUMPN TA, IA0E5D
JRST IA0.A ;CLEAR REGET WORD BIT.
IA0E5E: CAIG TYPE,ENDIT.+AMRGN. ;[740] SEE IF RESERVED WORD
TRNN TYPE,AMRGN. ;[740] IN THE "A" MARGIN
JRST IA0E5H ;[740] NO
MOVEI NODE,ED269.## ;[740] YES, SET RETURN ADDRESS
MOVEM NODE,0(NODPTR) ;[740] SO WE CAN RECOVER CORRECTLY
SWONS FREGWD ;[740] MAKE SURE WE REGET THIS WORD
;[740] AND WARN THE USER
IA0E5H: SWOFF FREGWD; ;CLR REGET WORD BIT.
EWARNJ E.5 ;'DECSYSTEM-10/20 ASSUMED'.
;STOP SOURCE FROM GOING TO LISTING FOR DATE-COMPILED
INTER. IA1.
IA1.: FLAGAT HI
SWON FNOCPY ;SET NO LISTING BIT
POPJ PP,
INTER. IA1.N
IA1.N: SWON FNOCPY ;SET NO LISTING BIT
PUSHJ PP,SKPNW. ;SKIP BLANKS ETC.
JRST IA0.G ;GET NEXT ITEM
;START SOURCE GOING TO LISTING AGAIN
INTER. IA1.L
IA1.L: SWOFF FNOCPY ;CLEAR NO LISTING BIT
POPJ PP,
;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
;IF NO NAME GIVEN, GIVE IT THE NAME 'MAIN'
INTER. IA2.
IA2.: SKIPE PROGID ;'PROGRAM-ID' SEEN ALREADY?
EWARNJ E.3 ;YES, DUPLICATE PARAGRAPH
PUSHJ PP,CKPERI ;GET THE PERIOD
TRNN TYPE,AMRGN. ;AT THE A-MARGIN?
JRST IA2.0 ;NO
IA2.2: MOVE TD,[SIXBIT /MAIN/] ;YES, NO ID THERE
MOVEM TD,NAMWRD ;SO GIVE IT A DUMMY NAME
TSWF FDSKC ;CCL?
OUTSTR [ASCIZ /MAIN/]
IA2SUB: MOVEM TD,PROGID ;STORE RESULT
TSWT FDSKC ;CCL OR CMD FILE?
JRST IA2SU3 ;NO
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 /]
/]
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,[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
PJRST PUTLNK
IA2.0: PUSHJ PP,GETITM ;REGET SOURCE ITEM AFTER THE PERIOD
SKIPE NAMWRD ;IS IT A USER-NAME?
JRST IA2.12 ;YES
SKIPE LITVAL ;IS IT A LITERAL?
JRST .+3 ;YES
EWARNW E.4 ;NEITHER A WORD NOR A LITERAL
JRST IA2.2 ;USE "MAIN"
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
IA2.12: SETZ TD, ;INIT AC FOR RESULT
MOVEI TB,6 ;CTR FOR 6 CHARS
MOVE TA,[POINT 6,NAMWRD]
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
ADDI TC,40 ;CONVERT 6BIT TO ASCII
OUTCHR TC ;PRINT CHAR
IA2.N3: SOJG TB,IA2.N2 ;CONT. THRU 6 CHARS.
PUSHJ PP,IA2SUB
JRST IA0.
;REPLACE DATE-COMPILED COMMENTS WITH TODAY'S DATE
INTER. IA4.
IA4.:
IFN ANS74!FT68274,<
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
IA4.P: PUSHJ PP,GETSRC## ;[702][1422] READ NEXT CHARACTERS
IFN FT68274,< ;[1422]
JUMPE CH,IA4.Q ;[1422] SKIP NULLS
SOSGE CVTBFC## ;[1422] MAKE SURE THERE IS ROOM IN LINE BUFFER
JRST [OUTSTR [ASCIZ /68274 - source line too long to convert/]
CAIN CH,12
PUSHJ PP,IA4.S
JRST IA4.R] ;[1422]
IDPB CH,CVTBFP## ;[1422] STORE CURRENT CHARACTER
> ;[1422]
IA4.Q: CAIE CH,12 ;[702][1422] <CR-LF>
JRST IA4.P ;[702][1422] NO, LOOK FOR END OF LINE
IA4.R: SWOFF FNOCPY ;[702] RE-ENABLE LISTING
SWON FREGCH ;[702] GET EOL AGAIN
IFN ANS74,<
SETOM DCCFLG## ;SIGNAL IN DATE-COMPILED COMMENT ENTRY.
>
IFE FT68274,<
JRST IA0.S ;AND SKIP REST OF PARAGRAPH
>
IFN FT68274,<
TRNE TYPE,AMRGN. ;A-MARGIN (SHOULDN'T BE)?
POPJ PP, ;YES, NEW PARAGRAPH.
SETOM CVTCAL ;NO, MAKE THE REST IN THIS PARAGRAPH A COMMENT
PUSHJ PP,IA0.S ;SKIP THE PARAGRAPH
SETZM CVTCCF ;THIS LINE IS NO LONGER A COMMENT
SETZM CVTCAL
POPJ PP,
IA4.S: PUSHJ PP,GETSRC ;[1422] GET NEXT SOURCE CHARACTER
CAIE CH,12 ;[1422] CR ?
JRST IA4.S ;[1422] NO
POPJ PP, ;[1422]
>
;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,
IFN CSTATS,<
;"WITH METER--ING" SPECIFIED
INTER. IA6.
IA6.: FLAGAT NS
SETOM METRSW##
JRST IA0.G ;GET NEXT
>;END IFN CSTATS
IFN ANS74,<
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
JRST [HRRZS TB ;[1330]
CAIE TB,0 ;[1330] GREATER THAN 262,144 WORDS?
EWARNW E.652 ;[1330] YES - WARNING
HRRZI TB,777777 ;[1330] SET TO MAX
JRST .+1] ;[1330]
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
IFN ANS74,<
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.ACC ;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,
IFN ANS74,<
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,6] ;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 7,TBLOCK,6]
IDIVI TD,5 ;GET LENGTH OF VALTAB ENTRY (INCL CHAR CNT)
ADDI TD,1 ;AT LEAST 1 WORD
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,6] ;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 NUMBER OF ALTERNATE BUFFERS
;IN COBOL-74, THIS IS 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
REPEAT 1,< ;Delete when LIBOL doesn't have
; to be compatible with 12A.
;Then change OPEN code in LIBOL.
IFN ANS74,<
JUMPLE TC,[EWARNJ E.643] ;MUST BE POSITIVE INTEGER
SUBI TC,2 ; Remove the default size
CAMN TC,[-1] ;Did he say 1?
JRST IA19A ;Yes, OK
>
>;END REPEAT 1
IFN FT68274,<
ADDI TC,2 ;INCREASE SIZE BY 2 FOR -74
SKIPG TC ;[1425] GREATER THAN 1 ?
HRRZI TC,1 ;[1425] NO, SET IT TO 1
>
IFN ANS74!FT68274,<
; JUMPLE TC,[EWARNJ E.643] ;MUST BE POSITIVE INTEGER
>
JUMPGE TC,.+2 ; [355] IF NEGATIVE SET TO
SETOI TC, ; [355] MAX-LIBOL WILL INTERPRET AS ONE BUFFER
CAIG TC,^D62 ; [355] IF LESS THAN OR EQUAL TO 62
JRST IA19A ; [355] OK, GO ON.
EWARNW E.587 ; [355] OTHERWISE WARN USER.
MOVEI TC,^D62 ; [355] SET TO MAX.
IA19A:
REPEAT 0,< ;Turn this code on when the REPEAT 1 above
; is turned off.
IFN ANS74,<
JUMPN TC,IA19A1 ;JUMP IF NOT ZERO SPECIFIED
EWARNW E.734 ;"RESERVE 2 AREAS ASSUMED".
MOVEI TC,2 ;GET DEFAULT VALUE.
IA19A1:
>;END IFN ANS74
>;end REPEAT 0
IFN FT68274,<
MOVE TB,TC ;GET THE NO. OF BUFFERS
IDIVI TB,^D10 ;GET BOTH DIGITS
MOVE TD,CVTSCP## ;GET POINTER TO START OF INTEGER
ADDI TA,"0" ;MAKE UNITS ASCII
JUMPE TB,[DPB TA,TD ;ONLY ONE DIGIT
JRST IA19A2]
ADDI TB,"0" ;MAKE TENS ASCII
DPB TB,TD
IDPB TA,TD
IA19A2: IBP TD ;ADVANCE TO THE NEXT CHAR
CAME TD,CVTBFP## ;DID WE EAT UP THE SPACE?
JRST IA19A3 ;NO, MAKE SURE NO JUNK LEFT
LDB TA,CVTBFP ;YES, INSERT SPACE
MOVEI TB," "
DPB TB,CVTBFP
IDPB TA,CVTBFP
JRST IA19A4
IA19A3: MOVEI TA," " ;GET SPACE
DPB TA,TD ;WE ALREADY ADVANCED THIS CHAR
TRNA
IDPB TA,TD ;STORE SPACE
CAME TD,CVTBFP ;ARE WE THERE YET?
JRST .-2 ;NO
IA19A4:>
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,
;INDICATE NO ALTERNATE BUFFERS
IFN ANS68,<
INTER. IA20.
IA20.:
IFN FT68274,<
MOVEI TA,[ASCIZ /NO/]
MOVEI TB,[ASCIZ / 1/]
PUSHJ PP,CVTRCW ;REPLACE NO BY 1
>
HRRZ TA,CURFIL ;FILTAB ENTRY ABS. ADDR.
LDB TB,FI.NBF ;GET NUMBER OF BUFFERS FIELD
CAILE TB,1 ;0 OR 1?
EWARNJ E.16 ;NO, GIVE 'DUPLICATE CLAUSE' MSG
HRRZI TC,1 ;SET TO 1 BUFR (NO ALTERNATES)
>
IA19.P: DPB TC,FI.NBF ;INSERT NO. OF EXTRA BUFFERS IN FILTAB ENTRY
POPJ PP,
;CHECK FOR MORE THAN 1 ORGANIZATION MODE SETTING PER FILE
INTER. IA21.
IA21.:
IFN ANS74,<
PUSHJ PP,IA21F. ;TEST FIPS FLAGGER
>
IFN FT68274,<
MOVEI TA,[ASCIZ /ACCESS/]
MOVEI TB,[ASCIZ /ORGANIZATION/]
PUSHJ PP,CVTRCW ;REPLACE ACCESS BY ORGANIZATION
>
HRRZ TA,CURFIL ;AIM AT CURRENT FILTAB ENTRY
LDB TB,FI.ACC ;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'
IFN ANS74,<
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)
>
;SAVE SYMBOLIC KEY CODE FOR HLDTAB
IFN ANS68,<
INTER. IA22.
IA22.:
IFN ISAM,<
IFN FT68274,<
PUSHJ PP,CVTCTC## ;TURN SYMBOLIC KEY CLAUSE INTO A COMMENT
PUSHJ PP,CVTDPL## ;DUMP THE PREVIOUS LINE
SETZM CVTCPF## ;NOT A COMMENT
SETZM CVTPXC## ;NO EXTRA CHARACTERS
SETOM CVTPLF## ;BUT REAL DATA
MOVE TD,[POINT 7,IA22X.] ;COPY MESSAGE
PUSHJ PP,CVTTPL## ;TO PREVIOUS LINE BUFFER
>
HRRZ TA,CURFIL ;[505] ABS. ADDR. OF FILTAB ENTRY
LDB TB,FI.ACC ;[505] GET ACCESS MODE
CAIE TB,%%ACC ;[505] IS IT THE "DEFAULT"?
CAIN TB,%ACC.I ;[505] NO, INDEXED?
JRST IA22A. ;[505] YES, OK
MOVEI DW,E.595 ;[505] NO, ERROR - WRONG TYPE KEY
PUSHJ PP,FATALW## ;[505] FLAG IT
HRRZI TB,%HL.AK ;[505] GET PROPER CODE
SKIPA ;[505]
IA22A.: HRRZI TB,%HL.SY ;[505] GET CODE
JRST IA24X.
>
IFE ISAM,<EWARNJ E.91> ;?NOT IMPLEMENTED
>
IFN FT68274,<
IA22X.: ASCIZ / ACCESS MODE IS DYNAMIC
/
>
;SAVE RECORD KEY CODE FOR HLDTAB
INTER. IA22R.
IA22R.:
IFN ISAM,<
FLAGAT H
HRRZI TB,%HL.RC ;GET CODE
JRST IA24X.
>
IFE ISAM,<EWARNJ E.91> ;?NOT IMPLEMENTED
IFN ANS74,<
;HERE WHEN PARSED "ALTERNATE.." AND EXPECTING "RECORD KEY IS.."
INTER. IA22K.
IA22K.:
IFN ISAM,<
FLAGAT H
MOVE TA,CURFIL
LDB TB,FI.ACC ;GET FILE ORGANIZATION
CAIE TB,%ACC.I ;MAKE SURE THIS IS AN INDEXED FILE
CAIN TB,%%ACC ;OR NOT SPECIFIED YET
CAIA ;ALL OK
JRST IA22K2 ;NO, ERROR
SETO TB, ;MAKE SURE RMS BIT IS SET
DPB TB,FI.RMS##
DPB TB,FI.AKS## ;SET "ALTERNATE KEYS SPECIFIED" FOR THIS FILE
SETOM RMSFLS## ;SET "RMS FILES" FLAG
POPJ PP, ;RETURN OK
IA22K2: EWARNJ E.624 ;"ALTERNATE KEY ONLY ALLOWED WITH INDEXED FILES"
>;END IFN ISAM
IFE ISAM,<EWARNJ E.91> ;?NOT IMPLEMENTED
>;END IFN ANS74
;INITIALIZE FILE-LIMIT CLAUSE
IFN ANS68,<
IFN FT68274,< ;[1423]
INTER. IA23B. ;[1423]
IA23B.: PUSHJ PP,CVTCTC ;[1423] STATEMENT IS FILE-LIMIT, COMMENT IT OUT
SKPNAM ;[1423]
> ;[1423]
INTER. IA23.
IA23.: PUSHJ PP,IA62. ;RE-INIT SAVLST
;[1423] IFN FT68274,<
;[1423] PUSHJ PP,CVTCTC## ;TURN THIS CLAUSE INTO A COMMENT
;[1423] >
HRRZ TA,CURFIL ;FILTAB ENTRY ABS. ADDR.
LDB TB,FI.NFL## ;GET NO. OF FILE-LIMIT CLAUSES
JUMPN TB,JBE16. ;ERROR IF NOT 0 (DUP. CLAUSE)
POPJ PP,
IFN FT68274,< ;[1423]
INTER. IA23A. ;[1423]
IA23A.: PUSH PP,TB ;[1423] CHECK FOR FILE SPACE LIMIT
LDB TB,CVTBFP ;[1423] GET CURRENT CHARACTER
CAIE TB,"l" ;[1423] IS NEXT WORD LIMIT ?
CAIN TB,"L" ;[1423]
PUSHJ PP,CVTCTC## ;[1423] YES, TURN STATEMENT INTO COMMENT
POP PP,TB ;[1423]
POPJ PP, ;[1423]
> ;[1423]
>
;SAVE ACTUAL/RELATIVE KEY CODE FOR HLDTAB
INTER. IA24.
IA24.: FLAGAT LI
IFN FT68274,<
MOVEI TA,[ASCIZ /ACTUAL/]
MOVEI TB,[ASCIZ /RELATIVE/]
PUSHJ PP,CVTRCW## ;REPLACE ACTUAL BY RELATIVE
>
HRRZ TA,CURFIL ;[505] ABS. ADDR. OF FILTAB ENTRY
LDB TB,FI.ACC ;[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.:
IFN ISAM,<
FLAGAT H
ifn ft68274,<
;add " access mode is dynamic"
>
HRRZI TB,%ACC.I ;ACCESS MODE IS ISAM CODE
JRST IA27.X ;INSERT IN FILTAB ENTRY
>
IFE ISAM,<EWARNJ E.91> ;?NOT IMPLEMENTED
;SET RMS BIT
IFN ANS74,<
INTER. IA26W.
IA26W.: EWARNW E.777 ;WE CHANGED THE SYNTAX ON THE USERS
SKPNAM ;BUT THE OLD SYNTAX STILL WORKS
INTER. IA26R.
IA26R.:
IFE ISAM,< POPJ PP,> ;ALREADY GOT ERROR MESSAGE
IFN ISAM,<
FLAGAT NS
HRRZ TA,CURFIL ;ABS. ADDR OF FILTAB ENTRY
SETO TB, ;GET A BIT "ON"
DPB TB,FI.RMS ;SET RMS BIT
SETOM RMSFLS## ;SET FLAG "RMS FILES USED"
POPJ PP, ;DONE, RETURN
>>;END IFN ANS74
;SET RANDOM ORGANIZATION/ACCESS FLAG
INTER. IA27.
IA27.: FLAGAT LI
IFN FT68274,<
MOVEI TA,[ASCIZ /RANDOM/]
MOVEI TB,[ASCIZ /RELATIVE ACCESS MODE IS DYNAMIC/]
PUSHJ PP,CVTRCW
>
HRRZI TB,%ACC.R ;ACCESS MODE RANDOM CODE
IA27.X: HRRZ TA,CURFIL ;ABS. ADDR. OF FILTAB ENTRY
IFN ANS74,<
LDB TC,FI.AKS ;WERE ALTERATE KEYS SPECIFIED?
JUMPN TC,IA27X1 ;JUMP IF YES
IA27X0:>
DPB TB,FI.ACC ;DEPOSIT IN FILTAB ENTRY
IFN ANS68,<
POPJ PP,
>
IFN ANS74,<
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
>
IFN ANS74,<
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)
>;END IFN ANS74
;PUT KEY DATA-NAME IN HLDTAB
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,
IFN ANS74,<
;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
>;END IFN ANS74
;LITERAL FILE-LIMIT
IFN ANS68,<
INTER. IA29.
IA29.: HLRZ TB,W1 ;GET SIZE OF LITERAL
ANDI TB,000777
TLNE W1,GWNLIT ;IS IT A NUMERIC LITERAL?
TLNE W1,GWDP ;DOES IT HAVE A DECIMAL POINT?
EWARNJ E.264 ;NOT AN INTEGER
MOVE TC,[POINT 7,LITVAL] ;GET PTR TO LITERAL
ILDB TD,TC ;AND PICK UP FIRST CHARACTER
CAIN TD,"-" ;IS IT -?
EWARNW E.25 ;YES, GIVE ERROR MESSAGE
HRRZI TB,1(TB) ;1 MORE FOR NUMBER OF CHARACTERS
MOVEM TB,LSIZE ;SAVE
HRRZI TB,4(TB) ;ROUND UPWARDS
IDIVI TB,5 ;NO. OF WORDS REQUIRED
HRRZI TA,(TB) ;GET A VALTAB ENTRY OF THIS SIZE
HRLI TA,CD.VAL
PUSHJ PP,GETENT
MOVEM TA,CURVAL ;SAVE ADDRESS
MOVE TB,[POINT 7,(TA)] ;PTR TO VALTAB STORE
MOVE TC,[POINT 7,LITVAL] ;PTR TO LITERAL
MOVE TE,LSIZE ;CHAR COUNT FOR THE MOVE
MOVEI TD,-1(TE) ;1ST STORE THE TRUE CHAR COUNT
JRST IA29.L+1
IA29.L: ILDB TD,TC ;GET CHARACTER
IDPB TD,TB ;STASH IT
SOJG TE,IA29.L
HLRZ TA,CURVAL ;SAVE VALTAB PTR
JRST IA30.X
;PUT FILE-LIMIT DATA-NAME IN HLDTAB
INTER. IA30.
IA30.: PUSHJ PP,IA59S. ;SAVE NAMTAB ADDR
PUSHJ PP,IA28S. ;SET UP HLDTAB ENTRY
HLRZ TA,CURHLD ;PUT HLDTAB PTR ON SAVE LIST
IA30.X: PUSH SAVPTR,TA
POPJ PP,
;ERROR OF TYPE: "FILE-LIMITS 1 THRU 200, FOO."
;(OBJECT IS TO KEEP HLDTAB FROM GETTING MIXED UP)
INTER. IA30E
IA30E: PUSHJ PP,IA32. ;SET UP DUMMY LOW LIMIT
PUSHJ PP,IA34. ;MAKE FOO THE HIGH LIMIT
EWARNJ E.303 ;?'THRU' EXPECTED
;ITEM BEFORE 'THRU' BECOMES LOW FILE-LIMIT
INTER. IA31.
IA31.: HRRZ TA,CURFIL ;GET PTR TO CURRENT FILTAB ENTRY
LDB TC,FI.NFL ;INCREMENT NO. OF FILE-LIMITS CLAUSES
ADDI TC,1
DPB TC,FI.NFL ;PUT NEW VALUE IN FILTAB FIELD
MOVE TA,[XWD CD.FIL,1] ;GET 1 WORD IN FILTAB FOR FILE-LIMITS
PUSHJ PP,GETENT
MOVEM TA,CFLM ;SAVE ADDRESS
POP SAVPTR,TD ;GET POINTER FROM SAVE LIST
CAIL TD,<CD.VAL>B20 ;SAVING LOW-LIM ON VALTAB OR HLDTAB?
HRLZM TD,(TA) ;VALTAB, PUT PTR TO LOW-LIMIT IN FILTAB
HRRZI TB,%HL.LL ;SET LOW-LIMIT FLAG IN HLDTAB
IA31.X: TRNE TD,600000 ;VALTAB OR HLDTAB ADDR?
POPJ PP, ;VALTAB
HRRZ TA,HLDLOC ;GET HLDTAB START ADDR.
ADDI TA,(TD) ;PLUS REL ADDR. OF CURRENT WORD
DPB TB,HL.COD
HLRZ TB,CFLM ;PUT FILTAB LINK IN HLDTAB
DPB TB,HL.LNK
POPJ PP,
;SINGLE-ITEM FILE-LIMIT SEEN -- ASSUME 1 AS LOW LIMIT
INTER. IA32.
IA32.: MOVE TA,[XWD CD.VAL,1] ;GET 1-WORD VALTAB ENTRY
PUSHJ PP,GETENT
MOVSI TB,5420 ;PUT '1' IN VALTAB
MOVEM TB,(TA)
HLRZ TB,TA ;PUT VALTAB POINTER ON SAVE LIST
PUSH SAVPTR,TB
JRST IA31. ;PUT LOW LIMIT OF 1 IN FILTAB
;STORE HIGH LIMIT IN FILTAB FILE-LIMIT WORD
INTER. IA34.
IA34.: HLRZ TA,CFLM ;REL ADDR OF FILE-LIMIT WORD
HRRZ TB,FILLOC ;FILTAB ENTRY ADDR
ADD TA,TB ;ABS. ADDR. OF CURRENT FILE-LIMIT
POP SAVPTR,TD ;GET POINTER TO LAST ITEM
CAIL TD,<CD.VAL>B20 ;SAVING HI-LIM ON VALTAB OR HLDTAB?
JRST IA34.X ;VALTAB, CHECK AGAINST LOW LIMIT
HRRZI TB,%HL.HL ;SET HI-LIM FLAG IN HLDTAB
JRST IA31.X
IA34.X: HLRZ TB,(TA) ;PICK UP LOW LIMIT POINTER FROM FILTAB
CAIGE TB,<CD.VAL>B20 ;IS IT VALTAB?
JRST IA34.Y ;NO, CAN'T CHECK LIMITS
PUSH PP,TA ;SAVE POINTER TO FILE LIMITS WORD
PUSH PP,TD ;SAVE POINTER TO HI-LIMIT
MOVE TA,TB ;MOVE RELATIVE POINTER FOR LOW LIMIT
HRRZ TC,VALLOC## ;GET POINTER TO VALTAB
ADD TA,TC ;MAKE LOW-LIMIT PTR ABSOLUTE
TRZ TA,600000 ;GET RID OF FLAGS
MOVE TD,[POINT 7,(TA)] ;BYTE POINTER TO LOW LIMIT
ILDB TB,TD ;PICK UP FIRST BYTE
MOVEM TB,CTR## ;AND USE IT AS CHAR COUNT
PUSHJ PP,GETV2## ;GO GET VALUE FOR LOW LIMIT
POP PP,TA ;NOW SET UP FOR HIGH LIMIT
PUSH PP,TC ;SAVE LOW LIMIT VALUE
HRRZ TC,VALLOC ;CONVERT RELATIVE HI-LIMIT
ADD TA,TC ;POINTER TO ABSOLUTE
TRZ TA,600000 ;AND GET RID OF FLAGS
MOVE TD,[POINT 7,(TA)] ;GET ITS FIRST BYTE
ILDB TB,TD ;INTO TB
MOVEM TB,CTR## ;AND USE AS COUNT
PUSHJ PP,GETV2 ;NOW GET HI-LIMIT VALUE INT TC
POP PP,TD ;RESTORE LOW LIMIT VALUE TO TD
CAMG TC,TD ;IS HI-LIM GREATER?
JRST IA34.Z ;NO, FIX STACK AND GIVE ERROR
TRO TA,600000 ;YES, RESTORE FLAGS
HRRZ TB,VALLOC## ;AND MAKE POINTER RELATIVE
SUB TA,TB ;TO VALTAB
MOVE TD,TA ;RETURN IT TO ITS USUAL PLACE
POP PP,TA ;AND RESTORE POINTER TO FILE LIMITS WORD
IA34.Y: HRRM TD,(TA) ;HERE IF ALL OK, STORE HI-LIM
HRRZI TB,%HL.HL ;AND SET HI-LIM FLAG IN HLDTAB
JRST IA31.X
IA34.Z: POP PP,TA ;HERE ON ERROR, CLEAR THE STACK
EWARNJ E.272 ;GO GIVE ERROR
>;END IFN ANS68
;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
JUMPLE TC,JBE19. ;<=0 IS ILLEGAL
CAILE TC,^D49 ;>=50 IS ILLEGAL
JBE19.: EWARNJ E.19 ;'IMPROPER SEGMENT LIMIT' -- EXIT
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
IFN ANS74,<
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
IFN ANS74,<
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
IFN ANS74,<
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
IFN ANS74,<
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: MOVE TE,-1(SAVPTR) ;[1567]GET POINTER TO THE FIRST FILE
HRLS TE ;[1567]GET IT IN BOTH HALFS
CAMN TE,TB ;[1567]SAME FILE AGAIN?
EWARNJ E.174 ;[1567]'FILE ALREADY IN SAME-AREA CLAUSE'
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
IFN ANS74,<
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,040000 ;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
IFN ANS74,<
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,730000 ;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:
IFN ANS74,<
TLNE TA,(1B6) ;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'
IFN ANS74,<
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,020000 ;GET CHANNEL TYPE FLAG
JRST IA44.D
;GET MNEMONIC-NAME FOR HARDWARE SWITCH
INTER. IA47.
IA47.: HRLZI TA,400000 ;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,100000 ;'OFF STATUS'
TSWF FSTAT;
HRLZI TA,200000 ;'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:
IFN FT68274,<
MOVE TD,[POINT 6,CSL74] ;AIM AT LIST OF ILLEGAL CHARS
IA51.S: ILDB TC,TD ;GET A CHAR FROM LIST
JUMPE TC,IA51.T ;END OF LIST -- ALL IS WELL
CAIE TB,(TC) ;IS THIS A MATCH?
JRST IA51.S ;NO, TRY NEXT
EWARNW E.772 ;YES, INVALID CHARACTER
IA51.T:
>
MOVEM TA,DOLLR. ;STASH NEW CURRENCY SIGN
POPJ PP,
;ITEMS ILLEGAL AS CURRENCY SIGN
;(SPACE MARKS END OF LIST)
CSL:
IFN ANS68,<
SIXBIT /0123456789*+-,.;()"ABCDPRSVXZ /
>
IFN ANS74,<
SIXBIT '0123456789*+-,.;()"=/ABCDLPRSVXZ '
>
IFN FT68274,<
CSL74: SIXBIT '=/L'
>
;SWITCH FUNCTIONS OF COMMA AND DECIMAL POINT
INTER. IA52.
IA52.: 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
IFN ANS74,<
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.: 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,
;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'
IFN FT68274,<
;FLAG SWITCH (N) AS DIFFERENT
INTER. IA62A.
IA62A.: EWARNW E.776
SKPNAM
>
IFN ANS74,<
;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,
;FLAG MISSING DATA DIVISION, THEN GO TO COBOLC
INTER. IA63F.
IA63F.: EWARNW E.31 ;'NO DATA DIVISION'
SKPNAM
;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
IFN ANS74,<
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,
;SET MULTIPLE REEL FLAG FOR FILE
IFN ANS68,< INTER. IA68.
IA68.: HRRZ TA,CURFIL ;FILTAB ENTRY ADDR
LDB TB,FI.MLT ;GET MULTIPLE REEL BIT
JUMPN TB,JBE16. ;IF ON, GIVE 'DUPLICATE CLAUSE' MSG
SETO TB, ;OK, SET MULTIPLE REEL BIT
DPB TB,FI.MLT
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
IFN ANS74,<
MOVEM W2,SAMLNC## ;SAVE LN & CP OF "SAME"
SETZM CURORG ;NO FILES SEEN YET
>
JRST IA62. ;CLR SAVLST
IFN RPW,<
;STASH LITERAL FOR CODE UNTIL MNEMONIC SEEN
INTER. IA78.
IA78.: FLAGAT RP
HLRZ TC,W1 ;PUT SIZE IN THE SPECIAL PLACE
ANDI TC,177
MOVEM TC,(SAVPTR)
IDIVI TC,5 ;CONVERT TO WORDS
JUMPE TB,.+2
ADDI TC,1
MOVEM TC,1(SAVPTR)
MOVE TA,[LITVAL,,TBLOCK] ;STORE LITERAL
MOVEI TB,TBLOCK-1(TC)
BLT TA,(TB)
POPJ PP,
;GET LITERAL FOR REPORT CODE
INTER. IA79.
IA79.: HRLZI TA,010000 ;"CODE" FLAG
PUSHJ PP,IA44.D ;MAKE A CODE MNETAB ENTRY
HRRZ TA,1(SAVPTR) ;# WORDS IN LITERAL
HRLI TA,CD.MNE ;GET THAT MUCH SPACE IN MNETAB
PUSHJ PP,GETENT
HRLI TA,TBLOCK ;MOVE LITERAL TO MNETAB
HRRZI TB,-1(TA)
ADD TB,1(SAVPTR)
BLT TA,(TB)
POPJ PP,
>
;DEFERRED OUTPUT ISAM
INTER. IA80.
IA80.: FLAGAT NS
IFN ISAM,<
HRRZ TA,CURFIL ;AIM AT FILTAB ENTRY
MOVEI TB,1 ;SET DEFERRED BIT
DPB TB,FI.DFR##
>
POPJ PP,
IFN ANS74,<
;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.:
IFN ANS74,<
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.
JRST IA101. ;BUMP COUNT AGAIN AND LEAVE.
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.
IFN ANS74,<
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,
IFN ANS74,<
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,(1B6) ;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
POPJ PP,
;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 OR ASCII
INTER. IA203S
IA203S: MOVE TA,CURMNE ;GET REL ADDRESS
ANDI TA,77777 ;OFFSET
ADD TA,MNELOC## ;ABS.
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: MOVE TA,CURMNE ;GET REL ADDRESS
ANDI TA,77777 ;OFFSET
ADD TA,MNELOC ;ABS.
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
MOVE TA,CURMNE ;GET REL ADDRESS
ANDI TA,77777 ;OFFSET
ADD TA,MNELOC ;ABS.
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
MOVE TA,CURMNE ;GET REL ADDRESS
ANDI TA,77777 ;OFFSET
ADD TA,MNELOC ;ABS.
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
MOVE TA,CURMNE ;GET REL ADDRESS
ANDI TA,77777 ;OFFSET
ADD TA,MNELOC ;ABS.
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,1B20 ;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,
IA210.: HRRZ TA,MNELOC
ADDI TA,1 ;BYPASS ZERO
IA210L: MOVE TB,1(TA) ;GET 2'ND WORD
TLNE TB,(1B5) ;RD CODE?
JRST IA210D ;YES
TLNN TB,(1B6) ;[1363] ALPHABET-NAME?
JRST IA210E ;[1363] NO, IGNORE IT
TRNE TB,-1 ;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,1B20 ;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 ;ACCOUNT FOR <LN,,CP> WORD
IA210D: ADDI TA,(TB) ;ADD IN SIZE OF RD CODE
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
TLNE TB,(1B5) ;RD CODE?
POPJ PP, ;YES, SHOULD NEVER HAPPEN
TLNN TB,(1B6) ;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,1B18 ;THRU?
JRST CSMNET ;YES
TRZE TB,1B19 ;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
>
END COBOLB