TITLE DMLVOK

	SEARCH COPYRT
	SALL

;     This software is furnished under a license and may only be used
;       or copied in accordance with the terms of such license.

COPYRIGHT (C) 1974, 1984 BY DIGITAL EQUIPMENT COPRORATION, MAYNARD, MASS.

; *******************************************************************
; NOTE!!! This module is shared by the COBOL and DBMS products. Any
; modification by either group should be immediately reflected in the
; copy of the other group.
; *******************************************************************

; ****
;Append TOPS20==0 to beginning of module for COBOL68/74-12B
; ****


	SEARCH GENDCL,DMLSYM,STRING,DBSDCL
	SEGMEN

	IFNDEF $COB,<$COB==0>		;DEFAULT FOR FORTRAN

	;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>>

	IFN $COB,<SEARCH P>

	IFNDEF TOPS20,<TOPS20==0>

	.COPYRIGHT		;Put standard copyright statement in REL file


	ENTRY DMLVOK,VOKINI

	;;;	MODULE REGS
	MREG(BMASK,6)
	MREG(CRU,7)			;CUR BLK OF RUN-UNIT
	MREG(OCC)			;FOR OCCURS
	MREG(SYMCOD)
	MREG(KEYTYP)			;[1114] VIA KEY TYPE FOR ALIAS CHECK

	; 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(CURREC,2)			;Ptr to current qualifier
	>

	IFE $COB,<			; [1101] 
	DATA(CHRTMP)			; [1101] tmp flag for chr data
	>				; [1101]
	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)
	DATA(VOKFLG)			;SET ON FIRST BIND OF BUF DATA-NAME
	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
