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, 1981 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