Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/cblsrc/iogen.mac
There are 22 other files named iogen.mac in the archive. Click here to see a list.
; UPD ID= 1958 on 3/3/89 at 8:39 AM by KSTEVENS
TITLE IOGEN FOR COBOL V13
SUBTTL I/O GENERATORS AL BLACKINGTON/SIP/CAM/MEM
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, 1986 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
IFN TOPS20,<SEARCH MONSYM,MACSYM>
IFE TOPS20,<SEARCH UUOSYM,MACTEN>
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
;EDITS
;V13*****************
;NAME DATE COMMENTS
;RLF 12-JUL-90 [1653] 12C only.
;KWS 22-FEB-89 [1652] Change code generation so that when Sorting an
; RMS file, the correct code is generated.
;RLF 04-AUG-87 [1643] SELECTed sequential file gets error message
; erroneously from FREE EVERY RECORD statement
;MEM 12-NOV-86 [1636] Check for a depending variable when calculating
; the size of an item to be displayed.
;JEH 31-MAY-84 [1536] Restore AC16 to curfil value before using it
;V12B****************
;NAME DATE COMMENTS
;RLF 11-JUL-83 [1474] Correction to edit 1450.
;RLF 22-APR-83 [1464] Correction to edit 1450.
;RLF 27-JAN-83 [1450] Give error message on FREE syntax error.
;RLF 1-OCT-82 [1412] Make RETAIN do RETAIN NEXT so LSU works
; for ISAM Sequential access.
;SMI 2-Aug-82 [1375] Bad move generated on variable length records.
;JEH 28-Jun-82 [1370] Make CURAKT an absolute addr so XPAND updates it correctly.
;JEH 13-Jan-82 [1331] Fix failure in phase E when WRITE ADVANCING data-name has a syntax error.
;DMN 11-Aug-81 [1305] Wrong code for WRITE record-name AFTER ADVANCING data-name
; where record-name has an OCCURS DEPENDING ON clause
;DMN 6-Jul-81 [1303] RMS variable length records always take DEPENDING ON error return.
;DMN 23-Jun-81 [1302] Bad table link if RMS RECORD KEY is missing.
;V12A****************
;NAME DATE COMMENTS
;WTK 04-DEC-80 [1101] REWRITE and DELETE generating WRITV. when record
; has a DEPENDING ON clause.
;DAW 29-DEC-80 [1107] Make error message point to correct place
; if there are errors in depending variable usage
;DAW 22-SEP-80 [1053] FIX "ACCEPT ITEM(SUBSCRIPTS) FROM DATE/DAY/TIME".
;DMN 26-JUN-80 [1030] MORE OF EDIT 605 WHEN OCCURS IS NOT ELEMENTRY ITEM.
;JEH 24-JUN-80 [1027] BUILD RECORD NAME TABLE IF NESTED READS
;DMN 24-OCT-79 [750] COBOL-74 BAD TABLE LINK IF RELATIVE KEY CONVERSION REQUIRED
;V12*****************
;NAME DATE COMMENTS
;DMN 1-DEC-78 [605] MAKE VARIABLE LENGTH READS WORK USEFULLY
;V10*****************
;NAME DATE COMMENTS
;VR 20-SEP-77 [512] CHECK FOR COMP ITEM AT 01 LEVEL WHEN DOING A BINARY WRITE
;EHM 20-MAY-77 [474] PUT OUT ERROR MESSAGE WHEN TRYING TO DO A
; READ INTO ON A RECORD OF ZERO SIZE.
;MDL 04-NOV-76 [447] GIVE WARNING WHEN ATTEMPTING TO 'ACCEPT' MORE THAN
; 1023 CHARACTERS INTO AN AREA.
;SSC 2-AUG-76 MAKE ERENQ GEN CALL TO CNTAI. FOR COMPOUND RETAIN
;DPL 23-JUN-76 [430] FIX ACCGEN WHEN ARG HAS FAULTY SUBSCRIPT
; 18-FEB-76 [407] FIX STD ASCII WRITING BEFORE/AFTER
;ACK 26-APR-75 DISPLAY DISPLAY-9 ITEMS.
;********************
; EDIT 366 FIX DISPLAY OF DISPLAY-7 ITEMS SO NO EXTRA <CR-LF> DONE.
; EDIT 357 FIX RECOVERY IF RECORD NAME IS NOT DEFINED IN READ INTO STATEMENTS.
; EDIT 345 FIX SUBSCRIPTED DISPLAY ITEM SO NO ADVANCING WORKS.
; EDIT 252 FIXES POSSIBLE PUSHDOWN LIST PROBLEM OF EDIT 122
; EDIT 245 FIXES READ INTO AT END GENERATE TO MAKE INTO WORK
; EDIT 176 FIXES ACCEPT FOO FOR FOO A DISPLAY ITEM IN LINKAGE SECTION.
; EDITS 166,163 131 ALLOW ADVANCING ITEM TO BE SUBSCRIPTED.
;EXIT IF THE ERROR FLAG IS ON
DEFINE EQUIT,<
TSWF FERROR
POPJ PP,
>
;PRINT A MESSAGE
DEFINE TYPE(ADDR),<
IFE TOPS20,<
OUTSTR ADDR
>
IFN TOPS20,<
HRROI 1,ADDR
PSOUT%
>
>
;DIE WITH A MESSAGE
DEFINE DIE(MSG),<
TYPE [ASCIZ/MSG/]
JRST KILL
>
;; ** BITS THAT WILL BE DEFINED IN COMUNI FOR V13 **
;THESE ARE HERE BECAUSE IN 12B THEY MAY CONFLICT WITH EXISTING DEFINITIONS.
; THESE ARE VALID ONLY FOR RMS FILES IN 12B.
;IO VERBS
O%BOPR==POINT 4,IOFLGS,3 ;PLACE TO STORE VALUE
O%SM5B==POINT 9,IOFLGS,17 ;SMU OPTION 5 BITS FOR SELF, OTHERS, + FLAGS
; FOR OPEN VERB WITH RMS FILES
V%OPEN==1 ;OPEN
V%CLOS==2 ;CLOSE
V%READ==3 ;READ
V%WRIT==4 ;WRITE
V%RWRT==5 ;REWRITE
V%DELT==6 ;DELETE
V%STRT==7 ;START
V%ACPT==10 ;ACCEPT
V%DPLY==11 ;DISPLAY
V%OPS5==12 ;OPEN RMS FILE FOR SMU OPTION 5
; ASSUME OPEN FOR I-O AND ANY BITS ARE FOR
; SHARING OR UNAVAILABLE
V%SORT==13 ;[1652]Sort
O.BOPR: O%BOPR
O.SM5B: O%SM5B
;OPEN FLAG BITS
OPN%IN==1B9 ;OPEN FOR INPUT
OPN%OU==1B10 ;OPEN FOR OUTPUT
OPN%IO==1B11 ;OPEN FOR I/O
OPN%EX==1B13 ;OPEN FOR EXTEND
;CLOSE FLAG BITS
CLS%CF==1B12 ;CLOSE FILE
CLS%LK==1B13 ;WITH LOCK
CLS%DL==1B14 ;WITH DELETE
;READ FLAGS
RD%NXT==1B9 ;READ NEXT RECORD
RD%KRF==1B10 ;KEY OF REFERENCE GIVEN
RD%NIK==1B11 ;NO INVALID KEY/AT END CLAUSE RETURN--CALL
; THE ERROR RETURN
;WRITE FLAGS
WT%SEQ==1B9 ;WRITE WITH SEQUENTIAL ACCESS
WT%NIK==1B11 ;NO INVALID KEY CLAUSE GIVEN
;REWRITE FLAGS -- FOR COMPLETENESS
RW%SEQ==1B9 ;REWRITE WITH SEQUENTIAL ACCESS
RW%NIK==1B11 ;NO INVALID KEY CLAUSE GIVEN
;DELETE FLAG BITS
DL%SEQ==1B9
DL%NIK==1B11 ;NO "INVALID KEY" CLAUSE GIVEN
;START FLAG BITS
STA%EQ==3B13 ;EQUAL TO (IF 0)
STA%NL==1B12 ;NOT LESS THAN
STA%GT==1B13 ;GREATER THAN
STA%AK==1B14 ;START WITH APPROX. KEY
STA%NI==1B15 ;NO "INVALID KEY" CLAUSE GIVEN
;DEQUEUE FLAG BITS
DQ%KEY==10 ;[1450] FREE WITH KEY
DQ%EVR==200 ;[1450] FREE EVERY RECORD
DQ%ALR==400 ;[1474] FREE RECORDS IN ALL FILES
;BIT DEFINITIONS FOR 12B NON-RMS FILES
STA%AP==1B8 ;NON-RMS FILE START WITH APPROX. KEY
IOGEN::
EXTERNAL MOVGEN
EXTERNAL PUTASY, PUTASN
EXTERNAL MOVGN., MXX., MXTMP., MACX., MXAC.
EXTERNAL SETOPN, GETEMP,SUBSCR,PUT.LD,LITD.
EXTERNAL STASHP,STASHQ,POOLIT,POOL,PLITPC
EXTERNAL FATAL, OPFAT,OPWRN, OPNFAT, BADEOP, LNKSET,WARN
EXTERNAL KILL, BMPEOP, EWARN
EXTERNAL ASRJ.,AQRJ.,AZRJ.,SPIFGN,READEM
EXTERNAL FPMODE,F2MODE,DSMODE
EXTERNAL ESIZEZ,ADDI.,TLO.,TLZ.
ENTRY READGN ;"READ" GENERATOR
ENTRY RITEGN ;"WRITE" GENERATOR
ENTRY OPENGN ;"OPEN" GENERATOR
ENTRY CLOSGN ;"CLOSE" GENERATOR
ENTRY STRTGN ;"START" GENERATOR
ENTRY DISPGN ;"DISPLAY" GENERATOR
ENTRY ACCGEN ;"ACCEPT" GENERATOR
ENTRY REWGEN ;"REWRITE" GENERATOR
ENTRY DELGEN ;"DELETE" GENERATOR
ENTRY CRHLD ; CREATE HLDTAB ENTRY FOR "READ INTO" - USED BY RETNGN
INTERN LARGE,LARGER ;[245] FIND LARGEST RECORD FOR A FILE
INTERN INTOCK ;TO CHECK INTO OPTION FOR VALIDITY
SUBTTL OPEN
OPENGN: PUSHJ PP,SETOP ;SET UP EOPTAB
EQUIT;
;AT THIS POINT, IF BASIC-LOCKING IS IN EFFECT AND WE HAVE AN RMS FILE
;OPEN, WE CAN ASSUME THAT IT IS FOR SIMULTANEOUS UPDATE (OPTION 5).
;HOWEVER, WE ARE JUST GOING TO DO A SINGLE FILE OPEN BECAUSE WE DON'T
;HAVE TO WORRY ABOUT ACCUMULATING LOCKS. IF THE USER DOES AN UNAVAILABLE
;CLAUSE ON THE OPEN, HE CAN HANDLE PROBLEMS WITH THE INDIVIDUAL FILE.
;HOWEVER, IF HE DOES NOT, HE WILL GET A FATAL I-O ERROR, AND THAT'S LIFE.
SKIPN ABSEEN## ;APPLY BASIC-LOCKING IN EFFECT?
JRST OPNG1 ; NO - NON-SMU OPEN FOR A FILE
;IF APPLY BASIC-LOCKING HAS BEEN SEEN IN THIS PROGRAM, A LOT OF POSSIBILITIES
;ARISE, AND WE HAVE TO FILTER THEM OUT, AS INDICATED BELOW.
LDB TD,FI.RMS## ;GET RMS FLAG FROM FILE TABLE
LDB TE,[POINT 9,W1,8] ;GET OPCODE OF GENFIL OPERATOR
;FIRST FILTER -- IS IT AN RMS FILE?
SKIPN TD ;SKIP IF FI.RMS BIT IS ON
;IF NOT, SECOND FILTER -- GENFIL OPER MUST BE 62 (ASSUMED)
;FOR A NON-SMU OPEN
JRST [CAIE TE,143 ;WAS GENFIL OPERATOR FOR FENQGN?
JRST OPNG1 ; NO - NON-SMU OPEN
MOVEI DW,E.833 ;YES - FATAL ERROR
JRST OPFAT] ;
;FOR RMS FILE -- SECOND FILTER -- IS GENFIL OPERATOR 143 FOR SMU?
LDB TC,FI.ABL## ;GET FILE'S BASIC-LOCKING FLAG
CAIE TE,143 ;WAS GENFIL OPERATOR FOR FENQGN?
JRST OPNG1 ;NO - NON-SMU OPEN
;FOR SMU OPEN - THIRD FILTER -- BASIC LOCKING ON THIS FILE?
SKIPE TC ;DOING OPEN FOR BASIC-LOCKING
JRST OPENG2 ; YES, SKIP OVER STUFF FOR NON RMS OPEN
MOVEI DW,E.833 ;NO - FATAL ERROR
JRST OPFAT ;
OPNG1:
;DON'T ALLOW "OPEN EXTEND" FOR ANYTHING BUT SEQUENTIAL FILES.
TXNN W1,1B13 ;IS THE "EXTEND" BIT ON?
JRST OPENG0 ;NO
LDB TE,FI.ORG ;FETCH FILE ORGANIZATION
CAIE TE,%ACC.S ;SEQUENTIAL?
JRST ENOPNX ;NO, COMPLAIN
OPENG0: LDB CH,FI.LCI## ;NEED TO CONVERT LINAGE-COUNTER
JUMPE CH,OPENG2 ;NO
PUSHJ PP,RIFTAG## ;REFERENCE IF TAG
HRLI CH,EPJPP ;"PUSHJ PP,"
PUSHJ PP,PUTASY ;GENERATE CALL TO INLINE ROUTINE
OPENG2: LDB TE,FI.RMS## ;IS THIS AN RMS FILE?
JUMPN TE,OPNM ;YES, GO DO IT
MOVSI CH,OPN##
LDB TE,[POINT 2,W1,14]
DPB TE,[POINT 2,CH,14] ;PASS ON OPEN EXTENDED AND REVERSED
OPNGN1: LDB TE,[POINT 3,W1,11]
DPB TE,[POINT 3,CH,11]
OPNGN3: PUSHJ PP,CNVKYB ;SEE IF KEY NEEDS CONVERTING
PUSHJ PP,PUTOP
PUSHJ PP,CNVKYC ;SEE IF KEY NEEDS CONVERTING BACK
OPNGN4: LDB CH,FI.DEB## ;WANT DEBUG CODE FOR THIS FILE?
JUMPE CH,CPOPJ ;NO
MOVEI CH,DBIO.## ;YES
OPNGN5: PUSHJ PP,PUT.PJ ;PUSHJ 17,DBIO. OR DBRD.
MOVE CH,[AS.XWD,,1]
PUSHJ PP,PUTASN
LDB CH,[POINT 13,PREVW1##,28] ;GET LINE # OF PREVIOUS OPERATOR
PUSHJ PP,PUTASN
HLRZ CH,CURFIL
IORI CH,AS.FIL ;CONVERT INTO FILTAB ADDRESS
JRST PUTASY ;XWD LINE #,FILTAB
SUBTTL OPEN RMS FILE
OPNM:: MOVEI TD,V%OPEN ;[1652]SET OPEN VERB
DPB TD,O.BOPR ;TELL LIBOL THE OPERATION
LDB TE,[POINT 9,W1,8] ;GET GENFIL OP CODE BACK FROM W1
CAIE TE,143 ;GENFIL OPCODE OF 143 FOR RMS SMU?
JRST OPNM1 ; NO
LDB TE,FI.ABL## ;APPLY BASIC-LOCKING TO THIS FILE?
JUMPE TE,OPNM1 ; NO
MOVEI TD,V%OPS5 ;SMU OPTION 5 STYLE OPEN
DPB TD,O.BOPR ; OPERATION CODE TO PASS TO LSU
LDB TD,[POINT 9,W1,17] ;GET BITS FOR SELF, OTHERS, + FLAGS
DPB TD,O.SM5B ; AND PUT IN IOFLAGS WORD
LDB TD,[POINT 1,W2,17] ;GET UNAVAILABLE FLAG
MOVSS TD,TD ; GET IT IN THE LEFT HALF OF THE AC
IORM TD,IOFLGS## ; AND PUT IT INTO THE I-O FLAG WORD
JRST OPNM2 ;HOP OVER NON-SMU I-O CODE PROCESSING.
OPNM1:
; SET IOFLGS FOR TYPE OF OPEN
MOVX TD,OPN%IN ;INPUT
MOVE TE,EIOOP ;[1652]GET OPERATOR
CAIE TE,SORT## ;[1652]SORT?
JRST OPNM11 ;[1652]NO
IORM TD,IOFLGS ;[1652]YES, SET INPUT
JRST OPNM2 ;[1652]AND CONTINUE
OPNM11: TXNE W1,1B10 ;[1652] "INPUT"
IORM TD,IOFLGS ;SET IN IO FLAGS.
MOVX TD,OPN%OU ;OUTPUT
TXNE W1,1B9 ;"OUTPUT"
IORM TD,IOFLGS## ;SET IN IO FLAGS
MOVX TD,OPN%IO
LDB TE,[POINT 2,W1,10] ;"INPUT" AND "OUTPUT" BITS
CAIN TE,3 ;BOTH SET?
IORM TD,IOFLGS## ;YES, NOW ALL THREE SET IN IOFLGS
MOVX TD,OPN%EX ;SET UP OPEN FOR EXTEND BIT
TXNE W1,1B13 ;EXTEND BIT SET IN FILE FLAG WORD?
IORM TD,IOFLGS## ;YES, SET IT IN IO FLAG WORD
REPEAT 0,<
;GET PTR TO KEYS
PUSHJ PP,KYPTR ;GET KEY PTR IN EACA
POPJ PP, ;RETURN ON ERRORS
;GENERATE AN "OPEN" ARG LIST:
; FLAG-BITS,,FILTAB-ADDR
; 0,,ADDR OF KEY-INFO NOTE: THIS LINE NOT GENERATED IN V13
PUSH PP,EACA ;SAVE ADDR OF KEY-INFO
> ; END REPEAT 0
OPNM2: ;START TO GENERATE THE LITERAL BLOCK.
MOVE TE,ELITPC ;SAVE LITERAL PC NOW
MOVEM TE,LPCSAV
MOVE TA,[XWDLIT,,2] ;START OF LITERAL BLOCK
PUSHJ PP,STASHP
HLLZ TA,IOFLGS ;GET FLAG BITS
HRRI TA,AS.CNB
PUSHJ PP,STASHQ ;PUT IT OUT
HLRZ TA,CURFIL ;CURRENT FILE
IORI TA,AS.FIL ; SAY IN FILTAB
REPEAT 0,<
PUSHJ PP,STASHQ ;WRITE IT OUT
AOS ELITPC ;BUMP LITERAL PC
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHP ;NEXT WORD
SETZ TA,
PUSHJ PP,STASHQ ;XWD 0,,
POP PP,EACA ; ADDRESS OF KEY INFO
HRLZ TA,EACA ;%LIT00
HRRI TA,AS.MSC
> ; END REPEAT 0
PUSHJ PP,POOLIT ;FINISH UP AND POOL LITERALS
AOS ELITPC ;BUMP LITERAL PC
MOVE TE,LPCSAV ;IF WE POOLED, RESTORE LITERAL PC
SKIPE PLITPC
MOVEM TE,ELITPC
;GENERATE "MOVEI 16,ADDR"
; "PUSHJ PP,OP.MIX"
SKIPN CH,PLITPC ;GET PC IF POOLED
MOVE CH,LPCSAV ;NOT POOLED, GET STARTING PC
IORI CH,AS.LIT
PUSH PP,CH ;SAVE INCREMENT IN %TEMP
MOVE CH,[MOVEI.+AC16+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
POP PP,CH ;GET INCREMENT
PUSHJ PP,PUTASN ;WRITE IT
MOVEI CH,OP.MIX##
PUSHJ PP,PUT.PJ
HLRZ TA,CURFIL ;CHECK TO SEE IF DEBUGGING WANTED
ADD TA,FILLOC ;FOR THIS FILE
JRST OPNGN4 ;TA: = PTR TO FILTAB ENTRY
;HERE TO GIVE ERROR IF HE SAID "OPEN EXTEND"
ENOPNX: MOVEI DW,E.631 ;"OPEN EXTEND only allowed for sequential files"
JRST OPFAT ;GIVE FATAL ERROR AND POPJ
;GENERATE A "CLOSE"
CLOSGN: PUSHJ PP,SETOP
EQUIT;
LDB TE,FI.RMS## ;CHECK FOR RMS FILE
JUMPN TE,CLOM ; GO GENERATE THE RMS CLOSE
MOVSI CH,CLOS##
TLNE W1,(1B13) ;IF 'FOR REMOVAL' BIT ON
TLO CH,(1B13) ;PASS IT ON
TLNN W1,DELETF ;IF 'DELETE' FLAG NOT UP,
JRST OPNGN1 ; THIS IS A STANDARD CLOSE
MOVSI CH,PURGE. ;THIS IS A 'CLOSE WITH DELETE'
JRST OPNGN3 ;SEE IF KEY NEEDS CONVERTING
SUBTTL RMS CLOSE
CLOM:: MOVEI TE,V%CLOS ;[1652]TELL LIBOL THIS IS "CLOSE"
DPB TE,O.BOPR ;SET LIBOL OPERATION CODE
MOVX TE,CLS%CF ;TURN ON "CLOSE" BIT
IORM TE,IOFLGS
MOVX TE,CLS%LK ;WITH LOCK
TXNE W1,1B10
IORM TE,IOFLGS ;YES, TURN ON FLAG
MOVX TE,CLS%DL ;WITH DELETE
TXNE W1,1B12
IORM TE,IOFLGS ;YES, TURN ON FLAG
;ARGLIST: FLAG-BITS,,FILTAB-ADDR
PUSHJ PP,STDAGL ;STANDARD ARG LIST
;GEN "PUSHJ PP,CL.MIX"
MOVEI CH,CL.MIX##
PUSHJ PP,PUT.PJ
HLRZ TA,CURFIL ;CHECK TO SEE IF DEBUGGING WANTED
ADD TA,FILLOC ;FOR THIS FILE
JRST OPNGN4 ;TA: = PTR TO FILTAB ENTRY
SUBTTL STDAGL - WRITE A STANDARD ARG LIST AND MOVEI 16,ADDR
;CALL: IOFLGS/ IO FLAGS
; PUSHJ PP,STDAGL
; <RETURN HERE>
;CODE GENERATED:
; MOVEI 16,%LITT
; . .
;%LITT: FLAG-BITS,,FILTAB-ADDR
STDAGL: PUSH PP,ELITPC ;SAVE CURRENT LIT PC
PUSHJ PP,STDW1 ;WRITE STD. WORD 1
PUSHJ PP,POOL ;POOL THE LITERAL
SKIPN PLITPC ;DID WE POOL?
AOS ELITPC ;NO, BUMP LITERAL PC
POP PP,CH ;GET STARTING PC
SKIPE PLITPC ; IF WE POOLED,
MOVE CH,PLITPC ;USE THAT
IORI CH,AS.LIT ;MAKE IT LOOK LIKE A LITERAL ADDRESS
PUSH PP,CH
MOVE CH,[MOVEI.+AC16+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
POP PP,CH
PJRST PUTASN
;WRITE 1ST STD WORD, DON'T TOUCH ELITPC.
; FORMAT IS XWD FLAGS,FILE-TABLE-ADDRESS
STDW1: MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHP
HLLZ TA,IOFLGS
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
HLRZ TA,CURFIL
IORI TA,AS.FIL
PJRST STASHQ
SUBTTL READ
READGN: PUSHJ PP,SETOP ;SET UP OPERAND
EQUIT; ;QUIT IF ERRORS
LDB TE,FI.RMS ;RMS FILE?
JUMPN TE,READM ;YES
MOVEI CH,READ##
LDB TE,FI.ORG ;[1412] GET FILE ORGANIZATION
CAIE TE,%ACC.I ;[1412] IS IT INDEXED?
JRST RDGNX ;[1412] NO,
LDB TE,FI.FAM ;[1412] YES, CHECK ACCESS MODE.
CAIE TE,%FAM.S ;[1412] IF SEQUENTIAL, JUST DO READ NEXT.
RDGNX: ;[1412] OTHERWISE DO CHECK FOR READ NEXT.
TLNE W1,(1B10) ;READ NEXT?
MOVEI CH,RDNXT.## ;YES
MOVEM CH,EIOOP
PUSHJ PP,VLTST ;[605] TEST FOR VARIABLE LENGTH
RDGN0: SETZM EINTO ;CLEAR "INTO" INDICATION
TLNN W1,INTO ;"INTO" OPTION FOR THIS READ?
JRST RDGN1 ;NO
PUSHJ PP,LARGE ;YES--FIND LARGEST DATA RECORD FOR THIS FILE
PUSHJ PP,INTOOK ;SEE IF "INTO" OK
JRST RDGN9 ;NO, GO COMPLAIN
PUSHJ PP,INTOCK ;SEE IF INTO IS ALLOWED
RDGN1: HRRZ CH,EIOOP ;17-AUG-79 /DAW DON'T ALLOW DELETE FOR SEQ. FILE
CAIE CH,DELETE##
JRST RDGN1A ;NOT DELETE, OK
MOVE TA,CURFIL ;FIND ACCESS MODE FOR FILE
LDB TD,FI.ORG
JUMPN TD,RDGN1A ;DELETE IS OK
MOVEI DW,E.729 ;"DELETE NOT ALLOWED FOR SEQ FILES"
PUSHJ PP,OPFAT
RDGN1A: MOVS CH,EIOOP
PUSHJ PP,CNVKYB ;SEE IF KEY NEEDS CONVERTING
PUSHJ PP,PUTOP
PUSHJ PP,CNVKYA ;SEE IF KEY NEEDS CONVERTING BACK
;"READ" (CONT'D)
;CHECK TO SEE THAT THE NEXT OPERATOR IS "SPIF"
PUSHJ PP,RDGN10 ;READ UP THRU NEXT OPERATOR
CAIN TE,SPIF. ;IS IT SPIF.?
TLNN W1,ATINVK ;AND SOME KIND OF AT-END/INVALID-KEY ?
JRST RDGN5 ;NO
LDB TE,FI.FAM## ;GET ACCESS MODE
JRST @[EXP RDGN2,RDGN2,RDGN3D,RDGN3D](TE)
RDGN3D: MOVE TE,EIOOP ;GET LAST OPERATOR
CAIE TE,RDNXT. ;READ NEXT IS SEQUENTIAL
JRST RDGN3 ;RANDOM
;SEQUENTIAL
RDGN2: TLNE W1,ATEND ;YES--IS SPIF "AT END"?
JRST SPIF74 ;YES--DO IT
MOVEI DW,E.208 ;NO--TROUBLE
JRST RDGN4
RDGN3: TLNE W1,INVKEY ;IT'S RANDOM FILE--IS SPIF "INVALID KEY"?
JRST SPIF74 ;YES--DO IT
MOVEI DW,E.209 ;NO--TROUBLE
RDGN4: LDB CP,W1CP
LDB LN,W1LN
PUSHJ PP,WARN
JRST SPIFGC
RDGN5: CAIE TE,NOOP.## ;DUMMY TO MAKE READ HAPPY?
JRST RDGN6 ;NO
MOVE TE,EIOOP ;
CAIE TE,DELETE ;IF DELETE <FILE-NAME>
JRST RDGN5A ;NOT
LDB TE,FI.FAM ;GET ACCESS
CAIG TE,%FAM.S ;IF SEQUENTIAL
JRST NOOPGN ;GENERATE A NOOP SINCE INVALID KEY NOT ALLOWED
RDGN5A: LDB TA,FI.ERR## ;SEE IF THERE IS A FILE SPECIFIC ERROR PROCEDURE
JUMPE TA,[SKIPN TB,USP.I## ;NO, SEE IF GENERAL USE PROCEDURE
SKIPE TB,USP.IO## ;OR FOR I-O
JRST RDGN5C ;OK, USE IT
JRST RDGN6A] ;NO, GIVE ERROR RETURN
RDGN5B: LDB TB,LNKCOD
CAIE TB,CD.PRO
JRST RDGN6A ;NOT A PROTAB LINK
PUSHJ PP,LNKSET ;GET PROTAB
MOVE TB,PR.DUP##(TA) ;GET PR.SFI AND PR.DEB
MOVE TE,EIOOP ;GET I/O OPERATOR
RDGN5C: HLRZ TA,CURFIL
ADD TA,FILLOC
MOVE CH,[JRST.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZI CH,AS.DOT+2
TLNE TB,-1 ;IF DEBUGGING ON PROCEDURE-NAME?
ADDI CH,3 ;WE NEED MORE SPACE
MOVE TE,EIOOP
CAIN TE,DELETE
TDZA TE,TE ;DON'T DEBUG ON DELETE OR
LDB TE,FI.DEB ;ARE WE DUBUGGING ON FILE-NAME?
SKIPE TE
ADDI CH,1 ;YES, NEED JUMP AROUND SPIF. CODE
PUSHJ PP,PUTASN ;OK RETURN
TLNN TB,-1 ;IF NOT DEBUGGING?
JRST RDGN5D ;DON'T GENERATE SPECIAL CODE
PUSHJ PP,IODBU ;GENERATE SOME CODE
MOVE TE,EIOOP
CAIN TE,DELETE
TDZA CH,CH
LDB CH,FI.DEB ;DO WE NEED DEBUGGING CODE?
JUMPE CH,RDGN5D ;NO
MOVE CH,TB ;GET TAG
HRLI CH,EPJPP ;PUSHJ PP,
PUSHJ PP,PUTASY## ;EOF RETURN
MOVE CH,[JRST.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
MOVEI CH,AS.DOT+3
PUSHJ PP,PUTASN
PUSHJ PP,RDGN5E
PUSHJ PP,CRHLD ;CREATE HLDTAB ENTRY
JRST ENDIFR## ;SEE IF READ INTO
RDGN5D: MOVE CH,TB ;GET TAG
HRLI CH,EPJPP ;PUSHJ PP,
PUSHJ PP,PUTASY## ;EOF RETURN
PUSHJ PP,CRHLD ;CREATE HLDTAB ENTRY
JRST ENDIFR## ;SEE IF READ INTO
RDGN5E: MOVE TE,EIOOP ;SEE WHAT IT WAS
CAIE TE,READ
CAIN TE,RDNXT.
JRST [MOVEI CH,DBRD.## ;READ IS SPECIAL
JRST OPNGN5] ;AS DEBUG HAS MORE TO DO
JRST OPNGN4 ;PUT OUT DBIO. CODE
;READ WAS NOT FOLLOWED BY A "SPIF" OF CORRECT TYPE
;CHECK FOR USE ERROR PROCEDURE AND IF GIVEN USE IT
RDGN6: MOVE TA,CURFIL
LDB TE,FI.ENT## ;IS USE PROCEDURE FOR OPEN
JUMPN TE,RDGN6A ;YES, GIVE ERROR
LDB TA,FI.ERR## ;ERROR USE GIVEN
JUMPN TA,RDGN5B ;YES, OUTPUT IT
RDGN6A: MOVE TA,CURFIL
MOVEI DW,E.318 ;ASSUME FILE IS SEQUENTIAL
LDB TE,FI.ORG ;IF FILE IS NOT
SKIPE TE ; SEQUENTIAL
MOVEI DW,E.319 ; USE 'INVALID KEY REQUIRED'
RDGN7: MOVE TC,OPLINE
LDB CP,TCCP
LDB LN,TCLN
PUSHJ PP,FATAL
CAIN W2,NOOP. ;IF NOOP.,
POPJ PP, ; SKIP IT
JRST GO2NXT ;GO TO NEXT OPERATOR ACTION
;NOT ENOUGH OPERANDS FOR "READ INTO"
RDGN9: SETZM EINTO
JRST BADEOP
;READ UP THRU NEXT OPERATOR
RDGN10: MOVE EACA,EOPLOC ;RESET
MOVEM EACA,EOPNXT ; EOPTAB
SETZB EACC,ETEMPC ;MORE RESETS
PUSHJ PP,READEM ;DO THE READ
HRRZ TE,W2 ;PICK UP OPERATOR CODE
MOVE TA,CURFIL ;SET 'TA' TO CURRENT FILE
POPJ PP,
;SEE IF DEBUGGING CODE IS NEEDED AFTER CALL TO SPIF.
SPIF74: LDB TD,FI.DEB ;DEBUGGING ON FILE-NAME
JUMPE TD,SPIFGC ;NO
MOVE TE,PREVW1 ;YES, GET LINE # OF PREVIOUS OPERATOR
MOVEM TE,DBSPIF+1 ;SAVE LINE NUMBER
MOVE TE,EIOOP ;CURRENT OPERATOR
HLLZ TD,CURFIL ;GET FILE-TABLE
HRRI TD,DBIO. ;ROUTINE TO USE
CAIE TE,READ ;UNLESS READ
CAIN TE,RDNXT. ;OR READ NEXT
HRRI TD,DBRD. ;IN WHICH CASE WE NEED DBRD.
MOVEM TD,DBSPIF## ;FLAG TO BE DONE AFTER SPIF.
JRST SPIFGC
SPIFGC: PUSHJ PP,CRHLD ;CREATE HLDTAB ENTRY FOR "ENDIFG"
JRST SPIFGN ;GO TO IFGEN TO GENERATE THE INITIAL "JRST"
SUBTTL RMS READ
READM:: MOVEI TE,V%READ ;[1652]TELL LIBOL THIS IS A "READ"
DPB TE,O.BOPR ; . .
MOVX TE,RD%NXT ;GET BIT TO SET
MOVE TA,CURFIL
LDB TD,FI.FAM ;IF SEQ. ACCESS, TURN THE BIT ON
CAIE TD,%FAM.S
TXNE W1,1B10 ; SHALL WE?
IORM TE,IOFLGS ;YES
;CHECK FOR VARIABLE LENGTH RECORDS WHERE THE DEPENDING ITEM
;IS NOT PART OF THE RECORD ITSELF
;.. SET UP "EDEPFT" FOR IFGEN IF IT IS.
PUSHJ PP,VLTST
;CHECK FOR "READ .. KEY IS .."
;COBOLD HAS ONLY ALLOWED THIS SYNTAX WHEN:
;1) FILE ORGANIZATION IS INDEXED
;2) FILE ACCESS IS NOT SEQUENTIAL
;3) "READ NEXT" HAS NOT BEEN SPECIFIED
SETZM KEYREF## ;CLEAR "KEY OF REFERENCE"
TXNN W1,1B11 ;"KEY IS"?
JRST RDM0 ;NO
;FIND THE OPERAND, GET KEY OF REFERENCE (WHICH WILL BE 2ND WORD),
; THEN BLT DOWN THE REST OF THE OPERANDS AS IF "KEY IS" WAS THE SECOND
; ONE GIVEN. (THIS IS BECAUSE COBOLD HAS PROCESSED THE OPERANDS IN
; ANY ORDER).
MOVE TC,OPERND ;GO GET OPERAND
MOVEM TC,CUREOP
RDM00: PUSHJ PP,BMPEOP
POPJ PP, ;ERRORS.. RETURN
MOVE TC,CUREOP ;POINT TO CURRENT OPERAND (-1 + KEY)
MOVE TD,0(TC) ;IS THIS THE ONE?
CAME TD,[-1]
JRST RDM00 ;NO, GO LOOK FOR IT
MOVE TD,1(TC) ;GET KEY OF REFERENCE
MOVEM TD,KEYREF## ;STORE AWAY
HRRZ TE,EOPNXT ;COPY REST OF OPERANDS DOWN
SUBI TE,2 ;TO HERE
HRRZ TD,OPERND ;FROM HERE
SUB TD,TE ;GET -# WORDS
HRLI TE,-1 ;PREVENT "PUSHDOWN OVERFLOW"
AOJE TD,RDM0 ;JUMP IF NO MORE OPERANDS TO POP
POP TE,2(TE) ;COPY OPERAND
JRST .-2 ;LOOP
;CHECK FOR "READ INTO"
RDM0: SETZM EINTO ;CLEAR "INTO" INDICATOR
MOVE TE,EIOOP ;[1652]CHECK FOR SORT
CAIE TE,SORT## ;[1652]
TLNN W1,INTO ;"INTO" OPTION FOR THIS READ?
JRST RDM1 ;[1652]NOT INTO, OR SORT
PUSHJ PP,LARGE ;INTO--FIND LARGEST DATA RECORD FOR THIS FILE
SKIPE KEYREF ;SKIP IF NO KEY OF REFERENCE ITEM
JRST [PUSHJ PP,INTOK1 ;THERE IS ANOTHER OPERAND TO WORRY ABOUT
JRST RDGN9 ;NOT SUFFICIENT
JRST RDM0A] ;OK
PUSHJ PP,INTOOK ; SEE IF "INTO" IS OK
JRST RDGN9 ;NO, COMPLAIN
RDM0A: PUSHJ PP,INTOCK ;SEE IF INTO IS ALLOWED
;;AT THIS POINT WE ARE DONE READING ALL OPERANDS FOR THE "READ".
; WE WILL READ AHEAD TO SEE IF AN INVALID KEY/AT END CLAUSE IS
; PRESENT
RDM1:
PUSHJ PP,CNVKYB ;CHECK IF GENERATE KEY CONVERSION ROUTINE
PUSHJ PP,RDGN10 ;READ UP THRU NEXT OPERATOR
CAIN TE,SPIF. ;IS IT SPIF.?
TLNN W1,ATINVK ;AND SOME KIND OF AT END/INVALID KEY?
JRST RDM7 ;NO
;A SPIF. IS THERE. MAKE SURE IT IS THE PROPER TYPE.
MOVE TD,IOFLGS ;GET FLAGS FOR THE READ
TXNN TD,RD%NXT ;SKIP IF A "READ NEXT"
JRST RDM5 ;NO
;READ NEXT.. AT END
TLNE W1,ATEND ;AT END?
JRST RDM6 ;YES, GO DO IT
MOVEI DW,E.208 ;NO, GIVE ERROR
JRST RDM5A
RDM5: TLNE W1,INVKEY ;"INVALID KEY"
JRST RDM6 ;YES, GO DO IT
MOVEI DW,E.209 ;NO, GIVE ERROR
RDM5A: PUSHJ PP,OPWRN ;SOMETHING ASSUMED..
JRST RDM6 ;GO DO IT
;HERE IF NO SPIF AFTER THE READ.. CHECK FOR "USE" PROCEDURE
; AND GIVE ERROR IF THERE IS NONE.
RDM7: HLRZ TA,CURFIL
ADD TA,FILLOC
LDB TE,FI.ENT## ;IS USE PROCEDURE FOR OPEN
JUMPN TE,RDM6A ;YES, GIVE ERROR
LDB TA,FI.ERR## ;ERROR USE GIVEN
JUMPN TA,RDM7A ;YES, GO OUTPUT IT
SKIPN TB,USP.I## ;NO, SEE IF A GENERAL USE PROCEDURE
SKIPE TB,USP.IO## ; OR FOR I-O
JRST RDM7A ;YES, USE IT
MOVE TE,EIOOP ;[1652]GET OPERATOR
CAIN TE,SORT## ;[1652]IS IT SORT
JRST RDM7A ;[1652]YES
;NO VALID "USE" PROCEDURE AND "INVALID KEY" OR "AT END" NOT GIVEN.
; THIS IS AN ERROR.
RDM6A: MOVEI DW,E.129 ;"AT END" OR "INVALID KEY" CLAUSE MISSING
JRST RDGN7 ;GO GIVE ERROR
RDM7A: MOVX TE,RD%NIK ;SET "NO AT END RETURN"
IORM TE,IOFLGS ;SET THE FLAG
RDM6: MOVE TE,IOFLGS ;GET IO FLAGS
TXNE TE,RD%NXT ;READ NEXT?
JRST RDM2 ;NO, ONE-WORD ARG LIST
SKIPE KEYREF ;DO WE HAVE A KEY OF REFERENCE?
MOVX TE,RD%KRF ;YES, SAY "KEY OF REFERENCE GIVEN"
IORM TE,IOFLGS
;GET OCTAL ADDRESS OF KEY, AND PUT IN ADRKEY
HLRZ TA,CURFIL ;POINT TO CURRENT FILE
ADD TA,FILLOC
MOVE TE,KEYREF ;GET KEY OF REFERENCE
CAILE TE,1 ;SKIP IF PRIMARY KEY, OR NONE GIVEN
JRST RDM1A ;ALTERNATE KEY
LDB TA,FI.RKY ;GET RECORD KEY DATANAME
PUSHJ PP,UKADR ; GET KEY ADDRESS, AND USE IT
JRST RDM1B
;ALTERNATE KEY - FIND A KEY BUFFER ADDRESS
RDM1A: LDB TA,FI.ALK## ;FIND POINTER TO FIRST ALTERNATE KEY
ADD TA,AKTLOC ;GET ABS POINTER
SUBI TE,2 ;TE= OFFSET INTO AKTTAB
IMULI TE,SZ.AKT ; # SIZE OF ENTRY = OFFSET TO FIRST WORD
ADD TA,TE ;TA POINTS TO ENTRY NOW
LDB TA,AK.DLK ;GET DATANAME LINK
PUSHJ PP,UKADR ; GET KEY ADDRESS, AND USE IT
;"KEYADR" HAS NOW BEEN SET UP
RDM1B: EQUIT; ;QUIT IF ERRORS SO FAR
PUSH PP,ELITPC ;SAVE STARTING LITERAL PC
PUSHJ PP,STDW1 ;WRITE STD WORD 1
AOS ELITPC ;BUMP LITERAL PC
;WRITE KEY OF REF,,ADDR OF KEY
MOVE TA,[XWDLIT,,2] ;WRITE THE STUFF
PUSHJ PP,STASHP
MOVE TA,KEYREF
SKIPE TA ;WRITE 0 IF NONE GIVEN
SUBI TA,1 ;MAKE PRIMARY=0, ETC.
PUSHJ PP,STASHQ ;XWD KEYREF,
MOVE TA,KEYADR## ;GET KEY ADDRESS
PUSHJ PP,POOLIT ;FINISH XWD, AND LITERAL POOL
MOVE CH,[MOVEI.+AC16+ASINC,,AS.MSC]
PUSHJ PP,PUTASY ;START MOVEI OF ARG LIST INST.
POP PP,CH ;GET OLD LITERAL PC
SKIPN PLITPC ;DID WE POOL?
AOSA ELITPC ;NO, BUMP LITERAL PC
MOVEM CH,ELITPC ;YES, RESTORE ORIGINAL
SKIPE PLITPC ;SKIP IF WE DIDN'T
MOVE CH,PLITPC ;GET THE POOLED VALUE
IORI CH,AS.LIT ; MAKE IT LOOK LIKE A LITERAL
PUSHJ PP,PUTASN ;FINISH ARG
JRST RDM3 ;NOW GO GENERATE THE PUSHJ
;GENERATE THE "READ NEXT" ARG LIST AND MOVEI 16,%LIT
RDM2: PUSHJ PP,STDAGL ;STANDARD ARG LIST
;DECIDE WHICH ROUTINE TO CALL, BASED ON THE ACCESS MODE
RDM3: MOVEI CH,RD.MIR## ;ASSUME RANDOM
MOVE TE,IOFLGS ;SEE IF READ NEXT
TXNE TE,RD%NXT
MOVEI CH,RD.MIS## ;YES, SEQUENTIAL ACCESS
RDM4:
MOVE TE,EIOOP ;[1652]GET OPERATOR
CAIN TE,SORT## ;[1652]IS IT SORT?
MOVEI CH,RD.MIS## ;[1652]ALWAYS READ SEQ.
PUSHJ PP,PUT.PJ ;GENERATE CALL
PUSHJ PP,CNVKYA ;CHECK IF GENERATE KEY CONVERSION ROUTINES
MOVE TE,EIOOP ;[1652]GET OPERATOR
CAIN TE,SORT## ;[1652]IS IT SORT?
POPJ PP, ;[1652]YES, LET'S LEAVE.
MOVE TE,IOFLGS ;DO WE HAVE A SPIF. WAITING?
TXNE TE,RD%NIK
JRST RDMNSP ;NO
HLRZ TA,CURFIL
ADD TA,FILLOC
LDB TD,FI.DEB ;DEBUGGING ON FILE-NAME?
JUMPE TD,SPIFGC ;NO
MOVEM W1,DBSPIF+1 ;YES, SAVE LINE NUMBER
HLLZ TD,CURFIL ;GET FILE-TABLE NUMBER
HRRI TD,DBRD. ;ROUTINE TO USE
MOVEM TD,DBSPIF## ;FLAG TO BE DONE AFTER SPIF.
JRST SPIFGC
;READ HAD NO SPECIAL "IF" - CALL THE ERROR USE PROCEDURE
RDMNSP: HLRZ TA,CURFIL ;SET UP "TA" THE WAY RDGN5A EXPECTS IT
ADD TA,FILLOC
JRST RDGN5A ;GO REJOIN OLD CODE
SUBTTL CRHLD - CREATE HLDTAB ENTRY FOR READ
; CRHLD creates a HLDTAB entry for every "SPIF" seen. See
;comments in IFGEN at ENDIFG to see how it is used.
;
;Input parameters:
; EINTO - if non-zero, "into" operand is stored
; EDEPFT - variable length read information
;[74] DBSPIF - debugging code
;
;Output parameters:
; -NONE-
CRHLD: MOVSI TA,CD.HLD ;HLDTAB CODE
HRRI TA,.HESIZ ;SIZE OF ENTRY NEEDED
PUSHJ PP,GETENT## ;RETURNS ADDRESS IN TA
MOVE TD,PTRHLD## ;GET PREVIOUS POINTER
HLRZM TA,PTRHLD## ;STORE NEW PTR
MOVEM TD,.HEHDR(TA) ;SAVE OLD PTR IN NEW ENTRY
;Store information in the entry
SKIPN EINTO ;READ..INTO OR RETURN..INTO?
JRST CRHLD1 ;NO
MOVX TB,HE%RIN ;SET FLAG
IORM TB,PTRHLD ; IN PTRHLD
HRLI TB,EINTO ;COPY FROM HERE..
HRRI TB,.HERIN(TA) ; TO HERE
MOVEI TC,.HERIN(TA) ; FIND LAST LOCATION
ADDI TC,OPNSIZ+OPNMAX
BLT TB,-1(TC) ;COPY THE TWO OPERANDS..
SETZM EINTO ;CLEAR FLAG
CRHLD1: SKIPN TE,EDEPFT ;READ... VARIABLE LENGTH RECORD?
JRST CRHLD2 ;NO
MOVX TB,HE%VLR ;SET THE FLAG
IORM TB,PTRHLD ; IN PTRHLD
MOVEM TE,.HEVLR(TA) ;STORE THE WORD IN HLDTAB ENTRY
SETZM EDEPFT ;CLEAR FLAG
CRHLD2: SKIPN TE,DBSPIF ;SPECIAL-IF CODE?
JRST CRHLD3 ;NO
MOVX TB,HE%DEB ;SET THE FLAG
IORM TB,PTRHLD ; IN PTRHLD
MOVEM TE,.HEDEB(TA) ;STORE THE WORD IN HLDTAB ENTRY
SETZM DBSPIF ;CLEAR FLAG
CRHLD3: POPJ PP, ;RETURN NOW
SUBTTL INTOOK - SEE IF "INTO" CLAUSE IS OK
;THIS ROUTINE SKIPS IF # OPERANDS FOR "INTO" IS SUFFICIENT
; IF OK, STORE IN EINTO
INTOOK: HRRZ TA,EOPLOC
ADDI TA,1 ;LOCATION OF 1ST OPERAND
HRRZ TE,EOPNXT
SUBI TE,2(TA) ;TOTAL NUMBER OF SPARE WORDS
JUMPL TE,CPOPJ ;BETTER BE AT LEAST ONE MORE OPERAND
HRLI TD,2(TA) ;FROM HERE..
PUSHJ PP,INTOCP ;COPY OPERAND
JRST CPOPJ1 ;SKIP RETURN
;SAME AS ABOVE, BUT ACCOUNTS FOR AN OPERAND BEFORE THE REST.
INTOK1: MOVE TA,OPERND
HRRZ TE,EOPNXT
SUBI TE,4(TA) ;TWO OPERANDS, EACH TWO WORDS
JUMPL TE,CPOPJ ;THERE BETTER BE MORE..
HRLI TD,4(TA) ;START AT THE 3RD OPERAND
PUSHJ PP,INTOCP ;COPY OPERAND
JRST CPOPJ1 ;SKIP RETURN
;COPY OPERAND TO EINTO
; TE/ # WORDS TO COPY - 1
; TD/ ADDRESS TO START AT,,XXX
INTOCP: ADDI TE,EINTO+3 ;TE= FINAL ADDRESS
HRRI TD,EINTO+2 ;COPY TO HERE
BLT TD,(TE) ;COPY OPERAND TO HLDTAB
POPJ PP, ;RETURN
SUBTTL REWRITE -- WRITE
REWGEN: PUSHJ PP,SETOP ;SET UP OPERAND
EQUIT; ;QUIT IF ERRORS
MOVEI CH,RERIT.
JRST RITGN0
;SUBTTL WRITE
RITEGN: PUSHJ PP,SETOP ;SET UP OPERAND
EQUIT; ;QUIT IF ERRORS
MOVEI CH,WRITE## ;SET UP 'WRITE' UUO
RITGN0: MOVEM CH,EIOOP
RITG00: MOVE TE,CURFIL ;OPERAND IS ACTUALLY
MOVEM TE,CURDAT ; A RECORD-NAME
PUSHJ PP,GTFATH ;SET UP "FT"
EQUIT
MOVE TA,CURFIL
LDB TE,FI.RMS ;RMS BIT SET?
JUMPN TE,WRTM ;YES, GO GENERATE THE CODE
MOVE TA,CURDAT
LDB TE,DA.EXS ;GET RECORD SIZE
REPEAT 0,<
;EDIT 512 WAS ADDED TO WRITE OUT ONLY 1 WORD FOR A 1-WORD COMP RECORD.
; IF THE KEY WAS S9(10), COBOL TREATED THIS AS 10 CHARACTERS, WHICH
; TRANSLATED TO 2 WORDS IN CBLIO.
;
; THIS IS REMOVED IN VERSION 12 FIELD TEST BECAUSE SOMEONE FOUND THAT
;THIS MAKES IT INCOMPATIBLE WITH READ. FIXING "READ" IS NOT A GOOD IDEA
;BECAUSE THAT MAKES IT INCOMPATIBLE WITH FILES WRITTEN BEFORE VERSION 12.
;THEREFORE, THE OLD CODE HAS BEEN RESTORED.
LDB TB,DA.USG ;[512] GET USAGE
SKIPE EBCMP3## ;[512] DO WE HAVE /X
JRST RITG10 ;[512] YES- CHECK FOR COMP
CAIN TB,SIXLIT## ;[512] IS IT 1-WORD COMP?
MOVEI TE,6 ;[512] YES-USE SIZE OF SIX CHARS
CAIN TB,FPMODE ;[512] IS IT 2-WORD COMP?
MOVEI TE,12 ;[512] YES - USE SIZE OF 12 CHARS
RITG1B:
>;END REPEAT 0 FOR EDIT 512
MOVEM TE,ERECSZ ;SAVE IT
SETZM WDPITM ;ASSUME NO DEPENDING ITEM
MOVE TA,CURFIL
LDB TE,FI.DEP## ;VARIABLE RECORD DEPENDING ON ITEM?
JUMPN TE,RITG1A ;YES, THEN ITS VARIABLE FORMAT
HLRZ TA,CURDAT ;NO, CHECK FOR DEPENDING VARIABLES
HRRZM TA,ETABLA## ; SO WE CAN DO A VARIABLE LENGTH WRITE
PUSHJ PP,DEPTSA## ;SKIP IF WE HAVE ONE
JRST RITG1C ;NO
HRRZ TE,ETABLA ; YES--SAVE LINK
RITG1A: HRRZM TE,WDPITM ;SAVE 0,,LINK
RITG1C: TLNN W1,FROM
JRST RITGN1
MOVE TC,OPERND ;GET RECORD TABLE-LINK
MOVEI TA,2(TC) ;GET "FROM" DATA-NAME
MOVEM TA,CUREOP
PUSH PP,CURDAT ;SAVE CURRENT DATAB
SETOM EDEBDA## ;SEE IF DEBUGGING WANTED
PUSHJ PP,MOVGN. ;GENERATE MOVE
PUSHJ PP,GDEBA## ;GENERATE DEBUGING CODE IF REQUIRED
POP PP,TA ;NEED TO RESTORE CURDAT
MOVEM TA,CURDAT ; SINCE MOVGN. MIGHT DESTROY IT
HLRZ TA,TA ; IF SUBSCRIPTED
PUSHJ PP,LNKSET ;HOWEVER MAKE SURE TABLES HAVE NOT MOVED
HRRM TA,CURDAT ; SINCE BEFORE CALL TO MOVGEN
RITGN1: MOVE TA,CURDAT ;GET RECORD NAME
MOVEI LN,EBASEA ;POINT TO "A" DATA BLOCK
SETOM EDEBDA## ;SEE IF DEBUGGING WANTED
PUSHJ PP,TSDEBA ; ...
PUSHJ PP,GDEBA## ;GENERATE DEBUGING CODE IF REQUIRED
MOVE TA,CURFIL
LDB TD,FI.ORG
MOVE TE,EIOOP ;GET VERB BACK
JUMPE TD,RITG1E ;IF SEQUENTIAL, WE CAN HAVE ADVANCING
TLNN W1,ADVANC ;IS THERE AN ADVANCING CLAUSE?
JRST RITGN2 ;NO ADVANCING
MOVEI DW,E.372 ;'ADVANCING ILLEGAL'
PUSHJ PP,OPFAT
JRST RITGN3
RITG1E: TLNE W1,ADVANC!POSTNG ;"ADVANCING" OR "POSITIONING" OPTION.
JRST WADVGN ;YES
CAIE TE,WRITE ;IF ITS DELETE OR REWRITE
JRST RITGN2 ;DON'T SET WADV. BY MISTAKE
LDB TB,FI.ERM ;GET EXTERNAL RECORDING MODE
CAIE TB,%RM.SA ; [407] IF NOT STD ASCII
CAIN TB,%RM.7B ; [407] OR ASCII
CAIN TE,%ACC.I ; OR ACCESS MODE IS INDEXED,
JRST RITGN2 ; USE NORMAL WRITE
HRLOI TC,(1B12) ;SAY "DEFAULT ADVANCING"
;BY SETTING "THIS IS AN ADDRESS"
; AND VALUE = -1
TLO W1,AFTER ;"AFTER"
JRST WADVG5
;"WRITE" GENERATOR (CONT'D).
; NO ADVANCING
;PUT OUT 'WRITE', 'REWRITE', OR 'DELETE'
RITGN2: HRLZ CH,EIOOP ;GET OP-CODE
PUSHJ PP,CNVKYB ;SEE IF KEY NEEDS CONVERTING
MOVE TE,EIOOP ;[1101] IF THIS IS NOT A WRITE
CAIE TE,WRITE## ;[1101] SKIP OVER
JRST RITG2C ;[1101] VARIABLE RECORD CODE
SKIPE TE,WDPITM## ;DEPENDING VARIABLE OPTION?
TRNN TE,-1 ;ARE WE SURE?
JRST RITG2C ;NO
TLNE TE,-1 ; HAVE TO PRESERVE %PARAM+0?
SETOM SAVPR0## ;YES, TELL SZDPVA
HRRZM TE,ETABLA ;LOOK FOR LINK IN ETABLA
HRRZ TE,EOPLOC ;[1107] POINT TO THE RECORD OPERAND
ADDI TE,1 ;[1107] IN CASE OF ERROR
HRLM TE,OPERND ;[1107] "A" OPERAND
MOVEI TE,15 ; LOAD SIZE IN RUNTIME AC 15
PUSHJ PP,SZDPVR ;SEE WHICH KIND OF VARIABLE LENGTH
JRST DPPER1 ;?ERRORS
;PUT OUT "MOVEI AC16,LIT"
; PUSHJ PP,WRITV.##
HLRZ CH,CURFIL
ANDI CH,LMASKB
IORI CH,AS.FIL
HRLI CH,MOVEI.##+AC16
PUSHJ PP,PUTASY
MOVEI CH,WRITV.##
PUSHJ PP,PUT.PJ
JRST PUTXDD ;GO PUT OUT XWD FOLLOWING
; THIS SHOULD NEVER HAPPEN
DPPEMS: ASCIZ/%IOGEN -- problem with depending variable, ignored
/
DPPER1: TYPE DPPEMS ;% PROBLEM WITH DEPENDING VARIABLE--IGNORED
; JRST RITG2C
RITG2C: PUSHJ PP,PUTOP ;SET UP AND WRITE OPERATOR
PUTXDD: SETZM WDPITM## ;CLEAR DEPENDING ITEM FLAG
MOVE CH,[XWD AS.XWD,1] ;PUT OUT XWD
PUSHJ PP,PUTASY
MOVE CH,ERECSZ ;PUT RECORD SIZE IN
ROT CH,-14 ; BITS 0-11
HRRI CH,AS.CNB
PUSHJ PP,PUTASN
HRRZI CH,0 ;ZERO FOR RIGHT HALF
PUSHJ PP,PUTASN
PUSHJ PP,CNVKYA ;SEE IF KEY NEEDS CONVERTING BACK
;IF FILE IS RANDOM OR ISAM--"INVALID KEY" REQUIRED
RITGN3: SETZM WDPITM## ;CLEAR DEPENDING ITEM
PUSHJ PP,RDGN10 ;READ UP THRU NEXT OPERATOR
CAIE TE,SPIF.
JRST RITGN5
;REWRITE WITH FILE ACCESS MODE OF SEQUENTIAL IS NOT ALLOWED TO
; HAVE AN INVALID KEY CLAUSE.
MOVE TE,EIOOP
CAIE TE,RERIT. ;IS THIS REWRITE?
JRST RITGN4 ;NO
LDB TE,FI.FAM ;GET FILE ACCESS MODE
CAIE TE,%FAM.S ;SEQUENTIAL?
JRST RITGN4 ;NO
LDB TE,FI.ORG ;UNLESS IT'S INDEXED
CAIE TE,%ACC.I
JRST RITGN6 ;RELATIVE--"Invalid key not allowed"
RITGN4: LDB TE,FI.ORG
TLNN W1,INVKEY
JRST RITGN7
;"INVALID KEY" FOUND
JUMPN TE,SPIFGC ;IF NOT SEQ, ALL OK
RITGN6: MOVEI DW,E.320 ;"INV KEY NOT ALLOWED"
JRST RDGN7
;"AT END" FOUND
RITGN7: JUMPN TE,RITGN8 ;FILE NOT SEQ.
TLNE W1,ATEOP## ;END OF PAGE?
JRST SPIFGC ;YES
MOVEI DW,E.320 ;"This conditional not allowed for SEQUENTIAL files"
JRST RDGN7
RITGN8: MOVEI DW,E.319 ;"INV KEY REQUIRED"
JRST RDGN7
;NO "SPIF" OF ANY KIND FOUND
;[74] CHECK FOR ERROR USE PROCEDURE AND IF GIVEN USE IT
RITGN5: MOVE TE,EIOOP ;IS THIS A REWRITE?
CAIE TE,RERIT.
JRST RTGN5A ;NO
LDB TE,FI.ORG ;IS FILE RELATIVE?
CAIE TE,%ACC.R
JRST RTGN5A ;NO
LDB TE,FI.FAM ;AND SEQ. ACCESS MODE?
CAIE TE,%FAM.S
JRST RTGN5A
PUSHJ PP,NOOPGN ;GO GENERATE NO-OP SINCE INV KEY NOT ALLOWED.
JRST GO2NXT ; AND GENERATE THIS NEXT OPERATOR
RTGN5A: LDB TE,FI.ORG ;GET ORGANIZATION
JUMPE TE,RITGN9 ;SEQUENTIAL
LDB TA,FI.ERR## ;SEE IF FILE SPECIFIC ERROR PROCEDURE
JUMPE TA,[SKIPN TA,USP.O## ;NO, SEE IF GENERAL USE PROCEDURE
SKIPE TA,USP.IO## ;OR FOR I-O
JRST RTGN8A ;OK, USE IT
JRST RITGN7] ;NO, GIVE ERROR
LDB TB,LNKCOD
CAIE TB,CD.PRO
JRST RITGN7 ;NOT A PROTAB?
PUSHJ PP,LNKSET ;GET ADDRESS
LDB TA,PR.SFI## ;GET TAG
RTGN8A: MOVE CH,[JRST.+ASINC,,AS.MSC##] ;JRST.
PUSHJ PP,PUTASY
MOVEI CH,AS.DOT##+2 ;.+2
PUSHJ PP,PUTASN
MOVE CH,TA ;GET TAG
HRLI CH,EPJPP ;PUSHJ PP,
PUSHJ PP,PUTASY
JRST GO2NXT ;DO NEXT OPERATOR
RITGN9: LDB TE,FI.ORG ;IF FILE IS NOT SEQ,
JUMPN TE,RITGN8 ; TROUBLE
JRST GO2NXT
REPEAT 0,<
;(EDIT 512 HAS BEEN REMOVED)
;BINARY WRITE - WITH /X
RITG10: CAIN TB,SIXLIT ;[512] IS IT 1-WORD COMP?
MOVEI TE,4 ;[512] YES - USE SIZE OF 4 CHARS
CAIN TB,FPMODE ;[512] IS IT 2-WORD COMP?
MOVEI TE,8 ;[512] YES - USE SIZE OF 8 CHARS
JRST RITG1B ;[512] CONTINUE
>;END REPEAT 0
;GENERATE CODE FOR "WRITE" (WITH ADVANCING)
WADVGN: HRRZ EACC,EOPLOC ; [163] LOCATION OF 2ND OPERATOR WORD
HLRZ TA,2(EACC) ; [163] PICK UP NO. OF SUBSCRIPTS OF RECORD
IMULI TA,2 ; [163] SKIP TO NEXT ITEM-2ND WORD
ADDI EACC,4(TA) ; [163]
TLNN W1,FROM ; [166] SEE IF ANY FROM OPERAND
JRST WADVGA ; [166] NO WE ARE AT ADVANCING ITEM
HLRZ TA,(EACC) ; [166] SEE IF FROM OPERAND SUBSCRIPTED
IMULI TA,2 ; [166] SKIP AROUND ANY FROM SUBSCRIPTS
ADDI EACC,2(TA) ; [166] NOW WE ARE AT ADVANCING ITEM-2N WRD
WADVGA: HRRZM EACC,CUREOP ; [166] [163] SAVE ADVANCING ITEM
SOS CUREOP ; [163] POINT BACK TO 1ST WORD OF ADV ITEM
SKIPN TA,0(EACC) ;GET TABLE-LINK FOR "ADVANCING" OPERAND
JRST [MOVE TC,-1(EACC) ;MIGHT BE "ZERO"
TLNN TC,GNFIGC+GNFCZ ;IS IT?
JRST BADLIN ;NO, GIVE ERROR
SETZ TC, ;YES
JRST WADG2B] ;AND CONTINUE
CAIN TA,PAGE. ;'ADVANCING PAGE'
JRST WADG2P ;YES, PUT OUT CHANNEL 1
PUSHJ PP,LNKSET
MOVE TC,-1(EACC)
TLNN TC,GNLIT ;IS IT A LITERAL?
JRST WADVG4 ;NO
TLNN TC,GNNUM ;YES--IS IT NUMERIC?
JRST BADLIN ;NO--ERROR
HRLI TA,(POINT 7,0,13) ;YES--CREATE AN ILDB BYTE POINTER TO LITERAL IN VALTAB
LDB TD,VA.SIZ## ;GET SIZE
JUMPE TD,BADLIN ;IF ZERO--ERROR
MOVEI TC,0 ;SET RESULT TO ZERO
WADVG2: ILDB TE,TA ;GET A DIGIT
CAIG TE,"9" ;IS IT REALLY A DIGIT?
CAIGE TE,"0"
JRST BADLIN ;NO--ERROR
ADDI TC,-"0"(TE) ;YES--ADD INTO RESULT
CAILE TC,^D66 ;TOO BIG?
JRST BADLIN ;YES--ERROR
SOJLE TD,WADG2B ;NO--ANY MORE DIGITS?
IMULI TC,^D10 ;YES
JRST WADVG2
WADG2B: TLNN W1, POSTNG ;POSITIONING?
JRST WADVG3 ;NO, GO DO ADVANCING.
JUMPN TC, WADG2D ;DOES HE WANT A FORM FEED?
WADG2P: ;[ANS74] ADVANCING PAGE
MOVE TC, [XWD 1,1] ;YES, PUT OUT CHANNEL 1.
JRST WADVG5
WADG2D: CAILE TC, 3 ;ONLY ALLOW UP TO TRIPLE SPACING
JRST BADPNU ; FOR POSITIONING.
WADVG3: HRRZI TC,(TC) ;SET CHANNEL TO 8 MOD 8.
JRST WADVG5
WADVG4: LDB TE,[POINT 3,0(EACC),20] ;GET TYPE OF OPERAND
CAIE TE,TB.MNE
JRST WADVG6
MOVE TC,1(TA)
TLNN TC,MTCHAN
JRST BADLIN
LDB TC,CHANUM
MOVSS TC
HRRI TC,1
;GENERATE CODE FOR "WRITE ADVANCING" (CONT'D)
WADVG5:
MOVSI CH,WADV. ;SET UP OP-CODE
PUSHJ PP,CNVKYB ;SEE IF KEY NEEDS CONVERTING
SKIPE TE,WDPITM## ;DEPENDING ITEM?
TRNN TE,-1 ;ARE WE SURE?
JRST WADV5A ;NO
PUSHJ PP,WADVV ;[1305] YES, GENERATE CODE FOR IT
JRST OVRPUT ;JUMP OVER PUTOP
WADVV: PUSH PP,TC ;[1305] SAVE TC NOW
TLNE TE,-1 ; HAVE TO PRESERVE %PARAM+0?
SETOM SAVPR0## ;YES, TELL SZDPVA
HRRZM TE,ETABLA ;LINK IN ETABLA
HRRZ TE,EOPLOC ;[1107] POINT TO THE RECORD OPERAND
ADDI TE,1 ;[1107] IN CASE OF ERROR
HRLM TE,OPERND ;[1107] "A" OPERAND
MOVEI TE,15 ; LOAD SIZE IN RUNTIME AC 15
PUSHJ PP,SZDPVR ;SEE WHICH KIND OF VARIABLE LENGTH
JRST DPPER2 ; GO REPORT ERROR
;PUT OUT "MOVEI AC16,LIT"
; PUSHJ PP,WADVV.##
HLRZ CH,CURFIL
ANDI CH,LMASKB
IORI CH,AS.FIL
HRLI CH,MOVEI.+AC16
PUSHJ PP,PUTASY
MOVEI CH,WADVV.##
PUSHJ PP,PUT.PJ
POP PP,TC ;RESTORE TC
POPJ PP, ;[1305] RETURN
;THIS SHOULD NEVER HAPPEN. IF IT DOES, THE PROGRAM SHOULD STILL WORK ANYWAY.
DPPER2: OUTSTR DPPEMS ;REPORT PROBLEM WITH DEPENDING VARIABLE
POP PP,TC ;RESTORE TC
POPJ PP, ; AND PRETEND IT'S NOT THERE
WADV5A: PUSHJ PP,PUTOP ;WRITE OUT OPERATOR
OVRPUT: MOVE TE,ERECSZ ;GET SIZE OF OUTPUT RECORD
DPB TE,[POINT 12,TC,11]
TLNN W1,AFTER ;"AFTER ADVANCING"?
TLO TC,1B31 ;NO--SET "BEFORE"
MOVE CH,[XWD AS.XWD,1];CREATE THE XWD
PUSHJ PP,PUTASY
MOVE CH,TC
HRRI CH,AS.CNB
PUSHJ PP,PUTASN
HRRZ CH,TC
CAIN CH,777777 ;DID WE USE THE DEFAULT?
HRROI CH,AS.CNB ;YES, PUT "-1" IN RH
JRST WADVG9
;ADVANCING <DATA-NAME> LINES
WADVG6: CAIE TE,TB.DAT
JRST BADLIN
LDB TE,DA.DEF ;IF ITEM IS
JUMPE TE,UNDEFD ; UNDEFINED, TROUBLE
TLNE W1,POSTNG ;WRITE POSITIONING?
JRST WPSGN ;YES GO WORRY OVER IT.
LDB TE,DA.CLA ;IS THIS NUMERIC?
CAIE TE,2
JRST NOTINT
LDB TE,DA.NDP
JUMPN TE,NOTINT
LDB TE,DA.USG
CAIE TE,%US.1C ; [166] ITEM 1-WORD COMP
JRST WADVGB ; [166] NO NEED MOVE TO TEMP
MOVE TA,CUREOP ; [166] SEE IF COMP ADV ITEM SUBSCRIPTED
HLRZ EACC,1(TA) ; [166] IF SO NEED TO MOVE TO TEMP
JUMPN EACC,WADVGB ; [166] SUBSCRIPTED ADV ITEM MUST MOVE TO TEMP
HRRZ EACC,1(TA) ; [166] NOT SUBSCRIPTED SAVE NO MOVE NEEDED
JRST WADVG8 ; [166] GET ADV ITEM ADDRESS AND GO
;CHECK POSITIONING ITEM OUT. IT MUST BE AN ITEM DESCRIBED BY "PIC X".
WPSGN: LDB TC,DA.EDT## ;IF IT'S EDITED
JUMPN TC,BADPSN ; COMPLAIN.
LDB TC,DA.USG## ;IF IT'S A ONE
LDB TD,DA.EXS## ; CHARACTER DISPLAY
CAIG TC,%US.DS ; ITEM,
SOJE TD,WPSGND ; GO ON.
;IT ISN'T, COMPLAIN.
BADPSN: HRRZI DW,E.582 ;POSITIONING ITEM MUST BE A
JRST ADVERA ; NON-EDITED ONE CHARACTER
; DISPLAY DATA ITEM.
BADPNU: HRRZI DW,E.583 ;MUST BE AN INTEGER IN THE RANGE 0 - 3.
JRST ADVERA
WPSGND: MOVEI TE,1 ;GET A TEMP.
PUSHJ PP,GETEMP
MOVEM EACC,EINCRB## ;SAVE ITS ADDRESS.
MOVSM EACC,ESAVAC##
SETZM EDPLB ;SET UP A ONE
MOVEI TE,1 ; CHARACTER
MOVEM TE,ESIZEB ; RIGHT JUSTIFIED
MOVE TE,[XWD 7,AS.MSC]
MOVEM TE,EBASEB ; DISPLAY-7 DATA
MOVEI TE,D7MODE ; ITEM IN THE
MOVEM TE,EMODEB ; TEMP.
SWOFF FBNUM!FBSUB;
MOVEI LN,EBASEA ;SET UP THE SOURCE
HRRZ TC,CUREOP
HRLZM TC,OPERND
PUSHJ PP,SETOPN
TSWF FANUM; ;IF IT'S NUMERIC,
JRST BADPSN ; GO COMPLAIN.
PUSHJ PP,MXX. ;GO DO THE MOVE.
JRST WADV7D ;GO PUT OUT THE WADV.
;GENERATE CODE FOR "WRITE ADVANCING" (CONT'D)
;ADVANCING <DATA-NAME> LINES (CONT'D)
;<DATA-NAME> IS NOT A 1-WORD COMP--CONVERT AND STASH IN TEMP
WADVGB: MOVEI TE,1 ; [166] GET A SINGLE TEMP WORD
PUSHJ PP,GETEMP
MOVEM EACC,EINCRB
MOVSM EACC,ESAVAC
SETZM EDPLB
MOVEI TE,^D10
MOVEM TE,ESIZEB
MOVE TE,[XWD ^D36,AS.MSC]
MOVEM TE,EBASEB
MOVEI TE,D1MODE
MOVEM TE,EMODEB
MOVEI LN,EBASEA
HRRZ TC,CUREOP ; [163] GET BACK ADV ITEM ADDRESS
HRLZM TC,OPERND ; [163] GET ADDRESS OF ADV ITEM
PUSHJ PP,SETOPN
TSWF FERROR ;[1331] DOES ADV ITEM HAVE AN ERROR?
JRST BADADV ;[1331] YES, GIVE ERROR MESSAGE HERE ALSO
SWOFF FASIGN; ;SET "A" IS UNSIGNED
SWON FBSIGN ;SET "B" IS SIGNED
PUSHJ PP,MXX. ;GENERATE A MOVE TO TEMPORARY
WADV7D:
MOVE EACC,ESAVAC
HRRI EACC,AS.MSC
WADVG8:
MOVSI CH,WADV. ;WRITE WITH ADVANCING OPERATOR
WDVG8C: PUSHJ PP,CNVKYB ;SEE IF KEY NEEDS CONVERTING
SKIPE TE,WDPITM## ;[1305] DEPENDING ITEM?
TRNN TE,-1 ;[1305] ARE WE SURE?
JRST WDVG8A ;[1305] NO
PUSHJ PP,WADVV ;[1305] YES, GENERATE CODE FOR IT
JRST WDVG8B ;[1305] JUMP OVER PUTOP
WDVG8A: PUSHJ PP,PUTOP ;[1305]
WDVG8B: MOVE CH,[XWD AS.XWD,1] ;[1305]
PUSHJ PP,PUTASY
MOVE CH,[EXP 1B12+AS.CNB]
TLNN W1,AFTER
TLO CH,1B31
TLNE W1,POSTNG ;WRITE POSITIONING?
TLO CH,(1B14) ;YES, SET THE FLAG.
MOVE TE,ERECSZ ;PUT IN RECORD SIZE
DPB TE,[POINT 12,CH,11]
PUSHJ PP,PUTASN
MOVE CH,EACC
WADVG9: PUSHJ PP,PUTASN
PUSHJ PP,CNVKYA ;SEE IF KEY NEEDS CONVERTING BACK
PUSHJ PP,RDGN10 ;READ UP THRU NEXT OPERATOR
CAIN TE,SPIF.
JRST RITGN4
LDB TE,FI.LCP## ;ANY LINAGE-COUNTER?
JUMPE TE,RITGN5 ;NO
PUSHJ PP,PUTASA ;YES
MOVSI CH,JFCL.## ; NEED A NO-OP INCASE OF PAGE OVERFLOW
PUSHJ PP,PUTASY ; AND NO EOP ROUTINE CALLED
JRST RITGN5
SUBTTL WRITE - RMS RECORD
;WRITE AND REWRITE COME HERE
WRTM: MOVEI TE,V%WRIT ;TELL LIBOL THIS IS A WRITE
MOVE TD,EIOOP ;GET TYPE OF OPERATION
CAIE TD,WRITE ;SKIP IF WRITE
MOVEI TE,V%RWRT ; TELL LIBOL IT'S A REWRITE
DPB TE,O.BOPR ;. .
MOVE TA,CURDAT ;POINT TO RECORD
LDB TE,DA.EXS ;GET RECORD SIZE
MOVEM TE,ERECSZ ;SAVE IT
;CHECK FOR DEPENDING VARIABLE, SO WE CAN DO A VARIABLE-LENGTH WRITE
SETZM WDPITM ;ASSUME NO DEPENDING ITEM
MOVE TA,CURFIL
LDB TE,FI.DEP## ;VARIABLE RECORD DEPENDING ON ITEM?
JUMPN TE,WRTM0B ;YES, THEN ITS VARIABLE FORMAT
HLRZ TE,CURDAT ;NO, CHECK FOR DEPENDING ITEM
HRRZM TE,ETABLA## ; SO WE CAN DO A VARIABLE LENGTH WRITE
PUSHJ PP,DEPTSA## ;SKIP IF WE HAVE ONE
JRST WRTM0A ;NO
HRRZ TE,ETABLA ; YES--SAVE LINK
WRTM0B: HRRZM TE,WDPITM ;SAVE 0,,LINK
WRTM0A: TLNN W1,FROM
JRST WRTM1 ;NO "FROM"
MOVE TC,OPERND ;GET RECORD TABLE-LINK
MOVEI TA,2(TC) ;GET "FROM" DATA-NAME
MOVEM TA,CUREOP
SETOM EDEBDA## ;SEE IF DEBUGGING WANTED
PUSHJ PP,MOVGN. ;GENERATE MOVE TO RECORD AREA
PUSHJ PP,GDEBA## ;GENERATE DEBUGING CODE IF REQUIRED
WRTM1:
SETZM ADVPR1## ;INITIALIZE FIELDS TO CARRY ADVANCING PARMS
SETZM ADVPR2## ;
MOVE TA,CURDAT ;GET RECORD NAME
MOVEI LN,EBASEA ;POINT TO "A" DATA BLOCK
SETOM EDEBDA## ;SEE IF DEBUGGING WANTED
PUSHJ PP,TSDEBA ; ...
PUSHJ PP,GDEBA## ;GENERATE DEBUGING CODE IF REQUIRED
TLNN W1,ADVANC!POSTNG ;ADVANCING / POSITIONING CLAUSE?
JRST WRTM1X ;NO, OK
SETZ TC, ;ZERO OUT AC WHICH WILL COLLECT THE PARMS
MOVE TA,CURFIL ;GET ADDRESS OF CURRENT FILE'S TABLE
LDB TD,FI.ORG ;GET ITS ORGANIZATION
JUMPN TD,WRTM2 ; NOT SEQUENTIAL
LDB TD,FI.ERM ;GET ITS EXTERNAL RECORDING MODE
CAIE TD,%RM.7B ;IS FILE ASCII?
JRST WRTM1E ;NO, SIXBIT OR EBCDIC RMS NOT STREAM ORIENTED
PUSHJ PP,WRDVGN ;GO PICK UP ADV / POS PARMS
JRST WRTM2 ; AND GO ON.
WRTM1E:
MOVEI DW,E.372 ;** CHECK THIS **
PJRST OPFAT ;RETURN FROM WRITE
WRTM1X: ;SET UP DEFAULT PARAMS FOR WRITE ADVANCING
HRLI TE,40 ;
HRRI TE,AS.CNB ;
HRLI TD,-1 ;
HRRI TD,AS.CNB ;
DMOVEM TE,ADVPR1## ; AND SAVE ASIDE IN ADVPR1/2 FOR LIT POOL LATER
WRTM2: PUSHJ PP,CNVKYB ;CHECK IF GENERATE KEY CONVERSION ROUTINE
PUSHJ PP,RDGN10 ;READ UP THRU NEXT OPERATOR
CAIE TE,SPIF.
JRST WRTM2A ;NOT SPECIAL "IF"
;"WRITE" OR "REWRITE"..<SPECIAL IF>
WRTM20: TLNE W1,INVKEY ;MUST BE "INVALID KEY"
JRST WRTM2O ;ALL OK
MOVEI DW,E.209 ;"INVALID KEY" ASSUMED
PUSHJ PP,OPWRN
JRST WRTM2O ;AT LEAST THERE IS A "SPIF" OF SOME KIND
;NO SPIF AFTER WRITE OR REWRITE. THIS IS OK AS LONG AS
; THERE IS A USE PROCEDURE.
; IF SO, SET THE IOFLGS BIT, ELSE GIVE A FATAL ERROR.
WRTM2A: HLRZ TA,CURFIL
ADD TA,FILLOC
LDB TB,FI.ERR## ;SEE IF FILE-SPECIFIC USE PROCEDURE
JUMPN TB,WRTM2D ;YES, SET THE BIT
SKIPN USP.O## ;NO, GENERAL USE PROCEDURE?
SKIPE USP.IO##
JRST WRTM2D ;YES, SET THE BIT
LDB TA,FI.ORG ;GET FILE'S ORGANIZATION
JUMPE TA,WRTM2Z ;IF SEQUENTIAL, GO TO HANDLE REC LENGTH
MOVEI DW,E.319 ;"INVALID KEY" REQUIRED
MOVE TC,OPLINE
LDB CP,TCCP
LDB LN,TCLN
PUSHJ PP,FATAL
JRST GO2NXT ;GO TO NEXT OPERATOR ACTION
;NO SPIF, BUT THERE IS A USE PROCEDURE. SET THE IOFLGS BIT
WRTM2D: MOVX TE,WT%NIK
IORM TE,IOFLGS
;GET THE KEY BUFFER ADDRESS
WRTM2O: HLRZ TA,CURFIL
ADD TA,FILLOC
LDB TA,FI.RKY ;GET RECORD KEY DATANAME
PUSHJ PP,UKADR ;GET THE KEY ADDRESS, MOVE IT IF NECESSARY
EQUIT; ;QUIT IF ERRORS
;IF FIXED-LENGTH WRITE, PUT ARG LIST IN %LIT
; IF VARIABLE-LENGTH WRITE, PUT ARG LIST IN %PARAM
WRTM2Z:
;BEFORE WE DO THAT THOUGH, LET'S CHECK FOR ACCESS SEQUENTIAL AND
; SET THE PROPER I-O FLAG IF SO.
MOVX TE,WT%SEQ ;SET SEQUENTIAL FLAG
MOVE TA,CURFIL ;GET FILE'S FILE TABLE ADDRESS
LDB TD,FI.FAM ;TEST ITS ACCESS MODE FOR SEQUENTIAL
CAIN TD,%FAM.S ;
IORM TE,IOFLGS ; IF IT IS, TURN ON THE FLAG
SKIPE TE,WDPITM ;DEPENDING VARIABLE OPTION?
TRNN TE,-1 ;ARE WE SURE?
JRST WRTM2P ;NO, USE %LIT
;VARIABLE-LENGTH WRITE OR REWRITE. PUT ARG LIST IN %PARAM
;** FIRST: GET SIZE OF RECORD IN AC4.
TLNE TE,-1 ;HAVE TO PRESERVE %PARAM+0?
SETOM SAVPR0## ;YES, TELL SZDPVA
HRRZM TE,ETABLA ;IT LOOKS FOR LINK IN ETABLA
HRRZ TE,EOPLOC ;POINT TO THE RECORD OPERAND
ADDI TE,1 ; IN CASE OF ERROR
HRLM TE,OPERND ;"A" OPERAND
MOVEI TE,4 ;[1303] LOAD RUNTIME SIZE IN AC4
PUSHJ PP,SZDPVR ;GENERATE THE CODE..
JRST [TYPE DPPEMS ;TYPE "UNEXPECTED ERROR" MESSAGE
JRST WRTM2P] ;GO IGNORE DEPENDING VARIABLE
;FIRST WORD OF ARG LIST
MOVE CH,[XWD AS.XWD,1]
PUSHJ PP,PUTAS1##
HLLZ CH,IOFLGS ;FLAGS IN LH
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
HLRZ CH,CURFIL ;FILE-TABLE-ADDR IN RH
IORI CH,AS.FIL
PUSHJ PP,PUTAS1
;SECOND WORD OF ARG LIST
;FORMAT: XWD RECLEN,,KEY-BUFFER-ADDRESS
;NOTE: MAX REC LEN IS NOT PRESERVED HERE BECAUSE IT IS AVAILABLE IN THE
; RUN-TIME FILE TABLE AT WORD 8, BITS 9 - 17.
MOVE CH,[XWD AS.XWD,1]
PUSHJ PP,PUTAS1
SETZ CH, ;REC SIZE: TO BE FILLED IN
PUSHJ PP,PUTAS1
MOVE CH,KEYADR ;GET KEY ADDRESS
PUSHJ PP,PUTAS1 ;FINISH THE XWD
;THIRD WORD OF ARG LIST -- FOR WRITE WITH ADVANCING / POSITIONING.
;CALL TO WRDVGN AT WRTM1: + A FEW PICKED UP THIS INFO EARLIER AND PUT
; IT INTO ADVPR1 AND ADVPR2 WITH THE PROPER CODES SET UP IN THE RIGHT
; HALVES OF THE WORDS.
;ONLY WT.MIS FOR SEQUENTIAL ASCII STREAM FILES WILL KNOW HOW TO USE IT.
;FORMAT: XWD APV/POS FLAGS , COUNT/ADDRESS
MOVE CH,[XWD AS.XWD,1]
PUSHJ PP,PUTAS1
MOVE CH,ADVPR1## ;GET ADV/POS FLAGS IN LH
PUSHJ PP,PUTAS1
MOVE CH,ADVPR2## ;GET COUNT/ADDRESS IN RH
PUSHJ PP,PUTAS1
;STORE ACTUAL RECORD SIZE IN %PARAM WORD
PUSHJ PP,PUTASA ;HRLM IN 2ND CODE SET
MOVE CH,[HRLM.##+AC4+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EAS1PC##
ADDI CH,1 ;IN 2ND WORD
IORI CH,AS.PAR##
PUSHJ PP,PUTASN
;GENERATE MOVEI 16,%PARAM
MOVE CH,[MOVEI.+AC16+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EAS1PC
IORI CH,AS.PAR
PUSHJ PP,PUTASN
;UPDATE EAS1PC
MOVEI TE,3 ;WE JUST GENERATED THREE WORDS
ADDM TE,EAS1PC
JRST WRTM2H ;GO GENERATE THE "PUSHJ"
;HERE FOR NORMAL CASE OF WRITE/REWRITE. PUT ARG LIST IN %LIT
WRTM2P: PUSH PP,ELITPC ;SAVE LITERAL PC NOW
REPEAT 0,<
;THIS CODE PUTS OUT A TWO-WORD ARG BLOCK, AND IS REPLACED BY THE FOLLOWING
; CODE WHICH PUTS OUT A THREE-WORD ARG BLOCK FOR THE RMS WRITE CALL.
; NOTE: ONLY RMS WRITE WITH ADVANCING WILL KNOW ABOUT THE THIRD WORD.
PUSHJ PP,STDW1 ;PUT OUT STD. FIRST WORD OF ARG LIST
AOS ELITPC ;BUMP LITERAL PC
;PUT OUT 2ND WORD OF ARG LIST:
; XWD RECLEN,,KEY-BUFFER-ADDRESS
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHP
> ; END REPEAT 0
;THE FOLLOWING CODE IS INTENDED TO REPLACE THE ABOVE FOUR LINES
; PUSHJ PP,STDW1 THRU
; PUSHJ PP,STASHP
;WE ARE GENERATING A THREE-WORD LITERAL (SIX HALF-WORDS) FOR THE RMS WRITE
; CALL AT RUN TIME. FIRST -- FILE FLAGS,,FILE NAME ; SECOND -- REC LEN,,0 ,
; THIRD -- ADV/POS FLAGS,, PARMS
;THE EXISTING V12B CODE ALWAYS GENERATES A TWO-WORD LITERAL, AND THE THIRD
; WORD IS ONLY NECESSARY FOR THE ADVANCING / POSITIONING. SO WE SHOULD
; DECIDE IF WE WANT TO KEEP THE V12B CODE FOR MOST CASES AND SPECIAL-CASE
; THIS CODE FOR RMS ASCII STREAM FILE WRITES ONLY.
MOVE TA,[XWDLIT,,6] ;SET UP HEADER FOR 6 HALF-WORDS
PUSHJ PP,STASHP ;PUT HEADER IN TEMP LITAB
HLLZ TA,IOFLGS ;GET FILE IO FLAGS
HRRI TA,AS.CNB ;FLAG FOR LARGE NUMBER
PUSHJ PP,STASHQ ;PUT IN LITAB
HLRZ TA,CURFIL ;GET CUR FILE'S NUMBER
IORI TA,AS.FIL ;FLAG AS A FILE IDENTIFIER
PUSHJ PP,STASHQ ;PUT IN LITAB
HRLZ TA,ERECSZ ;GET REC SIZE
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
MOVE TA,KEYADR ;GET KEY ADDRESS
;PUT OUT THE FOURTH HALF-WORD TO THE LITAB AND GENERATE THE FIFTH AND SIXTH
PUSHJ PP,STASHQ ;PUT FOURTH WORD IN LITAB
MOVE TA,ADVPR1## ;GET ADV/POS PARMS
PUSHJ PP,STASHQ ;AND PUT FIFTH HALF-WORD IN LITAB
MOVE TA,ADVPR2## ;GET ADV/POS COUNT/ADDRESS
PUSHJ PP,POOLIT ;PUT LAST HALF-WORD IN TEMP LITAB AND POOL
; THE ENTIRE LITERAL.
WRTM2G: MOVE CH,[MOVEI.+AC16+ASINC,,AS.MSC]
PUSHJ PP,PUTASY ;START MOVEI OF ARG LIST INST.
POP PP,CH ;GET OLD LITERAL PC
REPEAT 0,< ;TO PULL OUT OLD CODE TO UPDATE LITERAL PC FOR TWO WORDS
SKIPN PLITPC ;DID WE POOL?
AOSA ELITPC ;NO, BUMP LITERAL PC
;ONLY ADD 1 HERE BECAUSE 1 WAS ADDED AT WRTM2P + 2 IN V12B CODE.
MOVEM CH,ELITPC ;YES, RESTORE ORIGINAL
SKIPE PLITPC ;SKIP IF WE DIDN'T
MOVE CH,PLITPC ;GET THE POOLED VALUE
> ; END REPEAT 0 FOR OLD LITERAL PC
;THIS PIECE OF CODE REPLACES THE FIVE LINES ABOVE AND UPDATES THE LITERAL
; PC FOR THREE WORDS
;THIS CODE IS A LITTLE RAIN DANCE TO UPDATE THE LITERAL PC IF THE OLD ONE
; MUST BE BUMPED BY THREE. A MORE GENERALIZED PROCEDURE SHOULD BE DEVELOPED.
SKIPE CH,PLITPC ;DID WE POOL?
JRST WRT2G1 ; YES, DON'T NEED TO UPDATE.
MOVE CH,ELITPC ;GET OLD LITERAL PC
ADDI CH,3 ;BUMP UP THREE
EXCH CH,ELITPC ;SWAP THEM, INCL. TO SET UP FOR ARG
; GENERATION BELOW.
WRT2G1:
IORI CH,AS.LIT ; MAKE IT LOOK LIKE A LITERAL
PUSHJ PP,PUTASN ;FINISH ARG
;GENERATE PUSHJ TO APPROPRIATE ROUTINE
WRTM2H: SETZ TD, ;TD=0 MEANS USE RANDOM ACCESS ROUTINE
HLRZ TA,CURFIL
ADD TA,FILLOC
LDB TB,FI.FAM## ;SEE IF SEQ. ACCESS MODE
CAIN TB,%FAM.S
SETO TD, ;YES, TURN ON FLAG
MOVE TE,EIOOP
CAIN TE,WRITE
JRST WRTM2I ;A "WRITE" ROUTINE
;A "REWRITE" ROUTINE
MOVEI CH,RW.MIR##
SKIPE TD ;SKIP IF RANDOM ACCESS
MOVEI CH,RW.MIS## ;NO, USE OTHER ROUTINE
JRST WRTM2J
WRTM2I: MOVEI CH,WT.MIR##
SKIPN TD ;SKIP IF NOT RANDOM ACCESS
JRST WRTM2J ; VARIABLE LENGTH IS ONLY FOR SEQ. WRITE
MOVEI CH,WT.MIS## ;NO, USE OTHER ROUTINE
SKIPE TE,WDPITM## ;VARIABLE LENGTH WRITE?
TRNN TE,-1 ;IS IT REALLY?
JRST WRTM2J ;NOPE
MOVEI CH,WT.MSV## ;YES, SEPARATE ENTRY POINT IN RMSIO.
WRTM2J: PUSHJ PP,PUT.PJ ;"PUSHJ PP,ROUTINE"
PUSHJ PP,CNVKYA ;CHECK IF GENERATE KEY CONVERSION ROUTINES
WRTM2K: LDB TE,FI.FAM ;GET FILE'S ACCESS MODE
CAIN TE,%FAM.S ;IF SEQUENTIAL
JRST GO2NXT ;THE VERB IS FINISHED
MOVE TE,IOFLGS ;GET IO FLAGS
TXNN TE,WT%NIK ;SKIP IF NO INVALID KEY CLAUSE WAS GIVEN
;NOTE: THIS MUST BE THE SAME BIT FOR
; DELETE,WRITE, AND REWRITE
JRST SPIFGC ; GO GEN "SPECIAL IF" STUFF
;NO "INVALID KEY" CLAUSE. GENERATE CALL TO "USE" PROCEDURE
HLRZ TA,CURFIL
ADD TA,FILLOC
LDB TA,FI.ERR## ;SEE IF FILE SPECIFIC ERROR PROCEDURE
JUMPE TA,[SKIPN TA,USP.O## ;NO, SEE IF GENERAL USE PROCEDURE
SKIPE TA,USP.IO## ;OR FOR I-O
JRST WRTM8A ;OK, USE IT
HALT .] ;** IMPOSSIBLE, WE CHECKED EARLIER
LDB TB,LNKCOD
CAIE TB,CD.PRO
JRST RITGN8 ;"INVALID KEY REQUIRED"
PUSHJ PP,LNKSET ;GET PROTAB ADDRESS
LDB TA,PR.SFI## ;GET TAG
WRTM8A: MOVE CH,[JRST.+ASINC,,AS.MSC##]
PUSHJ PP,PUTASY
MOVEI CH,AS.DOT##+2
PUSHJ PP,PUTASN ;"JRST .+2"
MOVE CH,TA ;GET TAG
HRLI CH,EPJPP
PUSHJ PP,PUTASY ;GENERATE "PUSHJ PP,ERROR.ROUTINE"
JRST GO2NXT
;GENERATE CODE FOR "WRITE" (WITH ADVANCING) FOR RMS SEQ ASCII STREAM FILES
WRDVGN: HRRZ EACC,EOPLOC ; [163] LOCATION OF 2ND OPERATOR WORD
HLRZ TA,2(EACC) ; [163] PICK UP NO. OF SUBSCRIPTS OF RECORD
IMULI TA,2 ; [163] SKIP TO NEXT ITEM-2ND WORD
ADDI EACC,4(TA) ; [163]
TLNN W1,FROM ; [166] SEE IF ANY FROM OPERAND
JRST WRDVGA ; [166] NO WE ARE AT ADVANCING ITEM
HLRZ TA,(EACC) ; [166] SEE IF FROM OPERAND SUBSCRIPTED
IMULI TA,2 ; [166] SKIP AROUND ANY FROM SUBSCRIPTS
ADDI EACC,2(TA) ; [166] NOW WE ARE AT ADVANCING ITEM-2N WRD
WRDVGA: HRRZM EACC,CUREOP ; [166] [163] SAVE ADVANCING ITEM
SOS CUREOP ; [163] POINT BACK TO 1ST WORD OF ADV ITEM
SKIPN TA,0(EACC) ;GET TABLE-LINK FOR "ADVANCING" OPERAND
JRST [MOVE TC,-1(EACC) ;MIGHT BE "ZERO"
TLNN TC,GNFIGC+GNFCZ ;IS IT?
JRST BADLIN ;NO, GIVE ERROR
SETZ TC, ;YES
JRST WRDG2B] ;AND CONTINUE
CAIN TA,PAGE. ;'ADVANCING PAGE'
JRST WRDG2P ;YES, PUT OUT CHANNEL 1
PUSHJ PP,LNKSET
MOVE TC,-1(EACC)
TLNN TC,GNLIT ;IS IT A LITERAL?
JRST WRDVG4 ;NO
TLNN TC,GNNUM ;YES--IS IT NUMERIC?
JRST BADLIN ;NO--ERROR
HRLI TA,(POINT 7,0,13) ;YES--CREATE AN ILDB BYTE POINTER TO LITERAL IN VALTAB
LDB TD,VA.SIZ ;GET SIZE
JUMPE TD,BADLIN ;IF ZERO--ERROR
MOVEI TC,0 ;SET RESULT TO ZERO
WRDVG2: ILDB TE,TA ;GET A DIGIT
CAIG TE,"9" ;IS IT REALLY A DIGIT?
CAIGE TE,"0"
JRST BADLIN ;NO--ERROR
ADDI TC,-"0"(TE) ;YES--ADD INTO RESULT
CAILE TC,^D66 ;TOO BIG?
JRST BADLIN ;YES--ERROR
SOJLE TD,WRDG2B ;NO--ANY MORE DIGITS?
IMULI TC,^D10 ;YES
JRST WRDVG2
WRDG2B:
TLNN W1, POSTNG ;POSITIONING?
JRST WRDVG3 ;NO, GO DO ADVANCING.
JUMPN TC, WRDG2D ;DOES HE WANT A FORM FEED?
WRDG2P: ;[ANS74] ADVANCING PAGE
MOVE TC, [XWD 1,1] ;YES, PUT OUT CHANNEL 1.
JRST WRDVG5
WRDG2D: CAILE TC, 3 ;ONLY ALLOW UP TO TRIPLE SPACING
JRST BADPNU ; FOR POSITIONING.
WRDVG3: HRRZI TC,(TC) ;SET CHANNEL TO 8 MOD 8.
JRST WRDVG5
WRDVG4: LDB TE,[POINT 3,0(EACC),20] ;GET TYPE OF OPERAND
CAIE TE,TB.MNE
JRST WRDVG6
MOVE TC,1(TA)
TLNN TC,MTCHAN
JRST BADLIN
LDB TC,CHANUM
MOVSS TC
HRRI TC,1
;GENERATE CODE FOR "WRITE ADVANCING" (CONT'D)
WRDVG5:
;FINISH OFF ADVANCING/POSITIONING WITH A LITERAL
TLNN W1,AFTER ;AFTER ADV/POS?
TLO TC,1B31 ; NO, BEFORE
;PUT LITAB PARMS INTO ADVPR1 AND ADVPR2
HRL TB,TC ;SPLIT UP THE TWO HALVES INTO TWO LEFT-HALVES
HRRI TC,AS.CNB ;FLAG EACH AS A LARGE NUMBER
HRRI TB,AS.CNB ;
DMOVEM TC,ADVPR1## ;AND SAVE THEM ASIDE IN ADVPR1/2
POPJ PP, ; AND RETURN TO RMS WRITE CODE.
;ADVANCING <DATA-NAME> LINES
WRDVG6: CAIE TE,TB.DAT
JRST BADLIN
LDB TE,DA.DEF ;IF ITEM IS
JUMPE TE,UNDEFD ; UNDEFINED, TROUBLE
TLNE W1,POSTNG ;WRITE POSITIONING?
JRST WRPSGN ;YES GO WORRY OVER IT.
LDB TE,DA.CLA ;IS THIS NUMERIC?
CAIE TE,2
JRST NOTINT
LDB TE,DA.NDP
JUMPN TE,NOTINT
LDB TE,DA.USG
CAIE TE,%US.1C ; [166] ITEM 1-WORD COMP
JRST WRDVGB ; [166] NO NEED MOVE TO TEMP
MOVE TA,CUREOP ; [166] SEE IF COMP ADV ITEM SUBSCRIPTED
HLRZ EACC,1(TA) ; [166] IF SO NEED TO MOVE TO TEMP
JUMPN EACC,WADVGB ; [166] SUBSCRIPTED ADV ITEM MUST MOVE TO TEMP
HRRZ EACC,1(TA) ; [166] NOT SUBSCRIPTED SAVE NO MOVE NEEDED
JRST WRDVG8 ; [166] GET ADV ITEM ADDRESS AND GO
;CHECK POSITIONING ITEM OUT. IT MUST BE AN ITEM DESCRIBED BY "PIC X".
WRPSGN: LDB TC,DA.EDT## ;IF IT'S EDITED
JUMPN TC,BADPSN ; COMPLAIN.
LDB TC,DA.USG## ;IF IT'S A ONE
LDB TD,DA.EXS## ; CHARACTER DISPLAY
CAIG TC,%US.DS ; ITEM,
SOJE TD,WRPSND ; GO ON.
JRST BADPSN ;IT ISN'T, COMPLAIN.
WRPSND: MOVEI TE,1 ;GET A TEMP.
PUSHJ PP,GETEMP
MOVEM EACC,EINCRB## ;SAVE ITS ADDRESS.
MOVSM EACC,ESAVAC##
SETZM EDPLB ;SET UP A ONE
MOVEI TE,1 ; CHARACTER
MOVEM TE,ESIZEB ; RIGHT JUSTIFIED
MOVE TE,[XWD 7,AS.MSC]
MOVEM TE,EBASEB ; DISPLAY-7 DATA
MOVEI TE,D7MODE ; ITEM IN THE
MOVEM TE,EMODEB ; TEMP.
SWOFF FBNUM!FBSUB;
MOVEI LN,EBASEA ;SET UP THE SOURCE
HRRZ TC,CUREOP
HRLZM TC,OPERND
PUSHJ PP,SETOPN
TSWF FANUM; ;IF IT'S NUMERIC,
JRST BADPSN ; GO COMPLAIN.
PUSHJ PP,MXX. ;GO DO THE MOVE.
JRST WRDV7D ;GO PUT OUT THE WADV.
;GENERATE CODE FOR "WRITE ADVANCING" (CONT'D)
;ADVANCING <DATA-NAME> LINES (CONT'D)
;<DATA-NAME> IS NOT A 1-WORD COMP--CONVERT AND STASH IN TEMP
WRDVGB: MOVEI TE,1 ; [166] GET A SINGLE TEMP WORD
PUSHJ PP,GETEMP
MOVEM EACC,EINCRB
MOVSM EACC,ESAVAC
SETZM EDPLB
MOVEI TE,^D10
MOVEM TE,ESIZEB
MOVE TE,[XWD ^D36,AS.MSC]
MOVEM TE,EBASEB
MOVEI TE,D1MODE
MOVEM TE,EMODEB
MOVEI LN,EBASEA
HRRZ TC,CUREOP ; [163] GET BACK ADV ITEM ADDRESS
HRLZM TC,OPERND ; [163] GET ADDRESS OF ADV ITEM
PUSHJ PP,SETOPN
TSWF FERROR ;[1331] DOES ADV ITEM HAVE AN ERROR?
JRST BADADV ;[1331] YES, GIVE ERROR MESSAGE HERE ALSO
SWOFF FASIGN; ;SET "A" IS UNSIGNED
SWON FBSIGN ;SET "B" IS SIGNED
PUSHJ PP,MXX. ;GENERATE A MOVE TO TEMPORARY
WRDV7D:
MOVE EACC,ESAVAC
HRRI EACC,AS.MSC
WRDVG8:
MOVE CH,[EXP 1B12+AS.CNB] ;SET UP AS TYPE 40
TLNN W1,AFTER ;AFTER ADVANCING/POSITIONING?
TLO CH,1B31 ; NO, BEFORE
TLNE W1,POSTNG ;WRITE POSITIONING?
TLO CH,(1B14) ;YES, SET THE FLAG.
MOVEM CH,ADVPR1## ;SAVE ADV/POS FLAGS ASIDE
MOVEM EACC,ADVPR2## ;SAVE LITERAL / ADDRESS ALSO
POPJ PP, ; AND RETURN TO RMS WRITE GENERATION
;SETUP AC FOR VARIABLE LENGTH READ AND WRITE
;IF NOT VARIABLE LENGTH SYNTAX "RECORD IS VARYING IN SIZE ..." GO TO SZDPVA AS BEFORE
;IF IT IS USE SIMILAR CODE AS SZDPVA BUT CHECK BOTH BOUND
;ROUTINE TO SETUP AC = SIZE OF VARIABLE, WHERE VARIABLE HAS A DEPENDING ITEM
;CALLED BY:
; MOVEI TE,WHICH AC TO USE (0-16)
; SAVPR0/ 0 (NORMAL CASE) OR -1 (%PARAM+0 MUST BE PRESERVED)
; PUSHJ PP,SZDPVR
; <RETURN HERE IF NO DEPENDING VARIABLE OR ERRORS, DEPVB/ -1, FERROR SET>
; <RETURN HERE IF SIZE SETUP IN AC SPECIFIED, DEPVB / RUNTIME AC USED>
; ALL RUNTIME AC'S MAY BE SMASHED!!
SZDPVR: MOVE TA,CURFIL
LDB TA,FI.DEP## ;IS THERE A DEPENDING VARIABLE?
JUMPE TA,SZDPVA## ;NO, USE OLD CODE
MOVEI LN,EBASEA ;REMEMBER WE'RE DOING 'A'
MOVEM TE,DEPVB## ;SAVE RUNTIME AC TO USE
MOVE TB,TA ;COPY DEPENDING VARIABLE
MOVEM TA,DPLNK##
MOVEM TB,DPITM##
PUSHJ PP,LNKSET ;LOOK AT ITEM
LDB CH,DA.LKS ;IN LINKAGE SECTION?
JUMPN CH,GTBDP0 ;YES, DO HARD WAY
LDB CH,DA.USG ;GET USAGE
CAIE CH,%US.1C ;IF 1-WORD COMP
CAIN CH,%US.IN ;OR INDEX IT OK
JRST GTBDP1 ;SINCE NO CONVERSION REQUIRED
;SET UP FAKE "A" OPERAND TO POINT TO DEPENDING ITEM. GET IT INTO SPECIFIED ACC.
GTBDP0: PUSH PP,W1 ;SAVE W1
PUSH PP,W2 ; AND W2.
PUSH PP,OPERND## ;SAVE OPERND TOO. (IN CASE IT'S IN THE LINKAGE SECTION.)
MOVSI W1,(1B0) ;SET THE OPERAND FLAG.
MOVE W2,DPITM ;GET DEP ITEM LINK
LDB TD,DA.SYL## ;SET THE SYNC FLAGS.
DPB TD,[POINT 1,W1,5]
LDB TD,DA.SYR##
DPB TD,[POINT 1,W1,6]
LDB TD,DA.CLA## ;SET THE NUMERIC FLAG.
CAIN TD,%CL.NU
TLO W1,(1B7)
LDB TD,DA.JST## ;SET THE JUSTIFIED FLAG.
DPB TD,[POINT 1,W1,8]
LDB TD,DA.LKS## ;SET THE LINKAGE SECTION FLAG.
DPB TD,[POINT 1,W1,9]
LDB TD,DA.USG## ;SET THE USAGE.
DPB TD,[POINT 4,W1,13]
PUSHJ PP,PUSH12## ;STASH THE INFO IN EOPTAB.
HRRZI TC,-1(EACA) ;POINT AT THE EOPTAB ENTRY.
MOVEM TC,CUREOP ;MAKE IT THE CURRENT ENTRY.
HRRZM TC,OPERND## ;MAKE IT THE CURRENT OPERAND TOO.
MOVEI LN,EBASEA ;POINT TO "A"
PUSHJ PP,SETOPN ;SET UP "A" OPERAND
PUSH PP,EAC ;SAVE CURRENT NEXT FREE ACC
MOVE TD,DEPVB
MOVEM TD,EAC ;WHICH ONE TO USE (TEST LATER FOR DP)
TSWT FERROR ;DON'T TRY TO STORE IF ERROR FOUND
PUSHJ PP,MXAC.## ;GET DEPENDING ITEM
POP PP,EAC ;RESTORE FREE ACC
POP PP,OPERND## ;RESTORE OPERAND
POP PP,W2 ;RESTORE W2
POP PP,W1 ; AND W1.
MOVE EACA,EOPNXT## ;RESET EOPTAB.
POP EACA,(EACA)
POP EACA,(EACA)
MOVE TA,CURFIL
JRST GTBDP5 ;GENERATE COMPARES
GTBDP1: MOVE CH,DPITM ;PUT ITEM IN CH
GTBDP4: MOVE TA,CURFIL
LDB TE,FI.LRS## ;GET LOWER BOUND
JUMPE TE,GTBDP6 ;ZERO, OR NOT SETUP
HRLI CH,MOV ;NORMAL COMP ITEM..
HRRZ TE,DEPVB ;GET AC AGAIN
LSH TE,5
TLO CH,(TE)
PUSHJ PP,PUTASY ;"MOVE AC,DEPENDING VARIABLE"
GTBDP5: LDB CH,FI.LRS ;GET LOWER BOUND TO TEST
HRLI CH,CAIL.##
HRRZ TE,DEPVB ;GET AC AGAIN
LSH TE,5
TLO CH,(TE)
PUSHJ PP,PUTASY ;"CAIL AC,LOWER.BOUND"
JRST GTBDP3
GTBDP6: HRLI CH,SKPLE.## ;NORMAL COMP ITEM..
HRRZ TE,DEPVB ;GET AC AGAIN
LSH TE,5
TLO CH,(TE)
PUSHJ PP,PUTASY ;"SKIPLE AC,DEPENDING VARIABLE"
;HERE TO DO UPPER BOUND TEST
;SKIPLE AC, DEPENDING.VARIABLE JUST PUT OUT
; NOW GENERATE:
;CAILE AC,UPPER.BOUND.FOR.DEPENDING.VARIABLE
GTBDP3: MOVE TA,CURFIL
SETZM SAVPR0## ;CLEAR FLAG
LDB CH,FI.MRS## ;GET UPPER BOUND
HRLI CH,CAILE.##
HRRZ TE,DEPVB
LSH TE,5
TLO CH,(TE)
PUSHJ PP,PUTASY ;"CAILE AC,UPPER.BOUND"
MOVEI CH,SUBE2.##
AOS (PP) ;SKIP RETURN
JRST PUT.PJ ;"PUSHJ PP,SUBE2." - OUT OF RANGE
QITDPV: SETOM DEPVB ;SET DEPVB TO -1 TO INDICATE ERROR
SETZM SAVPR0## ;CLEAR FLAG
SWON FERROR ;SET "ERROR" BIT
POPJ PP,
SUBTTL START
STRTGN: SETZM EIOOP ;CLEAR LAST I/O OPERATOR
PUSHJ PP,SETOP
EQUIT;
LDB TE,FI.ORG ;IF FILE IS SEQUENTIAL
JUMPE TE,NOTRAN ; ERROR
LDB TE,FI.RMS ;IF FILE IS AN RMS FILE,
JUMPN TE,STRTM ; GO GEN THE "START"
PUSHJ PP,CNVKYB ;CONVERT KEY IF NEEDED
MOVE TA,[XWDLIT,,2] ;DO IT BY HAND
PUSHJ PP,STASHP ; SINCE NO MORE UUOS LEFT
LDB TA,[POINT 2,W1,10] ;GET LESS AND GREATER
LSH TA,4 ;BITS 12 AND 13
TLNE W1,(1B12) ;APPROX KEY?
TRO TA,(STA%AP) ;YES, SET FLAG
PUSHJ PP,STASHQ
HLRZ TA,CURFIL ;GET FILE ADDRESS
ANDI TA,LMASKB
IORI TA,AS.FIL
REPEAT 0,<
PUSHJ PP,STASHQ
TLNN W1,(1B12) ;APPROX KEY?
JRST STRTG2 ;NO, LITERAL DONE
MOVE TA,OPERND
MOVEM TA,CUREOP
PUSHJ PP,BMPEOP ;GET SIZE OF KEY
JRST STRTG2 ;ERROR
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHP
SETZ TA,
PUSHJ PP,STASHQ
HRRZ TA,CUREOP ;LOOK AT NEW OPERAND
HLRZ TA,1(TA) ;GET SIZE
PUSHJ PP,STASHQ
STRTG2: PUSHJ PP,POOL
>;END REPEAT 0
REPEAT 1,<
PUSHJ PP,POOLIT
>
MOVE CH,[MOV##+ASINC+AC16,,AS.MSC]
PUSHJ PP,PUTASY
REPEAT 0,<
MOVEI TE,1 ;ASSUME 1 WORD LITERAL
TLNE W1,(1B12) ;APPROX KEY?
ADDI TE,1 ;YES, NEEDS TWO WORDS
>
SKIPN CH,PLITPC
HRRZ CH,ELITPC
SKIPN PLITPC
REPEAT 0,<
ADDM TE,ELITPC ;NOW ACCOUNT FOR IT
>
REPEAT 1,<
AOS ELITPC
>
IORI CH,AS.LIT
PUSHJ PP,PUTASN
REPEAT 1,<
TLNN W1,(1B12) ;APPROX KEY?
JRST STRTG3 ;NO, LITERAL DONE
MOVE TA,OPERND
MOVEM TA,CUREOP
PUSHJ PP,BMPEOP ;GET SIZE OF KEY
JRST STRTG3 ;ERROR
HRRZ CH,CUREOP ;LOOK AT NEW OPERAND
HLRZ CH,1(CH) ;GET SIZE
HRLI CH,MOVEI.+AC1 ;PUT SIZE IN AC1
PUSHJ PP,PUTASY
STRTG3:>
MOVEI CH,C.STRT##
PUSHJ PP,PUT.PJ
PUSHJ PP,CNVKYA ;CONVERT BACK
PUSHJ PP,RDGN10 ;READ UP THRU NEXT OPERATOR
CAIE TE,SPIF.
JRST [PUSHJ PP,RDGN6 ;CHECK FOR USE PROCEDURE
JRST STRTG1] ;CHECK FOR DEBUGGING REQUIRED
TLNN W1,ATINVK ;ONLY INVALID KEY LEGAL
JRST RDGN6A ;GIVE ERROR MESSAGE
PUSHJ PP,SPIF74 ;OK, GENERATE CODE
STRTG1: MOVE TA,CURFIL ;POINT TO FILE AGAIN
LDB CH,FI.DEB ;DEBUGGING ON THIS FILE
JUMPN CH,OPNGN4 ;OUTPUT DEBUG STUFF
POPJ PP, ;NO
SUBTTL START RMS FILE
;ARG-LIST IS:
; STDW1
; KEY OF REF,,ADDR OF KEY BUFFER
; [LENGTH OF APPROXIMATE KEY]
STRTM: MOVEI TE,V%STRT ;THIS IS A START
DPB TE,O.BOPR ;TELL LIBOL
LDB TE,[POINT 2,W1,10] ;GET CONDITION CODE
HRRZ CH,[ST.MEQ##
ST.MGT##
ST.MNL##](TE) ;GET APPROPRIATE ROUTINE
MOVEM CH,ROUCAL ;SAVE ROUTINE TO CALL
MOVE TE,[0 ;STA%EQ SET TO 0
STA%GT
STA%NL](TE) ;GET IO FLAG TO SET
IORM TE,IOFLGS ;SET IO FLAGS DEPENDING ON CONDITION
SETOM KEYREF ;SET TO -1 TO INDICATE "NO KEY GIVEN"
MOVE TA,OPERND
MOVEM TA,CUREOP ;PREPARE TO CALL BMPEOP
PUSHJ PP,BMPEOP ;SEE IF "KEY IS".. SPECIFIED
JRST STRTM0 ;NO "STA%EQ" EQUAL TO 0, GO ON
HRRZ TD,CUREOP ;LOOK AT THIS OPERAND
MOVE TA,1(TD) ;TA= SIZE,,KEY#
HLRZM TA,KEYRLN## ;LENGTH OF KEY OF REFERENCE
HRRZM TA,KEYREF## ;KEY#
MOVX TD,STA%AK ;PREPARE TO SET "APPROX KEY" BIT
TLNE TA,-1 ;SKIP IF SIZE IS ZERO
IORM TD,IOFLGS ;SET BIT
;CHECK "INVALID KEY" CLAUSE
STRTM0:
PUSHJ PP,CNVKYB ;CHECK IF GENERATE KEY CONVERSION ROUTINE
PUSHJ PP,RDGN10 ;READ THRU TO NEXT OPERATOR
CAIE TE,SPIF.
JRST NOSMSP ;NO "SPECIAL IF"
TLNE W1,ATINVK ;ONLY INVALID KEY LEGAL
JRST STRTM1 ;OK
NOSMSE: MOVEI DW,E.319 ;"INVALID KEY REQUIRED"
JRST RDGN7 ;GIVE FATAL ERROR
;NO INVALID KEY SPECIFIED.. LOOK FOR A "USE" PROCEDURE
NOSMSP: HLRZ TA,CURFIL
ADD TA,FILLOC
LDB TE,FI.ERR## ;ERROR USE GIVEN
JUMPE TE,NOSMSE ;NO, GIVE ERROR
;USE PROCEDURE IS OK.. SET THE IOFLGS BIT
MOVX TE,STA%NI ;GET BIT
IORM TE,IOFLGS ;SET IT
;SET UP "KEY BUFFER ADDRESS"
STRTM1: SKIPG TE,KEYREF ;DO WE HAVE A KEY OF REFERENCE?
JRST STRM1A ;NO, USE PRIMARY KEY'S ADDRESS
CAIN TE,1 ;PRIMARY KEY?
JRST STRM1A ;YES
;ALTERNATE KEY - FIND A KEY BUFFER ADDRESS
LDB TA,FI.ALK## ;FIND POINTER TO FIRST ALTERNATE KEY
ADD TA,AKTLOC ;GET ABS POINTER
SUBI TE,2 ;TE= OFFSET INTO AKTTAB
IMULI TE,SZ.AKT ; * SIZE OF ENTRY = OFFSET TO FIRST WORD
ADD TA,TE ;TA POINTS TO ENTRY NOW
LDB TA,AK.DLK ;GET DATANAME LINK
PUSHJ PP,UKADR ; GET KEY ADDRESS
JRST STRM1B ;AND GO USE IT
;PRIMARY KEY - FIND A KEY BUFFER ADDRESS
STRM1A: LDB TA,FI.RKY ;GET RECORD KEY DATANAME
PUSHJ PP,UKADR ; GET KEY ADDRESS
STRM1B: EQUIT; ;QUIT IF ERRORS SO FAR
PUSH PP,ELITPC ;SAVE LITERAL PC
PUSHJ PP,STDW1 ;STD 1ST WORD OF ARG LIST
AOS ELITPC ;BUMP LITERAL PC
;WRITE KEY OF REF,,ADDR OF KEY
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHP
SKIPG TA,KEYREF ;KEY OF REFERENCE GIVEN?
TDZA TA,TA ;NO, PRETEND HE SAID PRIMARY-KEY
SUBI TA,1 ;MAKE PRIMARY=0, 1ST ALTERNATE=1, ETC.
PUSHJ PP,STASHQ ;XWD KEYREF,
MOVE TA,KEYADR## ;GET KEY ADDRESS
PUSHJ PP,STASHQ ;WRITE THAT
SKIPN KEYRLN ;SKIP IF APPROX. KEY
JRST STRTM2 ;NO
AOS ELITPC ;BUMP LITERAL PC
MOVE TA,[OCTLIT,,1] ;WRITE LENGTH OF APPROX. KEY
PUSHJ PP,STASHP ; HEADER
HRRZ TA,KEYRLN ;GET LENGTH
PUSHJ PP,STASHQ ;WRITE IT OUT
STRTM2: PUSHJ PP,POOL ;POOL THE LITERAL IF WE CAN
POP PP,CH ;RESTORE LITERAL BASE
SKIPN PLITPC ;DID WE POOL?
AOSA ELITPC ;NO, FIX ELITPC AND SKIP
MOVEM CH,ELITPC ; POOLED, RESTORE ORIGINAL
SKIPE PLITPC ;SKIP IF WE DIDN'T POOL
MOVE CH,PLITPC ;YES, GET BASE ADDR OF ARG LIST
IORI CH,AS.LIT ;MAKE IT LOOK LIKE A LITERAL
PUSH PP,CH
MOVE CH,[MOVEI.+AC16+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
POP PP,CH
PUSHJ PP,PUTASN ;FINISH MOVEI
HRRZ CH,ROUCAL ;GET SAVED ROUTINE TO CALL
PUSHJ PP,PUT.PJ ;GENERATE THE PUSHJ
PUSHJ PP,CNVKYA ;CHECK IF GENERATE KEY CONVERSION ROUTINES
;IF THERE WAS AN "INVALID KEY" CLAUSE GIVEN, GENERATE THE SPIF CODE,
; ELSE DO THE "USE" PROCEDURE STUFF
MOVE TE,IOFLGS
TXNN TE,STA%NI ;WAS "INVALID KEY" CLAUSE GIVEN?
JRST SPIFGC ;YES, GO DO "SPECIAL IF" STUFF
;GET A USE PROCEDURE
HLRZ TA,CURFIL
ADD TA,FILLOC ;POINT TO FILTAB ENTRY
LDB TA,FI.ERR## ;ERROR USE GIVEN
JUMPN TA,RDGN5B ;YES, USE IT
HALT . ;??WE CHECKED EARLIER
SUBTTL DELETE
DELGEN: PUSHJ PP,SETOP ;SET UP OPERAND
EQUIT; ;QUIT IF ERRORS
MOVEI CH,DELETE##
MOVEM CH,EIOOP
LDB TE,[POINT 3,CURFIL,2]
CAIE TE,CD.FIL ;MAKE SURE ITS A FILE TABLE
POPJ PP, ;NO, GIVE UP BEFORE HARM IS DONE
MOVE TA,CURFIL
LDB TE,FI.RMS ;CHECK FOR RMS DELETE
JUMPN TE,DELM ;YES, GO DO IT
PUSHJ PP,RDGN0 ;DON'T GENERATE XWD TO FOLLOW
JRST STRTG1 ;GENERATE DEBUGGING CODE IF REQUIRED
;GENERATE CODE FOR 'NO-OP'
NOOPGN::PUSHJ PP,PUTASA##
MOVSI CH,JFCL.##
JRST PUTASY
SUBTTL DELETE RMS RECORD
;GENERATE AN RMS DELETE
;LH (CURFIL) POINTS TO THE FILE TABLE.
;ARG-LIST:
; STDW1
; [ADDRESS OF KEY BUFFER] ;RANDOM DELETES ONLY
DELM: MOVEI TE,V%DELT ;TELL LIBOL THIS IS A DELETE
DPB TE,O.BOPR ; . .
PUSHJ PP,CNVKYB ;CHECK IF GENERATE KEY CONVERSION ROUTINE
PUSHJ PP,RDGN10 ;READ UP THRU NEXT OPERATOR
CAIN TE,SPIF. ; INVALID KEY GIVEN?
TLNN W1,ATINVK ;SKIP IF TRUE
JRST DELM2 ;NO
;NOTE: IF USER SAID "AT END" INSTEAD OF "INVALID KEY",
; COBOLD SAID "STATEMENT EXPECTED" AND PASSED "NOOP".
;DELM2 MAY NOW POINT TO "DELETE" AND SAY "INVALID KEY
; REQUIRED".
;"INVALID KEY CLAUSE GIVEN.. MAKE SURE FILE IS NOT SEQ. ACCESS.
HLRZ TA,CURFIL
ADD TA,FILLOC
LDB TE,FI.FAM
CAIN TE,%FAM.S ;SEQ ACCESS MODE?
JRST BADIKY ;YES, COMPLAIN
JRST DELM3 ;INVALID KEY GIVEN, AND IS OK
;HERE IF "INVALID KEY" CLAUSE NOT SUPPLIED FOR "DELETE".
; IF FILE IS SEQ. ACCESS, OR THERE IS A USE PROCEDURE, THIS IS OK.
DELM2: HLRZ TA,CURFIL ;MAKE TA POINT TO FILTAB ENTRY
ADD TA,FILLOC
LDB TE,FI.FAM
CAIE TE,%FAM.S ;SEQUENTIAL ACCESS?
JRST DELM2B ;NO, GO LOOK FOR USE PROC
LDB TE,FI.ORG ;GET FILE ORGANIZATION
JUMPN TE,DELM3 ;SEQUENTIAL?
MOVEI DW,E.729 ;YES, DELETE NOT ALLOWED FOR ORG SEQ.
JRST RDGN7 ;GO REPORT FATAL DIAG.
;THERE BETTER BE A USE PROCEDURE
DELM2B: LDB TA,FI.ERR ;CHECK FOR FILE-SPECIFIC ERROR PROC.
JUMPN TA,DELM2A ;YES, SET BIT
SKIPE USP.IO## ;BETTER BE A GENERAL I-O USE PROCEDURE
JRST DELM2A ;OK, SET BIT
MOVEI DW,E.319 ;"INVALID KEY REQUIRED"
JRST RDGN7
;USE PROCEDURE WAS GIVEN.. SET IOFLGS BIT
DELM2A: MOVX TE,DL%NIK ;"NO INVALID KEY GIVEN"
IORM TE,IOFLGS ;SET THE BIT
DELM3:
;FIGURE OUT IF WE HAVE SEQUENTIAL ACCESS, AND IF SO SET THE BIT
MOVX TE,DL%SEQ ;SET UP THE SEQUENTIAL ACCESS BIT
MOVE TA,CURFIL ;GET FILE'S FILE TABLE ADDRESS
LDB TD,FI.FAM ;GET ITS ACCESS AND TEST FOR SEQUENTIAL
CAIN TD,%FAM.S ;
IORM TE,IOFLGS ; IS SEQUENTIAL SO TURN ON THE BIT
;GET A ROUTINE, DEPENDING ON THE FILE ACCESS MODE
MOVEI CH,DL.MIR## ;ASSUME RANDOM
HLRZ TA,CURFIL
ADD TA,FILLOC ;POINT TO FILTAB ENTRY
LDB TD,FI.FAM ;IF ACCESS IS
CAIN TD,%FAM.S ; SEQUENTIAL,
MOVEI CH,DL.MIS## ; USE "SEQ. DELETE"
MOVEM CH,ROUCAL ;SAVE ROUTINE TO CALL
;IF THIS IS A RANDOM DELETE, GET THE KEY BUFFER ADDRESS
CAIN TD,%FAM.S ;SEQUENTIAL ACCESS?
JRST [PUSHJ PP,STDAGL ;YES, JUST DO STD. ARG LIST
JRST DELM4] ;AND LEAVE
LDB TA,FI.RKY ;GET PTR TO RECORD KEY
PUSHJ PP,UKADR ;SET UP KEYADR
EQUIT; ;QUIT IF ERRORS
PUSH PP,ELITPC ;SAVE LIT PC
PUSHJ PP,STDW1 ;STD. FIRST WORD
AOS ELITPC ;BUMP LITERAL PC
;WRITE 0,,ADDR-OF-KEY
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHP
SETZ TA, ;0
PUSHJ PP,STASHQ
MOVE TA,KEYADR ;GET KEY ADDRESS
PUSHJ PP,POOLIT ;FINISH XWD, AND LITERAL POOL
MOVE CH,[MOVEI.+AC16+ASINC,,AS.MSC]
PUSHJ PP,PUTASY ;START MOVEI OR ARG LIST.
POP PP,CH ;GET OLD LITERAL PC
SKIPN PLITPC ;DID WE POOL?
AOSA ELITPC ;NO, BUMP LITERAL PC
MOVEM CH,ELITPC ;YES, RESTORE ORIGINAL
SKIPE PLITPC ;SKIP IF WE DIDN'T
MOVE CH,PLITPC ;GET THE POOLED VALUE
IORI CH,AS.LIT ; MAKE IT LOOK LIKE A LITERAL
PUSHJ PP,PUTASN ;FINISH ARG
DELM4: MOVE CH,ROUCAL ;GET ROUTINE TO CALL
PUSHJ PP,PUT.PJ ;GENERATE THE CALL
PUSHJ PP,CNVKYA ;CHECK IF GENERATE KEY CONVERSION ROUTINES
;SEE IF INVALID KEY CLAUSE WAS SUPPLIED, AND GO TO "SPIFGC" IF SO.
HRRZ TE,W2 ;GET OPERATOR CODE FOR NEXT OPERATOR
CAIN TE,SPIF. ;WAS IF "SPECIAL IF"?
JRST SPIFGC ;GO GEN THE CODE
;NO INVALID KEY CLAUSE. IF USE PROCEDURE, GEN CALL TO THAT,
; ELSE GEN "NOOP". THEN GO ON TO NEXT OPERATOR ACTION.
HRRZ TA,CURFIL ;[1536] RESET AC16
LDB TE,FI.FAM ;GET ACCESS MODE
CAIN TE,%FAM.S ;IS SEQENTIAL,
JRST NODUSE ; JUST GENERATE "NOOP"
LDB TA,FI.ERR ;CHECK FOR FILE-SPECIFIC ERROR PROCEDURE
JUMPE TA,[SKIPE TB,USP.IO## ;NO, SEE IF A GENERAL USE PROCEDURE
JRST DLMG5C ;OK, USE IT
JRST NODUSE] ;NO, GENERATE "NOOP"
DLMG5A: LDB TB,LNKCOD
CAIE TB,CD.PRO
JRST DLMG6A ;NOT A PROTAB LINK
PUSHJ PP,LNKSET
MOVE TB,PR.DUP##(TA) ;GET PR.SFI AND PR.DEB
DLMG5C: MOVE CH,[JRST.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZI CH,AS.DOT+2 ;"JRST .+2"
TLNE TB,-1 ;DEBUGGING ON PROCEDURE NAME
ADDI CH,3 ;NEED MORE SPACE
PUSHJ PP,PUTASN ;"OK" RETURN
TLNN TB,-1 ;IF NOT DEBUGGING..
JRST DLMG5D ;DON'T GENERATE SPECIAL CODE
;GENERATE: SKIPA 16,.+1
; XWD DPB%UP,LINE #
; MOVEM 16,%PARAM+N
;
PUSHJ PP,IODBU ;GENERATE THE CODE..
DLMG5D: MOVE CH,TB ;GET TAG
HRLI CH,EPJPP ;PUSHJ PP,
PUSHJ PP,PUTASY ;EOF RETURN
PUSHJ PP,CRHLD ;CREATE HLDTAB ENTRY
JRST ENDIFR## ;??? NOT SURE..
DLMG6A: MOVEI DW,E.319 ;"INVALID KEY REQUIRED"
JRST RDGN7 ;GO GIVE ERROR
NODUSE: PUSHJ PP,NOOPGN ;GENERATE NOOP, SINCE
;NO "INVALID KEY" RETURN IS USED FOR
;SEQ. ACCESS FILES
JRST GO2NXT ;AND GO TO NEXT OPERATOR ACTION
BADIKY: MOVEI DW,E.735 ;"INVALID KEY" ILLEGAL WHEN FILE IS SEQ ACCESS
MOVE TC,OPLINE
LDB CP,TCCP
LDB LN,TCLN
PJRST FATAL## ;MAKE THIS A DIAG
SUBTTL DISPLAY
DISPGN: MOVEM W1,OPLINE ;SAVE LN&CP OF OPERATOR
MOVE EACA,EOPNXT
CAMN EACA,EOPLOC ;ANY OPERANDS?
JRST BADEOP ;NO--TROUBLE
TLNE W1,CONSOL ;"UPON" OPTION USED ?
PUSHJ PP,EDUPON ;YES--CHECK IT OUT
FSTRY: MOVEM EACA,EOPNXT ;POSITION OF LAST OPERAND SEEN INTO EOPNXT
MOVE EACA,EOPLOC ;GET POINTER TO BEGINNING OF TABLE
;NOT TO 1ST USED SLOT
HRRZM EACA,CUREOP ;CURRENT ENTRY BEING USED IN EOPTAB
;IS ONE HELD IN CUREOP.
AOSA EACA,CUREOP ;NOW WE POINT TO 1ST USED ENTRY, 1ST WORD...
GOTMOR: HRRZ EACA,CUREOP ;GET NEXT DEEPEST ENTRY
MOVSM EACA,OPERND ; IN OPERAND TABLE
MOVE EACB,(EACA) ;GET 1ST WORD OF NEXT OPERAND
MOVEI EACA,1(EACA) ;BUMP EACA TO POINT TO SECOND WORD
TLNE EACB,GNLIT ;IS IT A LITERAL ?
JRST DISLIT ;YEP !
;OK, IT'S NOT A LITERAL:
;EITHER IT REQUIRES CONVERSION (& MXTMP. WILL WORRY ABOUT SUBSCRIPTING, ETC,)
;OR IT'S DISPLAY-7 OR DISPLAY-6, IN WHICH CASE YOU WORRY ABOUT SUBSCRIPTING.
SETOM EDEBDA## ;SIGNAL WE MIGHT WANT TO DEBUG
SOS EDEBDA ; BUT ONLY IF "ON ALL REF".
MOVE TA,(EACA) ;GET OPERAND TABLE-LINK
MOVSM TA,CURDAT ; AND SAVE IT
PUSHJ PP,LNKSET ;CONVERT TO ADDRESS
HRRM TA,CURDAT ; AND SAVE THAT
LDB TC,[POINT 3,CURDAT,2] ;GET TABLE TYPE
CAIN TC,CD.MNE ;IS IT A MNEMONIC
JRST DISSYC ;YES, MUST BE A SYMBOLIC CHARACTER
LDB TC,DA.USG ;GET USAGE OF OPERAND
JRST @DISPDO(TC) ;DO WHAT TABLE SENDS YOU TO DO
DISPDO: EXP ENDTST ; _ 0 TYPE NO YET ASSIGNED
EXP DISPD6 ; _ 1 DISPLAY-6
EXP DISPD7 ; _ 2 DISPLAY-7
EXP STNDRD ; _ 3 DISPLAY-9
EXP STNDRD ; _ 4 1 WORD COMP
EXP STNDRD ; _ 5 2 WORD COMP
EXP DISPFP ; _ 6 COMP-1
EXP STNDRD ; _ 7 INDEX
EXP STNDRD ; _ 10 COMP-3
EXP DISPF2 ; - 11 COMP-2
;"DISPLAY" GENERATOR (CONT'D).
;NOW CALL ON THE MOVE GENERATOR FOR A LITTLE HELP
STNDRD: HRRZ TC,CUREOP
PUSHJ PP,MXTMP. ;MOVE X TO A TEMP., GENERATING CONVERSION
TSWF FERROR ;ANY TROUBLE?
JRST ENDTST ;YES--IGNORE THIS OPERAND
MOVE EACD,TA ;SAVE CALL PARAMETERS
MOVE EACC,TB
STND1: TLNE W1,NOADV ;IS IT 'WITH NO ADVANCING'?
JRST STND2 ;YES--DON'T WORRY ABOUT 'END-OF-LINE' FLAG
MOVE TC,CUREOP ;SAVE ADDRESS OF THIS OPERAND
PUSHJ PP,BMPEOP ;ANY MORE OPERANDS?
TLO EACC,1B<^D18+7> ;NO--SET "END-OF-LINE" FLAG
MOVEM TC,CUREOP ;RESET ADDRESS OF CURRENT OPERAND
STND2: PUSHJ PP,DEPTSA ;[1636] See if A is depending
JRST STND2A ;[1636] No
AOS EAC ;[1636] Allocate register 1
MOVEI TE,1 ;[1636]
PUSHJ PP,SZDPVA ;[1636] Set AC1 to size of A
JFCL ;[1636]
MOVE CH,[XWD MOV+AC16,1];[1636] get size into 16
PUSHJ PP,PUTASY ;[1636] MOVE 16,1
MOVEI CH,DSPLY%## ;[1636] CALL display routine
PUSHJ PP,GNPSX.## ;[1636] PUSHJ PP,DSPLY.
POPJ PP, ;[1636]
STND2A: MOVE TA,[XWD XWDLIT,2] ;[1636]
PUSHJ PP,STASHP
MOVE TA,EACC
MOVE TE,ESIZEA ;GET SIZE OF OPERAND
CAIG TE,1777 ;WILL IT FIT IN 10 BITS?
JRST STND3 ;YES
TLZ TA,1B<^D18+7> ;NO--TURN OF 'END-OF-LINE'
MOVEI TE,^D1020 ;CHANGE SIZE TO 1000
STND3: TLZ TA,1777 ;USE SIZE IN 'TE'
TLO TA,(TE)
MOVNS TE
ADDM TE,ESIZEA
PUSHJ PP,STASHQ
MOVE TA,EACD
PUSHJ PP,POOLIT
HRRZ TE,EMODEB ;MODE OF ITEM IS IN 'B'
CAIE TE,D6MODE ;SIXBIT IS SPECIAL
SKIPA CH,[XWD DSPLY.+ASINC,AS.MSC]
; MOVE CH,[MOVEI.##+AC16+ASINC,,AS.MSC]
MOVE CH,[DSPL.6##+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
SKIPN CH,PLITPC
HRRZ CH,ELITPC
IORI CH,AS.LIT
PUSHJ PP,PUTASN
SKIPN PLITPC
AOS ELITPC
; HRRZ TE,EMODEB
; MOVEI CH,DSPL.6##
; CAIN TE,D6MODE
; PUSHJ PP,PUT.PJ ;FINISH OFF SIXBIT
SKIPN ESIZEA ;IS OPERAND COMPLETELY OUT?
JRST ENDTST ;YES--LOOK FOR NEXT ONE
MOVE TA,EMODEA ;NO
CAIN TA,D6MODE
SKIPA TA,[EXP ^D1020/6]
MOVEI TA,^D1020/5
HRLZ TA,TA
ADD EACD,TA ;BUMP ADDRESS
JRST STND1
;ITEM TO BE DISPLAYED IS ASCII
DISPD6:
DISPD7: MOVE TC,CUREOP ;SET UP PARAMETERS IN "A"
MOVEI LN,EBASEA
PUSHJ PP,SETOPN
TSWF FERROR ;ANY TROUBLE?
JRST ENDTST ;YES--FORGET THIS OPERAND
TSWT FANUM ;NUMERIC?
TSWT FASUB ;NO--SUBSCRIPTED?
JRST STNDRD ;EITHER NUMERIC OR NOT SUBSCRIPTED
;NON-NUMERIC AND SUBSCRIPTED -- USE "SUBSC." UUO
MOVE TA,CURDAT
HRRZ TB,ESIZEA ;USE INTERNAL SIZE UNLESS
LDB TE,DA.EDT ; ITEM IS
SKIPE TE ; EDITED,
LDB TB,DA.EXS ; IN WHICH CASE USE EXTERNAL SIZE
HRRM TB,ESIZEA
CAILE TB,1777 ;BIG DISPLAY?
JRST DISP7C ;YES-- GO DO IT IN 2 OR MORE STEPS
MOVEI DT,ESAVES
PUSHJ PP,BMPEOP
; TLNN W1,NOADV ; [345] IF NO ADVANCING SKIP OVER LINE END SETTING
SKIPA ; [366] NO MORE ITEMS TO DISPLAY FINISH.
JRST DISP7A ; [366] MORE ITEMS TO DISPLAY
TLNN W1,NOADV ; [366] IF NO ADVANCING, SKIP OVER
; [366] LINE END SETTING
IORI TB,1B<^D18+7>
DISP7A: MOVEM TB,SUBCON
MOVS TC,OPERND
MOVEM TC,CUREOP
PUSHJ PP,SUBSCR
JRST DISP7B ;ALL SUBSCRIPTS WERE NUMERIC LITERALS
HRRZ TE,EMODEA
CAIN TE,D6MODE ;SIXBIT IS SPECIAL
SKIPA CH,[DSPL.6,,SXR]
MOVE CH,[XWD DSPLY.,SXR]
PUSHJ PP,PUTASY
JRST ENDTST
DISP7B: MOVE EACC,TE
HRRI EACC,AS.CNB
MOVS EACD,TE
HRR EACD,EBASEA
MOVE TE,EMODEA ;SINCE CODE AFTER STND2 USES
MOVEM TE,EMODEB ;EMODEB TO CHECK FOR ASCII ITEM
JRST STND2
DISP7C: SUBI TB,^D1020 ;FIRST WE WILL DO 1020 CHARACTERS
HRRZM TB,ESIZEZ ;ESIZEZ = CHARS LEFT TO MOVE
MOVEI TE,^D1020
MOVEM TE,SUBCON ;SET SUBCON TO 1020 CHARS - NO ADVANCING!
MOVS TC,OPERND
MOVEM TC,CUREOP
MOVEI DT,ESAVES
PUSHJ PP,SUBSCR ;CALL SUBSCRIPT ROUTINE
JRST DISP7B ; ALL WERE NUMERIC LITERALS
DISP7D: HRRZ TE,EMODEA
CAIN TE,D6MODE ;SIXBIT IS SPECIAL
SKIPA CH,[DSPL.6,,SXR]
MOVE CH,[XWD DSPLY.,SXR]
PUSHJ PP,PUTASY
SKIPN ESIZEZ ;MORE CHARS TO MOVE?
JRST ENDTST ;NO, DONE WITH THIS DISPLAY
CAIN TE,D6MODE
SKIPA CH,[^D1020/6]
MOVEI CH,^D1020/5 ;NUMBER OF WORDS TO BUMP SAC
HRLI CH,ADDI.+SAC ;GENERATE "ADDI SAC,#WORDS ALREADY DISPLAYED"
PUSHJ PP,PUTASY
HRRZ TE,ESIZEZ ;GET CHARS LEFT TO MOVE
CAILE TE,1777 ;STILL BIG?
JRST DISP7E ;YES--DO ANOTHER ^D1020
;DO THE LAST OF 'EM, SETUP "EOL" FLAG IN AC12 IF NECESSARY
;HAVE TO CHANGE THE SIZE IN LH (AC12) IF DIFFERENT FROM 1020
PUSH PP,CUREOP ;SAVE TO RESTORE AFTER "BMPEOP"
SETZ TC, ;TC= 0 IF WE DON'T WANT EOL AT END
PUSHJ PP,BMPEOP
SKIPA ;NO MORE ITEMS TO DISPLAY
JRST DISP7F ;FINISH UP
TLNE W1,NOADV ;NO ADVANCING?
JRST DISP7F ;YES, DON'T SET EOL FLAG
HRRI TC,1B<^D18+7> ;EOL BIT IN TD
DISP7F: POP PP,CUREOP ;RESTORE CUREOP (THIS OPERAND)
MOVE CH,[TLZ.+SAC,,3777]
PUSHJ PP,PUTASY ;"TLZ SAC,3777" TO CLEAR OLD PARAMETERS
HRLI CH,TLO.+SAC
HRR CH,ESIZEZ ;SIZE LEFT TO DO
IOR CH,TC ;POSSIBLY SET EOF BIT
PUSHJ PP,PUTASY ;"TLO SAC,NEW.PARAMETERS"
SETZM ESIZEZ ;NO MORE CHARS TO MOVE!
JRST DISP7D ; GO DO ANOTHER DSP. UUO
;DO ANOTHER ^D1020 CHARACTER DISPLAY -- SAME PARAMS IN SAC
DISP7E: MOVEI TE,^D1020
MOVN TD,TE ;-CHARS TO MOVE THIS TIME
ADDM TD,ESIZEZ ; HOPEFULLY GET TO LESS THAN 1777 SOMETIME
JRST DISP7D ;GO DO ANOTHER UUO
;DISPLAY A COMP-1 FIELD
DISPFP: MOVE TC,CUREOP
MOVEI LN,EBASEA
PUSHJ PP,SETOPN
TSWF FERROR;
JRST ENDTST
SETZM EAC
PUSHJ PP,MXAC.
MOVEI CH,DSP.FP
DISPF3: PUSHJ PP,PUT.PJ
MOVE TC,CUREOP
PUSHJ PP,BMPEOP
JRST DISFP1
SETZM ETEMPC
JRST GOTMOR
DISFP1: MOVEM TC,CUREOP
PUSHJ PP,ASRJ.
MOVSI EACC,446001
HRRI EACC,AS.CNB
MOVS EACD,EASRJ
HRRI EACD,AS.MSC
MOVEI TE,1
MOVEM TE,ESIZEA
MOVEI TE,D7MODE ;MAKE B'S MODE DISPLAY-7.
MOVEM TE,EMODEB ;BECAUSE STND2 THINKS ORIGINAL MODE OF "A" IS IN "B"
JRST STND2
;DISPLAY A COMP-2 FIELD
DISPF2: MOVE TC,CUREOP
MOVEI LN,EBASEA
PUSHJ PP,SETOPN
TSWF FERROR;
JRST ENDTST
SETZM EAC
PUSHJ PP,MXAC.
MOVEI CH,DSP.F2##
JRST DISPF3 ;JOIN COMMON CODE
;"DISPLAY" GENERATOR (CONT'D)
;DISPLAY A LITERAL
DISLIT: TLNE EACB,GNFIGC ;IS IT A FIG. CONST.?
JRST DISFC ;YES
MOVEI LN,EBASEA ;NO--SET UP PARAMETERS
HRRZ TC,CUREOP
PUSHJ PP,SETOPN
TSWF FERROR ;ANY TROUBLE?
JRST ENDTST ;YES--FORGET THIS ONE
MOVE TE,[XWD EBASEA,EBASEB] ;MAKE "B" LOOK LIKE "A"
BLT TE,EBASBX
MOVEI TE,D7MODE ;MAKE B'S MODE DISPLAY-7.
MOVEM TE,EMODEB
MOVEI TE,2
MOVEM TE,ADCRLF## ;SEE IF WE NEED CR-LF OF JUST NULL
TLNE W1,NOADV ;IS IT 'WITH NO ADVANCING'?
JRST DISLT1 ;YES--DON'T WORRY ABOUT 'END-OF-LINE' FLAG
MOVE TC,CUREOP ;SAVE ADDRESS OF THIS OPERAND
PUSHJ PP,BMPEOP ;ANY MORE OPERANDS?
AOSA ADCRLF ;NO, ADD CR-LF
DISLT1: SOS ADCRLF ;YES, JUST NULL REQUIRED
MOVEM TC,CUREOP ;RESET ADDRESS OF CURRENT OPERAND
PUSHJ PP,LITD.
SETZM ADCRLF
REPEAT 0,<
MOVS EACD,EINCRA
HRRI EACD,AS.MSC
MOVE EACC,[EXP ^D36B5+AS.CNB]
MOVE TE,ESIZEA
DPB TE,[POINT 7,EACC,17]
JRST STND1
>
MOVE CH,[DSPL.7##+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EINCRA
ANDI CH,077777
IORI CH,AS.LIT
PUSHJ PP,PUTASN
JRST ENDTST ;SEE IF MORE
;"DISPLAY" GENERATOR (CONT'D)
;DISPLAY A FIGURATIVE CONSTANT
DISFC: TLNE EACB,GNTIME ;"DATE", "DAY", "TIME"
JRST STNDRD ;YES--USE STANDARD ROUTINE
TLNE EACB,GNFCS ;SPACE?
JRST FIGC1
TLNE EACB,GNFCZ ;ZERO
JRST FIGC2
TLNE EACB,GNFCQ ;QUOTE?
JRST FIGC3
TLNE EACB,GNFCHV ;HIGH-VALUE
JRST FIGC4
TLNE EACB,GNFCLV ;LOW-VALUE
JRST FIGC5
MOVEI DW,E.184 ;NONE OF THE ABOVE
PUSHJ PP,OPNFAT
JRST ENDTST
FIGC1: MOVSI TA,(BYTE(7)" ") ; A SPACE
JRST FIGC6
FIGC2: MOVSI TA,(BYTE(7)"0") ; A ZERO
JRST FIGC6
FIGC3: MOVSI TA,(BYTE(7)"""") ; A QUOTE
JRST FIGC6
FIGC4: MOVSI TA,(BYTE(7)177) ; A NORMAL HIGH-VALUE
SKIPG COLSEQ## ;PROGRAM COLLATING SEQUENCE?
JRST FIGC6 ;NO
HRRZ TA,COHVLV##+1 ;YES, GET ASCII HIGH-VALUE CHAR.
JRST FIGC7 ;LEFT JUSTIFY
FIGC5: MOVSI TA,(BYTE(7)0) ; A NORMAL LOW-VALUE
SKIPG COLSEQ ;PROGRAM COLLATING SEQUENCE?
JRST FIGC6 ;NO
HRRZ TA,COHVLV+4 ;YES, GET ASCII LOW-VALUE CHAR.
FIGC7: ROT TA,-7 ;LEFT JUSTIFY
FIGC6: PUSH PP,TA ;SAVE LITERAL WE WANT
MOVE TA,[XWD ASCLIT##,1]
PUSHJ PP,STASHP
POP PP,TA ;GET LITERAL WE WANT
MOVE TC,CUREOP
PUSHJ PP,BMPEOP ;ANY MORE OPERANDS?
TLNE W1,NOADV ;NO MORE, BUT IS NO ADVANCING SET?
JRST FIGC8 ;MORE TO FOLLOW, LEAVE AS IS
SKIPE TA ;IS IT A NUL?
TDOA TA,[BYTE(7)0,15,12,0,0] ;NO, APPEND <CRLF>
MOVSI TA,(BYTE(7)15,12) ;YES, CONVERT TO <CRLF>
FIGC8: MOVEM TC,CUREOP
PUSHJ PP,POOLIT
SKIPN EACC,PLITPC
MOVE EACC,ELITPC
SKIPN PLITPC
AOS ELITPC
MOVE CH,[DSPL.7##+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
MOVE CH,EACC
IORI CH,AS.LIT
PUSHJ PP,PUTASN
JRST ENDTST
;Enter here with a MNETAB entry. TA contains table address, also in CURDAT.
;This should point to a symbolic character.
DISSYC: LDB TB,MN.SYC## ;MAKE SURE IT REALY IS A SYMBOLIC CHARACTER
JUMPE TB,FIGC6 ;NO, OUTPUT A NUL
LDB TB,MN.ESC## ;SEE IF EBCDIC
LDB TA,MN.SCV## ;GET CHARACTER
JUMPE TB,FIGC7 ;OK ITS ASCII
MOVE TE,TA ;GET READY TO CONVERT TO ASCII
PUSHJ PP,VLIT9A## ;CONVERT TO ASCII IN TE
MOVE TA,TE
JRST FIGC7 ;LEFT JUSTIFY AND OUTPUT IT
;"DISPLAY" GENERATOR (CONT'D).
ENDTST: PUSHJ PP,CDEBA## ;COPY LAST INDENTIFIER TO DEBUG LIST
PUSHJ PP,BMPEOP ;ANY MORE OPERANDS?
PJRST GDEBV## ;NO, DUMP THE DEBUG LIST AND RETURN
SETZM ETEMPC ;YES--RESET %TEMP BASE
JRST GOTMOR ;CONTINUE PROCESSING
EDUPON: HRRZ TA,(EACA) ;GET TABLE ENTRY FOR "UPON" OPERAND
CAIL TA,700001
CAILE TA,777777 ;BETWEEN COARSE LIMITS OF MNEMONIC TABLE?
JRST BADNEW ;BAD NEWS, NOT A MNEM TABLE LINK
PUSHJ PP,LNKSET ;CONVERT TO REAL ADDRESS
MOVE EACB,1(TA) ;GET MNEMONIC TABLE ENTRY
TLNE EACB,1B21 ;CONSOLE FLAG UP ?
JRST REPOS ;YES HE'S AOK
;REPOSITION POINTER TO LOOK AT LAST
;"WRIT-ABLE" ITEM.
BADNEW: MOVEI DW,E.102
PUSHJ PP,EWARN
REPOS: SUB EACA,[XWD 2,2] ;BACK OFF EACA
CAMN EACA,EOPLOC ;WAS THAT THE ONLY OPERAND?
JRST BADEOP ;YES--TROUBLE
POPJ PP, ;NO--RETURN
SUBTTL ACCEPT
ACCGEN: MOVEM W1,OPLINE ;SAVE LN&CP OF OPERATOR
MOVE EACA,EOPNXT
CAMN EACA,EOPLOC ;ANY OPERANDS?
JRST BADEOP ;NO--TROUBLE
MOVE TA,-1(EACA) ;GET 2ND OPERAND
TLNE TA,GNFIGC ;FIG. CONST?
JRST ACCTDY ;YES
TLNE W1,CONSOL
PUSHJ PP,EDUPON
MOVEM EACA,EOPNXT ;SAVE UDPATED EOPNXT
HRRZ TC,EOPLOC
ADDI TC,1
MOVEM TC,CUREOP
SWOFF FASUB!FALWY0 ;AC'S NOT SUBSCRIPTED AND NOT ZERO
ACEPT1: MOVEM TC,OPERND
SETOM EDEBDB## ;SIGNAL WE MIGHT WANT TO DEBUG
MOVEI LN,EBASEB
PUSHJ PP,SETOPN
TSWF FERROR ; [430] ANY ERRORS?
JRST ACEPT6 ; [430] YES--DON'T BOTHER WITH THE REST
MOVE TE,[XWD EBASEB,EBASEA] ;SET "A" EQUAL TO "B"
BLT TE,EBASAX
MOVE TA,CUREOP ;IS "B" EDITED?
MOVE TA,1(TA)
PUSHJ PP,LNKSET
LDB TE,DA.EDT
JUMPE TE,ACEPT2
MOVEI TD,EDMODE ;YES--RESET MODE TO
HRRM TD,EMODEB ; 'EDITED'
ACEPT2: HRLZ TC,ESIZEB
PUSHJ PP,BMPEOP
TLO TC,1B<^D18+7>
MOVSM TC,SUBCON
MOVE TC,OPERND
MOVEM TC,CUREOP
MOVE TE,0(TC)
TLNE TE,GNOPNM
JRST ACEP15
;"ACCEPT" GENERATOR (CONT'D).
;FIELD IS ALPHANUMERIC
HRRZ TE,EMODEB
CAIE TE,D7MODE
JRST ACEP10
HRRZ TE,EMODEB
CAIN TE,EDMODE
JRST ACEP10
TSWT FBSUB;
JRST ACEPT5
MOVEI DT,ESAVSB
PUSHJ PP,SUBSCR
JRST ACEPT4
MOVE CH,[XWD ACEPT.,SXR]
PUSHJ PP,PUTASY
JRST ACEPT6
ACEPT4: HRRZM TE,EINCRA
LSH TE,-14
HLLM TE,ERESA
ACEPT5: PUSHJ PP,ACEP20
ACEPT6: PUSHJ PP,CDEBB## ;COPY LAST INDENTIFIER TO DEBUG LIST
PUSHJ PP,BMPEOP ;ANY MORE OPERANDS?
PJRST GDEBV## ;NO, DUMP THE DEBUG LIST AND RETURN
MOVE TC,CUREOP ;YES--LOOP BACK FOR MORE
JRST ACEPT1
;"ACCEPT" GENERATOR (CONT'D).
;FIELD IS EITHER ALPHA-EDITED, OR NON-ASCII ALPHANUMERIC
ACEP10: MOVE TE,[XWD ^D36,AS.MSC]
MOVEM TE,EBASEA
MOVE TE,ESIZEA
IDIVI TE,5
SKIPE TD
ADDI TE,1
PUSHJ PP,GETEMP
HRRZM EACC,EINCRA
MOVEI TE,D7MODE
MOVEM TE,EMODEA
PUSHJ PP,ACEP20
SWOFF FASIGN!FANUM;
PUSHJ PP,MXX.
JRST ACEPT6
;FIELD IS NUMERIC OR NUMERIC EDITED
ACEP15: PUSHJ PP,ACEP25
SETZM EAC
SWON FASIGN!FANUM
HRRZ TE,EMODEA
CAIE TE,FPMODE ;SKIP IF IT'S GOING TO RETURN A FLOATING NUMBER
CAIN TE,F2MODE ;OR COMP-2
TRNA ;YES
MOVEI TE,D2MODE ;NO, A 2-WORD COMP
MOVEM TE,EMODEA
PUSHJ PP,MACX. ;GEN CODE TO STORE VALUE IN THE ITEM
JRST ACEPT6 ;AND GO ON TO NEXT OPERAND
;"ACCEPT" GENERATOR (CONT'D).
;CREATE LITERAL AND CALL FOR ALPHANUMERIC
ACEP20: MOVE TA,[XWD XWDLIT,2]
PUSHJ PP,STASHP
HRRZ TA,ESIZEB ;[447] # OF CHARACTERS TO ACCEPT
CAIL TA,2000 ;[447] # .GT. 1023. ?
PUSHJ PP,SUBWRN ;[447] YES, GIVE WARNING AND SET TO 1023.
HRLZ TA,SUBCON
LSH TA,6
HLR TA,ERESA
ROT TA,-6
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
MOVE TA,EBASEA
HRL TA,EINCRA
ACEP21: PUSHJ PP,POOLIT
MOVSI CH,ACEPT.
PUSHJ PP,PUT.LD
SKIPN PLITPC
AOS ELITPC
POPJ PP,
;[447] AREA GREATER THAN 1023 CHARACTERS. GIVE WARNING AND SET TO 1023.
SUBWRN: MOVEI DW,E.590 ;[447] DIAGNOSTIC NUMBER
PUSHJ PP,EWARN ;[447]
HRLZI TA,^D1023 ;[447] 'ACCEPT' ONLY 1023. CHARACTERS
JRST CPOPJ1 ;[447] SKIP RETURN
;CREATE LITERAL AND CALL FOR NUMERIC
ACEP25: MOVE TA,[XWD XWDLIT,2]
PUSHJ PP,STASHP
MOVS TA,SUBCON
TLO TA,1B<^D18+6>
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
HRRZ TA,EMODEA ;ACCEPT FLOATING POINT NUMBER?
CAIE TA,FPMODE
CAIN TA,F2MODE
JRST [MOVSI TA,1B19 ;YES, SET BIT 19 FOR ACEPT.
JRST ACEP26]
HRLZ TA,EDPLA
JUMPGE TA,ACEP26
MOVMS TA
TLO TA,40
JRST ACEP27
ACEP26: HRRZ TB,ESIZEA ;CHECK FOR PPPP...9999
SUB TB,EDPLA
SKIPGE TB ;NOPE
TLO TA,1B18 ;YES- SET BIT 18 (SAVE ONLY FIELD-SIZE DIGITS)
ACEP27: HRRI TA,AS.CNB
JRST ACEP21
;ACCEPT XXX FROM DATE, DAY, OR TIME.
;[1053] TA CONTAINS THE FIRST WORD OF THE TWO-WORD OPERAND
;[1053] FOR "DATE" OR "DAY" OR "TIME".
;[1053] THE TWO OPERANDS ARE SWAPPED SO IT LOOKS LIKE A "MOVE"
;[1053] FROM THE FIGURATIVE CONSTANT TO THE ITEM.
;[1053] THEN MOVGEN IS CALLED TO GENERATE THE CODE.
ACCTDY: TLNN TA,GNTODY ;ONE OF DATE, DAY, OR TIME?
JRST BADEOP ;WELL IT SHOULD BE
PUSH PP,TA ;[1053] SAVE 1ST WORD OF F.C.
PUSH PP,0(EACA) ;[1053] AND 2ND.
;[1053] MOVE THE ITEM DOWN TO MAKE ROOM FOR THE 2ND OPERAND TO GO FIRST.
HRRZ TB,EOPNXT ;[1053] END OF EOPTAB
HRRZ TA,EOPLOC ;[1053] START OF EOPTAB
SUBI TB,2(TA) ;[1053] CALCULATE NO. WORDS IN 1ST OPERAND.
HRROI TA,-2(EACA) ;[1053] FIRST WORD TO COPY, MAKE A PD-PTR.
POP TA,2(TA) ;[1053] REVERSE BLT
SOJG TB,.-1 ;[1053] ONE WORD AT A TIME
;[1053] STORE FIG. CONST. OPERAND IN THE TWO WORDS WE JUST FREED UP.
HRRZ TB,EOPLOC ;[1053] PLACE TO START
POP PP,2(TB) ;[1053] ..SECOND WORD..
POP PP,1(TB) ;[1053] .. AND FIRST WORD.
JRST MOVGEN## ;AND TREAT AS IF A MOVE
SUBTTL IO GENERATOR SUBROUTINES
;SETOP: SETUP POINTERS TO OPERANDS
;[12B] SET IOFLGS TO 0
SETOP: MOVEM W1,OPLINE ;SAVE OPERATOR'S LN&CP
SWOFF FEOFF1 ;CLEAR MOST FLAGS
MOVE EACA,EOPNXT
CAME EACA,EOPLOC ;ANY OPERANDS?
JRST SETOP1 ;YES
SWON FERROR ;NO--SET FLAG SO NO CODE GENERATED
JRST BADEOP
SETOP1: HRRZ TA,EOPLOC ;SET TA TO FIRST ONE
ADDI TA,1
MOVEM TA,OPERND ;SAVE
MOVE TA,1(TA) ;RESOLVE INTO ACTUAL ADDRESS
MOVSM TA,CURFIL
PUSHJ PP,LNKSET
HRRM TA,CURFIL
SETZM IOFLGS## ;CLEAR IO FLAGS
POPJ PP,
;SET UP AND WRITE OPERATOR
PUTOP: HLR CH,CURFIL
AND CH,[XWD -1,LMASKB]
IORI CH,AS.FIL
JRST PUTASY
;CONVERT RELATIVE KEY TO COMP IF REQUIRED
;CNVKYB - CONVERT KEY BEFORE I/O, NON-SKIP RETURN
;SET LH(WDPITM) = -1 IF KEY IS NOW STORED IN %PARAM+0
CNVKYB: PUSH PP,TA ;SAVE TA
MOVE TA,CURFIL ;RELOAD IT
PUSH PP,CH ;SAVE CURRENT OPERATOR
LDB CH,FI.CKB## ;NEED TO CONVERT KEY
JUMPE CH,CNVKYR ;NO
HRLI CH,EPJPP ;
PUSHJ PP,PUTASY
HRROS WDPITM## ;[750] SET LH(WDPITM) TO -1
CNVKYR: POP PP,CH
POP PP,TA
POPJ PP,
;CNVKYA - CONVERT KEY BACK AFTER I/O, SKIP RETURN ALWAYS
CNVKYA: PUSH PP,TA ;SAVE TA
MOVE TA,CURFIL ;RELOAD IT
PUSH PP,CH ;SAVE CURRENT OPERATOR
LDB CH,FI.CKA## ;NEED TO CONVERT KEY
JUMPE CH,CNVKYR ;NO
PUSHJ PP,PUTASA ;USE SKIP TYPE PUSHJ
LDB CH,FI.CKA
HRLI CH,XPSHJ.##+AC17
PUSH PP,CH
PUSHJ PP,PUTASY
PUSHJ PP,PUTASA
POP PP,CH
PUSHJ PP,PUTASY
JRST CNVKYR ;RETURN
;CNVCKC - CONVERT KEY BACK AFTER I/O, NON-SKIP RETURN
CNVKYC: PUSH PP,TA ;SAVE TA
MOVE TA,CURFIL ;RELOAD IT
PUSH PP,CH ;SAVE CURRENT OPERATOR
LDB CH,FI.CKA## ;NEED TO CONVERT KEY
JUMPE CH,CNVKYR ;NO
ADDI CH,1 ;GET NEXT TAG
HRLI CH,EPJPP
PUSHJ PP,PUTASY
JRST CNVKYR ;RETURN
;GET FILTAB ENTRY CORRESPONDING TO THE SPECIFIED OUTPUT RECORD
GTFATH: LDB CH,[POINT 3,(TA),2] ;IS THIS A DATA-NAME?
CAIE CH,TB.DAT
JRST NOTREC ;NO--ERROR
LDB TE,DA.DEF ;IS IT DEFINED?
JUMPE TE,NOTREC ;IF NOT, ERROR
GTFAT1: MOVE CH,TA
LDB TA,DA.BRO
JUMPE TA,NOTREC
LDB TE,LNKCOD ;IS FATHER/BROTHER LINK TO DATAB?
CAIE TE,TB.DAT
JRST GTFAT2 ;NO
PUSHJ PP,LNKSET ;YES--CONVERT TO ADDRESS
JRST GTFAT1 ;LOOP TO NEXT
GTFAT2: CAIE TE,TB.FIL ;IS FATHER/BROTHER A FILE?
JRST NOTREC ;NO--ERROR
MOVSM TA,CURFIL ;YES--SAVE LINK
PUSHJ PP,LNKSET ;CONVERT TO ADDRESS
HRRM TA,CURFIL ; AND SAVE THAT
POPJ PP,
;FIND LARGEST DATAB RECORD FOR THIS FILTAB--PUT OPERAND FOR IT INTO "EINTO"
LARGE: PUSHJ PP,LARGER ; [245] FIND LARGEST RECORD
MOVEM CH,EINTO ; [245] STORE INTO EINTO FOR READ OR RETURN
MOVE TB,EINTR+1 ; [245] FINISH FOR
MOVEM TB,EINTO+1 ; [245] 2ND WORD
POPJ PP, ; [245]
LARGER: MOVE TA,CURFIL ; [245] REPORT WRITER ENTRY GET LINK TO
LDB TA,FI.DRL ; FIRST DATA RECORD
HRRZI TD,0 ;CLEAR SIZE OF LARGEST
LARGE1: MOVE CH,TA ;SAVE DATAB LINK
JUMPE TA,LARGE4 ;MUST BE AN ERROR CASE, NONE THERE
PUSHJ PP,LNKSET
LDB TC,DA.EXS ;GET SIZE OF THAT RECORD
JUMPE TC,LARGE5 ;[474] IF SIZE ZERO TROUBLE
CAIG TC,(TD) ;IS THIS LARGEST SO FAR?
JRST LARGE2 ;NO
MOVE TD,TC ;YES
HRRZM CH,EINTR+1 ; [245] SAVE LARGEST
MOVEM TA,EINTR ; [245] RECORD
LARGE2: LDB TC,DA.FAL ;IF THERE IS NO
JUMPN TC,LARGE3 ; BROTHER, WE ARE DONE
LDB TA,DA.BRO ;GET BROTHER LINK
JRST LARGE1 ;LOOP
LARGE5: MOVEI DW,E.340 ;[474] GET SIZE ERROR MESSAGE
LDB CP,W1CP ;[474] GET CHARACTER POSITION
LDB LN,W1LN ;[474] GET LINE NUMBER
PUSHJ PP,WARN ;[474] PUT OUT MESSAGE AND CONTINUE
LARGE4: MOVEI TA,<CD.DAT>B20+1 ;AIM AT DUMMY
MOVEM TA,EINTR+1 ; [357] KEEP DUMMY DATAB LINK
PUSHJ PP,LNKSET ; & GO ON (ERROR MSG FROM ELSEWHERE)
MOVEM TA,EINTR ; [357] SAVE DUMMY DATAB ADDRESS
LARGE3: MOVE TA,EINTR ; [245] GET ADR OF RECORD
LDB CH,DA.LNC ; [245] GET LN&CP OF LARGEST RECORD
MOVEM CH,EINTR ; [245] SAVE IT
POPJ PP,
;Similar to LARGE
;In ANS-8x INTO is only allowed if there is only 1 data-record or
;all data records plus INTO item are either group items or elementary alphanumeric items.
INTOCK: SKIPG AS7482## ;OK IN COBOL-74
POPJ PP, ;SO BYPASS ALL THIS TESTING
MOVE TA,CURFIL ;Copy routine LARGE
LDB TA,FI.DRL## ; FIRST DATA RECORD
JUMPE TA,CPOPJ ;MUST BE AN ERROR CASE, NONE THERE
PUSHJ PP,LNKSET
LDB CH,DA.FAL ;IF THERE IS NO BROTHER
JUMPN CH,CPOPJ ;THEN ONLY 1 DATA RECORD, AND TEST PASSES
INTCK1: LDB CH,DA.SON## ;IS IT A GROUP ITEM?
JUMPN CH,INTCK2 ;YES, SO THIS ONE IS OK
LDB CH,DA.CLA## ;ELEMENTARY, SO GET CLASS
CAIE CH,%CL.AN ;IS IT ALPHANUMERIC?
JRST INTCK4 ;NO, SO TEST FAILED
INTCK2: LDB TC,DA.FAL ;IF THERE IS NO
JUMPN TC,INTCK3 ; BROTHER, WE ARE DONE
LDB TA,DA.BRO ;GET BROTHER LINK
JUMPE TA,CPOPJ
PUSHJ PP,LNKSET
JRST INTCK1 ;LOOP
INTCK3: HRRZ TA,EINTO+3 ;GET INTO DATAB
PUSHJ PP,LNKSET
LDB CH,DA.SON ;IS IT A GROUP ITEM?
JUMPN CH,CPOPJ ;YES, SO THIS IS OK
LDB CH,DA.CLA ;ELEMENTARY, SO GET CLASS
CAIN CH,%CL.AN ;IS IT ALPHANUMERIC?
POPJ PP, ;YES, SO TEST PASSED
INTCK4: MOVEI DW,E.828 ;ERROR, WARN USER
MOVE TC,OPLINE ;POINT TO DATA ITEM
PJRST ANYWRN##
;[605] SEE IF THIS IS A VARIABLE LENGTH READ IN WHICH THE DEPENDING ITEM
;[605] IS NOT CONTAINED IN THE RECORD ITSELF
;OR IF ITS "RECORD IS VARYING IN SIZE DEPENDING ON ..." SYNTAX
INTERN VLTST,VLTSTN ;[605] SO IT CAN BE CALLED FROM IFGEN
VLTST: SETZM EDEPFT## ;[605] CLEAR THE FLAG WORD
MOVE TA,CURFIL ;[605] GET LINK TO CURRENT FILE TABLE
LDB TB,FI.DEP## ;DEPENDING VARIABLE?
JUMPE TB,VLTST0 ;NO, TEST ALL THE DATA RECORDS FOR VARIABLE CASE
HLRZM TA,EDEPFT ;YES, SAVE FILTAB LINK FOR AFTER READ
POPJ PP,
VLTST0: LDB TA,FI.DRL ;[605] GET FIRST DATA RECORD
VLTST1: JUMPE TA,CPOPJ ;[605] MUST BE AN ERROR CASE, NONE THERE
HRRZ CH,TA ;[605] SAVE DATAB LINK
PUSHJ PP,LNKSET ;[605]
LDB TC,DA.DLL## ;[605] DEPENDING ITEM AT LOWER LEVEL?
JUMPE TC,VLTST9 ;[605] NO, TRY NEXT RECORD
LDB TB,DA.SON## ;[605] FIND THE DEPENDING ITEM
VLTST2: PUSHJ PP,FNDBRO## ;[605] THIS CODE COPIED FROM MOVGEN CODE
SKIPA TA,TB ;[605] FOUND LAST BROTHER
JRST VLTST2 ;[605] NO, LOOP
HRL CH,TA ;[605] SAVE OCCURS ITEM FOR IFGEN
PUSHJ PP,LNKSET ;[605]
LDB TB,DA.DLL ;[1375] [1030] IS THE DEPENDING VARIABLE AT THIS LEVEL?
JUMPE TB,VLTST3 ;[1375] [1030] YES
LDB TB,DA.SON ;[605] ARE WE AT THE ELEMENTARY ITEM
JUMPN TB,VLTST2 ;[605] THIS ISN'T IT, GO DOWN DEEPER
LDB TB,DA.DEP## ;[605] IS THIS THE DEPENDING VARIABLE?
JUMPE TB,VLTST8 ;[605] ?ERROR--SHOULD HAVE FOUND DEPENDING ITEM!
VLTST3: PUSH PP,TB ;[605] INCASE ALREADY AT THE TOP LEVEL
PUSHJ PP,FNDPOP## ;[605] FIND THE TOP LEVEL
JRST VLTST5 ;[605] MUST BE ALREADY AT TOP LEVEL
POP PP,(PP) ;[605] CLEANUP THE STACK
VLTST4: PUSHJ PP,FNDBRO## ;[605] GET LAST BROTHER
JRST VLTST3 ;[605] NOW LOOK FOR ITS FATHER
JRST VLTST4 ;[605] NO, LOOP
VLTST5: POP PP,TB ;[605] GET BACK THE TOP ITEM
HLRZ TA,CURFIL ;[605] GET TABLE ENTRY FOR CURRENT FILE
CAMN TA,TB ;[605] IS THE DEPENDING ITEM PART OF THE RECORD
JRST VLTST8 ;[605] YES, IGNORE THIS CASE
MOVEM TA,EDEPFT ;[605] SAVE IT FOR AFTER READ
POPJ PP, ;[605]
VLTST8: HRRZ TA,CH ;[605] RELOAD
VLTSTN: PUSHJ PP,LNKSET ;[605] ENTRY FROM IFGEN FOR NEXT BROTHER
VLTST9: LDB TC,DA.FAL ;[605] IF THERE IS NO
JUMPN TC,CPOPJ ;[605] BROTHER, WE ARE DONE
LDB TA,DA.BRO ;[605] GET BROTHER LINK
JRST VLTST1 ;[605] LOOP
;DIAGNOSTIC ROUTINES
;FILE IS NOT RANDOM
NOTRAN: MOVEI DW,E.205
JRST OPFAT
;[1331] IMPROPER "ADVANCING N LINES"
BADADV: MOVEI DW,E.288 ;[1331] DATA-NAME HAS ERROR BIT ON
JRST ADVERA ;[1331]
;IMPROPER "ADVANCING N LINES"
BADLIN: MOVEI DW,E.98
JRST ADVERA
;ADVANCING <DATA-NAME> HAD DECIMAL PLACES
NOTINT: MOVEI DW,E.207
ADVERA: HRRZ TE,EOPNXT
MOVEI TE,-1(TE)
MOVEM TE,CUREOP
PUSHJ PP,OPNFAT
MOVE TA,CURFIL ;FIND OUT IF WE ARE DOING AN RMS FILE,
LDB TE,FI.RMS ; AND IF SO, GO BACK TO CODE WHICH IS
JUMPN TE,WRTM2K ; GENERATING THE RMS WRITE VERB.
JRST RITGN3
;NOT WRITING A RECORD
NOTREC: MOVEI DW,E.206
MOVE TE,OPERND
HRRZM TE,CUREOP
JRST OPNFAT
;UNDEFINED DATA-NAME IN "ADVANCING"
UNDEFD: MOVEI DW,E.104
JRST ADVERA
;MISCELLANEOUS CONSTANTS
ADVANC==1B27 ;"ADVANCING" IN GENFIL OPERATOR
AFTER==1B28 ;"AFTER ADVANCING" IN GENFIL OPERATOR
FROM==1B29 ;"WRITE FROM" IN GENFIL OPERATOR
INTO==1B27 ;"READ INTO" IN GENFIL OPERATOR
POSTNG==(1B12) ;"POSITIONING" IN GENFIL OPERATOR
CONSOL==1B27 ;"UPON" FOR DISPLAY, "FROM" FOR ACCEPT
DELETF==1B30 ;"WITH DELETE" IN GENFIL OPERATOR
NOADV==1B28 ;"WITH NO ADVANCING" IN 'DISPLAY' OPERATOR
CHANUM: POINT 3,1(TA),35 ;CHANNEL NUMBER IN MNETAB
EXTERNAL CURDAT,EIOOP,LMASKB
EXTERNAL EINTO,EINTR,OPERND,ESAVAC,EAC,W1LN,W1CP,EPJPP,PUT.PJ
EXTERNAL EASRJ,EAZRJ,EAQRJ,ERECSZ
EXTERNAL EOPLOC,EOPNXT,CURFIL,CUREOP,OPLINE
EXTERNAL ETEMPC,ELITPC,ESAVAC
EXTERNAL LITLOC,BYTE.W
EXTERNAL SUBCON,DSP.FP
EXTERNAL EBASEB,EMODEB,EDPLB,EINCRB,ESIZEB,ERESB,ETABLB,EFLAGB
EXTERNAL EBASEA,EMODEA,EDPLA,EINCRA,ESIZEA,ERESA,EBASAX,EBASBX
EXTERNAL ESAVES, ESAVSB
EXTERNAL JRST.,ACEPT.,DSPLY.,RERIT.,WADV.,PURGE.
EXTERNAL AS.FIL,AS.TAG,AS.CNB,AS.MSC,AS.LIT,XWDLIT
EXTERNAL AS.XWD,D1MODE,D2MODE,D6MODE,D7MODE,EDMODE
EXTERNAL ATINVK,ATEND,INVKEY,SPIF.,TCCP,TCLN,GO2NXT
EXTERNAL LNKCOD,TB.DAT,TB.FIL,TB.MNE
EXTERNAL DA.LNC,DA.DEF,DA.USG,DA.NDP,DA.EXS,DA.BRO,DA.CLA,DA.EDT,DA.FAL
EXTERNAL DA.LN,DA.CP
EXTERNAL FI.ORG,FI.ERM,FI.DRL,FI.RKY,FI.SKY
EXTERN CPOPJ,CPOPJ1
EXTERN ROUCAL
SUBTTL SIMULTANEOUS ACCESS CODE GENERATION ROUTINES.
ENTRY FENQGN,EFENQG,FUNAVG,EFUNAV
ENTRY ERENQG,RDEQGN
ENTRY ERUNAV,ENRGEN,RENQGN,ERDEQG
EXTERN AS.EXT,AS.LIT,AS.MSC,AS.TAG,COMEBK,CUREOP
EXTERN AS.CNB,AS.FIL,OCTLIT
EXTERN ELITPC,EOPNXT,ESAVW1,ESUCNT,ESUCT2
EXTERN ESUFN1,ESUFN2,ESUTAG,ESUTC,GETTAG
EXTERN JRST.,XJRST.,MOVEI.,XWDLIT,PUSH12,PUSHJ.,PUTASN
EXTERN PUTASY,PUTASA,PUT.EX,PUT.PJ,PUTTAG,REFTAG,SARG,XWDLIT,ARG
EXTERN EUNSPT,EUNSTK
EXTERN LFENQ.,LRENQ.,LRDEQ.,CNTAI.
EXTERN STASHI,STASHL,STASHP,STASHQ,POOLIT,PLITPC
EXTERN FILLOC,LPCSAV
EXTERN DA.RES
EXTERN FI.ORG,FI.FAM
;FILE ENQUEUE - RECORD ENQUEUE
FENQGN:
;SINCE APPLY BASIC-LOCKING IS A FORM OF SIMULTANEOUS UPDATE, IT SEEMED
;REASONABLE TO HAVE COBOLD CREATE A GENFIL OPERATOR FOR FENQ (143).
;HOWEVER, AT THIS POINT, THE OPEN UNDER APPLY BASIC-LOCKING MUST BE
;TREATED AS THE OPEN FOR A SINGLE FILE. THIS IS WHY WE SHUNT IT OVER
;TO OPENGN AT THIS POINT.
SKIPE ABSEEN## ;APPLY BASIC-LOCKING SEEN?
JRST OPENGN ; YES
;I FOUND OUT THE HARD WAY THAT RDEQGN COMES THRU HERE TOO.
RENQGN: PUSHJ PP,PUSH12 ;SAVE OPERATOR ON OPERAND STACK
AOS ESUCNT ;INCREMENT COUNT OF OPERATORS STACKED
AOJA EACC,COMEBK ;GO BACK FOR MORE
;FILE UNAVAILABLE
FUNAVG: PUSHJ PP,GETTAG ;GET A LABEL
AOS TA,EUNSPT
CAILE TA,20
JRST KILL## ;CHECK IF UNAVAILABLE STACK OVERFLOW
MOVEM CH,EUNSTK-1(TA) ;STORE LABEL ON STACK IF NO OVERFLOW
IOR CH,[JRST.,,AS.TAG]
PUSHJ PP,PUTASY ;GENERATE JRST TAG
MOVE TA,EUNSTK-1(TA)
PUSHJ PP,REFTAG ;REFERENCE TAG
SKIPE CH,ESUTAG ;IF ESUTAG IS NON-ZERO
PUSHJ PP,PUTTAG ;DEFINE LABEL USED BY EFENQG
JRST COMEBK ;ALL DONE; UNAVAILABLE CODE GENERATED NEXT
;END FILE ENQUEUE
EFENQG:
MOVEM W1,ESAVW1 ;SAVE FLAG IN W1 FOR USE LATER
MOVE TA,ESUCNT
MOVEM TA,ESUCT2 ;SAVE N FOR DECREMENTING
AOJ TA,
LSH TA,1
HRLI TA,XWDLIT ;CREATE HEADER WORD FOR LITERAL
PUSHJ PP,STASHI ;STASH AWAY HEADER WORD
LSH W1,-8
TLZ W1,777776
HLL TA,W1 ;MOVE UNAVAILABLE BIT TO LH OF TA
HRRI TA,AS.CNB
PUSHJ PP,STASHL ;STASH UNAVAILABLE FLAG IN LIT TAB
HRL TA,ESUCNT
HRRI TA,AS.CNB
PUSHJ PP,STASHL ;STASH AWAY N IN LIT TABLE
EFENQ1: SOSGE ESUCT2 ;IS THERE ANOTHER FILE ARGUMENT ?
JRST EFENQ2 ;NO
MOVE EACA,EOPNXT ;YES, GET POINTER TO TOP OF STACK
POP EACA,W2
POP EACA,TA ;POP OFF OPERATOR
HRRI TA,AS.CNB
PUSHJ PP,STASHL ;STASH AWAY FLAGS
POP EACA,TA
ANDI TA,77777
ORI TA,AS.FIL
PUSHJ PP,STASHL ;STASH AWAY FILE TABLE ADDRESS
POP EACA,W1 ;POP OFF OPERAND
MOVEM EACA,EOPNXT ;UPDATE POINTER TO TOP OF STACK
SUBI EACC,2 ;DECREMENT COUNT OF OPERANDS ON STACK
JRST EFENQ1 ;GO BACK FOR THE NEXT ONE
EFENQ2: MOVE CH,[MOVEI.+ASINC+AC16,,AS.MSC]
PUSHJ PP,PUTASY ;GENERATE MOVEI 16,LIT-TABLE-ENTRY
HRRZ CH,ELITPC
TRO CH,AS.LIT
PUSHJ PP,PUTASN ;(IT REQUIRES 2 WORDS IN THE AS FILE)
MOVEI CH,LFENQ.
PUSHJ PP,PUT.PJ ;GENERATE PUSHJ PP,LFENQ
AOS TA,ESUCNT
ADDM TA,ELITPC ;INCREMENT ELITPC BY N+1
SETZM ESUCNT ;ZERO COUNT OF OPERANDS
MOVE TA,ESAVW1
TLNN TA,000400 ;USER SUPPLIED UNAVAILABLE STATEMENT?
JRST COMEBK ;NO, WE'RE ALL DONE
PUSHJ PP,PUTASA ;IN SECOND SET
PUSHJ PP,GETTAG ;GET A LABEL
MOVEM CH,ESUTAG ;SAVE FOR LATER USE BY FUNAVG
IOR CH,[XJRST.,,AS.TAG]
PUSHJ PP,PUTASY ;GENERATE JRST TAG
MOVE TA,ESUTAG ;GET TAG
PUSHJ PP,REFTAG ;REFERENCE IT
JRST COMEBK ;ALL DONE
;END FILE UNAVAILABLE - END RECORD UNAVAILABLE
;END NOT RETAINED
EFUNAV:ERUNAV:
ENRGEN: SOSGE TA,EUNSPT ;CHECK FOR STACK UNDERFLOW
JRST KILL
MOVE CH,EUNSTK(TA) ;GET LABEL FROM TOP OF UNAVAILABLE STACK
PUSHJ PP,PUTTAG ;DEFINE IT
;END RECORD ENQUEUE - END RECORD DEQUEUE
ERENQG:
ERDEQG: MOVE TA,ESUCNT ;GET COUNT OF RENQ OR RDEQ OPERATORS ON STACK
JUMPE TA,COMEBK ;ZERO COUNT MEANS USER SYNTAX ERROR - NO CODE GENERATED
MOVE TC,EOPNXT
MOVEM W1,ESAVW1 ;SAVE ERENQ OR ERDEQ FLAGS
SETZM ERFFLG## ;INIT FLAG FOR RETAIN / FREE VERB
ERENQ1: POP TC,W2 ;LOCATE 1ST RENQ OR RDEQ OPERATOR ON STACK
POP TC,W1
JUMPL W1,ERENQ1 ;JUMP IF OPERAND
CAIN W2,147
JRST ERENQ0 ;JUMP IF RENQ
CAIE W2,152
JRST ERENQ1 ;JUMP IF NOT RDEQ
MOVEM W1,ERFFLG## ;SAVE OPERATOR FLAG WORD TO INDICATE FREE VERB
ERENQ0: SOJG TA,ERENQ1 ;JUMP IF NOT 1ST RENQ OR RDEQ
CAIE W2,152 ;[1450] DOING DEQUEUE?
JRST ERENQ2 ;[1450] NO.
TLNE W1,DQ%EVR+DQ%KEY+DQ%ALR ;[1450] [1474] ANY ONE OF THE TRHEE?
JRST ERENQ2 ;[1450] YES.
MOVEI DW,E.759 ;[1450] MUST HAVE ONE OF THEM,
PUSH PP,TC ;[1450] OR IT IS A FATAL
PUSHJ PP,OPFAT ;[1450] [1464] ERROR.
POP PP,TC ;[1450] RESTORE AC WE BORROWED.
ERENQ2: POP TC,W2 ;LOCATE FILE-NAME OPERAND FOR 1ST RENQ OR RDEQ
POP TC,W1
JUMPGE W1,ERENQ2 ;JUMP IF OPERATOR (SHOULDN'T BE ANY, THOUGH)
TLNE W1,200000
JRST ERENQ2 ;JUMP IF LITERAL
LDB TE,[POINT 3,W2,20]
JUMPN TE,ERENQ2 ;JUMP IF NOT FILE-NAME
AOJ TC, ;ADJUST TC TO POINT AT 1ST WORD OF FILE-NAME
MOVEM TC,ESUFN1 ;SAVE POINTER TO 1ST WORD OF FILE-NAME
SETZM ESUCVT## ;HAVEN'T CONVERTED ANY KEYS YET.
PUSHJ PP,ERENSF ;SETUP CURFIL; GENERATE CODE TO CONVERT KEY
MOVE TA,ERFFLG## ;[1643] GET FLAGS FOR FREE VERB
TLNE TA,DQ%EVR!DQ%ALR ;[1643] DOING FREE RECORD?
JRST ERNQ2A ;[1643] YES, DON'T CHECK FILE ORGANIZATION
MOVE TA,CURFIL ;GET FILE'S FILE TABLE ADDRESS
LDB TB,FI.ORG## ;GET FILE'S ORGANIZATION
CAIN TB,%ACC.S ;IF IT IS SEQUENTIAL
JRST [LDB LN,[POINT 13,2(TC),28]
LDB CP,[POINT 7,2(TC),35]
MOVEI DW,E.659
PUSHJ PP,FATAL## ;IT IS DISALLOWED
JRST ERNQ2A]
ERNQ2A:
MOVE TA,CURFIL ;GET FILE'S FILE TABLE ADDRESS AGAIN
LDB TB,FI.RMS## ; THE KEY BEING EXPLICITLY SPECIFIED FOR
CAIE TB,1 ; A RETAIN BY KEY.
JRST ERENQ4 ;NOT RMS FILE
HRRZI TB,0 ;ZERO OUT A TEMP AC TO TEST
CAMN TB,ERFFLG## ; IF RETAIN / FREE FLAG ZERO
JRST ERNQ2B ; DOING RETAIN
MOVE TD,ERFFLG## ;ELSE DOING FREE - GET OPERATOR WITH FLAGS
TXNE TD,1B9!1B10!1B14 ;TEST FOR A FLAG SET FOR EVERY,
; FILE-NAME EVERY, OR FILE-NAME KEY
; OR FILE-NAME NEXT
JRST ERENQ4 ; ONE OF THESE FLAGS IS SET
LDB LN,[POINT 13,2(TC),28] ;NONE ARE, GIVE FATAL DIAG
LDB CP,[POINT 7,2(TC),35] ;
MOVEI DW,E.663 ;
PUSHJ PP,FATAL## ;
JRST ERENQ4 ; BYPASS TEST FOR EXPLICIT KEY DATA NAME
;AT THIS POINT WE ARE CHECKING OVER A RETAIN. IT MAY ON KEY OR
; NEXT. IF KEY, WORD 2(TC) IS A DATA-NAME OPERAND. IF NEXT,
; WORD 2(TC) HAS THE 147 OPCODE IN BITS 0 - 8.
ERNQ2B:
LDB TB,[POINT 9,2(TC),8] ;GET OPCODE PORTION OF WORD
CAIE TB,147 ;RETAIN OPCODE?
JRST ERNQ2C ; NO, HAS TO BE OPERAND
LDB TB,[POINT 1,2(TC),15] ;YES, HAS TO BE FOR NEXT
CAIE TB,1 ; IS NEXT BIT TURNED ON?
JRST ERENQF ; NO, FATAL ERROR
JRST ERENQ4 ; YES, GO ON
ERNQ2C: ;CHECK OUT DATA-NAME OPERAND
LDB TB,[POINT 3,2(TC),2] ;GET OPERAND'S TYPE CODE
CAIE TB,4 ;TEST FOR A 4 FOR DATA NAME
JRST ERENQF ; IS NOT -- FATAL
LDB TB,[POINT 3,3(TC),20] ;GET OPERAND'S TABLE CODE AND RE-CHECK
CAIN TB,1 ; DATAB ENTRY HAS A 1 IN THAT BYTE
JRST ERENQ4 ;IS DATAB ENTRY
;ERROR MESSAGE ROUTINE FOR FAILURE ON NAMING KEY
ERENQF:
LDB LN,[POINT 13,2(TC),28] ;GET LINE NO. AND
LDB CP,[POINT 7,2(TC),35] ; CHARACTER POSITION
MOVEI DW,E.662 ;THE DIAG MSG NO.
PUSHJ PP, FATAL## ;FLAG IT AND ON TO NEXT OPERAND
;FOR ANYONE WHO ASKS, THIS CODE FLOWS IN SEQUENCE FROM THE ERROR REPORTING
; PROCEDURE TO THE NEXT STEP OF NORMAL PROCESSING BECAUSE THAT'S THE WAY
; IT WORKS. SOMEHOW, THIS PROCEDURE SEEMS TO KEEP THE STACK OF GENFIL OPERANDS
; STRAIGHT WHICH IS POINTED TO BY TC.
ERENQ3: ADDI TC,2 ;POINT TO NEXT ITEM
ERENQ4: HRRZ TE,EOPNXT ;ARE WE LOOKING AT THE TOP OF THE STACK?
CAIN TE,-1(TC)
JRST ERENQ5 ;YES, JUMP (ALL SUBSCRIPTS HAVE BEEN HANDLED)
SKIPL TE,0(TC) ;ARE WE LOOKING AT AN OPERAND?
JRST ERENQ3 ;NO, IGNORE ITEM
TLNE TE,200000
JRST ERENR0 ;JUMP IF LITERAL OR FIG CONSTANT
LDB TE,[POINT 3,1(TC),20]
JUMPE TE,ERENR1 ;JUMP IF WE ARE LOOKING AT A FILE-NAME
ERENR0: MOVEM TC,CUREOP ;SET CUREOP FOR SARG
PUSHJ PP,SARG ;GENERATE CODE FOR SUBSCRIPTS, IF ANY
MOVEM TC,ESUTC ;SAVE RETURNED TC
MOVE TC,CUREOP ;RESTORE TC THAT POINTS TO ARGUMENT
PUSHJ PP,ARG ;SET ARG LIST FOR LATER OUTPUT
MOVE TC,ESUTC ;RESTORE RETURNED TC
HRRZ TA,CURFIL ;GET THE CURRENT FILE POINTER TO SEE
LDB TA,FI.RMS## ; IF IT IS AN RMS INDEXED FILE
JUMPE TA,ERENQ3 ;NOT RMS
HRRZ TA,CURFIL ;GET THE CURRENT FILE POINTER TO SEE
LDB TA,FI.ORG ;IF ITS ORGANIZATION IS INDEXED
CAIE TA,%ACC.I ;INDEXED?
JRST ERENQ3 ; NO
MOVE TA,[XWDLIT,,2] ;CREATE THIRD WORD OF LITERAL
PUSHJ PP,STASHI ;
HRLZ TA,KEYREF## ;GET CURRENT RMS INDEX KEY POSITION
HRRI TA,AS.CNB ; IS CONSTANT
PUSHJ PP,STASHL ; AND PUT IT IN LITERAL
MOVE TA,KEYADR## ;GET ADDRESS FROM UKADR CALL
; IT IS ALL SET UP TO STASH.
PUSHJ PP,STASHL ; AND STASH IT.
AOS ELITPC ;ADVANCE COUNT OF LITERAL POINTER
JRST ERENQ4
ERENR1: PUSHJ PP,ERENS1 ;GENERATE CODE TO CONVERT KEY, IF NECESSARY
SKIPL TA,2(TC)
JRST ERNR1A ;JUMP IF NO OPERAND FOLLOWING FILE NAME
MOVEM TC,CUREOP ;SAVE TC
TLNN TA,GNLIT ;SKIP IF OPERAND A LITERAL OR FIGURATIVE CONSTANT
JRST ERENR2
TLNN TA,GNFIGC
TLNN TA,GNNUM
JRST ERENR8 ;JUMP IF FIGURATIVE CONSTANT OR NON-NUMERIC LITERAL
MOVE TA,3(TC)
PUSHJ PP,LNKSET##
LDB TA,[POINT 7,0(TA),6]
CAILE TA,^D10
JRST ERENR8 ;JUMP IF MORE THAN 10 CHARACTERS IN LITERAL
MOVEM TA,ESIZEA
MOVEI TA,D1MODE##
MOVEM TA,EMODEA## ;SET EMODEA TO COMP
MOVE TC,CUREOP
ADDI TC,2
JRST ERENR7
; NO OPERAND FOLLOWING FILE NAME
;(NO KEY WAS GIVEN). IF CBL74,
;IF ORGANIZATION IS SEQUENTIAL OR RELATIVE, (NOT INDEXED),
; AND ACCESS MODE = SEQUENTIAL, THEN SET "NEXT" BIT.
ERNR1A: MOVE TA,1(TC) ;POINT TO FILE TABLE
PUSHJ PP,LNKSET
LDB TB,FI.ORG ;ORGANIZATION
CAIN TB,%ACC.I ; IF INDEXED, DON'T SET "NEXT" BIT
JRST ERENQ3
LDB TB,FI.FAM ;FILE ACCESS MODE
CAIE TB,%FAM.S ;SEQUENTIAL?
JRST ERENQ3 ;NO, DON'T SET "NEXT" BIT.
MOVSI TB,(1B15) ;NICE SYMBOLIC CONSTANT, HA HA
IORM TB,2(TC) ;SET "NEXT" BIT FOR CONVENIENCE OF LSU
JRST ERENQ3 ;
ERENR8: LDB LN,[POINT 13,2(TC),28]
LDB CP,[POINT 7,2(TC),35]
MOVEI DW,E.570
PUSHJ PP,FATAL## ;GENERATE ERROR MESSAGE
;(LITERAL OR FIGURATIVE CONSTANT NOT ALLOWED)
ERENR9: MOVE TC,CUREOP ;RESTORE TC
JRST ERENQ3 ;RETURN TO MAIN STREAM
ERENR2: MOVEI LN,EBASEA##
ADDI TC,2
PUSHJ PP,SETOPN## ;GET DESCRIPTION OF DATA NAME
ERENR7: MOVE TA,-1(TC)
PUSHJ PP,LNKSET## ;GET POINTER TO FILE TABLE
LDB TB,FI.ORG
CAIN TB,%ACC.I
JRST ERENR3 ;JUMP IF FILE INDEXED
MOVE TB,EMODEA##
CAIN TB,D1MODE##
JRST ERENR9 ;JUMP IF 1 WORD COMP
MOVE TC,CUREOP
LDB LN,[POINT 13,2(TC),28]
LDB CP,[POINT 7,2(TC),35]
MOVEI DW,E.571
PUSHJ PP,FATAL## ;GENERATE ERROR MESSAGE
;(KEY FOR SEQUENTIAL OR RELATIVE MUST BE COMP)
JRST ERENR9
;CHECK OUT AVAILABLE RECORD KEYS AGAINST RETAIN'S KEY OPERAND.
; IF THE FILE IS AN RMS FILE, WE CAN GO THROUGH ANY ALTERNATE KEYS TO SEE
; IF THEY AGREE WITH THE "A" OPERAND WHICH WE ARE TESTING.
; ALSO, WE INITIALIZE THE COUNT OF KEYS. THIS COUNT WILL BE INCREMENTED FOR
; EACH RMS INDEX KEY TESTED. IF WE GET A MATCH, THIS IS THE NUMBER OF THE
; KEY IN THE %N TABLE, AND THIS NUMBER WILL BE PUT INTO %LIT00 AS THE THIRD
; ARGUMENT FOR THE KEY TO BE RETAINED IN LSU. KEYREF = 0 POINTS AT THE
; PRIMARY KEY.
;
;IN THE FIRST INSTANCE, WE WILL CHECK TO SEE IF THE USER HAS SUPPLIED A
; REAL PRIMARY OR ALTERNATE KEY FIELD. IF SO, WE CAN DO A RETAINUSING
; THAT EXACT FIELD IN THE RECORD. OTHERWISE WE GO BACK THROUGH PRESUMING
; THAT THE FIELD IS SOME OTHER UNRELATED FIELD, AS IN WORKING-STORAGE.
; AT THIS POINT, WE LOOK FOR A MATCH ON THE KEY SIZE AND USAGE. THE USER
; WINS THE FIRST MATCH WHETHER IT IS THE ONE HE WANTS OR NOT. IT WOULD
; TAKE ADDITIONAL SYNTAX TO MAKE THIS OTHERWISE CASE MORE PRECISE.
ERENR3:
LDB TA,FI.RKY## ;SET UP EMODEB, ESIZEB FOR RECORD KEY
JUMPE TA,ERENR9 ;ERROR, SYMBOLIC KEY NOT DEFINED
SETZM KEYREF## ;INIT THE COUNT OF KEYS
HRRZ TB,1(TC) ;GET GENFIL DATA FIELD OPERAND
CAME TB,TA ; DOES IT REFERENCE THE PRIMARY KEY?
JRST ERNR3J ;NO
PUSHJ PP,UKADR ;MAKE SURE KEY IS WORD-ALIGNED
MOVE TA,CURFIL ;GET CURRENT FILE AGAIN
LDB TA,FI.RKY ;GET IT AGAIN
PUSHJ PP,LNKSET ;LOOK UP DATAB ENTRY
LDB TB,DA.RES ;GET DATA ITEM'S BYTE RESIDUE
CAIN TB,^D36 ;WORD ALIGNED?
SETZM KEYADR## ; YES, DON'T PICK UP FILE KEY DATA ITEM
; FOR LITERAL TABLE
MOVE TC,CUREOP ;RESTORE POINTER TO CURRENT GENFIL OPERAND
JRST ERENQ3 ; AND GO TO GOOD RETURN
ERNR3J:
HRRZ TA,CURFIL ;GET FILE'S ABSOLUTE TABLE ADDR IN CORE
LDB TA,FI.RMS## ;IS IT AN RMS FILE?
JUMPE TA,ERNR3M ; NO
HRRZ TA,CURFIL ;GET IT AGAIN
LDB TA,FI.ALK## ;GET RELATIVE PTR TO FIRST ALT KEY IN AKTTAB
JUMPE TA,ERNR3M ; THERE IS NONE
ADD TA,AKTLOC## ;ADD IN CURRENT BASE ADDR OF TABLE
HRRZ TA,TA ; AND CLEAR THE LH SIDE
MOVEM TA,AKTHLD## ; AND SAVE IT ASIDE FOR TESTING BELOW
HLRZ TD,CURFIL ;GET FILE TABLE LINK FROM CURFIL
; NEXT, CHECK THE "A" OPERAND AGAINST THE ALTERNATE KEYS FOR THIS FILE
ERNR3K:
AOS KEYREF## ;INCREMENT THE COUNT OF RMS INDEX KEYS
LDB TE,AK.FLK## ;GET ENTRY'S FILE TABLE LINK
CAIE TE,(TD) ;SAME FILE?
JRST ERNR3L ; NO - ERROR
LDB TA,AK.DLK## ;GET ALTERNATE KEY'S DATA LINK FROM AKTTAB
HRRZ TB,1(TC) ; GET GENFIL OPERAND FOR DATA FIELD
CAME TB,TA ;SAME?
JRST ERNR3L ; NO, GO TRY THE NEXT ONE.
PUSHJ PP,UKADR ;MAKE SURE KEY IS WORD-ALIGNED
HRRZ TA,AKTHLD## ;GET BACK ADDR OF AKT DATAB ENTRY
LDB TA,AK.DLK## ;GET AKTTAB ENTRY'S DATA LINK
PUSHJ PP,LNKSET ;LOOK UP DATAB ENTRY
LDB TB,DA.RES ;GET DATA ITEM'S BYTE RESIDUE
CAIN TB,^D36 ;WORD ALIGNED?
SETZM KEYADR## ; YES, DON'T PICK UP FILE KEY DATA ITEM
; FOR LITERAL TABLE
MOVE TC,CUREOP ;RESTORE PTR TO CURR GENFIL OPERAND
JRST ERENQ3 ; AND GO TO GOOD RETURN
ERNR3L:
MOVE TA,AKTHLD## ;GET ADDR OF CURRENT AKTTAB ENTRY
ADDI TA,SZ.AKT ;POINT TO NEXT ENTRY IN AKTTAB
MOVEM TA,AKTHLD## ;SAVE NEXT ENT ADDR FOR NEXT TIME AROUND
HRRZ TB,AKTNXT## ;GET ADDR OF FIRST FREE WORD OF AKTTAB
CAML TA,TB ;ARE WE INTO FREE AREA?
JRST ERNR3M ; YES - RETAIN KEY MUST BE DEFINED OUTSIDE THE RECORD
JRST ERNR3K ;NOT OK, GO TRY NEXT ENTRY
ERNR3M:
MOVE TA,CURFIL ;GET BACK FILE'S FILE TABLE
LDB TA,FI.RKY## ;SET UP EMODEB, ESIZEB FOR RECORD KEY
JUMPE TA,ERENR9 ;ERROR, SYMBOLIC KEY NOT DEFINED
SETZM KEYREF## ;INIT THE COUNT OF KEYS
PUSHJ PP,ERNR3X ;GET REC KEY'S ADDR + CHECK KEY OUT
JRST ERENQ3 ;OK, THIS KEY AGREES
HRRZ TA,CURFIL ;GET FILE'S ABSOLUTE TABLE ADDR IN CORE
LDB TA,FI.RMS## ;IS IT AN RMS FILE?
JUMPE TA,ERENR4 ; NO
HRRZ TA,CURFIL ;GET IT AGAIN
LDB TA,FI.ALK## ;GET RELATIVE PTR TO FIRST ALT KEY IN AKTTAB
JUMPE TA,ERENR4 ; THERE IS NONE
ADD TA,AKTLOC## ;ADD IN CURRENT BASE ADDR OF TABLE
HRRZ TA,TA ; AND CLEAR THE LH SIDE
MOVEM TA,AKTHLD## ; AND SAVE IT ASIDE FOR TESTING BELOW
HLRZ TD,CURFIL ;GET FILE TABLE LINK FROM CURFIL
; NEXT, CHECK THE "A" OPERAND AGAINST THE ALTERNATE KEYS FOR THIS FILE
ERNR3A:
AOS KEYREF## ;INCREMENT THE COUNT OF RMS INDEX KEYS
LDB TE,AK.FLK## ;GET ENTRY'S FILE TABLE LINK
CAIE TE,(TD) ;SAME FILE?
JRST ERENR4 ; NO - ERROR
LDB TA,AK.DLK## ;GET AKTTAB ENTRY'S DATA LINK
PUSHJ PP,ERNR3X ;GO CHECK OUT DATA LINK
JRST ERENQ3 ; OK - THIS KEY AGREES
MOVE TA,AKTHLD## ;GET ADDR OF CURRENT AKTTAB ENTRY
ADDI TA,SZ.AKT ;POINT TO NEXT ENTRY IN AKTTAB
MOVEM TA,AKTHLD## ;SAVE NEXT ENT ADDR FOR NEXT TIME AROUND
HRRZ TB,AKTNXT## ;GET ADDR OF FIRST FREE WORD OF AKTTAB
CAML TA,TB ;ARE WE INTO FREE AREA?
JRST ERENR4 ; YES - ERROR
JRST ERNR3A ;NOT OK, GO TRY NEXT ENTRY
ERENR4: LDB LN,[POINT 13,2(TC),28]
LDB CP,[POINT 7,2(TC),35]
MOVEI DW,E.572
PUSHJ PP,FATAL## ;GENERATE ERROR MESSAGE
;(KEYS DON'T AGREE IN USAGE AND SIZE)
JRST ERENR9
ERENQ5: MOVE CH,[MOVEI.+ASINC+AC16,,AS.MSC]
PUSHJ PP,PUTASY ;GENERATE MOVEI 16,LIT-TABLE-ENTRY
HRRZ CH,ELITPC
TRO CH,AS.LIT
PUSHJ PP,PUTASN ;(IT TAKES 2 WORDS)
MOVE TA,[OCTLIT,,1] ;CREATE HEADER WORD FOR LITERAL
PUSHJ PP,STASHI
HLL TA,ESAVW1 ;GET ERENQ OR ERDEQ FLAGS
TLZ TA,777377 ;ZERO ALL BITS EXCEPT UNAVAILABLE
LSH TA,-8 ;NORMALIZE IN LH
HRR TA,ESUCNT ;SET RH TO N
PUSHJ PP,STASHL ;STASH AWAY
AOS ELITPC
LDB W1,[POINT 9,ESAVW1,8]
MOVEI CH,LRDEQ.
CAIN W1,000153
JRST ERNQ5A
MOVE TA,ESAVW1 ;GEN COMPOUND RETAIN FLAG
MOVEI CH,LRENQ. ;PRESUME NOT COMPOUND
TLNE TA,200
MOVEI CH,CNTAI.
ERNQ5A: PUSHJ PP,PUT.PJ ;GENERATE PUSHJ PP,LRENQ (OR LRDEQ)
SKIPA TE,ESUFN1
ERENQ6: MOVE TE,ESUFN2 ;GET POINTER TO FILE-NAME IN CUREOP
MOVEM TE,CUREOP
ERENQ7: ADDI TE,2 ;GET POINTER TO CORRESPONDING RENQ OR RDEQ IN TE
LDB TA,[POINT 9,0(TE),8]
CAIN TA,000147
JRST ERENQ9
CAIE TA,000152
JRST ERENQ7
ERENQ9: HLLZ W1,0(TE) ;SET UP RENQ OR RDEQ & FLAGS IN LH
HRR W1,CUREOP
HRR W1,1(W1)
ORI W1,AS.FIL
CAMN W1,[152400,,0] ;IF FREE EVERY RECORD, THEN
ORI W1,AS.CNB ;SET FILE TABLE TO NULL
ADDI TE,2
MOVEM TE,ESUFN2 ;SAVE POINTER TO NEXT FILE NAME (IF ANY)
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHI
MOVE TA,W1
HRRI TA,AS.CNB
PUSHJ PP,STASHL
HRRZ TA,W1
PUSHJ PP,STASHL ;STASH AWAY FILE ARGUMENT
AOS ELITPC
MOVE TC,CUREOP
LDB CH,[POINT 9, 2(TC), 8]
CAIE CH,000147
CAIN CH,000152
JRST ERENQ8 ;JUMP IF OPERATOR
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHI
HLRZ TA,2(TC)
ANDI TA,740 ;EXTRACT AC FIELD OF OPERAND
CAIN TA,2B30 ;CONVERT TO NEW TYPE CODES
MOVEI TA,4B30
CAIN TA,0B30
MOVEI TA,2B30
CAIN TA,10B30
MOVEI TA,15B30
CAIN TA,17B30
MOVEI TA,7B30
MOVE CH,2(TC)
TLNE CH,20
TRO TA,20
PUSHJ PP,STASHL
HRRZ TA,2(TC)
HRL TA,3(TC)
PUSHJ PP,STASHL ;GENERATE XWD (IT TAKES 3 STASHL'S)
AOS ELITPC
ERENQ8: HRRZ TA,ESUFN2 ;HAVE WE GENERATED LAST ITEM?
HRRZ TE,EOPNXT
SUB TA,TE
SOJN TA,ERENQ6 ;NO, GO BACK AND DO NEXT ITEM
HRRZ TA,ESUFN1 ;YES
SOJ TA,
SUBB TE,TA
LSH TE,-1
SUB EACC,TE ;ADJUST EACC
HRL TA,TA
MOVN TA,TA
ADDB TA,EOPNXT ;ADJUST EOPNXT
MOVEM TA,EACA ;ADJUST EACA
SETZM ESUCNT
MOVE TA,ESAVW1 ;GET UNAVAILABLE FLAG
TLNN TA,000400
JRST COMEBK ;ALL DONE IF NO UNAVAILABLE STATEMENT
SETZM ESUTAG ;OTHERWISE GENERATE JRST AROUND UNAVAILABLE STATEMENT
JRST FUNAVG
;ROUTINE TO CHECK OVER RETAINED KEY AGAINST AN AVAILABLE RMS INDEXED FILE KEY
; IT CHECKS THE USAGE AND THE SIZE OF EACH, THEN RESTORES POINTER TO THE
; OPERAND IN CASE WE HAVE SUCCESS AND GO BACK TO ERENQ3.
ERNR3X:
MOVEM TA,SVKYDT## ;SAVE ASIDE KEY'S DATAB ENTRY
PUSHJ PP,LNKSET## ;GET ADDR OF DATA FIELD'S TABLE IN TA
LDB TB,DA.USG## ;GET ITS USAGE
SUBI TB,1 ; AND ADJUST IT TO CORRESPOND TO WHAT
; WAS DONE TO THE "A" OPERAND.
MOVEM TB,EMODEB## ; AND SAVE IT
LDB TB,DA.INS## ;GET ITS SIZE
MOVEM TB,ESIZEB## ; AND SAVE IT
;NOW DO THE COMPARISONS
MOVE TB,EMODEB## ;GET FILE KEY'S USAGE
CAME TB,EMODEA## ; SAME AS RETAIN KEY'S?
JRST ERNRE1 ;JUMP IF USAGE DOESN'T MATCH
MOVE TA,ESIZEA## ;GET FILE KEY'S SIZE
CAMN TA,ESIZEB## ; SAME AS RETAIN KEY'S?
JRST ERNRUK ;JUMP IF SIZE MATCHES
CAIE TB,D1MODE## ;ONE-WORD DECIMAL?
JRST ERNRE1 ; NO - NOT A MATCH
CAMG TA,ESIZEB ;FOR ONE-WORD DECIMAL, FILE KEY CAN BE
;SHORTER THAN SIZE OF LITERAL
;OR DATA NAME IF BOTH ARE COMP
JRST ERNRE1 ;GO TO ERROR RETURN
ERNRUK:
MOVE TA,SVKYDT## ;GET BACK DATAB ENTRY
PUSHJ PP,UKADR ;MAKE SURE KEY IS WORD-ALIGNED
MOVE TA,SVKYDT## ;GET IT AGAIN
JUMPE TA,ERNRE1 ;IS ERROR IF HAPPENS, SHOULDN'T IF IT GOT
; HERE ORIGINALLY
PUSHJ PP,LNKSET ;LOOK UP DATAB ENTRY
LDB TB,DA.RES ;GET DATA ITEM'S BYTE RESIDUE
CAIN TB,^D36 ;WORD ALIGNED?
SETZM KEYADR## ; YES, DON'T PICK UP FILE KEY DATA ITEM
; FOR LITERAL TABLE
JRST ERNREX ; AND GO TO GOOD RETURN
ERNRE1: ;COME HERE IF RETAIN KEY NOT OK
AOS 0(PP) ;FAILURE RETURNS + 2
ERNREX: ;SUCCESS RETURNS + 1
MOVE TC,CUREOP ;RESTORE ARG POINTER TO TC
POPJ PP, ; AND RETURN
;ERENSF AND ERENS1
;ROUTINES TO SETUP CURFIL AND GENERATE KEY CONVERSION CODE,
; IF NECESSARY.
;ERENSF IS CALLED TO SETUP CURFIL AND GENERATE THE CONVERSION CODE
; FOR THE FIRST FILE.
ERENSF: LDB TA,[POINT 15,1(TC),35] ;GET FILTAB OFFSET
HRLM TA,CURFIL ;SETUP CURFIL
ADD TA,FILLOC
HRRM TA,CURFIL ;. .
LDB TD,FI.CKB## ;NEED TO CONVERT KEY?
JUMPE TD,CPOPJ ;NO
SKIPN ESUCVT## ;DID WE ALREADY HAVE TO CONVERT A KEY?
JRST ERENSN ;NO
HLRZ TD,CURFIL ;DID WE ALREADY CONVERT THIS FILE?
CAMN TD,ESUCVT## ;WAS IT THIS FILE?
POPJ PP, ;YES, CONVERSION DONE.
JRST ERENS2 ;NO, ERROR
ERENSN: HLRZ TD,CURFIL ;SET ESUCVT = F.T. ADDRESS OF THE FILE
HRRZM TD,ESUCVT## ; REMEMBER WHICH FILE WE CONVERTED A KEY FOR.
PUSH PP,TC ;SAVE TC
PUSHJ PP,CNVKYB ;CONVERT KEY BEFORE I/O
POP PP,TC ;RESTORE TC
POPJ PP, ;RETURN
;GIVE ERROR BECAUSE DMN MADE ALL CONVERTED KEYS POINT TO %PARAM+0.
;; SO YOU CAN'T GENERATE CODE TO CONVERT A KEY FOR MORE THAN ONE
; FILE AT A TIME!
;THIS IS GENERALLY NOT NECESSARY BUT "RETAIN" AND "FREE" STATEMENTS
; MAY REFERENCE MORE THAN ONE FILE.
ERENS2: MOVEI DW,E.738 ;"Can't have more than 1 file with
; converted key".
LDB LN,[POINT 13,(TC),28]
LDB CP,[POINT 7,(TC),35]
PUSHJ PP,FATAL ;POINT TO THIS FILENAME
POPJ PP, ;AND RETURN
;ERENS1 IS CALLED FOR ALL OTHER FILES. IF THE FILENAME IS THE SAME,
; NO CODE IS GENERATED, ELSE IT STORES THE NEW CURFIL AND GENERATES
; CODE IF NECESSARY.
ERENS1: LDB TA,[POINT 15,1(TC),35] ;GET FILTAB OFFSET
HLRZ TD,CURFIL ;SAME FILE AS LAST TIME?
CAMN TA,TD
POPJ PP, ;YES, NOTHING TO DO, RETURN
JRST ERENSF ;GO GENERATE CODE IF NECESSARY
;RECORD DEQUEUE
RDEQGN: TLNN W1,000400
JRST RENQGN
MOVEM W1,ESAVW1
HRLZI W1,400000
HRRZI W2,000001
PUSHJ PP,PUSH12 ;IF FREE EVERY RECORD, PUT DUMMY FILE NAME ON OPERAND STACK
MOVE W1,ESAVW1
HRRZI W2,000152
AOJA EACC,RENQGN
SUBTTL KYPTR -- RMS ROUTINE TO GET PTR TO RECORD KEYS
REPEAT 0,<
;;; ALL THIS CODE HAS BEEN SNARFED INTO CLEANC.
;WHOLE BUNCH OF CODE IN ANS74
;THIS ROUTINE GENERATES THE KEY INFORMATION IN %LIT00
;; (UNLESS IT IS THERE ALREADY).
;; AND RETURNS EACA = PTR TO %LIT.
;RETURNS .+1 IF ERRORS, SKIP IF NO ERRORS
KYPTR: MOVE TA,CURFIL
LDB EACA,FI.KYE## ;DID WE HAVE ERRORS BEFORE?
JUMPN EACA,CPOPJ ;YES, RETURN .+1
;PUT THE FOLLOWING KEY INFORMATION IN LITTAB:
;
; EXP NUMBER OF KEYS
; 2-WORD-KEY-DESCRIPTORS
;
; EACH KEY-DESCRIPTOR HAS THE FOLLOWING FORMAT:
; XWD STARTING BYTE POSITION,,KEY SIZE
; XWD FLAGS,,DATATYPE
; FLAGS ARE:
; 1B0 DUPLICATES ALLOWED
; DATATYPE VALUES ARE:
; 0 SIXBIT
; 1 ASCII
; 2 EBCDIC
;FIRST, FIND NUMBER OF KEYS
LDB TA,FI.ALK## ;GET PTR TO FIRST ALTERNATE KEY
MOVEI TE,1 ;1 KEY SO FAR (THE PRIMARY KEY)
JUMPE TA,KYPTR1 ; JUMP IF THAT'S ALL
;LINK THRU AKTTAB TO COUNT ALTERNATE KEYS
;PTR TO FIRST ENTRY IS IN EACA
ADD TA,AKTLOC## ;TA= ABS ADDR OF ENTRY
HRRZ TA,TA ;CLEAR LEFT HALF
HRRZ TB,AKTNXT## ;TB= PTR TO "NEXT" ENTRY
; (TO TELL WHEN OFF TABLE)
LDB TD,AK.FLK## ;TD= WHICH FILE
KYPTR0: ADDI TE,1 ;COUNT ANOTHER KEY
ADDI TA,SZ.AKT ;LOOK AT NEXT ENTRY
CAML TA,TB ;PAST END OF TABLE?
JRST KYPTR1 ;YES, THAT'S ALL THE KEYS
LDB TC,AK.FLK## ;GET WHICH FILE THIS ENTRY POINTS TO
CAIN TC,(TD) ;SKIP IF LOOKING AT A DIFFERENT FILE NOW
JRST KYPTR0 ;SAME FILE, KEEP COUNTING
;FALL TO NEXT PAGE WHEN TE = NUMBER OF KEYS
;HERE WITH NUMBER OF KEYS IN TE
KYPTR1: MOVEM TE,NMAKYS## ;SAVE NUMBER OF ALTERNATE KEYS + 1
MOVE TE,ELITPC ;SAVE CURRENT LITERAL PC, INCASE WE POOL
MOVEM TE,LPCSAV##
MOVE TA,[OCTLIT,,1]
PUSHJ PP,STASHP
MOVE TA,NMAKYS ;WRITE OUT NUMBER OF KEYS
PUSHJ PP,STASHQ ; AS "OCT N"
AOS ELITPC ;BUMP LITERAL PC
;WRITE OUT KEY INFORMATION
;FIRST FOR THE PRIMARY RECORD KEY
HLRZ TA,CURFIL ;FIND PTR TO CURRENT FILE AGAIN
ADD TA,FILLOC
LDB TA,FI.RKY ;GET RECORD KEY PTR
SETZM EFLAGB ;CLEAR FLAGS
PUSHJ PP,KYINFO ;CREATE THE INFO BLOCK
JRST KYIER ;ERROR
MOVE TD,NMAKYS## ;NUMBER OF ALTERNATE KEYS
SOJ TD, ;IN TD
JUMPE TD,KYPTR6 ;JUMP IF NONE TO DO
HLRZ TA,CURFIL ;POINT TO CURRENT FILE
ADD TA,FILLOC
LDB TA,FI.ALK ;GET PTR TO ALTERNATE KEYS
ADD TA,AKTLOC ;[1370] GET ABS PTR
MOVEM TA,CURAKT## ;[1370] SAVE REL. ADDR - no. abs addr
;HERE WITH TA= ABS ADDR OF ENTRY, TD= # ENTRIES LEFT TO DO
KYPTR2: LDB TB,AK.DUP## ;GET "DUPLICATES" FLAG
TRNE TB,1 ;IS IT SET?
MOVX TB,1B0 ;YES, TURN ON BIT
MOVEM TB,EFLAGB ;SETUP FOR "FLAGS"
LDB TA,AK.DLK## ;GET DATAB LINK
PUSHJ PP,KYINFO ;CREATE THE INFO BLOCK
JRST KYIER ;ERROR
SOJLE TD,KYPTR6 ;JUMP IF NO MORE TO DO
MOVEI TA,SZ.AKT ;BUMP TO NEW ENTRY
ADDB TA,CURAKT ;FETCH AND UPDATE REL. LOC
JRST KYPTR2 ;GO BACK FOR MORE KEYS
;HERE IF AN ERROR IF FOUND IN KYINFO. SET FI.KYE TO -1
; TO INDICATE ERROR, AND LEAVE LITERALS IN A GOOD STATE
KYIER: HLRZ TA,CURFIL
ADD TA,FILLOC## ;GET ABS ADDR
SETO TB, ;SET FIELD TO -1
DPB TB,FI.KYE## ;THE NEXT TIME, DON'T TRY TO GEN CODE
;FALL INTO KYPTR6, AS IF WE HAD FINISHED GENERATING ALL THE KEYS
;HERE WHEN DONE PUTTING ALL KEY INFO IN LITTAB
KYPTR6: PUSHJ PP,POOL ;POOL THE BLOCK OF LITERALS
MOVE TE,LPCSAV ;IF WE POOLED, RESTORE LITERAL PC
SKIPE PLITPC
MOVEM TE,ELITPC
SKIPN EACA,PLITPC ;GET PC IF POOLED
MOVE EACA,LPCSAV ;NOT POOLED, GET STARTING PC
IORI EACA,AS.LIT ;TURN ON "LIT" BIT
JRST CPOPJ1 ;RETURN WITH PTR TO KEY INFO IN EACA
SUBTTL KYINFO -- WRITE KEY BLOCK FOR EACH KEY
;
;;CALL: TA/ PTR TO KEY DATANAME
; EFLAGB/ LH = FLAGS TO PASS
;
; PUSHJ PP,KYINFO
; <RETURN HERE IF ERRORS>
; <RETURN HERE IF OK>
;
; THIS ROUTINE CHECKS THE RMS RESTRICTIONS ON KEYS
; PRESERVES TD
KYINFO: JUMPE TA,CPOPJ ;ERROR IF NO LINK
PUSH PP,TD ;PRESERVE AC
MOVEM TA,ETABLB ;USE "B" LOCATIONS FOR TEMP STORAGE
PUSHJ PP,LNKSET ;LOOK AT DATAB ENTRY
LDB TE,DA.ERR## ;ERROR BIT ON?
JUMPN TE,KYINF9 ;YES, RETURN ERROR
;CHECK FOR KEY MODE OF "DISPLAY", AND SAVE MODE IN EMODEB
LDB TE,DA.USG
SUBI TE,1
CAILE TE,DSMODE
JRST KYINF8 ;GIVE ERROR
MOVEM TE,EMODEB ;SAVE IT
;CHECK FOR KEY SIZE TOO LARGE FOR RMS TO HANDLE
LDB TE,DA.INS## ;GET SIZE OF ITEM
CAILE TE,^D256 ;CHECK RMS LIMIT
JRST KYINF7 ;?TOO BIG, GIVE ERROR
MOVEM TE,ESIZEB ;SAVE SIZE
LDB TE,DA.RES## ;BYTE RESIDUE
HRLM TE,ERESB ;SAVE
;OK, EVERYTHING IS FINE.
; COMPUTE KEY OFFSET (BYTES) AND PUT IN EINCRB
LDB TE,DA.LOC## ;GET START OF THIS KEY
MOVE TD,EMODEB ;GET MODE OF THE DATA ITEM
MOVE TC,BYTE.W(TD) ;TC= BYTES PER WORD
IMUL TE,TC ;START COMPUTING OFFSET
HLRZ TB,ERESB ;FIND BYTE OFFSET IN WORD..
MOVEI TC,^D36
SUB TC,TB ; (# BITS IN..)
IDIV TC,BYTE.S##(TD) ;DIVIDE BY BYTE SIZE
ADD TE,TC ;ADD IN BYTE OFFSET WITHIN WORD
MOVEM TE,EINCRB ;SAVE BYTE OFFSET INTO THE RECORD
;GENERATE THE TWO-WORD BLOCK
MOVE TA,[XWDLIT,,2] ;GENERATE 1ST XWD
PUSHJ PP,STASHP
HRLZ TA,EINCRB ;POSITION OF KEY IN THE RECORD
HRRI TA,AS.CNB ; A CONSTANT
PUSHJ PP,STASHQ
HRLZ TA,ESIZEB ;KEY SIZE
HRRI TA,AS.CNB ; A CONSTANT
PUSHJ PP,STASHQ
AOS ELITPC ;BUMP LITERAL PC
MOVE TA,[XWDLIT,,2] ;NEXT XWD
PUSHJ PP,STASHP
HLLZ TA,EFLAGB ;FLAGS
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
HRLZ TA,EMODEB ;DATATYPE (0=SIXBIT, 1=ASCII, 2=EBCDIC)
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
AOS ELITPC ;BUMP LITERAL PC
POP PP,TD ;RESTORE AC
JRST CPOPJ1 ;GOOD RETURN
;ERROR ROUTINES
;SIZE OF KEY TOO LARGE
KYINF7: MOVEI DW,E.628 ;KEY LARGER THAN 256
JRST KYIN8A
;KEY NOT DISPLAY MODE
KYINF8: MOVEI DW,E.627 ;MODE NOT DISPLAY
KYIN8A: LDB LN,DA.LN ;POINT TO DATANAME DEFINITION FOR THIS ERROR
LDB CP,DA.CP ; (IT WILL ONLY HAPPEN ONCE)
PUSHJ PP,FATAL
JRST KYINF9
;HERE IF ERRORS OCCUR IN KYINFO ROUTINE
KYINF9: POP PP,TD ;RESTORE AC
POPJ PP, ;ERROR RETURN
> ; END REPEAT 0
;UKADR - FIND ADDRESS OF ITEM IN TB, STORE IN "KEYADR".
; IF THE ITEM IS NOT WORD ALIGNED, GENERATE A MOVE TO A %TEMP
; THAT IS WORD ALIGNED, AND STORE THE ADDRESS OF THE %TEMP.
;CALL: TA/ DATAB LINK OF KEY
; PUSHJ PP,UKADR
; <RETURN HERE, KEYADR SET UP, POSSIBLY CODE GENERATED>
UKADR: PUSH PP,TA ;MAYBE IT IS WORD ALIGNED
JUMPE TA,UKADRY ;GIVE UP IF IN ERROR
PUSHJ PP,LNKSET ; LOOK AT DATAB ENTRY
LDB TB,DA.RES ;BYTE RESIDUE..
CAIN TB,^D36 ;OH PLEASE!
JRST UKADRY ;YES! NOTHING DIFFICULT
;ITEM IS NOT ALIGNED.
; GENERATE A MOVE TO A %TEMP, SO IT CAN BE ALIGNED.
;CALL SETOPN WITH A FAKE 2-WORD OPERAND
; TO PUT THE ITEM IN "A"
HRRZ TB,(PP) ;GET ITEM
PUSH PP,[0] ;ON THE STACK, FIRST WORD IS 0
PUSH PP,TB ;2ND WORD = DATAB ADDR.
MOVEI TC,-1(PP) ;POINT TO THE "OPERAND"
MOVEI LN,EBASEA ;PUT IN "A"
PUSHJ PP,SETOPN##
POP PP,(PP) ;THROW AWAY THE 'OPERAND'
POP PP,(PP)
POP PP,(PP) ;ITEM IS NOW IN "EBASEA"
EQUIT; ;QUIT IF ERRORS
;SET UP A %TEMP TO LOOK LIKE THAT, EXCEPT IT IS WORD ALIGNED.
MOVE TE,[XWD EBASEA,EBASEB] ;SET "B" = "A"
BLT TE,EBASBX
MOVE TE,[XWD ^D36,AS.MSC] ;EXCEPT "B" WILL BE IN %TEMP
MOVEM TE,EBASEB
;GO GET SOME SPACE IN %TEMP
MOVE TE,ESIZEB ;TO FIND SIZE OF B IN WORDS
HRRZ TC,EMODEB
MOVE TC,BYTE.W(TC) ;GET BYTES PER WORD
ADDI TE,-1(TC)
IDIVI TE,(TC) ;TE= # FULL WORDS NEEDED
PUSHJ PP,GETEMP ;GO GET SOME %TEMP
MOVEM EACC,EINCRB
HRLZ EACC,EACC ;SHIFT TO LH
HRRI EACC,AS.MSC ; MISC. IN RH
MOVEM EACC,KEYADR## ;STORE KEY ADDRESS
SWOFF FBSUB!FASIGN ;CLEAR SOME FLAGS
PUSHJ PP,MXX.## ;GO GENERATE THE MOVE
POPJ PP, ;RETURN
UKADRY: POP PP,KEYADR## ;STORE KEY ADDRESS
POPJ PP, ;RETURN
;IODBU - GENERATE SOME DEBUGGING CODE AFTER A READ OR DELETE
IODBU: MOVE CH,[SKIPA.##+AC16+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
MOVEI CH,AS.DOT+1
PUSHJ PP,PUTASN ;SKIPA 16,.+1
MOVE CH,[AS.XWD,,1]
PUSHJ PP,PUTASN
MOVEI CH,DBP%UP ;USE PROCEDURE CODE
PUSHJ PP,PUTASN ;IN LHS
LDB CH,[POINT 13,PREVW1,28] ;GET LINE # OF PREVIOUS OPERATOR
PUSHJ PP,PUTASY
MOVE CH,[MOVEM.##+AC16+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
MOVE CH,DBPARM##
IORI CH,AS.PAR##
PJRST PUTASN ;MOVEM 16,%PARAM+N
;SEE IF WE NEED DEBUGGING ON "A" OPERAND FOR WRITE
TSDEBA: SKIPL TE,EDEBDA## ;DID USER WANT DEBUGGING?
POPJ PP, ;NO
SKIPE INDCLR## ;ARE WE STILL IN DECLARATIVES?
TDZA TD,TD ;YES, SO NO DEBUGGING ALLOWED
LDB TD,DA.DEB## ;DEBUGING ON THIS DATA-NAME ALLOWED?
SKIPE TD ;NO
HLRZ TD,TA ;YES, GET BASE ADDRESS
MOVEM TD,EDEBDA ;SIGNAL DEBUGGING REQUIRED (OR NOT)
JUMPE TD,CPOPJ ;DONE IF NOT DEBUGGING
HRRZM TE,EDEBGA## ;SAVE AS FLAG FOR "ARO" TEST
MOVE TD,EDEBDA## ;GET BASE
PJRST TSTARO## ;SET UP VARIOUS PARAMETERS AND RETURN
END