Trailing-Edge
-
PDP-10 Archives
-
BB-H506D-SM_1983
-
cobol/source/iogen.mac
There are 22 other files named iogen.mac in the archive. Click here to see a list.
; UPD ID= 3576 on 6/9/81 at 7:59 PM by NIXON
TITLE IOGEN FOR COBOL V12B
SUBTTL I/O GENERATORS AL BLACKINGTON/SIP/CAM
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1974, 1981 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
IFN TOPS20,<
SEARCH MONSYM,MACSYM>
IFE TOPS20,<
SEARCH UUOSYM,MACTEN>
;EDITS
;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.
TWOSEG
RELOC 400000
SALL
;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
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
O.BOPR: O%BOPR
;OPEN FLAG BITS
OPN%IN==1B9 ;OPEN FOR INPUT
OPN%OU==1B10 ;OPEN FOR OUTPUT
OPN%IO==1B11 ;OPEN FOR I/O
;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%NIK==1B9 ;NO INVALID KEY CLAUSE GIVEN
;DELETE FLAG BITS
DL%NIK==1B9 ;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
;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
IFN ANS68,<
ENTRY SEEKGN ;"SEEK" GENERATOR
>
IFN ANS74,<
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
INTERNAL LARGE,LARGER ;FIND LARGEST RECORD FOR A FILE [245]
SUBTTL OPEN
OPENGN: PUSHJ PP,SETOP ;SET UP EOPTAB
EQUIT;
;DON'T ALLOW "OPEN EXTEND" FOR ANYTHING BUT SEQUENTIAL FILES.
TXNN W1,1B13 ;IS THE "EXTEND" BIT ON?
JRST OPENG0 ;NO
IFN ANS68, LDB TE,FI.ACC ;FETCH FILE ACCESS
IFN ANS74, LDB TE,FI.ORG ;FETCH FILE ORGANIZATION
CAIE TE,%ACC.S ;SEQUENTIAL?
JRST ENOPNX ;NO, COMPLAIN
OPENG0:
IFN ANS74,<
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
>;END IFN ANS74
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]
IFN ANS68,<
JRST PUTOP
>
IFN ANS74,<
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
IFN ANS74,<
OPNM: MOVEI TD,V%OPEN ;SET OPEN VERB
DPB TD,O.BOPR ;TELL LIBOL THE OPERATION
; SET IOFLGS FOR TYPE OF OPEN
MOVX TD,OPN%IN ;INPUT
TXNE W1,1B10 ;"INPUT"
IORM TD,IOFLGS## ;SET IN IO FLAGS
MOVX TD,OPN%OU
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
;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
PUSH PP,EACA ;SAVE ADDR OF KEY-INFO
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
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
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
>;END IFN ANS74
;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;
IFN ANS74,<
LDB TE,FI.RMS## ;CHECK FOR RMS FILE
JUMPN TE,CLOM ; GO GENERATE THE RMS CLOSE
>;END IFN ANS74
MOVSI CH,CLOS##
IFN ANS74,<
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'
IFN ANS68,<
JRST PUTOP
>
IFN ANS74,<
JRST OPNGN3 ;SEE IF KEY NEEDS CONVERTING
>
SUBTTL RMS CLOSE
IFN ANS74,<
CLOM: MOVEI TE,V%CLOS ;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
>;END IFN ANS74
SUBTTL STDAGL - WRITE A STANDARD ARG LIST AND MOVEI 16,ADDR
IFN ANS74,<
;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
>;END IFN ANS74
SUBTTL READ
READGN: PUSHJ PP,SETOP ;SET UP OPERAND
EQUIT; ;QUIT IF ERRORS
IFN ANS74,<
LDB TE,FI.RMS ;RMS FILE?
JUMPN TE,READM ;YES
>;END IFN ANS74
MOVEI CH,READ##
IFN ANS74,<
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
RDGN1:
IFN ANS68,<
MOVS CH,EIOOP
PUSHJ PP,PUTOP ;SET UP AND WRITE OPERATOR
>
IFN ANS74,<
;17-AUG-79 /DAW DON'T ALLOW DELETE FOR SEQ. FILE
HRRZ CH,EIOOP
CAIE CH,DELETE##
JRST RDGN1A ;NOT DELETE, OK
MOVE TA,CURFIL ;FIND ACCESS MODE FOR FILE
LDB TD,FI.ACC
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
IFN ANS68,<
LDB TE,FI.ACC ;IS FILE
JUMPN TE,RDGN3 ; SEQUENTIAL?
>
IFN ANS74,<
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:
IFN ANS74,<
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
RDGN6:
IFN ANS74,<
;CHECK FOR USE ERROR PROCEDURE AND IF GIVEN USE IT
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.ACC ;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
IFN ANS74,<
CAIN W2,NOOP. ;IF NOOP.,
POPJ PP, ; SKIP IT
>;END IFN ANS74
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:
IFN ANS68,<
JRST SPIFGC
>
IFN ANS74,<
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
IFN ANS74,<
READM: MOVEI TE,V%READ ;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
TLNN W1,INTO ;"INTO" OPTION FOR THIS READ?
JRST RDM1 ;NO
PUSHJ PP,LARGE ;YES--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 RDM1] ;OK
PUSHJ PP,INTOOK ; SEE IF "INTO" IS OK
JRST RDGN9 ;NO, COMPLAIN
;;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,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
;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: PUSHJ PP,PUT.PJ ;GENERATE CALL
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
>;END IFN ANS74
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:
IFN ANS74,<
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:
>;END IFN ANS74
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
IFN ANS74,<
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
HLRZ TE,CURDAT ;CHECK FOR DEPENDING VARIABLES
HRRZM TE,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
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
IFN ANS74,<
PUSH PP,CURDAT ;SAVE CURRENT DATAB
SETOM EDEBDA## ;SEE IF DEBUGGING WANTED
>
PUSHJ PP,MOVGN. ;GENERATE MOVE
IFN ANS74,<
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:
IFN ANS74,<
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.ACC
MOVE TE,EIOOP ;GET VERB BACK
IFN ANS68,<
CAIE TD,%ACC.I ;IF FILE IS INDEXED
CAIN TE,WRITE ; OR THIS IS A 'WRITE'
JRST RITG1A ; ALL IS WELL
MOVEI DW,E.371 ;'NOT LEGAL UNLESS ISAM'
PUSHJ PP,OPFAT
>
RITG1A: 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
IFN ANS74,<
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
IFN ANS74,<
TLO W1,AFTER ;"AFTER"
>
JRST WADVG5
;"WRITE" GENERATOR (CONT'D).
; NO ADVANCING
RITGN2:
IFN ANS68,<
MOVE TE,EIOOP ;IF THIS IS
CAIN TE,DELETE## ; A 'DELETE',
JRST RITG2B ; SKIP SOME CODE
LDB TE,FI.ACC ;IS IT
CAIE TE,%ACC.I ; INDEXED FILE?
JRST RITG2B ;NO
;GENERATE MOVE OF SYMBOLIC KEY TO RECORD KEY
MOVE EACA,EOPLOC
MOVEM W1,1(EACA)
MOVEM W1,3(EACA)
PUSH PP,TA ;SAVE TA
LDB TA,FI.SKY ;GET POINTER TO SYBOLIC KEY
JUMPN TA,RITG2A ; SEE IF OKAY [252]
POP PP,TA ; [252] NO
JRST RITG2B ; [252] DON'T MOVE
RITG2A: PUSHJ PP,LNKSET ; [252]
LDB TB,DA.LKS## ; SYMBOLIC KEY IN LINKAGE SECTION?
POP PP,TA ;RESTORE TA
LDB TE,FI.SKY ;PICK UP POINTER TO SYMBOLIC KEY
JUMPE TB,.+3 ;IN LINKAGE SECTION?
MOVSI TB,(LKSFLG) ;YES, SET THE LINKAGE SECT. FLAG
IORM TB,1(EACA) ;IN FIRST WORD OF EOPTAB ENTRY
MOVEM TE,2(EACA)
LDB TE,FI.RKY
JUMPE TE,RITG2B
MOVEM TE,4(EACA)
ADD EACA,[XWD 4,4]
MOVEM EACA,EOPNXT
PUSHJ PP,MOVGEN
>
;PUT OUT 'WRITE', 'REWRITE', OR 'DELETE'
RITG2B: HRLZ CH,EIOOP ;GET OP-CODE
IFN ANS74,<
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,SZDPVA##
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
IFN ANS74,<
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
IFN ANS74,<
;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.ACC ;UNLESS IT'S INDEXED
CAIE TE,%ACC.I
JRST RITGN6 ;RELATIVE--"Invalid key not allowed"
RITGN4:
>;END IFN ANS74
LDB TE,FI.ACC
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:
IFN ANS68,<
JUMPE TE,RITGN6 ;IF FILE IS SEQ,
>
IFN ANS74,<
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:
IFN ANS74,<
MOVE TE,EIOOP ;IS THIS A REWRITE?
CAIE TE,RERIT.
JRST RTGN5A ;NO
LDB TE,FI.ACC ;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.ACC ;GET ORGANIZATION MODE
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.ACC ;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,350700 ;YES--CREATE A BYTE POINTER TO LITERAL IN VALTAB
LDB TD,TA ;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
IFN ANS74,<
PUSHJ PP,CNVKYB ;SEE IF KEY NEEDS CONVERTING
>
SKIPN TE,WDPITM## ;DEPENDING ITEM?
JRST WADV5A ;NO, SKIP THIS
TRNN TE,-1 ;ARE WE SURE?
JRST WADV5A ;NO
PUSH PP,TC ;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,SZDPVA##
JRST [POP PP,TC ;RESTORE TC
JRST DPPER2] ; AND 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
JRST OVRPUT ;JUMP OVER PUTOP
;THIS SHOULD NEVER HAPPEN. IF IT DOES, THE PROGRAM SHOULD STILL WORK ANYWAY.
DPPER2: OUTSTR DPPEMS ;REPORT PROBLEM WITH DEPENDING VARIABLE
; JRST WADV5A ; 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,D1MODE+1 ; [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
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.
IFN ANS74,<
PUSHJ PP,CNVKYB ;SEE IF KEY NEEDS CONVERTING
>
PUSHJ PP,PUTOP
MOVE CH,[XWD AS.XWD,1]
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
IFN ANS68,<
JRST RITGN3
>
IFN ANS74,<
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
IFN ANS74,<
;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
HLRZ TE,CURDAT ;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
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: 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 ;ADVANCING CLAUSE?
JRST WRTM2 ;NO, OK
MOVEI DW,E.372 ;** CHECK THIS **
PUSHJ PP,OPFAT
POPJ PP, ;RETURN FROM WRITE
WRTM2: 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 TA,FI.ERR## ;SEE IF FILE-SPECIFIC USE PROCEDURE
JUMPN TA,WRTM2D ;YES, SET THE BIT
SKIPN USP.O## ;NO, GENERAL USE PROCEDURE?
SKIPE USP.IO##
JRST WRTM2D ;YES, SET THE BIT
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
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.
;NOTE FOR MAINTAINERS:
; THERE IS NO REAL REASON FOR CHOOSING AC4 RATHER THAN ANOTHER AC ;
TLNE TE,-1 ;HAVE TO PRESERVE %PARAM+0?
SETOM SAVPR0## ;YES, TELL SZDPVA
HRRZM TE,ETABLA ;IT LOOKS FOR LINK IN ETABLA
MOVEI TE,4 ; LOAD RUNTIME SIZE IN AC4
HRRZ TE,EOPLOC ;POINT TO THE RECORD OPERAND
ADDI TE,1 ; IN CASE OF ERROR
HRLM TE,OPERND ;"A" OPERAND
PUSHJ PP,SZDPVA## ;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
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
;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,2 ;WE JUST GENERATED TWO 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
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
HRLZ TA,ERECSZ ;GET REC SIZE
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
MOVE TA,KEYADR ;GET KEY ADDRESS
PUSHJ PP,POOLIT
WRTM2G: 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
;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##
SKIPE TD ;SKIP IF RANDOM ACCESS
MOVEI CH,WT.MIS## ;NO, USE OTHER ROUTINE
WRTM2J: PUSHJ PP,PUT.PJ ;"PUSHJ PP,ROUTINE"
WRTM2K: 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
>;END IFN ANS74 ;GO DO NEXT OPERATOR
SUBTTL SEEK
IFN ANS68,<
SEEKGN: PUSHJ PP,SETOP
EQUIT;
LDB TE,FI.ACC ;IF FILE IS NOT RANDOM,
SOJN TE,NOTRAN ; ERROR
MOVSI CH,SEEK##
JRST PUTOP
>
SUBTTL START
IFN ANS74,<
STRTGN: SETZM EIOOP ;CLEAR LAST I/O OPERATOR
PUSHJ PP,SETOP
EQUIT;
LDB TE,FI.ACC ;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,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
;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
>;END IFN ANS74
SUBTTL DELETE
DELGEN: PUSHJ PP,SETOP ;SET UP OPERAND
EQUIT; ;QUIT IF ERRORS
MOVEI CH,DELETE##
IFN ANS68,<
;FOR ANS68, DELETE'S ARGUMENT IS A RECORD, NOT A FILESPEC.
JRST RITGN0
>
IFN ANS74,<
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'
IFN ANS74,<
NOOPGN::PUSHJ PP,PUTASA##
MOVSI CH,JFCL.##
JRST PUTASY
>
SUBTTL DELETE RMS RECORD
IFN ANS74,<
;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,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
CAIN TE,%FAM.S
JRST DELM3 ;OK
;THERE BETTER BE A USE PROCEDURE
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
;GET A ROUTINE, DEPENDING ON THE FILE ACCESS MODE
DELM3: 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
;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.
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
>;END IFN ANS74
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.
IFN ANS74,<
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,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
;"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: MOVE TA,[XWD XWDLIT,2]
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
IFN ANS68,<
HRRZ TE,EMODEA
TSWT FANUM ;NUMERIC IS ALWAYS CONVERTED TO ASCII
>; END IFN ANS68
IFN ANS74,<
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
MOVEI TE,5
MOVEM TE,EAC
PUSHJ PP,MXAC.
MOVEI CH,DSP.FP
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" 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:
IFN ANS68,<
TLNE EACB,GNTALY!GNTODY ;"TALLY" OR "TODAY"?
>
IFN ANS74,<
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
IFN ANS74,<
SKIPG COLSEQ## ;PROGRAM COLLATING SEQUENCE?
JRST FIGC6 ;NO
HRRZ TA,COHVLV##+1 ;YES, GET ASCII HIGH-VALUE CHAR.
ROT TA,-7 ;LEFT JUSTIFY
>
JRST FIGC6
FIGC5: MOVSI TA,(BYTE(7)0) ; A NORMAL LOW-VALUE
IFN ANS74,<
SKIPG COLSEQ ;PROGRAM COLLATING SEQUENCE?
JRST FIGC6 ;NO
HRRZ TA,COHVLV+4 ;YES, GET ASCII LOW-VALUE CHAR.
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?
TRNA ;MORE TO FOLLOW, LEAVE AS IS
IOR TA,[BYTE(7)" ",15,12,0,0] ;NO, APPEND <CRLF>
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
;"DISPLAY" GENERATOR (CONT'D).
ENDTST:
IFN ANS74,<
PUSHJ PP,CDEBA## ;COPY LAST INDENTIFIER TO DEBUG LIST
>
PUSHJ PP,BMPEOP ;ANY MORE OPERANDS?
IFN ANS68,<
POPJ PP, ;NO--QUIT
>
IFN ANS74,<
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
IFN ANS74,<
MOVE TA,-1(EACA) ;GET 2ND OPERAND
TLNN TA,GNFIGC ;FIG. CONST?
JRST ACCGN1 ;NO
TLNE TA,GNTODY ;ONE OF DATE, DAY, OR TIME?
JRST ACCTDY ;YES
JRST BADEOP ;WELL IT SHOULD BE
ACCGN1:>
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
IFN ANS74,<
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)
IFN ANS68,<
CAIN TA,TALLY.##
JRST ACEPT2
>
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)
IFN ANS68,<
HRRZ TD,1(TC) ; GET OPERAND ADDRESS [176]
CAIE TD,TALLY.## ; IF TALLY TREAT AS NUMERIC [176]
>
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:
IFN ANS74,<
PUSHJ PP,CDEBB## ;COPY LAST INDENTIFIER TO DEBUG LIST
>
PUSHJ PP,BMPEOP ;ANY MORE OPERANDS?
IFN ANS68,<
POPJ PP, ;NO--QUIT
>
IFN ANS74,<
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.
IFN ANS74,<
;[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: 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
IFN ANS74,<
;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,
;[605] SEE IF THIS IS A VARIABLE LENGTH READ IN WHICH THE DEPENDING ITEM
;[605] IS NOT CONTAINED IN THE RECORD ITSELF
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 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.DEP ;[1030] IS THE DEPENDING VARIABLE AT THIS LEVEL?
JUMPN TB,VLTST3 ;[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
;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
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.ACC,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
IFN ANS74, EXTERN FI.ORG,FI.FAM
IFN ANS68, EXTERN FI.ACC
;FILE ENQUEUE - RECORD ENQUEUE
FENQGN:
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
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
ERENQ0: SOJG TA,ERENQ1 ;JUMP IF NOT 1ST RENQ OR RDEQ
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
IFN ANS74,<
SETZM ESUCVT## ;HAVEN'T CONVERTED ANY KEYS YET.
PUSHJ PP,ERENSF ;SETUP CURFIL; GENERATE CODE TO CONVERT KEY
>;END IFN ANS74 ;IF NECESSARY
SKIPA
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
JRST ERENQ4
ERENR1:
IFN ANS74,<
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:
IFN ANS74,<
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
>;END IFN ANS74
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
IFN ANS68, LDB TB,FI.ACC
IFN ANS74, 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
ERENR3: LDB TA,FI.SKY## ;SET UP EMODEB, ESIZEB FOR SYMBOLIC KEY
JUMPE TA,ERENR9 ;ERROR, SYMBOLIC KEY NOT DEFINED
PUSHJ PP,LNKSET##
LDB TB,DA.USG##
SUBI TB,1
MOVEM TB,EMODEB##
LDB TB,DA.INS##
MOVEM TB,ESIZEB##
MOVE TC,CUREOP
MOVE TB,EMODEB##
CAME TB,EMODEA##
JRST ERENR4 ;JUMP IF USAGE DOESN'T MATCH
MOVE TA,ESIZEA##
CAMN TA,ESIZEB##
JRST ERENQ3 ;JUMP IF SIZE MATCHES
CAIE TB,D1MODE##
JRST ERENR4
CAMG TA,ESIZEB
JRST ERENQ3 ;JUMP IF SIZE OF SYMBOLIC KEY
;GREATER THAN SIZE OF LITERAL
;OR DATA NAME IF BOTH ARE COMP
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
IFN ANS74,<
;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
>;END IFN ANS74
;RECORD DEQUEUE
RDEQGN: TLNN W1,000400
JRST FENQGN
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,FENQGN
SUBTTL KYPTR -- RMS ROUTINE TO GET PTR TO RECORD KEYS
IFN ANS74,< ;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
MOVEM TA,CURAKT## ;SAVE REL. ADDR
ADD TA,AKTLOC ;GET ABS PTR
;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
ADD TA,AKTLOC ;GET ABS LOC IN ALTERNATE KEY TABLE
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
;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
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 IFN ANS74
END