Trailing-Edge
-
PDP-10 Archives
-
BB-4148D-BM
-
dbms-v5a/source/dmlvok.mac
There are 22 other files named dmlvok.mac in the archive. Click here to see a list.
TITLE DMLVOK
;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,1975,1976,1977,1978,1979 BY DIGITAL EQUIPMENT CORPORATION
SEARCH GENDCL,DMLSYM,STRING,DBSDCL
IFNDEF $COB,<$COB==0> ;DEFAULT FOR FORTRAN
IFN $COB,<SEARCH P>
SEGMEN
;EDITS
;V12*****************
;NAME DATE COMMENTS
;HRB 7-JUN-79 [421] DO NOT GENERATE SBINDS WITH QUOTED
; STRING CONTINUATION LINES
;JSM 26-JAN-79 [374] TEST FOR "ACCESS" BEFORE SUPPLYING
; (1) FOR OCCURS ITEM IN "BIND"
;V11******************
;NAME DATE COMMENTS
;MDL DEC-14-77 [316] USE THE USAGE GIVEN FOR GROUP ITEMS
;BSM SEP-22-77 [265] IF INVALID PRIVACY KEY, FLAG IT FOR
; COMPILERS. NOTE: REQUIRES COBOL EDIT #513
;V10*****************
;NAME DATE COMMENTS
;SSC MAR-5-75 PLACED 6A EDIT %316 DIRECTLY IN V10
; NOTE THIS IS A NEW MODULE FOR COBOL
;********************
ENTRY DMLVOK,VOKINI
;THIS MODULE CAN BE USED FROM EITHER COBOL OF FORTRAN
;ITS USEABILITY IS CONTROLLED BY THE ASSEMBLY SWITCH, $COB.
IFE $COB,<PRINTX <ASSEMBLING FOR FORTRAN>>
IFN $COB,<PRINTX <ASSEMBLING FOR COBOL>>
;;; MODULE REGS
MREG(BMASK,6)
MREG(CRU,7) ;CUR BLK OF RUN-UNIT
MREG(OCC) ;FOR OCCURS
MREG(SYMCOD)
; FOR ERRORS
;;; DMLSSI ;SUB SCHEMA NAME INVALID
;;; DMLBDK ;BAD PRIVACY KEY
;;; DMLNSB ;NO SCHEMA BLOCK
;;; DMLCOS ;CANT OPEN SCHEMA
;;; DMLSAF ;SCHEMA ACCESS FAILURE
;;; DMLINP ;NON-DATA-BASE ITEM HAS NO PSEUDONYM
;;; DMLDUP ;V.3 WILL DETECT DUPLIC DB SYMBOLS
;;; DMLANN
;;; DMLNWP ;DATA-NAME(S) WITHOUT PSEUDONYM ENCOUNTERED
DEFINE HOWPUT(FARGS.,CARGS.,OCC.)<
IFNB <OCC.>,<MOVE OCC,OCC.>
IFE $COB,<UTIL PUTDCL,<FARGS.,OCC.>>
IFN $COB,<UTIL PUTDCL,<CARGS.,OCC.>>
>
DEFINE KEY(KEYARG),<
[$$'KEYARG]
>
;DEFINE PART OF SYMBOL NODES LOCAL TO SCHEMA PROCESSING
SM.TYP==SM.USR##
SM.NMID==SM.USR##+1
SYMLEN==SM.NMID+1
;THIS IS KLUDGE--SEE DMLDCL FOR RIGHT WAY
EXTERN $DBNAME,$IDENT,$DBID
SUBTTL LOW-SEG STUFF
IFN $COB,<
DEFINE DATA(NAM,SIZ)< ;;BECAUSE OF COBOL'S IMPURE.MAC
EXTERN NAM
>
DEFINE GDATA(NAM,SIZ)< ;;BECAUSE OF COBOL'S IMPURE.MAC
EXTERN NAM
>
CURNAM==CURN2
DATA(NULLREC)
DATA(SIZONL,2) ;FOR OCCURS CLAUSE
>
DATA(SIZAREA,2)
DATA(LEVNO,2) ;STRING PTR FOR CURRENT LEVEL
DATA(TMPNAM,2) ;A STRING PTR FOR SHORT TERM USAGE
DATA(PICBP,2) ;PTS AT CURR PICTURE
DATA(UNWIND) ;FOR HANDLING FATAL ERRORS
DATA(FILENM)
DATA(DASH)
DATA(UNDIDX)
DATA(TXTIDX) ;STRING VERSION OF ?L.NMID
DATA(PSUNYM)
DATA(A.TMP1) ;TEMPORARY FOR OLD ARG LISTS
DATA(A.TMP2)
A.PT1==A.TMP1
A.PT2==A.TMP2
IFE $COB,<
;;; SIZTXT IS SUBSTRING OF UNDEFP
ASP (STACMN,^D20)
ASP (UNDEFP,^D20,<UNDEFP(>)
SIZTXT: POINT 7,UNDEFP+2+1,6
0
SIZONL: POINT 7,UNDEFP+2+1,13
XWD ^D10,0
DATA(CURNAM,2) ;STRING PTR TO CURR DB SYMBOL
;;; ARG BLK TO MGRMEM
MMDESC: 0 ;;;ONLY VARIABLE WORD
SYMLEN ;AMOUNT TO ALLOC EACH TIME
200 ;AMOUNT TO GRAB WHEN RUN OUT
>
SUBTTL TEXT DATA FOR FORTRAN
$FUNCT (VOKDUM) ;FORCE HISEG
IFE $COB,<
STRIVRY (SYSCOM,< INTEGER SYSCOM(32),ERCNT,ERSTAT
INTEGER ERAREA(6),ERREC(6),ERSET(6),RECNAM(6),ARNAM(6)
EQUIVALENCE (SYSCOM(1),ARNAM),
1 (SYSCOM(7),RECNAM),
1 (SYSCOM(13),ERSTAT),
1 (SYSCOM(14),ERSET),
1 (SYSCOM(20),ERREC),
1 (SYSCOM(26),ERAREA),
1 (SYSCOM(32),ERCNT)
>)
DBNULL: STRIPT < INTEGER DBNULL
>
SYS32: STRIPT <SYSCOM
>
STASB: STRIPT < CALL SBIND(>
STABIND:STRIPT < CALL BIND(>
EBIND: STRIPT < CALL EBIND(0,DBNULL)
>
LEV1: STRIPT <*01 >
LEV2: STRIPT <* 02 >
Q: STRIPT <'>
INTEG: STRIPT < INTEGER >
REAL: STRIPT < REAL >
REAL8: STRIPT < REAL*8 >
COMPLEX: STRIPT < COMPLEX >
COMMUN: STRIPT < COMMON>
INCLUDE:STRIPT < INCLUDE '>
ELEM1: POINT 7,ELEM1 ;0-LENGTH, CAN PT ANYWHERE
EXP 0
SIZE2: STRIPT <(2>
SIZE6: STRIPT <(6>
SLASH: POINT 7,[ASCII\/\]
XWD 0,1
DOTSUB: STRIPT <.SUB'
>
NOLIST: STRIPT <.SUB/NOLIST'
>
> ;END IFE $COB
SUBTTL TEXT DATA FOR COBOL
IFN $COB,<
STRIVRY (SYSCOM,<
01 SYSCOM.
02 AREA-NAME, PIC X(30) USAGE DISPLAY-7.
02 RECORD-NAME, PIC X(30) USAGE DISPLAY-7.
02 ERROR-STATUS, PIC 9(5) USAGE DISPLAY-7.
02 ERROR-SET, PIC X(30) USAGE DISPLAY-7.
02 ERROR-RECORD, PIC X(30) USAGE DISPLAY-7.
02 ERROR-AREA, PIC X(30) USAGE DISPLAY-7.
02 ERROR-COUNT PIC 99, USAGE COMP.
>)
DBNULL: STRIPT <01 DBMS-NULL PIC 99 USAGE COMP.
>
DBSECT: STRIPT <
DBMS SECTION.
>
STASB: STRIPT < ENTER MACRO SBIND USING >
STABIND:STRIPT < ENTER MACRO BIND USING >
EBIND: STRIPT < ENTER MACRO EBIND USING 0,DBMS-NULL.
>
LEV1: STRIPT <01 >
LEV2: STRIPT < 02 >
Q: STRIPT <">
PICTUR: STRIPT < PIC >
PIC.DC: STRIPT <S9(18)>
PICX30: STRIPT <X(30)>
USCMP2: ;SAME IN COBOL
USCOMP: STRIPT < USAGE COMP>
USCMP1: STRIPT < USAGE COMP-1>
USCMP3: STRIPT < USAGE COMP-3>
USD6: STRIPT < USAGE DISPLAY-6>
USD7: STRIPT < USAGE DISPLAY-7>
USD9: STRIPT < USAGE DISPLAY-9>
ALLKEY: STRIPT < USAGE DBKEY>
ELEM1: STRIPT < (1)>
OCCURS: STRIPT < OCCURS >
L2FILL: STRIPT < 02 FILLER PIC X(1).
>
> ;END IFN
SUBTTL TEXT DATA FOR ALL HOSTS
NULSTR: POINT 7,ZERO
0
AZERO: STRIPT 0
SEP: STRIPT <,>
C.RUN.C:STRIPT <,0,>
LPAREN: STRIPT <(>
RPAREN: STRIPT <)>
DOTCRLF:STRIPT <.
>
CRLF: STRIPT <
>
SUBTTL INIT SYMBOL TABLE FOR COBOL
IFN $COB,<
DEFINE MAKASC(STRING)<ASCII/-00'STRING/>
DEFINE MAKASK(STRING)<ASCII/STRING/>
DEFINE SYMBLK(TYPE,STRING)<
GETLEN (<STRING>)
EXP 0
POINT 7,SYMLEN ;;ACTUAL STRING ALWAYS IMMED AFTER BLK
EXP LEN.
0 ;;SM.TYP...UNUSED BY COBOL
RADIX 10
MAKASC(\<-$$'TYPE>) ;;SM.NMID...THE ASCII REPR OF THE NUMERIC ENCODEMENT
RADIX 8
MAKASK(STRING) ;;THE ACTUAL SYMBOL
IFLE LEN.-5,<BLOCK 2
LEN.=100>
IFLE LEN.-^D10,<BLOCK 1>
>
KS.TAB:
SYMBLK ONLY,ONLY
KS.SIZ==.-KS.TAB
SYMBLK SELECT,SELECTIVE
SYMBLK FIRST,FIRST
SYMBLK LAST,LAST
SYMBLK PRIOR,PRIOR
SYMBLK NEXT,NEXT
SYMBLK DUPLIC,DUP
SYMBLK ALL,ALL
SYMBLK AREA,AREA
SYMBLK RECORD,RECORD
SYMBLK SET,SET
SYMBLK UPDATE,UPDATE
SYMBLK RETRIEV,RETRIEVAL
SYMBLK RETRIEV,RETR
SYMBLK RUNUNIT,RUN-UNIT
SYMBLK PROT,PROTECTED
SYMBLK PROT,PROT
SYMBLK EXCL,EXCLUSIVE
SYMBLK EXCL,EXCL
SYMBLK CURR,CURRENT
SYMBLK SHARED,SHARED
KS.LAST:
SYMBLK JOURNAL,JOURNAL
KS.END==.-KS.TAB
> ;END IFN $COB
SUBTTL THE DBCS INTERFACE
$FUNCT (VOKINI)
;;; THIS IS RATHER GROSS...U CANT WIN ALL THE TIME
IFN $COB,<
FUNCT BLDSY.,<SYM.TB##,[^D31]> ;31 IS ARBITRARY
MOVEM R0,SYMTAB
;;; KLUDGE AWAY
FUNCT ALCMEM,<ONE> ;KLUDGE--DON'T WANT OFFSET OF 0
FUNCT ALCMEM,<[KS.END]>
MOVEM R0,A.PT1
HRLI R0,KS.TAB
MOVE R1,R0
BLT R0,KS.END-1(R1)
COPI A.PT2,KS.LAST-KS.TAB(R1)
FUNCT INISY.,<SYMTAB,@A.PT1,@A.PT2,[KS.SIZ]>
>
RETURN
$FUNCT (DMLVOK) ;SCH,SS,KEY PASSED AS GLOBS
IFE $COB,<SETZM MMDESC+MM.CUR> ;FOR MGRMEM
COPI UNDIDX,1 ;INIT UNDEF ARRAY SUBSCRIPT
IFN $COB,<
FUNCT OWRITE,<DBSECT> ;FOR CLARITY IN LISTING
; IT'S SLOWER BUT MAKES THE REST EASIER
; COBOL PROVIDES THIS INFO IN SIXBIT
; FORDML IN ASCII -- AND THE CODE EXPECTS THE LATTER
UTIL COPSIX,<SCH.PT,SCHEMA##,SIX>
MOVEM R2,SCH.PT+1
UTIL COPSIX,<SS.PT,S.SCH##,[36]>
MOVEM R2,SS.PT+1
UTIL COPSIX,<KEY.PT,PKEY##,SIX>
MOVEM R2,KEY.PT+1
>
SETZM BAS ;SYSTEM REG FOR SCHIO
FUNCT OPEND%,<SCH.PT,ZERO,ZERO>
OTSERR (<DMLCOS##,SCH.PT>,VOKFAIL) ;CAN'T OPEN SCHEMA
FUNCT FINDR% ;THIS ENTRY POINT FINDS ROOT OF .SCH STRUCTURE
OTSERR (<DMLNSB##>,VOKFAIL) ;NO SCHEMA BLOCK IN .SCH FILE
SKIPL INVSEE ;DO ONLY FOR INVOKE
JRST VOKSSC
COPY A.TMP1,SL.EDIT(R1)
UTIL CNV.ZP ;CALL CNVSTR & ZEROPAD
FUNCT OBJOUT,<STASB,Q,SCH.PT,Q,SEP,INT TXTIDX,SEP>
FUNCT OBJCNTN ;[A421]
VOKSSC: ;INVOKE SUB-SCHEMA CHOOSE
FUNCT FIND3%,<KEY NEXT,ZERO,[$S.U],KEY SET>
OTSERR (<DMLSSI##>,VOKFAIL) ;INVALID SUB-SCHEMA NAME FOR THIS DB
MOVEM R1,CRU
COPI A.PT1,UL.NAM(CRU)
FUNCT EQLSTR,<VARY @A.PT1,SS.PT,[EXACT]>
JUMPE R0,VOKSSC ;KEEP LOOKING
;;; HAVING FOUND RIGHT ONE, GET THE USEFUL INFO OUT
MOVE BMASK,UL.MASK(CRU)
UTIL PARENAM,<FILENM,SS.PT>
IFE $COB,<
UTIL COPSIX,<SIZONL,FILENM,SIX> ;POOR NAME HAS GONE SIXBIT TO ASCII(STRIPPED)
;ASCII TO SIXBIT,TRUNC. & DASHES REMOVED
;SIXBIT TO ASCII
HRRM R2,SIZONL+1
FUNCT CATSTR,<STACMN,FOUR,COMMUN,SLASH,SIZONL,SLASH>
FUNCT OWRITE,<INCLUDE,SIZONL>
SKIPE VU.INCL ;LIST INCLUDE FILE?
JRST [FUNCT OWRITE,<DOTSUB> ;YES
JRST .+2]
JRST [FUNCT OWRITE,<NOLIST> ;NO
JRST .+1]
>
SKIPL INVSEE ;NO BINDING FOR ACCESS STAT.
JRST VOKFND
MOVE R0,BMASK ;PUT OUT MASK INDEX TO IDENT SS
JFFO R0,.+1 ;JUST WANT NUMBER, NO PATH SPLIT
MOVEM R1,A.TMP1 ;USES REGISTER PAIR
UTIL CNV.ZP ;CALL CNVSTR & ZEROPAD
FUNCT OBJOUT,<Q,SS.PT,Q,SEP,INT TXTIDX,SEP,MLIT SYSCOM>
FUNCT OBJFLUSH ;INCLUDE AND SBIND NOW OUT
VOKFND:
SKIPE UL.LOK(CRU) ;IS THERE A LOCK?
JRST [SKIPN R1,KEY.PT+1 ;IS LEN NON-ZERO
JRST INVPRI ;[265] BAD KEY IN EFFECT--NOT PRES.
CAILE R1,LOKMAX ;TRUNCATE IF NECES
MOVEI R1,LOKMAX
MOVEM R1,KEY.PT+1
COPY A.TMP1,UL.LOK(CRU)
SETZM A.TMP2 ;GUARAN ASCIZ
FUNCT EQLSTR,<KEY.PT,ASZ A.TMP1,[EXACT]>
JUMPE R0,INVPRI ;[265] KEYS DON'T MATCH
JRST .+1]
IFE $COB,< ;FOR COBOL, FILE TO OPEN INDEP OF SS NAME
FUNCT BLDVOK,<FILENM>
JUMPE R0,VOKFAIL
COPY VOKHDR,VOKCHAN+RING
FUNCT BUFINI,<VOKCHAN>
FUNCT VWRITE,<STACMN,SYS32,CRLF>
>
FUNCT VWRITE,<VARY SYSCOM>
UTIL RECWALK ;WRITE OUT INDIV NAMES
VOKDON:
; GENERATE INDEXES FOR AREAS
FUNCT FIND3%,<KEY NEXT,ZERO,[$S.A],KEY SET>
JUMPE R0,VOK.D1 ;YES
MOVEM R1,CRU
TDNN BMASK,AL.SS(CRU) ;IN SUB-SCHEMA?
JRST VOKDON ;NO
UTIL SYMALC,<VARY AL.NAM(CRU)>
JRST VOKDON
VOK.D1:
FUNCT VWRITE,<DBNULL>
IFE $COB,<
FUNCT VWRITE,<STACMN,MLIT DBNULL,CRLF>
SOSE UNDIDX ;UNDIDX REPRESENTS START PT. OF NEXT
;VAR TO GO IN UNDEF.
;SO IN TERMS OF STORAGE ALLOC IT
;IS ONE TOO BIG
JRST [FUNCT CNVSTR,<SIZONL,UNDIDX,[12],[TOASCI+NOFILL]>
FUNCT VWRITE,<STACMN,UNDEFP,SIZONL,RPAREN>
WARN (DMLNWP##) ;DATA-NAME(S) WITHOUT PSU ENCOUNTERED
JRST .+1]
>
SKIPGE INVSEE ;ONLY IF ACTU INVOKE
JRST [FUNCT OWRITE,<EBIND> ;TELL RUN-TIME SYS ALL DONE BINDING
JRST .+1]
FUNCT VWRITE,<CRLF> ;MAKES COBOL HAPPY
FUNCT BUFINI,<VOKCHAN>
RELEAS VOKCHN,
FUNCT CLOSD%,<KEY ALL>
SETO R0, ;NOTE SUCCESS
RETURN
VOKFAIL:
MOVE P,UNWIND ;BE SAFE--UNWIND STACK TO KNOWN CORRECT POS
FUNCT CLOSD%,<KEY ALL> ;CLEANUP BEFORE DIEING
SETZ R0,
RETURN
;[265] INVALID PRIVACY KEY GIVEN
INVPRI:
IFN $COB,<
SETOM PKEY## ;[265] FLAG INVALID KEY FOR COBOL
>
MOVEI 16,[DMLBDK##] ;[265] DBMS ERROR MESSAGE
PUSHJ P,TYPOUT ;[265] TYPE IT OUT
JRST VOKFAIL ;[265] CLEAN UP AND RETURN
SUBTTL THE LOOP THRU THE DATA NAMES
$UTIL RECWALK
SRLOOP:
IFN $COB,<
SETOM NULLREC ;START OUT WITH NULL RECORD (IE. NO 02'S)
>
FUNCT FIND3%,<KEY NEXT,ZERO,[$S.R],KEY SET>
JUMPE R0,LEAVE
MOVEM R1,CRU
TDNN BMASK,RL.SS(CRU) ;THIS ITEM IN RBUF (GOTTEN BY GET)
;IS A MASK OF WHICH SUBS THIS REC IS IN
JRST SRLOOP ;NOT THIS ONE
LD R0, RL,TID,(CRU) ;IS IT SYSTEM REC
CAIN R0,SYSTID
JRST [SKIPL INVSEE ;YES, SHOULD WE BIND TO IT?
JRST ROLOOP ;NO, OBV NO DATANAMES & SUCH, BUT DO PUT SETNAMES IN SYMBOL TABLE
FUNCT OBJOUT,<STABIND, MLIT 00001>
JRST ROLOOP]
UTIL SYMALC,<VARY RL.NAM(CRU)>
;;; AT THIS PT TXTIDX CONTAINS NUMERIC ID FOR RECNAM
FUNCT VWRITE,<LEV1,CURNAM,DOTCRLF>
SKIPE INVSEE ;IF SEEN INVOKE PUT OUT BIND
JRST [FUNCT OBJOUT,<STABIND,INT TXTIDX> ;FOR THE BIND
JRST .+1]
LD R1, RL,LM,(CRU)
SAVE <R1,RL.LOC(CRU),RL.WID(CRU)> ;SAVE AWAY SINCE MAYBE SOON BYE-BYE
DCOPY LEVNO,LEV2
RDLOOP:
FUNCT FIND3%,<KEY NEXT,ZERO,[$R.D],KEY SET>
JUMPE R0,RD.END
MOVEM R1,CRU
TDNN BMASK,DL.SS(CRU) ;DEFINED FOR THIS SCHEMA
JRST RDLOOP
IFN $COB,<SETZM NULLREC>
;;; DECODE DATA NAME, POSSIBLE PSUNYM
LD R1, DL,NLEN,(CRU)
MOVEI R0,DL.STRING(CRU)
HRLI R0,440700
DMOVEM R0,CURNAM
FUNCT RELSTR,<CURNAM,CURNAM+1>
LD R1, DL,SLEN,(CRU)
DMOVEM R0,TMPNAM
UTIL TSTONLY
UTIL DETDCL ;CALC DATTYP&SIZE
DTLOOP:
FUNCT FIND3%,<KEY NEXT,ZERO,[$D.T],KEY SET>
JUMPE R0,RDLOOP
MOVEM R1,CRU
TDNN BMASK,TL.SS(CRU)
JRST DTLOOP
COPI A.PT1,TL.TEXT(CRU)
FUNCT VWRITE,<VARY @A.PT1> ;TEXT IS DATA VARYING STRING
JRST DTLOOP
RD.END:
IFN $COB,<
SKIPE NULLREC ;01 NAME. WITHOUT 02'S IS ILLEGAL COBOL...FUDGE IT
JRST [FUNCT VWRITE,<L2FILL>
JRST .+1]
>
;;; NOW THE RECORD EXTERNAL STUFF
DCOPY LEVNO,LEV1 ;THE REC INDEP STUFF
;;; PUT OUT REC ASSOC VARIABLES, IF ANY
;;; IE. AREA-ID AND/OR DIRECT KEY
;;; WILL BE POINTED TO DIRECTLY BY RECBLK IF THEY EXIST
RESTOR <CRU>
JUMPN CRU,[
UTIL REFGET
JUMPN R0,.+1 ;DON'T REDCL--DUPLIC OR NO PSUNYM
HOWPUT <INTEG,SIZE6>,<PICX30,USD7>,ZERO
JRST .+1]
RESTOR <CRU,R1> ;RL.LOC & RL.LM
CAIN R1,LM.DIR
JRST [UTIL REFGET
JUMPN R0,.+1 ;DON'T REDCL--DUPLIC OR NO PSUNYM
HOWPUT <INTEG,NULSTR>,<ZERO,ALLKEY>,ZERO
JRST .+1]
;CONTINUED
; IF THIS RECORD IS OWNER OF SOME SET AND
; ANY OF ITS MEMBERS SOS IS LOC MODE OF OWNER,
; THE MEMBER MAY DEFINE AN ALIAS FOR USE IN FINDING ITS OWNER
ROLOOP:
FUNCT FIND3%,<KEY NEXT,ZERO,[$R.O],KEY SET>
JUMPE R0,RD.FLU ;ASSOC WITH NO MORE SETS
MOVEM R1,CRU
TDNN BMASK,OL.SS(CRU) ;IS THIS SET IN CURR S-S
JRST ROLOOP
; PUT SET NAMES AND INDEXES IN SYMBOL TABLE
; THIS INHERENTLY WORKS SINCE NO MEMBER RECORD CAN BE OWNED BY
; MORE THAN ONE OWNER; AND IN THIS PARTICULAR CASE THE OWNER-BLOCKS
; ARE ALL OWNED BY SOME RECORD-BLOCK
UTIL SYMALC,<VARY OL.NAM(CRU)>
; NOW CONTINUE WITH ALIAS PROCESSING
ALIAS2:
FUNCT FIND3%,<KEY NEXT,ZERO,[$O.M],KEY SET>
JUMPE R0,ROLOOP ;CAN'T BE A CONTROL(ALIAS) BLK UNDER A MEM BLK
;UNLESSTHERE IS A MEM BLK
FUNCT (FIND4%,<[$R.M],KEY SET>) ;SUPPRESS CSET CURR UPDATE
OTSERR (DMLSAF##,VOKFAIL)
TDNN BMASK,RL.SS(R1)
JRST ALIAS2 ;THIS MEM RECORD NOT IN SS
ALIAS3:
FUNCT FIND3%,<KEY NEXT,ZERO,[$M.V],KEY SET>
JUMPE R0,ALIAS2
ALIAS4:
FUNCT FIND3%,<KEY NEXT,ZERO,[$V.C],KEY SET>
JUMPE R0,ALIAS3
MOVEM R1,CRU
SKIPN CL.ALIAS(CRU) ;DOES IT PT TO AN ALIAS?
JRST ALIAS4 ;NO ALIAS IN THIS CB, GET ANOTHER
;;; GET ACTUAL TEXT & PUT IN PRESENTABLE FORM
FUNCT FIND1%,<CL.ALIAS(CRU)>
OTSERR DMLSAF##,VOKFAIL
MOVEM R1,CRU
UTIL SETTST,<VARY IL.NAM(CRU),VARY IL.PSU(CRU)>
;;; NEW-SYMBOL (OR FOR F10 PSUNYM) ONLY THING POSSIB IF "SCHEMA" PROG OK
JUMPG R0,[FILERR (<DMLDUP##,TMPNAM>,ALIAS4)]
JUMPL R0,ALIAS4 ;NOTHING TO DECLARE IF NO PSEUDONYM
FUNCT (FIND4%,<[$D.C],KEY SET>) ;SUPPR SET UPDATES
JUMPE R0,[ ;WILL BE DATA BLK UNLESS DIRECT KEY
HOWPUT <INTEG,NULSTR>,<ZERO,ALLKEY>,ZERO
JRST ALIAS4]
MOVEM R1,CRU
TDNN BMASK,DL.SS(CRU) ;IS THE DATA NAME ALIASED IN S-S
;;; ALIASED NAME NOT IN SS
USRERS (<DMLANN##,CURNAM>,ALIAS4)
UTIL DETDCL ;WILL APPLY TO THE DATA LK JUST GOTTEN
JRST ALIAS4 ;MORE CTL BLKS FOR THIS MEM BLK?
RD.FLU:
SKIPL INVSEE ;NO OBJ TO FLUSH IF ACCESS
JRST SRLOOP
FUNCT OBJFLUSH
JRST SRLOOP ;GET A NEW RECORD
SUBTTL NAME PROCESSING
$UTIL (REFGET)
FUNCT FIND1%,<CRU>
OTSERR DMLSAF##,VOKFAIL
MOVEM R1,CRU
UTIL SETTST,<IL.NAM(CRU),IL.PSU(CRU)>
RETURN
$UTIL (SETTST,<NAM,PSU>)
;;; COME HERE FOR DIRECT KEYS, AREA-IDS, AND ALIASES
;;; RETURNS R0:
;;; -1 IF NO PSEUDONYM (FORTRAN ONLY)
;;; 0 IF NEW SYMBOL (IE. UPDSYM INSERTED)
;;; + IF OLD SYMBOL (IE. UPDSYM FOUND RATHER THAN INSERTED)
MOVEI R3,@NAM(AP)
HRLI R3,440700 ;FINISH BUILDING NAME
MOVE R4,-1(R3) ;GET LENGTH
DMOVEM R3,CURNAM
MOVEI R3,@PSU(AP)
HRLI R3,440700
MOVE R4,-1(R3)
DMOVEM R3,TMPNAM ;THE PSUNYM, IF ONE
MOVEI SYMCOD,$IDENT ;SINCE A REFFED SYMBOL
JRST ST.MERG
$UTIL (TSTONL) ;CURNAM & TMPNAM ALREADY SETUP
MOVEI SYMCOD,$DBID
ST.MERG:
IFE $COB,<
;;; RULES ARE:
;;; IF PSUNYM PRESENT, USE IT
;;; ELSE...IF NAME SHORT ENOUGH JUST USE IT
;;; OTHERWISE PUT OUT UNDEF(XXX)
SETOM PSUNYM ;PRESET
SKIPE TMPNAM+1 ;PSUNYM OF ZERO LENGTH MEANS NONE
JRST [DCOPY CURNAM,TMPNAM
JRST SN.END]
MOVE R4,CURNAM+1
CAIG R4,6 ;OUT OF RUNNING IMMED?
SKIPE DASH ;CAN'T HAVE THESE EITHER
JRST [UTIL UNDBLD
UTIL PUTBIND
SETOM R0
RETURN()]
>
SN.END:
;;; COME HERE DIRECTLY FOR COBOL, NO PSEUDONYM FANCY-FOOTWORK NECES OBVIOUSLY
UTIL PUTBIND
UTIL IDALC ;IDALC TAKES CURNAM AS ITS ARG
return ;TRANSIV RETURN R0 (MEANINGFUL ONLY FOR SETTST)
IFE $COB,<
$UTIL (UNDBLD)
SETZM PSUNYM ;WOULDN'T BE HERE IF THIS WEREN'T TRUE
CAIN SYMCOD,$IDENT
JRST [UTIL IDALC ;SUPPRESS MSG IF ALREADY GIVEN
JUMPN R0,UBID.EX ;RETURNS ADDR IF FOUND RATHER THAN CREATED SYMNODE
WARN <DMLINP##,CURNAM>
JRST UBID.EX]
;;; SIZONL IS SUBSTRING OF UNDEFP ALLOCATION
FUNCT CNVSTR,<SIZONL,UNDIDX,[12],[TOASCI+NOFILL]>
FUNCT APPSTR,<SIZONL,RPAREN>
COPY CURNAM,UNDEFP ;GET RIGHT PTR
HRRZ R0,UNDEFP+1
HRRZ R1,SIZONL+1
ADD R0,R1
MOVEM R0,CURNAM+1
RETURN ;NO NEED TO ALC SYM IF UNDEF
UBID.EX:
DCOPY CURNAM,AZERO ;UNREFERENCABLE ITEM GETS NO STORAGE
RETURN
>
$UTIL (SYMALC,<NAMSYM>) ;EACH ACTUAL DB SYMBOL IS ASSOC WITH AN INDEX
MOVEI R3,@NAMSYM(AP)
HRLI R3,440700
MOVE R4,-1(R3)
DMOVEM R3,CURNAM
MOVEI SYMCOD,$DBNAME
$UTIL (IDALC) ;EXPECTS IDALC & SYMCOD VALID
IFE $COB,<
;;; SINCE CURNAM ALWAYS PTS INTO SCHEMA BUF
;;; STR.SV WILL COPY STRING TO PERM STRING AREA
;;; & ALTER CURNAM TO POINT THERE
FUNCT STR.SV,<CURNAM,CURNAM>
FUNCT MGRMEM,<MMDESC>
MOVEM R0,A.PT2
>
IFN $COB,<
MOVE R1,CURNAM+1
IDIVI R1,5 ;GET NUM OF WHOLE WORDS INTO R1
;JUST ASSUME NEED ONE MORE WORD FOR FRACT PART
COPI A.PT2,SYMLEN +1(R1) ;SYMLEN SIZE OF BLK EXCLU OF STRING
FUNCT ALCMEM,<A.PT2>
MOVEM R0,A.PT2
ADDI R0,SYMLEN ;START + NON-STRING-LEN=STRING ST. PT.
MOVEM R0,TMPNAM
FUNCT COPSTR,<VARY @TMPNAM,CURNAM> ;PUT IN THE PERM PLACE
MOVE R0,TMPNAM ;GET IT BACK TO ALTER CURNAM TO SAFE PLACE
HRLI R0,440700
MOVEM R0,CURNAM ;LENGTH IS OF COURSE CORRECT ALREADY
>
FUNCT UPDSYM,<SYMTAB,CURNAM,A.PT2>
CAIN SYMCOD,$IDENT ;IF REFFED SYMBOL, DON'T PUT IN TABLE
RETURN
;;; "SCHEMA" SHOULD PREVENT THIS FROM EVER OCCURRING
JUMPN R0,[FILERR (<DMLDUP##,CURNAM>,LEAVE)]
LD R0, RL,NMID,(CRU) ;ANY NMID WILL DO
MOVEM R0,A.TMP1
UTIL CNV.ZP
MOVE R1,A.PT2 ;PUT IN SYMBOL NODE
COPY SM.NMID(R1),TXTIDX
COPY SM.TYP(R1),SYMCOD
RETURN
$UTIL (CNV.ZP) ;ZEROPAD
FUNCT CNVSTR,<INT TXTIDX,A.TMP1,[12],[TOASCI+ZEROPA]>
RETURN
IFE $COB,< ;COBOL NO NEED FORTRAN DEFS
$UTIL (PUTDCL,<DATTYP,DIMEN>)
SKIPN PSUNYM
RETURN
COPI A.PT2,@DATTYP(AP)
COPI A.PT1,@DIMEN(AP)
;;; WAS THERE AN OCCURS CLAUSE
FUNCT VWRITE,<@A.PT2,CURNAM,@A.PT1>
;;; IS TIMES-OCCURS IF GT 0
JUMPG OCC,[
MOVEM OCC,A.TMP2
FUNCT CNVSTR,<SIZONL,A.TMP2,[12],[TOASCI+NOFILL]>
COPY A.TMP2,[ASCII/)/]
MOVE R1,A.PT1
MOVE R0,[ASCII/,/] ;PRESET FOR DIMEN-ED BLK CASE
;;; IF STRING'S LEN 0, JUST THE "OCCURS" DIMEN
SKIPN 1(R1)
MOVE R0,[ASCII/(/]
MOVEM R0,A.TMP1
JRST .+2]
JRST [HLLZS SIZONL+1 ;NOTE NO OCCURS
MOVE R1,A.PT1
;;; IDENT WILL BE UNDIM-ED IF THIS 0, SO SKIP VWRITE
SKIPN 1(R1)
JRST PD.CMN
COPY A.TMP2,[ASCII/)/]
JRST .+1]
FUNCT VWRITE,<ASZ A.TMP1,SIZONL,ASZ A.TMP2>
PD.CMN:
FUNCT VWRITE,<CRLF,STACMN,CURNAM,CRLF>
RETURN
>
IFN $COB,<
$UTIL (PUTDCL,<PICT,USAG>)
COPI A.PT2,@PICT(AP)
COPI A.PT1,@USAG(AP)
FUNCT VWRITE,<LEVNO,CURNAM>
SKIPE @A.PT2 ;NO PICTURE (DON'T PUT OUT KEYWORD PICTURE)
JRST [FUNCT VWRITE,<PICTUR,@A.PT2>
JRST .+1]
FUNCT VWRITE,<@A.PT1>
JUMPG OCC,[
MOVEM OCC,A.TMP1
FUNCT CNVSTR,<SIZONL,A.TMP1,[12],[TOASCI+NOFILL]>
FUNCT VWRITE,<OCCURS,SIZONL>
JRST .+1]
FUNCT VWRITE,<DOTCRLF>
RETURN
>
$UTIL (PUTBIND)
SKIPL INVSEE ;FOR ACCESS NO BIND CODE
RETURN
FUNCT OBJOUT,<SEP,CURNAM>
RETURN
SUBTTL SPECIAL STRING PROCESSING
REG(C1,R3) ;FOR VISUAL CLARITY
$UTIL (COPSIX,<DEST,SOURCE,LENMAX>)
MOVEI R1,@SOURCE(AP)
HRLI R1,440600 ;SET UP SOURCE BP
MOVE R0,@DEST(AP) ;IS 1ST WORD OF STRPTR
MOVE R4,@LENMAX(AP)
SETZM R2
SETZM DASH
COP.LP:
ILDB C1,R1
JUMPE C1,LEAVE
IFE $COB,<
CAIN C1,'-'
SETOM DASH
>
IFN $COB,< ;COBOL (UNBELIEVABLY) MAKES DASHES COLONS
CAIN C1,':'
JRST [SETOM DASH
MOVEI C1,'-'
JRST .+1]
>
ADDI C1,40
IDPB C1,R0
CAMGE R2,R4 ;MAXIMUM LEN OF SOURCE
AOJA R2,COP.LP
RETURN
$UTIL PARENAM,<DEST,SOURCE>
SETZM @DEST(AP) ;IN CASE REAL SHORT
MOVEI R0,@DEST(AP)
HRLI R0,440600
MOVEI R4,6
MOVEI R1,@SOURCE(AP) ;A STRING PTR
HRRZ R2,1(R1)
MOVE R1,0(R1)
PAR.LP:
ILDB C1,R1
CAIN C1,"-"
JRST PAR.E2
SUBI C1,40 ;ASC TO SIX
IDPB C1,R0
SOSLE R4
PAR.E2: SOJG R2,PAR.LP ;TWO CONDS: IS DEST FULL? IS SOURCE EXHAUSTED?
RETURN
SUBTTL DATA TYPE AND SIZE PROCESSING
DEFINE SETHOW<
IFN $COB,<
MOVEI R0,DL.STRING(CRU)
HRLI R0,440700
MOVEM R0,PICBP
LD R1, DL,NLEN,(CRU)
LD R0, DL,SLEN,(CRU)
ADD R1,R0
IBP PICBP
SOJG R1,.-1
LD R0, DL,PLEN,(CRU)
MOVEM R0,PICBP+1
>
IFE $COB,<
SETZM SIZTXT+1 ;;PRESET FOR NOT A STORAGE BLK
SKIPL PSUNYM
AOS UNDIDX ;IS NO PSUNYM, FOR NOW ASSUME ITEM 1 WORD LONG
>
>
$UTIL (DETDCL)
SETHOW
LD OCC, DL,OCC,(CRU) ;FOR OCCURS CLAUSE CHKING
SKIPE INVSEE ;[374]DO OCCURS ONLY FOR INVOKE -- NOT ACCESS
JUMPG OCC,[ ;NECES TO BIND TO SUBSCRIPTED QUAN?
FUNCT OBJOUT,<ELEM1> ;YES
JRST .+1]
LD R2, DL,SIZ,(CRU)
LD R1, DL,TYP,(CRU)
CAILE R1,DT.MAX ;NUM OF DT-1
DD.LDR:
DD.XBC:
DD.XDC:
DD.LDC:
OTSERR DMLSAF##,VOKFAIL
CASE R1,<DD.XBR,DD.LBR,DD.XDR,DD.LDR,DD.XBC,DD.LBC,DD.XDC,DD.LDC,DD.DBK,DD.D6,DD.D7,DD.D9>
IFN $COB,<
;;; HERE IS "SIZE" PHRASE
MOVEI R3,NULSTR ;[316] DEFAULT FOR STRUCTURES
LDB R0,[POINT 6,DL.OFF(CRU),11 ] ;[316] GET BYTE SIZE TO DETERMINE
;[316] USAGE MODE
CAIN R0,6 ;[316] SIXBIT ?
MOVEI R3,USD6 ;[316] YES, USAGE DISPLAY-6
CAIN R0,7 ;[316] ASCII ?
MOVEI R3,USD7 ;[316] YES, USAGE DISPLAY-7
CAIN R0,9 ;[316] EBCDIC ?
MOVEI R3,USD9 ;[316] YES, USAGE DISPLAY-9
UTIL PUTDCL,<ZERO,@R3> ;[316] PUT OUT NAME, OCCURS AND A POSSIBLE
;[316] USAGE MODE
RETURN
DD.XBR:
UTIL PUTDCL,<PICBP,USCOMP>
RETURN
DD.XDR: ;;; COMP-3 IS FIXED DEC REAL
UTIL PUTDCL,<PICBP,USCMP3>
RETURN
DD.LBR:
CAILE R2,1 ;IS IT REAL OR REAL*8
JRST DD.LBC ;TREAT LIKE COMPLEX
UTIL PUTDCL,<ZERO,USCMP1>
RETURN
DD.LBC: ;;; ENCODE F10 COMPLEX
UTIL PUTDCL,<PIC.DC,USCOMP> ;DOUBLE COMP=S9(18)
RETURN
DD.D6:
UTIL PUTDCL,<PICBP,USD6>
RETURN
DD.D7:
UTIL PUTDCL,<PICBP,USD7>
RETURN
DD.D9:
UTIL PUTDCL,<PICBP,USD9>
RETURN
DD.DBK:
UTIL PUTDCL,<ZERO,ALLKEY>
RETURN
>
IFE $COB,<
;;; PROCESS "SIZE" PHRASE ON FALL-THRU
LDB R0,[POINT 6,DL.OFF(CRU),11] ;GET SIZE BYTE
CAIN R0,^D36
MOVEI R1,1
CAIN R0,^D9
MOVEI R1,4
CAIN R0,7
MOVEI R1,5
CAIN R0,6
MOVEI R1,5 ;KEEP WITH CONVERSION POTENTIAL PHILOSOPHY
UTIL DISPSIZ
UTIL PUTDCL,<INTEG,SIZTXT>
RETURN
DD.XBR:
CAILE R2,1 ;DOUBLE PREC
JRST [UTIL PUTDCL,<INTEG,SIZE2> ;YES
RETURN()]
UTIL PUTDCL,<INTEG,NULSTR>
RETURN
DD.XDR: ;;; COBOL COMP-3
MOVEI R1,4 ;LIKE DISP-9
UTIL DISPSIZ
UTIL PUTDCL,<INTEG,SIZTXT>
RETURN
DD.LBR:
CAILE R2,1
JRST [UTIL PUTDCL,<REAL8,NULSTR>
RETURN()]
UTIL PUTDCL,<REAL,NULSTR>
RETURN
DD.LBC:
UTIL PUTDCL,<COMPLEX,NULSTR>
RETURN
DD.D6:
MOVEI R1,CPW
UTIL DISPSIZ
UTIL PUTDCL,<INTEG,SIZTXT>
RETURN
DD.D7:
MOVEI R1,CPW
UTIL DISPSIZ
UTIL PUTDCL,<INTEG,SIZTXT>
RETURN
DD.D9:
;;; EBCDIC IS 4 CHARS PER WORD
MOVEI R1,4
UTIL DISPSIZ
UTIL PUTDCL,<INTEG,SIZTXT>
RETURN
DD.DBK:
UTIL PUTDCL,<INTEG,NULSTR>
RETURN
$UTIL (DISPSIZ)
LD R2, DL,SIZ,(CRU)
IDIV R2,R1
SKIPE R3
ADDI R2,1 ;A REMAINDER MEANS NEED PART OF NXT WD
CAIG R2,1 ;SUBSCRIPT?
RETURN ;DON'T BOTHER WITH SHORT STRING
SKIPL PSUNYM
JRST [SKIPE OCC ;IF NO OCCURS, SIZE ALREADY OK
IMUL R2,OCC ;IF N BLKS SIZE IS OBV. BLKSIZ*HOW-MANY
ADDM R2,UNDIDX ;MAK UNDEF ARRAY BIGGER
SOS UNDIDX ;UNDO THE AOS AT TOP
RETURN]
MOVEM R2,A.TMP2
FUNCT CNVSTR,<SIZONL,A.TMP2,[12],[TOASCI+NOFILL]>
HRRZ R0,SIZONL+1 ;INCLUDE "(" BY PROP SUBSUM SIZONL UNDER SIZTXT
ADDI R0,1
MOVEM R0,SIZTXT+1
RETURN
> ;END IFE $COB
END