ASTRSK:	POINT	7,[ASCII/*/]		; [1101] used in VAR*N clause
	1				; [1101] only one character long

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

	; [1101] SYSCOC is the character data top half of SYSCOM

	STRIVRY	(SYSCOC,<	INTEGER SYSCOM(44),ERCNT,ERSTAT
	CHARACTER *30 ERAREA,ERREC,ERSET,RECNAM,ARNAM
>)

	; [1101] SYSCOI is the integer SYSCOM

	STRIVRY	(SYSCOI,<	INTEGER SYSCOM(44),ERCNT,ERSTAT
	INTEGER ERAREA(6),ERREC(6),ERSET(6),RECNAM(6),ARNAM(6)
>)

	; [1101] SYSCOM is the rest of it...

	STRIVRY	(SYSCOM,<	INTEGER DBKEY,ERDATA
	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),
	1 (SYSCOM(33),DBKEY),
	1 (SYSCOM(34),ERDATA)
>)

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 >
CHRTXT:	STRIPT	<	CHARACTER >	; [1101] for fortran 77
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>
SIZE30:	STRIPT	<30>			;[1101] Area-ID size for /CHARACTER
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.
02	DATA-BASE-KEY	USAGE DBKEY.
02	ERROR-DATA	PIC 9(10) 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.CP:	STRIPT	<S9(10)>
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).
>
QUALIF:	STRIPT	< OF >			;Sep. for qualified datanames

>				;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,A.TMP1> ;A.TMP1 DUMMY 
						 ; FOR RET'D VAL
	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>
	IFN	$COB,<
	FUNCT	OBJCNTN			;COBOL CONTINUATION BUG
	>;END IFN $COB
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
		 USRERS	(DMLBDK##,VOKFAIL) ;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,[USRERR	(DMLBDK##,VOKFAIL)]
		 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>
	SETOM	CHRTMP			; [1101] set char indic to false
	SKIPG	CHRFLG			; [1101] using fortran 77 char stuff?
	JRST	[FUNCT VWRITE,<VARY SYSCOI> ; [1101] /NOCHARACTER spec'd or
					    ; defaulted
		JRST .+2]		; [1101] go write rest of SYSCOM
	JRST	[FUNCT VWRITE,<VARY SYSCOC> ; [1101] /CHARACTER spec'd or
					    ; defaulted
		JRST .+1]		; [1101] go write rest of SYSCOM
	FUNCT	VWRITE,<VARY SYSCOM>	; [1101] put out rest of SYSCOM
	>

	IFN	$COB,<FUNCT	VWRITE,<VARY SYSCOM>> ; [1101]no choice if cobol

	UTIL	RECWALK			;WRITE OUT INDIV NAMES

					;[1117]
	SETZM	VOKFLG
	YOYO	OTHNAMES		;RESOLVE JNBUF IF DATANAME

VOKDON:
	; GENERATE INDEXES FOR AREAS
	FUNCT	FIND3%,<KEY NEXT,ZERO,[$S.A],KEY SET>
	JUMPE	R0,VD.XIT		;YES, NOW DO TRANSACTIONS
	MOVEM	R1,CRU
	TDNN	BMASK,AL.SS(CRU)	;IN SUB-SCHEMA?
	JRST	VOKDON			;NO
	YOYO	NBUFDN			;RESOLVE AL.NBUF=DATANAME
	UTIL	SYMALC,<VARY AL.NAM(CRU)>
	JRST	VOKDON

VD.XIT:	SKIPGE	INVSEE			;ACCESS OR INVOKE?
	SKIPN	VOKFLG			; FINISH BUF DATANAME BIND
	JRST	VOK.TR			; ACCESS OR DO NOTHING
	FUNCT	OBJFLUSH		; THE FINAL ")"

VOK.TR:
	;NOW GENERATE INDICES FOR TRANSACTIONS
	FUNCT	FIND3%,<KEY NEXT,ZERO,[$S.E],KEY SET> ;GET NEXT EB BLK
	JUMPE	R0,VOK.D1			      ;...DONE
	MOVEM	R1,CRU
	TDNN	BMASK,EL.SS(CRU)	;IN SS?
	JRST	VOK.TR			;...NO
	UTIL	SYMALC,<VARY EL.NAM(CRU)>
	JRST	VOK.TR


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>
IFE $COB,<				;FORDML CASE
	RELEAS VOKCHN,
>;END $COB

IFN $COB,<				;COBOL CASE
  IFE TOPS20,<				;12B SAME AS FORDML
	RELEAS VOKCHN,
  >;END TOPS20
>;END $COB

	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
	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	R0,R2			;SAVE TEMPORARILY
	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)>
IFN $COB,<
	DCOPY	CURREC,CURNAM		;Save qualifier name
>
	;;;	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>
	JUMPE	CRU,RD.EN2		;[1101] Skip if no Area-ID
	UTIL	REFGET			;[1101] Get symbol
	JUMPN	R0,RD.EN2		;[1101] DON'T REDCL--DUPLIC OR NO PSUNYM
	MOVE	OCC,ZERO		;[1101] Do HOWPUT by hand to allow
					;[1101] for /CHARACTER in FORTRAN

	IFN $COB,<			;[1101] COBOL specific
	UTIL	PUTDCL,<PICX30,USD7,ZERO> ;[1101]
	>; END IFN $COB			;[1101]

	IFE $COB,<			;[1101] FORTRAN specific
	SKIPN	CHRFLG			;[1101] If not /CHARACTER
	JRST	RD.EN1			;[1101] Use INTEGER declaration
	SETZM	CHRTMP			;[1101] Mark as character type
	UTIL	PUTDCL,<CHRTXT,SIZE30,ZERO> ;[1101] CHARACTER *30
	JRST	RD.EN2			;[1101] Return to common code
RD.EN1:	UTIL	PUTDCL,<INTEG,SIZE6,ZERO> ;[1101] INTEGER (6)
	>; END IFE $COB			;[1101]

RD.EN2:	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
	LD	KEYTYP,VL,TYP,(R1)	;[1114] NEED KEY TYPE FOR LATER TEST
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

	;[1114] SINCE THE CL FOR A DIRECT KEY ALIAS IS NOT A MEMBER OF A DC
	;[1114]  SET, THE FIND3% WILL NOT HAVE UPDATED DC SET CURR, SO 
	;[1114]  HANDLE THE DBKEY ALIAS CHECK MANUALLY
	CAIN	KEYTYP,VIA.DIR		;[1114] IF ALIAS OF DIRECT KEY
	JRST	[HOWPUT	<INTEG,NULSTR>,<ZERO,ALLKEY>,ZERO ;[1114] USAGE DBKEY
		 JRST	ALIAS4]		;[1114]

	FUNCT	(FIND4%,<[$D.C],KEY SET>) ;SUPPR SET UPDATES
	OTSERR	DMLSAF##,VOKFAIL	;[1114] MUST BE A DATA BLK
	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

$YOYO	(OTHNAMES)
	; ***	GENERATE DATA ITEM FOR JOURNAL BUFFERS
	; ***	BEFORE THE RECORD DEFINITIONS AND BIND IT.
	FUNCT	FINDR%			;GET BACK TO SL
	OTSERR	(<DMLNSB##>,VOKFAIL)
	SKIPG	CRU,SL.JNBUF(R1)	;WILL BE POS IF IS KEY OF IL
	JRST	OTH.X			;NO, VALUE, HANDLED BY BIND
	SKIPGE	INVSEE			;[1117] NO BIND IF ACCESS
	SKIPE	VOKFLG			; ONLY ONE BIND STA FOR ALL BUF DN'S
	JRST	OTH.1
	FUNCT	OBJOUT,<STABIND,MLIT 00000>
	SETOM	VOKFLG			; REMEMBER
OTH.1:
	UTIL	REFGET
	HOWPUT	<INTEG,NULSTR>,<PIC.CP,USCOMP>,ZERO
OTH.X:
	RETURN

$YOYO	(NBUFDN)
; 	BIND THE (BUFFER SIZE IS) DATANAME
	SAVE	<CRU>
	SKIPN	AL.DNBUF(CRU)		; GET POSSIBLE DBK
	JRST	NBXIT			; LOOP - NOT A DBK
	SKIPGE	INVSEE			;[1117] NO BIND IF ACCESS
	SKIPE	VOKFLG			; ONLY ONE BIND STA FOR ALL BUF DN'S
	JRST	NB001
	FUNCT	OBJOUT,<STABIND,MLIT 00000,SEP,Q,AZERO,Q>
	SETOM	VOKFLG			; REMEMBER
NB001:	LD	CRU,AL,DNBUF,(CRU)	; RESTORE NBUF DBK
	UTIL	REFGET			; PUT OUT SEP AND DATANAME
	HOWPUT	<INTEG,NULSTR>,<PIC.CP,USCOMP>,ZERO
NBXIT:	RESTOR	<CRU>
	RETURN


	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
IFN	$COB,<
	SETZM	CURREC			;Don't qualify alias, etc.
>
	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>)

	; [1101] note that A.PT1==A.TMP1 and A.PT2==A.TMP2
	; [1101] in this module.  Their global definitions,
	; [1101] however, are different.

	SKIPN	PSUNYM
	JRST	[SETOM	CHRTMP		; [1101] reset char flag
		RETURN]			; [1101]
	COPI	A.PT2,@DATTYP(AP)
	COPI	A.PT1,@DIMEN(AP)

	MOVE	R1,CHRTMP		; [1101] is this a char type var?
	JUMPE	R1,[			; [1101] yes...
		SETOM	CHRTMP		; [1101] don't use it twice
		SAVE	<A.PT1>		; [1101] save size
		COPI	A.PT1,ASTRSK	; [1101] use string delimiter
		FUNCT	VWRITE,<@A.PT2,@A.PT1> ; [1101] put out type *
		RESTOR	<A.PT1>		; [1101] get back size
		FUNCT	VWRITE,<@A.PT1>	; [1101] and write it

		; [1101] put a space followed by name

		COPY	A.PT1,[ASCII/ /] ; [1101] get a space
		FUNCT	VWRITE,<ASZ A.PT1,CURNAME> ; [1101] write it out

		; [1101] occurs clause?

		SKIPN	R0,OCC		; [1101] OCC contains times-occurs
		JRST	PD.CMN		; [1101] no, go exit

		MOVEM	OCC,A.TMP2	; [1101] yes...process it

		; [1101] get size of occurs into ascii

		FUNCT	CNVSTR,<SIZONL,A.TMP2,[12],[TOASCI+NOFILL]> ; [1101] 
		COPY	A.PT2,[ASCII/)/] ; [1101] surround by parens
		MOVE	R0,[ASCII/(/]	; [1101] 
		MOVEM	R0,A.PT1	; [1101] 
		FUNCT	VWRITE,<ASZ A.PT1,SIZONL,ASZ A.PT2> ; [1101] write it
		JRST	PD.CMN]		; [1101] go to common exit

	; [1101] here if NON-CHARACTER DATA

	; [1101] about to write TYPE followed by NAME followed by "(".
	; [1101] The actual process is to have A.PT1 pointing to the
	; [1101] string "(NNN" where NNN is the size of the var.
	; [1101] If the var is one-dimensional, A.PT1+1 will contain
	; [1101] zero so that no left paren is written.

	FUNCT	VWRITE,<@A.PT2,CURNAM,@A.PT1>

	;;;	WAS THERE AN OCCURS CLAUSE?
	;;;	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
IFE $COB,<				;Only qualify COBOL references
	FUNCT	OBJOUT,<SEP,CURNAM>
>					;End IFN
IFN $COB,<				;Qualify COBOL references
	FUNCT	OBJOUT,<SEP>		;Seperate the data-names
	FUNCT	OBJCNTN			;Each data-name on own line
	FUNCT	OBJOUT,<CURNAM>		;Data-name
	SKIPN	CURREC			;Qualifier specified?
	JRST	PUTBEX			;...No, go exit
	FUNCT	OBJOUT,<QUALIF,CURREC>	;...Yes, put it out
PUTBEX:
>					;End IFN
	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			;DON'T PROCESS OCCURS FOR 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
	COPI	R3,NULSTR		;DEFAULT FOR STRUCTURES
	LDB	R0,[POINT 6,DL.OFF(CRU),11] ;GET BYTE SIZE TO DETERMINE
					    ; USAGE MODE
	CAIN	R0,6			    ;SIXBIT?
	COPI	R3,USD6			    ;YES
	CAIN	R0,7			    ;NO, ASCII?
	COPI	R3,USD7			    ;YES
	CAIN	R0,^D8			    ;NO, EBCDIC?
	COPI	R3,USD9			    ;YES
	UTIL	PUTDCL,<ZERO,@R3>	    ;PUT OUT NAME, OCCURS,
	RETURN				    ;...AND A POSSIBLE USAGE MODE

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
	SKIPE	CHRFLG			; [1101] using char data stuff?
	CAIE	R0,7			; [1101] is this display 7?
	SKIPA				; [1101]	
	JRST	DD.CH			; [1101] use char data handler
	UTIL	DISPSIZ			; [1101] determine size
	UTIL	PUTDCL,<INTEG,SIZTXT>	; [1101] write it
	RETURN				; [1101] 

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:
	MOVE	R1,CHRFLG		; [1101] did he specify or default
					; [1101] character text?
	JUMPG	R1,DD.CH		; [1101] if so, process as character
	MOVEI	R1,CPW			; [1101] set up for dispsiz
	UTIL	DISPSIZ			; [1101] set up sizes
	UTIL	PUTDCL,<INTEG,SIZTXT>	; [1101] else proceed normally
	RETURN				; [1101] 

DD.CH:	SETZM	CHRTMP			; [1101] flag as character for later
	LD	R2, DL,SIZ,(CRU)	; [1101] get size
	MOVEM	R2,A.TMP2		; [1101] 

	; [1101] put size in ascii into SIZONL

	FUNCT	CNVSTR,<SIZONL,A.TMP2,[12],[TOASCI+NOFILL]> ; [1101] 
	UTIL	PUTDCL,<CHRTXT,SIZONL>	; [1101] put out CHARACTER instead
					; [1101] of INTEGER
	RETURN				; [1101] 

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