Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
cobol-source/dmlvok.mac
There are 22 other files named dmlvok.mac in the archive. Click here to see a list.
; UPD ID= 1502 on 1/22/84 at 11:46 PM by MAGRATH
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
;EDITS
;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
;;; 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) ;[6%42] 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) ;[6%36] 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 > ;[6%42] 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 ;[%317] 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 ;[6%36]
YOYO OTHNAMES ;[6%36] RESOLVE JNBUF IF DATANAME
VOKDON:
; GENERATE INDEXES FOR AREAS
FUNCT FIND3%,<KEY NEXT,ZERO,[$S.A],KEY SET>
JUMPE R0,VD.XIT ;[6%18] YES, NOW DO TRANSACTIONS
MOVEM R1,CRU
TDNN BMASK,AL.SS(CRU) ;IN SUB-SCHEMA?
JRST VOKDON ;NO
YOYO NBUFDN ;[6%36] RESOLVE AL.NBUF=DATANAME
UTIL SYMALC,<VARY AL.NAM(CRU)>
JRST VOKDON
;[6%36] BEGIN
VD.XIT: SKIPGE INVSEE ;[6%352] ACCESS OR INVOKE?
SKIPN VOKFLG ; FINISH BUF DATANAME BIND
JRST VOK.TR ; ACCESS OR DO NOTHING
FUNCT OBJFLUSH ; THE FINAL ")"
;[6%36] END
VOK.TR: ;[6%18]
;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 ;[6%23] 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>
; YOYO OTHNAMES ;[6%23] PUT OTH D-N'S OUT NOW
JRST ROLOOP]
UTIL SYMALC,<VARY RL.NAM(CRU)>
IFN $COB,<
DCOPY CURREC,CURNAM ;[6%42] 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) ;[6%23]
; *** [6%23] ADD CODE TO 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
;[6%36] BEGIN
$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
;[6%36] END
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 ;[6%42] 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,< ;[6%42] Only qualify COBOL references
FUNCT OBJOUT,<SEP,CURNAM>
> ;[6%42] End IFN
IFN $COB,< ;[6%42] Qualify COBOL references
FUNCT OBJOUT,<SEP> ;[6%42] Seperate the data-names
FUNCT OBJCNTN ;[6%42] Each data-name on own line
FUNCT OBJOUT,<CURNAM> ;[6%42] Data-name
SKIPN CURREC ;[6%42] Qualifier specified?
JRST PUTBEX ;[6%42] ...No, go exit
FUNCT OBJOUT,<QUALIF,CURREC> ;[6%42] ...Yes, put it out
PUTBEX:
> ;[6%42] 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 ;[%374] 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 ;[%316] DEFAULT FOR STRUCTURES
LDB R0,[POINT 6,DL.OFF(CRU),11] ;[%316] GET BYTE SIZE TO DETERMINE USAGE MODE
CAIN R0,6 ;[%316] SIXBIT?
COPI R3,USD6 ;[%316] YES
CAIN R0,7 ;[%316] NO, ASCII?
COPI R3,USD7 ;[%316] YES
CAIN R0,^D8 ;[%316] NO, EBCDIC?
COPI R3,USD9 ;[%316] YES
UTIL PUTDCL,<ZERO,@R3> ;[%316] PUT OUT NAME, OCCURS,
RETURN ;[%316] ...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 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 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