* Module: Memlist (Rexx external function) * * Function: Generate variables member.1 ... Member.N which * Contain the member names in a pds * * Also generates a message in variable result or as the * output of a function call. * * Also generates return codes. * * * * Syntax: * Call memlist dsname * Or xxx = Memlist(dsname) * * Where dsname is in quotes if fully qualified, * or has a prefix (If any) appended to it if it is not. * If not in tso, it acts as tso with no prefix. * The name is case in-Sensitive. * * Language: Pl/X * * Dependencies: Sys1.Xxx libs, and alloc99 macro from mvstools * * * Return codes and result messages: * * 0 - OK * 16 - TOO MANY PARAMETERS * 20 - INVALID DATASET NAME SUPPLIED * 24 - DATASET ALLOCATION OR OPEN ERROR * 28 - SYNAD ERROR READING DIRECTORY * 32 - DATASET MAY NOT BE PARTITIONED * * * Author: * * Doug Nadel (nadel@us.ibm.com) * * Change history: * 6/3/92 - Initial program * 6/15/00- Added 31 bit I/O and moved it above the line * * * ****************************************************************** * Test proc ( Must have rexx in comment on first line) * * /* Rexx */ Trace off * * Call try 'nadel.Private.Pls' /* Add prefix -- Error */ * Call try private.Obj /* Add prefix*/ * Call try '''nadel.Private.Obj''' /* In quotes */ * Call try '''nadel.Snerkly''' /* Not found */ * Call try memlist.Plist /* Sequential*/ * Say copies('-',78) * say memlist(too,many) /* Parm error*/ * Exit * try: * Parse arg ds * say copies('-',78) * say ds * call memlist ds * c='' * If rc=0 Then * Do * Say 'return code was 'rc'. ---> '||, * Member.0' names returned.' * Do a = 1 To member.0 * C = C||Left(member.A,10) * if length(c)>66 Then * Do * Say c * c='' * End * End * if c¬='' then say c * End * Else * Say 'return code was 'rc'. ---> 'result * Return * * ****************************************************************** * *memlist: * proc (p1,p2,p3,p4,efplparm,evalparm) options(amode(31),rmode(any), * reentrant,autodata(loc(below))); *@list off; *%INCLUDE syslib(cvt); *%INCLUDE syslib(ikjtcb ); *%INCLUDE syslib(ikjpscb); *%INCLUDE syslib(iezjscb); *%INCLUDE syslib(ikjupt); *%INCLUDE syslib(irxshvb); *%INCLUDE syslib(irxevalb); *%INCLUDE syslib(ihadcbe); * %declare * s99base2 character external; * %s99base2 = 'BASED'; *%INCLUDE syslib(iefzb4d0); *%INCLUDE syslib(iefzb4d2); * ?alloc99 declares; *@list on; *@list on; * dcl * 1 efplparm(*), /* Input parms */ * 3 parma ptr, /* Parm address */ * 3 parml fixed, /* Parm length */ * evalparm ptr(31); /* Ptr to eval block */ * dcl * dataset char(46), /* 44+2 For quotes */ * tempdataset char(44), /* Area for dsname resolution */ * cvtptr ptr(31) location(16), /* Pointer to cvt */ * pscbptr ptr(31), /* Pointer to pscb */ * uptptr ptr(31), /* Pointer to upt */ * tcbptr ptr(31), /* Pointer to tcb */ * memlistrc fixed, /* Retcode from routine */ * spfctnw char(8) boundary(dword), /* Work area for conversion */ * spfctnx char(16), /* Work area for conversion */ * staticdcb char(96) local static gend, /* Dcb for dataset */ * autodcb char(96), /* Dcb in auto storage */ * staticdcbe char(56) local static gend, /* Dcbe for dataset */ * autodcbe char(56), /* Dcbe in auto storage */ * count fixed, /* Count of found members */ * userarea char(256), /* Work area for svc 99 macro */ * 1 dsorg bit(16) based(dsorgp), /* Dsorg returned by svc99*/ * 3 * bit(6), * 3 dsorgpo bit(1), /* On means it is partitioned */ * dsorgp ptr(31), /* Pointer set by svc 99 macro */ * i fixed, /* General counter */ * 1 dirblk based(dirp), /* Directory block declares */ * 2 dirblksz fixed(15), /* Dir blk size */ * 2 dirents char(254), /* Dir block entries */ * direntp ptr(31), * 1 dirent based(direntp), /* Directory entry declares */ * 2 dirname char(8), /* Member name */ * 2 dirttr char(3), /* Ttr (Rel track-Record) */ * 2 dirc bit(8), /* Status byte */ * 3 dirca bit(1), /* Alias indicator */ * 3 dircnt bit(2), /* Number rel ttrn"S */ * 3 dircudl bit(5), /* Number user hwords */ * 2 dirud char(*), /* User area */ * dirlength bit(8), /* Work space to calculate * directoru entry length */ * entend ptr(31), /* Pointer to end of the dir * block */ * ddname char(8), /* System generated ddname */ * ddnamep ptr(31), /* Pointer set by svc 99 */ * dirp ptr(31), /* Pointer within dir block */ * dircount ptr(31), /* Count of dirblocks */ * prefix char(8), /* Tso prefix */ * dirblock char(256) based(dirp), /* Mapping of directorey block */ * varname char(16), /* Var name for rexx store */ * varnum char(8) bdy(dword), /* Conversion area */ * eom bit(1), /* End of member list scan */ * r0save ptr(31), /* Original register zero (R0) */ * shvblockp ptr(31), /* Ptr to local shvblock */ * shvbasep ptr(31), /* Ptr to local shvblock chain */ * shvcount fixed, /* Shv block counter */ * 1 struc(32*dim(dirblocks)) bdy(dword) based(shvbasep), * 3 lclshv char(length(shvblock)), * 3 varnames char(16), * 1 dblks based(dirblocksp), * 3 dirblocks(50) char(256), * dirblocksp ptr(31), * staticopenin bdy(dword) char(8) gend static local, * staticclosin bdy(dword) char(8) gend static local, * openin bdy(dword) char(8), * closin bdy(dword) char(8), * emcomp ptr(31), /* Pointer to module irxemcom */ * emcom internal entry based(emcomp) valrg(*) options(vlist); * * /*****************************************************************/ * /* */ * /* Declare the dcb, registers, and other misc stuff */ * /* */ * /*****************************************************************/ * * declare /* */ * 1 dcb based, /* Data control block */ * 3 dcbdcbe ptr(31), /* dcbe address */ * 3 * char(28), /* Dasd interface */ * 3 dcbfex, /* Foundation extension */ * 5 * char(1), /* */ * 5 dcbeodad ptr(24), /* End of data address */ * 5 * char(4), /* End of data address */ * 3 dcbfndbo, /* Foundation sgmnt before open */ * 5 dcbddnam char(8), /* Dd name */ * 5 dcboflgs bit(8), /* Flags used by open routine */ * 7 * bit(3), /* */ * 7 dcbopen bit(1), /* Dcb opened successfully */ * 5 * bit(24), /* */ * 3 dcbaccm, /* Access method interface */ * 5 * char(5), /* */ * 5 dcbsynad ptr(24), /* Addr of user synad routine */ * 5 * char(28), /* */ * r0 reg(0) pointer(31), /* Register definitions */ * r1 reg(1) pointer(31), * r2 reg(2) pointer(31), * r3 reg(3) pointer(31), * r14 reg(14) pointer(31), * r15 reg(15) pointer(31), * on bit(1) constant('1'B), /* Test or set switch on */ * off bit(1) constant('0'B), /* Test or set switch off */ * parray(*) ptr(31) based, /* Any pointer array */ * chars character(*) based; /* Any character string */ * GEN DATA DEFS (STATICDCB,staticdcbe,staticopenin,staticclosin); * DS 0D *STATICDCB DCB DSORG=PS,MACRF=(GL),DCBE=STATICDCBE,BLKSIZE=256, C * LRECL=256,RECFM=FB *STATICDCBE DCBE RMODE31=BUFF *STATICOPENIN OPEN (,),MF=L,MODE=31 *STATICCLOSIN CLOSE (,),MF=L,MODE=31 *@ENDGEN; * rfy * tcb based(cvttcbp->parray(1)), * pscb based(jscbpscb), * upt based(pscbupt), * shvblock based(shvblockp), * evalblock based(evalparm), * dcb based(addr(autodcb)), * dcbe based(addr(autodcbe)), * (r0, * r1, * r14, * r15) rstd; * * /*****************************************************************/ * /* */ * /* Setup */ * /* */ * /*****************************************************************/ * * autodcb = staticdcb; /* Get dcb template */ * autodcbe = staticdcbe; /* Get dcbe template */ * dcbdcbe = addr(autodcbe); * openin = staticopenin; * closin = staticclosin; * r0save = r0; * dircount = 1; /* Use 1st area for dirblock */ * dataset = ''; /* Assume no dataset name given */ * ddnamep = 0; /* Assume no sys gend dd */ * shvcount = 0; * memlistrc = 0; /* Assume no other errors */ * count = 0; /* No members yet */ * eom = off; /* Member list read not complete */ * prefix(1) = ' '; /* Assume no tso prefix */ * if jscbpscb then * if pscbupt then * if uptprefl then /* If user has a tso prefix */ * prefix = uptprefx(1:uptprefl); /* Get tso prefix */ * * /*****************************************************************/ * /* */ * /* Start of mainline code */ * /* */ * /*****************************************************************/ * * r0 = length(struc) * dim(struc) + length(dblks); * GEN SETS (R1,R0,R14,R15) REFS (R0) (GETMAIN RU,LV=(0),LOC=BELOW); * shvblockp = r1; * shvbasep = r1; * dirblocksp = r1 + length(struc) * dim(struc); * GEN SETS (R1,R0,R14,R15) (LOAD EP=IRXEXCOM); /* LOAD IRXEXCOM */ * emcomp = r0; /* Save address for later calls */ * * /*****************************************************************/ * /* */ * /* Drop member. To clear the whole stem variable */ * /* */ * /*****************************************************************/ * * shvblock = ''B; * shvcode = shvdropv; /* Drop variable */ * shvnaml = 7; /* Name length */ * shvnama = addr('MEMBER.'); /* Variable name (Stem) */ * r0 = r0save; * call emcom('IRXEXCOM',0,0,shvbasep->shvblock); * * /*****************************************************************/ * /* */ * /* Get data set name using tso conventions. */ * /* */ * /*****************************************************************/ * * if parma(1) ¬= 'FFFFFFFF'X & parma(2) ¬= 'FFFFFFFF'X then * memlistrc = 16; /* Too many parms */ * if memlistrc = 0 & /* No error yet */ * parma(1) ¬= 'FFFFFFFF'X & parml(1) <= length(dataset) & parml(1) * > 0 then * do; * dataset = parma(1) -> chars(1:parml(1)); * dataset = translate(dataset, /* Upper case data set name */ * 'ABCDEFGHIJKLMNOPQRSTUVWXYZ','abcdefghijklmnopqrstuvwxyz'); * if dataset(1) = '''' then /* If fully qualified */ * do; /* Set dataset for svc 99 */ * mvc(dataset(1::44),dataset(2::44)); /* Remove left quote */ * i = index(dataset,''''); /* Find right quote */ * if i > 0 then /* If a trailing quote exists */ * dataset(i) = ' '; /* Remove right quote */ * end; * else /* Must add prefix */ * if prefix(1) ¬= ' ' then /* If prefix exists */ * do; * tempdataset = ''; /* Start with blank */ * tempdataset = prefix; * tempdataset(uptprefl+1) = '.'; /* Add dot */ * tempdataset(uptprefl+2:length(tempdataset)) = dataset; * dataset = tempdataset; /* Save over original */ * end; * * /*************************************************************/ * /* */ * /* Check dsorg and allocate it to a system defined ddname; */ * /* */ * /*************************************************************/ * * ?alloc99 alloc returndd(ddnamep) shr da(dataset) run(memlistrc) * returnorg(dsorgp); * if ddnamep then /* If ddname returned */ * ddname = ddnamep -> chars(1:8); /* Save for later free */ * if memlistrc > 0 then * memlistrc = 24; /* Allocation error */ * else * if dsorgpo = off then /* If svc 99 says not partitioned*/ * memlistrc = 32; /* Dataset not partitioned */ * else * do; * ?alloc99 alloc file(ddname) reuse shr da(dataset) run( * memlistrc) input dsorg(ps) lrecl(255) blksize(255) * recfm(fb) bufno(8); * if memlistrc then * memlistrc = 24; * end; * * /*************************************************************/ * /* */ * /* Open the dcb and read the member list */ * /* */ * /*************************************************************/ * * rfy * (r2) rstd; * r2 = addr(dcb); * dcbddnam = ddname; * if memlistrc = 0 then * GEN REFS (R2) SETS (R0,R1,R14,R15) * (OPEN ((2),INPUT),MODE=31,MF=(E,OPENIN)); /* OPEN DCB */ * rfy * r2; * if memlistrc = 0 then * if dcbopen = on then * do until(eom); * dcbesyna = addr(inpsyn); * dcbeeoda = addr(inpeod); * r1 = addr(dcb); * rfy * r2 rstd, * r3 rstd; * GEN FLOWS (INPSYN,INPEOD) SETS (R0,R1,R3,R14,R15) REFS ( * R1); * GET (1) GET NEXT DIRECTORY BLOCK *@ENDGEN; * rfy * (r2, * r3); * dirblocks(dircount) = r1 -> dirblock; * dirp = addr(dirblocks(dircount)); /* Get address of * directory block */ * dircount = dircount + 1; * direntp = dirp + 2; /* Point to 1st entry */ * entend = dirp + dirblksz - 1; /* Point past last entry */ * if dirblksz & ¬ eom then /* If entries to be read */ * do while(eom=off&direntp= dim(dirblocks) then * do; * r0 = r0save; * call emcom('IRXEXCOM',0,0,shvbasep->shvblock); * shvcount = 0; * shvblockp = shvbasep; * dircount = 1; /* Point back to 1st dirblock */ * end; * end; * else /* Set alloc or open error */ * memlistrc = 24; /* Alloc or open error */ * goto close_label; * * /*************************************************************/ * /* */ * /* End of read loop */ * /* */ * /*************************************************************/ * *inpsyn: /* Synad exit point */ * rfy * (r3) rstd; * r3 = addr(a312) | '80000000'X; * bsm(r3,r0); *a312: * memlistrc = 28; /* Indicate a synad error */ *inpeod: /* End of data exit point */ * r3 = addr(close_label) | '80000000'X; * bsm(r3,r0); * rfy * (r3); *close_label: * if dcbopen = on then * do; * rfy * r2 rstd; * r2 = addr(dcb); * GEN REFS (R2) (CLOSE ((2)),MF=(E,CLOSIN),MODE=31); * rfy * r2; * if shvcount then * do; * r0 = r0save; * call emcom('IRXEXCOM',0,0,shvbasep->shvblock); * shvcount = 0; * end; * shvblockp = shvbasep; /* Use 1st block here */ * shvblock = ''B; /* Write member.0 (Total count) */ * cvd(count,spfctnw); /* Only if dcb was opened */ * unpk(spfctnx,spfctnw); * spfctnx(16) = spfctnx(16) | 'F0'X; * varnum = spfctnx(17-length(varnum):16); * i = verify(varnum,'0'); * if i = 0 then * i = 8; * varname = ''; * varname(1::9-i) = varnum(i::9-i); * varnum = varname(1::9-i); * shvcode = shvstore; * shvnaml = 8; * shvnama = addr('MEMBER.0'); * shvvala = addr(varnum); * shvvall = 9 - i; * r0 = r0save; * call emcom('IRXEXCOM',0,0,shvblock); * end; * end; * else /* Parameter error */ * if memlistrc = 0 then /* No code yet */ * memlistrc = 20; /* Invalid dsname supplied */ * if ddnamep then * do; * ?alloc99 free file(ddname) run; * end; * * /*****************************************************************/ * /* */ * /* Create rexx variable rc from local variable memlistrc */ * /* */ * /*****************************************************************/ * * shvblockp = shvbasep; /* Use 1st block here */ * shvblock = ''B; * cvd(memlistrc,spfctnw); * unpk(spfctnx,spfctnw); * spfctnx(16) = spfctnx(16) | 'F0'X; * varnum = spfctnx(17-length(varnum):16); * i = verify(varnum,'0'); * if i = 0 then * i = 8; * varname = ''; * varname(1::9-i) = varnum(i::9-i); * varnum = varname(1::9-i); * shvcode = shvstore; * shvnaml = 2; * shvnama = addr('RC'); * shvvala = addr(varnum); * shvvall = 9 - i; * r0 = r0save; * call emcom('IRXEXCOM',0,0,shvblock); * GEN(DELETE EP=IRXEXCOM); /* REMOVE IRXEXCOM FROM STORAGE */ * r1 = shvbasep; * r0 = length(struc) * dim(struc) + length(dblks); * GEN(FREEMAIN RU,LV=(0),A=(1)); * rfy * (r0, * r1, * r14, * r15); * * /*****************************************************************/ * /* */ * /* Set variable 'result' or function return */ * /* */ * /*****************************************************************/ * * select (memlistrc); * when (0) * do; * evalblock_evlen = 2; /* Set result to 'ok' */ * evalblock_evdata(1:2) = 'OK'; * end; * when (16) * do; * evalblock_evlen = 19; * evalblock_evdata(1:24) = 'TOO MANY PARAMETERS'; * end; * when (20) * do; * evalblock_evlen = 29; * evalblock_evdata(1:29) = 'INVALID DATASET NAME SUPPLIED'; * end; * when (24) * do; * evalblock_evlen = 32; * evalblock_evdata(1:32) = 'DATASET ALLOCATION OR OPEN ERROR'; * end; * when (28) * do; * evalblock_evlen = 29; * evalblock_evdata(1:32) = 'SYNAD ERROR READING DIRECTORY'; * end; * when (32) * do; * evalblock_evlen = 30; * evalblock_evdata(1:32) = 'DATASET MAY NOT BE PARTITIONED'; * end; * otherwise * do; * evalblock_evlen = 5; * evalblock_evdata(1:5) = 'ERROR'; * ; * end; * end; * return code(0); /* Always return code zero */ * end memlist; *---------------------------------------------------------------------* *-------------------- Assembler code starts below --------------------* *---------------------------------------------------------------------* TITLE ' /****************************************************** ********' MEMLIST CSECT , MEMLIST AMODE 31 MEMLIST RMODE ANY STM 14,12,12(13) LR 12,15 USING MEMLIST,12 LA 15,0 L 0,DSECT_SZ+4 GETMAIN RU,LV=(0),SP=(15), * LOC=BELOW LR 11,1 USING @DATD,11 ST 13,4(,11) ST 11,8(,13) LM 15,1,16(13) LR 13,11 MVC INPUTPTRS1(24),0(1) * * /*****************************************************************/ * /* */ * /* Setup */ * /* */ * /*****************************************************************/ * * autodcb = staticdcb; /* Get dcb template */ MVC AUTODCB(96),STATICDCB * autodcbe = staticdcbe; /* Get dcbe template */ MVC AUTODCBE(56),STATICDCBE * dcbdcbe = addr(autodcbe); LA 9,AUTODCB LA 2,AUTODCBE ST 2,0(,9) * openin = staticopenin; MVC OPENIN(8),STATICOPENIN * closin = staticclosin; MVC CLOSIN(8),STATICCLOSIN * r0save = r0; ST 0,R0SAVE * dircount = 1; /* Use 1st area for dirblock */ LA 9,1 ST 9,DIRCOUNT * dataset = ''; /* Assume no dataset name given */ MVI DATASET,C' ' MVC DATASET+1(45),DATASET * ddnamep = 0; /* Assume no sys gend dd */ SLR 9,9 ST 9,DDNAMEP * shvcount = 0; ST 9,SHVCOUNT * memlistrc = 0; /* Assume no other errors */ SLR 10,10 * count = 0; /* No members yet */ ST 9,COUNT * eom = off; /* Member list read not complete */ NI EOM,B'01111111' * prefix(1) = ' '; /* Assume no tso prefix */ MVI PREFIX,C' ' * IF jscbpscb THEN L 9,16 L 9,0(,9) L 9,0(,9) L 9,180(,9) ICM 6,15,260+4(9) BZ LABEL_1 * IF pscbupt THEN ICM 7,15,52(6) BZ LABEL_1 * IF uptprefl THEN /* If user has a tso prefix */ SLR 8,8 IC 8,23(,7) LTR 8,8 BZ LABEL_1 * prefix = uptprefx(1:uptprefl); /* Get tso prefix */ * MVI PREFIX+1,C' ' MVC PREFIX+2(6),PREFIX+1 LR 9,8 BCTR 9,0 EX 9,INSTRUCTION1 -> MVC PREFIX(0),16(7) * /*****************************************************************/ * /* */ * /* Start of mainline code */ * /* */ * /*****************************************************************/ * * r0 = length(struc) * dim(struc) + length(dblks); LABEL_1 L 0,=F'89600' * GENERATE SETS (R1,R0,R14,R15) REFS (R0) * (GETMAIN RU,LV=(0),LOC=BELOW); GETMAIN RU,LV=(0),LOC=BELOW * shvblockp = r1; LR 9,1 * shvbasep = r1; ST 1,SHVBASEP * dirblocksp = r1 + length(struc) * dim(struc); LR 8,1 AL 8,=F'76800' ST 8,DIRBLOCKSP * GENERATE SETS (R1,R0,R14,R15) (LOAD EP=IRXEXCOM); /* LOAD * IRXEXCOM */ LOAD EP=IRXEXCOM * emcomp = r0; /* Save address for later calls */ * ST 0,EMCOMP * /*****************************************************************/ * /* */ * /* Drop member. To clear the whole stem variable */ * /* */ * /*****************************************************************/ * * shvblock = ''B; XC 0(32,9),0(9) * shvcode = shvdropv; /* Drop variable */ MVI 8(9),C'D' * shvnaml = 7; /* Name length */ LA 8,7 ST 8,20(,9) * shvnama = addr('MEMBER.'); /* Variable name (Stem) */ LA 8,=CL16'MEMBER.' ST 8,16(,9) * r0 = r0save; L 0,R0SAVE * CALL emcom('IRXEXCOM',0,0,shvbasep->shvblock); * MVC ADDRLST6(12),ADDRLST2 L 8,SHVBASEP ST 8,ADDRLST6+12 OI ADDRLST6+12,X'80' L 15,EMCOMP LA 1,ADDRLST6 BALR 14,15 * /*****************************************************************/ * /* */ * /* Get data set name using tso conventions. */ * /* */ * /*****************************************************************/ * * IF parma(1) ¬= 'FFFFFFFF'X & parma(2) ¬= 'FFFFFFFF'X THEN L 6,INPUTPTRS1+16 L 8,0(,6) SLR 7,7 BCTR 7,0 CLR 8,7 BE LABEL_2 CL 7,8(,6) BE LABEL_2 * memlistrc = 16; /* Too many parms */ LA 10,16 * IF memlistrc = 0 & /* No error yet */ * parma(1) ¬= 'FFFFFFFF'X & parml(1) <= length(dataset) & parml(1) * > 0 THEN LABEL_2 LTR 10,10 BNZ LABEL_21 SLR 3,3 BCTR 3,0 CLR 8,3 BE LABEL_21 L 7,4(,6) LA 3,46 CR 7,3 BH LABEL_21 LTR 7,7 BNP LABEL_21 * DO; * dataset = parma(1) -> chars(1:parml(1)); MVI TEMPSTRING1+1,C' ' MVC TEMPSTRING1+2(254),TEMPSTRING1+1 LR 10,7 BCTR 10,0 EX 10,INSTRUCTION2 -> MVC TEMPSTRING1(0),0(8) MVC DATASET(46),TEMPSTRING1 * dataset = translate(dataset, /* Upper case data set name */ * 'ABCDEFGHIJKLMNOPQRSTUVWXYZ','abcdefghijklmnopqrstuvwxyz'); LA 8,25 MVC TEMPSTRING1+46(256),TRTAB1 SLR 10,10 SLR 2,2 LABEL_3 IC 2,=CL26'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(8) IC 10,=CL26'abcdefghijklmnopqrstuvwxyz'(8) STC 2,TEMPSTRING1+46(10) BCTR 8,0 LTR 8,8 BNM LABEL_3 MVC TEMPSTRING1(46),DATASET TR TEMPSTRING1(46),TEMPSTRING1+46 MVC DATASET(46),TEMPSTRING1 * IF dataset(1) = '''' THEN /* If fully qualified */ CLI DATASET,C'''' BNE LABEL_4 * DO; /* Set dataset for svc 99 */ * mvc(dataset(1::44),dataset(2::44)); /* Remove left quote */ MVC DATASET(44),DATASET+1 * i = index(dataset,''''); /* Find right quote */ XC TEMPSTRING1(256),TEMPSTRING1 SLR 10,10 IC 10,=CL1'''' LA 8,TEMPSTRING1(10) MVI 0(8),X'01' LR 10,1 LA 1,DATASET LR 8,1 SLR 2,2 TRT 0(46,1),TEMPSTRING1 ALR 1,2 LCR 8,8 ALR 8,1 LR 1,10 LTR 10,8 * IF i > 0 THEN /* If a trailing quote exists */ BNP LABEL_5 * dataset(i) = ' '; /* Remove right quote */ LA 8,DATASET-1(10) MVI 0(8),C' ' * END; * ELSE /* Must add prefix */ * IF prefix(1) ¬= ' ' THEN /* If prefix exists */ B LABEL_5 LABEL_4 CLI PREFIX,C' ' BE LABEL_5 * DO; * tempdataset = ''; /* Start with blank */ MVI TEMPDATASET,C' ' MVC TEMPDATASET+1(43),TEMPDATASET * tempdataset = prefix; MVI TEMPDATASET+8,C' ' MVC TEMPDATASET+9(35),TEMPDATASET+8 MVC TEMPDATASET(8),PREFIX * tempdataset(uptprefl+1) = '.'; /* Add dot */ L 10,16 L 10,0(,10) L 10,0(,10) L 10,180(,10) L 8,260+4(,10) L 7,52(,8) SLR 6,6 IC 6,23(,7) LA 10,TEMPDATASET(6) MVI 0(10),C'.' * tempdataset(uptprefl+2:length(tempdataset)) = dataset; LA 10,TEMPDATASET+1(6) LA 2,42 SLR 2,6 EX 2,INSTRUCTION3 -> MVC 0(0,10),DATASET * dataset = tempdataset; /* Save over original */ MVI DATASET+44,C' ' MVI DATASET+45,C' ' MVC DATASET(44),TEMPDATASET * END; * * /*************************************************************/ * /* */ * /* Check dsorg and allocate it to a system defined ddname; */ * /* */ * /*************************************************************/ * */* ?ALLOC99ALLOC RETURNDD(ddnamep)SHR DA(dataset)RUN(memlistrc)RETURNO *G(dsorgp) */ * * */*ALLOC99: THE AREA NAME HAS DEFAULTED TO 'USERAREA' */ * * S99RBPTR = ADDR(USERAREA(5)); LABEL_5 LA 3,USERAREA+4 ST 3,@OT00001 ST 3,S99RBPTR * S99RBPND = '1'B; /* Set high order bit of S99RBPTR*/ OI S99RBPND,B'10000000' * S99RBPTR -> S99RB = ''B; /* Zero out request block */ L 6,S99RBPTR XC 0(20,6),0(6) * S99RBPTR -> S99RBLN = 20; /* SET length field in request * block */ MVI 0(6),X'14' * S99RBPTR -> S99TXTPP = ADDR(USERAREA) + 24; /* Set text unit * pointer */ LA 8,24 LA 7,USERAREA ALR 7,8 ST 7,8(,6) * S99RBPTR -> S99VERB = S99VRBAL; /* Specify allocate function */ MVI 1(6),X'01' * DECLARE * 1 SPFS0001 STATIC LOCAL, * 3 TU0001, /* Dataset name */ * 5 * BIT(16) BDY(BYTE) INIT(DALDSNAM), /* Key * for data set name */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(min(44,LENGTH( * DATASET))), * 5 SVC99DSNAME CHAR(min(44,LENGTH(DATASET))), /* * Dsname */ * 3 TU0002, /* Request DDNAME return */ * 5 * BIT(16) BDY(BYTE) INIT(DALRTDDN), * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(8), /* Initial * len */ * 5 SVC99RETDD CHAR(8) INIT(' '), /* Area for return */ * 3 TU0003, /* Request dsorg return */ * 5 * BIT(16) BDY(BYTE) INIT(DALRTORG), * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(2), /* Initial * len */ * 5 SVC99RETOR BIT(16) BDY(BYTE) INIT(0), /* Area for * return */ * 3 TU0004, /* Original disposition */ * 5 * BIT(16) BDY(BYTE) INIT(DALSTATS), /* Key * for status text unit */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(1), /* Length */ * 5 * CHAR(1) INIT('08'X), /* Disp=Shr */ * 3 TU0005, /* Permanent attrib */ * 5 * BIT(16) BDY(BYTE) INIT(DALPERMA), * 5 * FIXED(16) BDY(BYTE) INIT(0), * 3 * CHAR(0); /* End of textunits */ * DECLARE * SPFU0001 BDY(BYTE) CHAR(LENGTH(SPFS0001)) DEFINED(USERAREA) * POS(45), * 1 SPFP0001(5) PTR(31) BDY(BYTE) DEFINED(USERAREA) POS(25), * /* Tu ptr list */ * 3 TPTR PTR(31) BDY(BYTE), * 5 HIGHBIT BIT(1); * USERAREA(1:4) = CHAR(S99RBPTR); STCM 6,15,USERAREA * SPFP0001.TPTR(1) = ADDR(SPFU0001) + OFFSET(SPFS0001.TU0001); LA 6,USERAREA+44 STCM 6,15,USERAREA+24 * SPFP0001.TPTR(2) = ADDR(SPFU0001) + OFFSET(SPFS0001.TU0002); LA 2,50 ALR 2,6 STCM 2,15,USERAREA+24+4 * SPFP0001.TPTR(3) = ADDR(SPFU0001) + OFFSET(SPFS0001.TU0003); LA 3,64 ALR 3,6 STCM 3,15,USERAREA+24+8 * SPFP0001.TPTR(4) = ADDR(SPFU0001) + OFFSET(SPFS0001.TU0004); LA 4,72 ALR 4,6 STCM 4,15,USERAREA+24+12 * SPFP0001.TPTR(5) = ADDR(SPFU0001) + OFFSET(SPFS0001.TU0005); LA 5,79 ALR 5,6 STCM 5,15,USERAREA+24+16 * SPFP0001.HIGHBIT(5) = '1'B; OI USERAREA+24+16,B'10000000' * BEGIN; * DECLARE * REGG1 REG(1) RSTD, * REGG15 REG(15) RSTD, * S99CHARS CHAR(*) BASED; * SPFU0001 = SPFS0001; MVC USERAREA+44(83),SPFS0001 * ADDR(SPFU0001) -> S99CHARS(1+OFFSET(SPFS0001.SVC99DSNAME):: * LENGTH(SPFS0001.SVC99DSNAME)) = DATASET; /* Dsname */ MVC 6(44,6),DATASET * ddnamep = ADDR(SPFU0001) + OFFSET(SPFS0001.SVC99RETDD); LA 2,56 ALR 2,6 ST 2,DDNAMEP * dsorgp = ADDR(SPFU0001) + OFFSET(SPFS0001.SVC99RETOR); LA 10,70 ALR 10,6 * REGG1 = ADDR(USERAREA); LA 1,USERAREA * SVC(99); SVC 99 * memlistrc = REGG15; LR 6,15 * END; /* End of begin block */ * IF ddnamep THEN /* If ddname returned */ ICM 2,15,DDNAMEP BZ LABEL_6 * ddname = ddnamep -> chars(1:8); /* Save for later free */ MVC DDNAME(8),0(2) * IF memlistrc > 0 THEN LABEL_6 LTR 6,6 BNP LABEL_7 * memlistrc = 24; /* Allocation error */ LR 10,8 * ELSE * IF dsorgpo = off THEN /* If svc 99 says not partitioned*/ B LABEL_9 LABEL_7 TM 0(10),B'00000010' BNZ LABEL_8 * memlistrc = 32; /* Dataset not partitioned */ LA 10,32 * ELSE * DO; * B LABEL_9 LABEL_8 DS 0H */* ?ALLOC99ALLOC FILE(ddname)REUSE SHR DA(dataset)RUN(memlistrc)INPUT *SORG(ps)LRECL(255)BLKSIZE(255)RECFM(fb)BUFNO(8) */ * * */*ALLOC99: THE AREA NAME HAS DEFAULTED TO 'USERAREA' */ */* ?ALLOC99AREA(USERAREA)RUN FREE FILE(DDNAME) */ * * S99RBPTR = ADDR(USERAREA(5)); L 3,@OT00001 ST 3,S99RBPTR * S99RBPND = '1'B; /* Set high order bit of S99RBPTR*/ OI S99RBPND,B'10000000' * S99RBPTR -> S99RB = ''B; /* Zero out request block */ L 6,S99RBPTR XC 0(20,6),0(6) * S99RBPTR -> S99RBLN = 20; /* SET length field in * request block */ MVI 0(6),X'14' * S99RBPTR -> S99TXTPP = ADDR(USERAREA) + 24; /* Set text * unit pointer */ ST 7,8(,6) * S99RBPTR -> S99VERB = S99VRBUN; /* Specify free * function */ MVI 1(6),X'02' * DECLARE * 1 SPFS0002 STATIC LOCAL, * 3 TU0001, /* DDNAME */ * 5 * BIT(16) BDY(BYTE) INIT(DUNDDNAM), /* * Key for data set name */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(LENGTH( * DDNAME)), * 5 SVC99DDNAME CHAR(LENGTH(DDNAME)), /* Dd name*/ * 3 TU0002, /* Force unalloc */ * 5 * BIT(16) BDY(BYTE) INIT(DUNUNALC), /* * Key for force dealloc */ * 5 * FIXED(16) BDY(BYTE) INIT(0), * 5 * FIXED(16) BDY(BYTE) INIT(0), /* * Length */ * 3 * CHAR(0); /* End of textunits */ * DECLARE * SPFU0002 BDY(BYTE) CHAR(LENGTH(SPFS0002)) DEFINED( * USERAREA) POS(33), * 1 SPFP0002(2) PTR(31) BDY(BYTE) DEFINED(USERAREA) * POS(25), /* Tu ptr list */ * 3 TPTR PTR(31) BDY(BYTE), * 5 HIGHBIT BIT(1); * USERAREA(1:4) = CHAR(S99RBPTR); STCM 6,15,USERAREA * SPFP0002.TPTR(1) = ADDR(SPFU0002) + OFFSET(SPFS0002. * TU0001); LA 6,USERAREA+32 STCM 6,15,USERAREA+24 * SPFP0002.TPTR(2) = ADDR(SPFU0002) + OFFSET(SPFS0002. * TU0002); LA 2,14 ALR 2,6 STCM 2,15,USERAREA+24+4 * SPFP0002.HIGHBIT(2) = '1'B; OI USERAREA+24+4,B'10000000' * BEGIN; * DECLARE * REGG1 REG(1) RSTD, * REGG15 REG(15) RSTD, * S99CHARS CHAR(*) BASED; * SPFU0002 = SPFS0002; MVC USERAREA+32(20),SPFS0002 * ADDR(SPFU0002) -> S99CHARS(1+OFFSET(SPFS0002. * SVC99DDNAME)::LENGTH(SPFS0002.SVC99DDNAME)) = * DDNAME; /* DDNAME */ MVC 6(8,6),DDNAME * REGG1 = ADDR(USERAREA); LA 1,USERAREA * SVC(99); SVC 99 * END; /* End of begin block */ * S99RBPTR = ADDR(USERAREA(5)); L 6,@OT00001 ST 6,S99RBPTR * S99RBPND = '1'B; /* Set high order bit of S99RBPTR*/ OI S99RBPND,B'10000000' * S99RBPTR -> S99RB = ''B; /* Zero out request block */ L 6,S99RBPTR XC 0(20,6),0(6) * S99RBPTR -> S99RBLN = 20; /* SET length field in * request block */ MVI 0(6),X'14' * S99RBPTR -> S99TXTPP = ADDR(USERAREA) + 24; /* Set text * unit pointer */ ST 7,8(,6) * S99RBPTR -> S99VERB = S99VRBAL; /* Specify allocate * function */ MVI 1(6),X'01' * DECLARE * 1 SPFS0003 STATIC LOCAL, * 3 TU0001, /* Dataset name */ * 5 * BIT(16) BDY(BYTE) INIT(DALDSNAM), /* * Key for data set name */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(min(44, * LENGTH(DATASET))), * 5 SVC99DSNAME CHAR(min(44,LENGTH(DATASET))), /* * Dsname */ * 3 TU0002, /* DDNAME */ * 5 * BIT(16) BDY(BYTE) INIT(DALDDNAM), /* * Key for data set name */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(LENGTH( * DDNAME)), * 5 SVC99DDNAME CHAR(LENGTH(DDNAME)), /* Dd name*/ * 3 TU0003, /* Original disposition */ * 5 * BIT(16) BDY(BYTE) INIT(DALSTATS), /* * Key for status text unit */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(1), /* * Length */ * 5 * CHAR(1) INIT('08'X), /* Disp=Shr */ * 3 TU0004, /* Data set organization */ * 5 * BIT(16) BDY(BYTE) INIT(DALDSORG), /* * Key for data organisation */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(2), /* * Length */ * 5 * BIT(16) BDY(BYTE) INIT('4000'X), /* * Dsorg(ps) */ * 3 TU0005, /* Record format */ * 5 * BIT(16) BDY(BYTE) INIT(DALRECFM), /* * Key for record format */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(1), /* * Length */ * 5 * FIXED(8) BDY(BYTE) INIT(10X /* B */ * +80X /* F */ * ), /* Record format */ * 3 TU0006, /* Record length */ * 5 * BIT(16) BDY(BYTE) INIT(DALLRECL), /* * Key for record length */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(2), /* * Length */ * 5 * FIXED(16) BDY(BYTE) INIT(255), /* * Record length */ * 3 TU0007, /* Block size */ * 5 * BIT(16) BDY(BYTE) INIT(DALBLKSZ), /* * Key for block size */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(2), /* * Length */ * 5 * FIXED(16) BDY(BYTE) INIT(255), /* * Block size */ * 3 TU0008, /* Input only */ * 5 * BIT(16) BDY(BYTE) INIT(DALINOUT), /* * Key for keylen */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(1), /* * Length */ * 5 * BIT(8) INIT('80'X), /* Input only */ * 3 TU0009, /* Number of buffers */ * 5 * BIT(16) BDY(BYTE) INIT(DALBUFNO), /* * Key for bufno */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(1), /* * Length */ * 5 * FIXED(8) BDY(BYTE) INIT(8), /* * Bufno */ * 3 TU0010, /* Permanent attrib */ * 5 * BIT(16) BDY(BYTE) INIT(DALPERMA), * 5 * FIXED(16) BDY(BYTE) INIT(0), * 3 * CHAR(0); /* End of textunits */ * DECLARE * SPFU0003 BDY(BYTE) CHAR(LENGTH(SPFS0003)) DEFINED( * USERAREA) POS(65), * 1 SPFP0003(10) PTR(31) BDY(BYTE) DEFINED(USERAREA) * POS(25), /* Tu ptr list */ * 3 TPTR PTR(31) BDY(BYTE), * 5 HIGHBIT BIT(1); * USERAREA(1:4) = CHAR(S99RBPTR); STCM 6,15,USERAREA * SPFP0003.TPTR(1) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0001); LA 6,USERAREA+64 STCM 6,15,USERAREA+24 * SPFP0003.TPTR(2) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0002); LA 7,50 ALR 7,6 STCM 7,15,USERAREA+24+4 * SPFP0003.TPTR(3) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0003); LA 7,64 ALR 7,6 STCM 7,15,USERAREA+24+8 * SPFP0003.TPTR(4) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0004); LA 7,71 ALR 7,6 STCM 7,15,USERAREA+24+12 * SPFP0003.TPTR(5) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0005); LA 7,79 ALR 7,6 STCM 7,15,USERAREA+24+16 * SPFP0003.TPTR(6) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0006); LA 7,86 ALR 7,6 STCM 7,15,USERAREA+24+20 * SPFP0003.TPTR(7) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0007); LA 7,94 ALR 7,6 STCM 7,15,USERAREA+24+24 * SPFP0003.TPTR(8) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0008); LA 7,102 ALR 7,6 STCM 7,15,USERAREA+24+28 * SPFP0003.TPTR(9) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0009); LA 7,109 ALR 7,6 STCM 7,15,USERAREA+24+32 * SPFP0003.TPTR(10) = ADDR(SPFU0003) + OFFSET(SPFS0003. * TU0010); LA 7,116 ALR 7,6 STCM 7,15,USERAREA+24+36 * SPFP0003.HIGHBIT(10) = '1'B; OI USERAREA+24+36,B'10000000' * BEGIN; * DECLARE * REGG1 REG(1) RSTD, * REGG15 REG(15) RSTD, * S99CHARS CHAR(*) BASED; * SPFU0003 = SPFS0003; MVC USERAREA+64(120),SPFS0003 * ADDR(SPFU0003) -> S99CHARS(1+OFFSET(SPFS0003. * SVC99DSNAME)::LENGTH(SPFS0003.SVC99DSNAME)) = * DATASET; /* Dsname */ MVC 6(44,6),DATASET * ADDR(SPFU0003) -> S99CHARS(1+OFFSET(SPFS0003. * SVC99DDNAME)::LENGTH(SPFS0003.SVC99DDNAME)) = * DDNAME; /* DDNAME */ MVC 56(8,6),DDNAME * REGG1 = ADDR(USERAREA); LA 1,USERAREA * SVC(99); SVC 99 * memlistrc = REGG15; LTR 10,15 * END; /* End of begin block */ * IF memlistrc THEN BZ LABEL_9 * memlistrc = 24; LR 10,8 * END; * LABEL_9 DS 0H * /*************************************************************/ * /* */ * /* Open the dcb and read the member list */ * /* */ * /*************************************************************/ * * RESPECIFY * (r2) rstd; * r2 = addr(dcb); LA 3,AUTODCB LR 2,3 * dcbddnam = ddname; MVC 40(8,3),DDNAME * IF memlistrc = 0 THEN LTR 10,10 BNZ LABEL_10 * GENERATE REFS (R2) SETS (R0,R1,R14,R15) * (OPEN ((2),INPUT),MODE=31,MF=(E,OPENIN)); /* OPEN DCB */ OPEN ((2),INPUT),MODE=31,MF=(E,OPENIN) * RESPECIFY * r2; LABEL_10 DS 0H * IF memlistrc = 0 THEN LTR 10,10 BNZ CLOSE_LABEL * IF dcbopen = on THEN LA 4,AUTODCB TM 40+8(4),B'00010000' BNO LABEL_18 * DO until(eom); LABEL_11 DS 0H * dcbesyna = addr(inpsyn); LA 5,AUTODCBE LA 4,INPSYN ST 4,44(,5) * dcbeeoda = addr(inpeod); LA 4,INPEOD ST 4,40(,5) * r1 = addr(dcb); LA 1,AUTODCB * RESPECIFY * r2 rstd, * r3 rstd; * GENERATE FLOWS (INPSYN,INPEOD) SETS (R0,R1,R3,R14,R15) * REFS (R1); GET (1) GET NEXT DIRECTORY BLOCK * RESPECIFY * (r2, * r3); * dirblocks(dircount) = r1 -> dirblock; L 2,DIRCOUNT LR 6,2 SLL 6,8 LA 7,256 SLR 6,7 L 3,DIRBLOCKSP ALR 3,6 MVC 0(256,3),0(1) * dirp = addr(dirblocks(dircount)); /* Get address of * directory block */ L 7,DIRBLOCKSP LA 7,0(6,7) * dircount = dircount + 1; LA 6,1 ALR 2,6 ST 2,DIRCOUNT * direntp = dirp + 2; /* Point to 1st entry */ LA 8,2 ALR 8,7 * entend = dirp + dirblksz - 1; /* Point past last entry */ LH 6,0(,7) LR 2,7 ALR 2,6 BCTR 2,0 ST 2,ENTEND * IF dirblksz & ¬ eom THEN /* If entries to be read */ LTR 6,6 BZ LABEL_16 TM EOM,B'10000000' BNZ LABEL_16 * DO while(eom=off&direntp MVC VARNAME+7(0),0(5) * shvcode = shvstore; MVI 8(9),C'S' * shvnaml = 16 - i; LA 2,16 SLR 2,7 ST 2,20(,9) * varnames(shvcount) = varname; L 6,SHVCOUNT LR 7,6 ALR 6,6 ALR 6,7 SLA 6,4 LA 7,48 SLR 6,7 L 7,SHVBASEP LR 2,7 ALR 2,6 MVC 32(16,2),VARNAME * shvnama = addr(varnames(shvcount)); LA 7,32(6,7) ST 7,16(,9) * shvvala = addr(dirname); ST 8,24(,9) * shvvall = 8; LA 2,8 ST 2,28(,9) * shvret = 'ff'X; MVI 8+1(9),X'FF' * dirlength = dirc; /* Get entry length */ MVC DIRLENGTH(1),11(8) * dirlength(1:3) = '000'B; /* Mask off high bits */ NI DIRLENGTH,B'00011111' * direntp = direntp + 12 + dirlength * 2; /* Move * to next directory entry */ LA 3,12 ALR 3,8 SLR 2,2 IC 2,DIRLENGTH ALR 2,2 ALR 3,2 LR 8,3 * END; * END; LABEL_15 TM EOM,B'10000000' BNZ LABEL_16 CL 8,ENTEND BL LABEL_12 LABEL_16 DS 0H * IF shvcount & dircount >= dim(dirblocks) THEN ICM 8,15,SHVCOUNT BZ LABEL_17 CLC DIRCOUNT(4),=F'50' BL LABEL_17 * DO; * r0 = r0save; L 0,R0SAVE * CALL emcom('IRXEXCOM',0,0,shvbasep->shvblock); MVC ADDRLST6(12),ADDRLST3 L 2,SHVBASEP ST 2,ADDRLST6+12 OI ADDRLST6+12,X'80' L 15,EMCOMP LA 1,ADDRLST6 BALR 14,15 * shvcount = 0; SLR 8,8 ST 8,SHVCOUNT * shvblockp = shvbasep; L 9,SHVBASEP * dircount = 1; /* Point back to 1st dirblock */ LA 8,1 ST 8,DIRCOUNT * END; * END; LABEL_17 TM EOM,B'10000000' BZ LABEL_11 * ELSE /* Set alloc or open error */ * memlistrc = 24; /* Alloc or open error */ B CLOSE_LABEL LABEL_18 LR 10,8 * GOTO close_label; * B CLOSE_LABEL * /*************************************************************/ * /* */ * /* End of read loop */ * /* */ * /*************************************************************/ * *inpsyn: /* Synad exit point */ * RESPECIFY * (r3) rstd; INPSYN DS 0H * r3 = addr(a312) | '80000000'X; LA 3,A312 O 3,=X'80000000' * bsm(r3,r0); BSM 3,0 *a312: * memlistrc = 28; /* Indicate a synad error */ A312 LA 10,28 *inpeod: /* End of data exit point */ * r3 = addr(close_label) | '80000000'X; INPEOD LA 3,CLOSE_LABEL O 3,=X'80000000' * bsm(r3,r0); BSM 3,0 * RESPECIFY * (r3); *close_label: * IF dcbopen = on THEN CLOSE_LABEL LA 4,AUTODCB TM 40+8(4),B'00010000' BNO LABEL_22 * DO; * RESPECIFY * r2 rstd; * r2 = addr(dcb); LR 2,4 * GENERATE REFS (R2) (CLOSE ((2)),MF=(E,CLOSIN),MODE=31); CLOSE ((2)),MF=(E,CLOSIN),MODE=31 * RESPECIFY * r2; * IF shvcount THEN ICM 5,15,SHVCOUNT BZ LABEL_19 * DO; * r0 = r0save; L 0,R0SAVE * CALL emcom('IRXEXCOM',0,0,shvbasep->shvblock); MVC ADDRLST6(12),ADDRLST4 L 2,SHVBASEP ST 2,ADDRLST6+12 OI ADDRLST6+12,X'80' L 15,EMCOMP LA 1,ADDRLST6 BALR 14,15 * shvcount = 0; SLR 6,6 * END; * shvblockp = shvbasep; /* Use 1st block here */ LABEL_19 L 8,SHVBASEP * shvblock = ''B; /* Write member.0 (Total count) */ XC 0(32,8),0(8) * cvd(count,spfctnw); /* Only if dcb was opened */ L 9,COUNT CVD 9,SPFCTNW * unpk(spfctnx,spfctnw); UNPK SPFCTNX(16),SPFCTNW(8) * spfctnx(16) = spfctnx(16) | 'F0'X; OI SPFCTNX+15,X'F0' * varnum = spfctnx(17-length(varnum):16); MVC VARNUM(8),SPFCTNX+8 * i = verify(varnum,'0'); MVI TEMPSTRING1,X'01' MVC TEMPSTRING1+1(255),TEMPSTRING1 SLR 7,7 IC 7,=CL1'0' LA 9,TEMPSTRING1(7) MVI 0(9),X'00' LR 7,1 LA 1,VARNUM LR 9,1 SLR 2,2 TRT 0(8,1),TEMPSTRING1 ALR 1,2 LCR 9,9 ALR 9,1 LR 1,7 LTR 7,9 * IF i = 0 THEN BNZ LABEL_20 * i = 8; LA 7,8 * varname = ''; LABEL_20 MVI VARNAME,C' ' MVC VARNAME+1(15),VARNAME * varname(1::9-i) = varnum(i::9-i); LA 6,9 SLR 6,7 LR 9,6 BCTR 9,0 LA 2,VARNUM-1(7) EX 9,INSTRUCTION5 -> MVC VARNAME(0),0(2) * varnum = varname(1::9-i); MVI TEMPSTRING1+1,C' ' MVC TEMPSTRING1+2(14),TEMPSTRING1+1 EX 9,INSTRUCTION6 -> MVC TEMPSTRING1(0),VARNAME MVC VARNUM(8),TEMPSTRING1 * shvcode = shvstore; MVI 8(8),C'S' * shvnaml = 8; LA 9,8 ST 9,20(,8) * shvnama = addr('MEMBER.0'); LA 9,=CL8'MEMBER.0' ST 9,16(,8) * shvvala = addr(varnum); LA 9,VARNUM ST 9,24(,8) * shvvall = 9 - i; ST 6,28(,8) * r0 = r0save; L 0,R0SAVE * CALL emcom('IRXEXCOM',0,0,shvblock); MVC ADDRLST6(12),ADDRLST5 ST 8,ADDRLST6+12 OI ADDRLST6+12,X'80' L 15,EMCOMP LA 1,ADDRLST6 BALR 14,15 * END; * END; * ELSE /* Parameter error */ * IF memlistrc = 0 THEN /* No code yet */ B LABEL_22 LABEL_21 LTR 10,10 BNZ LABEL_22 * memlistrc = 20; /* Invalid dsname supplied */ LA 10,20 * IF ddnamep THEN LABEL_22 ICM 2,15,DDNAMEP BZ LABEL_23 * DO; * */* ?ALLOC99FREE FILE(ddname)RUN */ * * */*ALLOC99: THE AREA NAME HAS DEFAULTED TO 'USERAREA' */ * * S99RBPTR = ADDR(USERAREA(5)); LA 3,USERAREA+4 ST 3,S99RBPTR * S99RBPND = '1'B; /* Set high order bit of S99RBPTR*/ OI S99RBPND,B'10000000' * S99RBPTR -> S99RB = ''B; /* Zero out request block */ L 6,S99RBPTR XC 0(20,6),0(6) * S99RBPTR -> S99RBLN = 20; /* SET length field in request * block */ MVI 0(6),X'14' * S99RBPTR -> S99TXTPP = ADDR(USERAREA) + 24; /* Set text unit * pointer */ LA 7,USERAREA LA 8,24 ALR 8,7 ST 8,8(,6) * S99RBPTR -> S99VERB = S99VRBUN; /* Specify free function */ MVI 1(6),X'02' * DECLARE * 1 SPFS0004 STATIC LOCAL, * 3 TU0001, /* DDNAME */ * 5 * BIT(16) BDY(BYTE) INIT(DUNDDNAM), /* Key * for data set name */ * 5 * FIXED(16) BDY(BYTE) INIT(1), * 5 * FIXED(16) BDY(BYTE) INIT(LENGTH(DDNAME)), * 5 SVC99DDNAME CHAR(LENGTH(DDNAME)), /* Dd name */ * 3 TU0002, /* Force unalloc */ * 5 * BIT(16) BDY(BYTE) INIT(DUNUNALC), /* Key * for force dealloc */ * 5 * FIXED(16) BDY(BYTE) INIT(0), * 5 * FIXED(16) BDY(BYTE) INIT(0), /* Length */ * 3 * CHAR(0); /* End of textunits */ * DECLARE * SPFU0004 BDY(BYTE) CHAR(LENGTH(SPFS0004)) DEFINED(USERAREA) * POS(33), * 1 SPFP0004(2) PTR(31) BDY(BYTE) DEFINED(USERAREA) POS(25), * /* Tu ptr list */ * 3 TPTR PTR(31) BDY(BYTE), * 5 HIGHBIT BIT(1); * USERAREA(1:4) = CHAR(S99RBPTR); STCM 6,15,USERAREA * SPFP0004.TPTR(1) = ADDR(SPFU0004) + OFFSET(SPFS0004.TU0001); LA 6,USERAREA+32 STCM 6,15,USERAREA+24 * SPFP0004.TPTR(2) = ADDR(SPFU0004) + OFFSET(SPFS0004.TU0002); LA 8,14 ALR 8,6 STCM 8,15,USERAREA+24+4 * SPFP0004.HIGHBIT(2) = '1'B; OI USERAREA+24+4,B'10000000' * BEGIN; * DECLARE * REGG1 REG(1) RSTD, * REGG15 REG(15) RSTD, * S99CHARS CHAR(*) BASED; * SPFU0004 = SPFS0004; MVC USERAREA+32(20),SPFS0004 * ADDR(SPFU0004) -> S99CHARS(1+OFFSET(SPFS0004.SVC99DDNAME):: * LENGTH(SPFS0004.SVC99DDNAME)) = DDNAME; /* DDNAME */ MVC 6(8,6),DDNAME * REGG1 = ADDR(USERAREA); LR 1,7 * SVC(99); SVC 99 * END; /* End of begin block */ * END; * * /*****************************************************************/ * /* */ * /* Create rexx variable rc from local variable memlistrc */ * /* */ * /*****************************************************************/ * * shvblockp = shvbasep; /* Use 1st block here */ LABEL_23 L 8,SHVBASEP * shvblock = ''B; XC 0(32,8),0(8) * cvd(memlistrc,spfctnw); CVD 10,SPFCTNW * unpk(spfctnx,spfctnw); UNPK SPFCTNX(16),SPFCTNW(8) * spfctnx(16) = spfctnx(16) | 'F0'X; OI SPFCTNX+15,X'F0' * varnum = spfctnx(17-length(varnum):16); MVC VARNUM(8),SPFCTNX+8 * i = verify(varnum,'0'); MVI TEMPSTRING1,X'01' MVC TEMPSTRING1+1(255),TEMPSTRING1 SLR 7,7 IC 7,=CL1'0' LA 9,TEMPSTRING1(7) MVI 0(9),X'00' LR 7,1 LA 1,VARNUM LR 9,1 SLR 2,2 TRT 0(8,1),TEMPSTRING1 ALR 1,2 LCR 9,9 ALR 9,1 LR 1,7 LTR 7,9 * IF i = 0 THEN BNZ LABEL_24 * i = 8; LA 7,8 * varname = ''; LABEL_24 MVI VARNAME,C' ' MVC VARNAME+1(15),VARNAME * varname(1::9-i) = varnum(i::9-i); LA 6,9 SLR 6,7 LR 9,6 BCTR 9,0 LA 2,VARNUM-1(7) EX 9,INSTRUCTION5 -> MVC VARNAME(0),0(2) * varnum = varname(1::9-i); MVI TEMPSTRING1+1,C' ' MVC TEMPSTRING1+2(14),TEMPSTRING1+1 EX 9,INSTRUCTION6 -> MVC TEMPSTRING1(0),VARNAME MVC VARNUM(8),TEMPSTRING1 * shvcode = shvstore; MVI 8(8),C'S' * shvnaml = 2; LA 9,2 ST 9,20(,8) * shvnama = addr('RC'); LA 2,=CL2'RC' ST 2,16(,8) * shvvala = addr(varnum); LA 3,VARNUM ST 3,24(,8) * shvvall = 9 - i; ST 6,28(,8) * r0 = r0save; L 0,R0SAVE * CALL emcom('IRXEXCOM',0,0,shvblock); MVC ADDRLST6(12),ADDRLST1 ST 8,ADDRLST6+12 OI ADDRLST6+12,X'80' L 15,EMCOMP LA 1,ADDRLST6 BALR 14,15 * GENERATE(DELETE EP=IRXEXCOM); /* REMOVE IRXEXCOM FROM STORAGE */ DELETE EP=IRXEXCOM * r1 = shvbasep; L 1,SHVBASEP * r0 = length(struc) * dim(struc) + length(dblks); L 0,=F'89600' * GENERATE(FREEMAIN RU,LV=(0),A=(1)); FREEMAIN RU,LV=(0),A=(1) * RESPECIFY * (r0, * r1, * r14, * r15); * * /*****************************************************************/ * /* */ * /* Set variable 'result' or function return */ * /* */ * /*****************************************************************/ * * SELECT(memlistrc); LTR 8,10 BM @RT00420 BE @RT00390 LA 15,32 CR 8,15 BH @RT00420 BE @RT00415 IC 8,@CB03881(8) SLL 8,2 B LABEL_25(8) LABEL_25 B @RT00420 B @RT00395 B @RT00400 B @RT00405 B @RT00410 * WHEN(0) @RT00390 DS 0H * DO; * evalblock_evlen = 2; /* Set result to 'ok' */ L 8,INPUTPTRS1+20 L 2,0(,8) ST 9,8(,2) * evalblock_evdata(1:2) = 'OK'; MVC 16(2,2),=CL2'OK' * END; * WHEN(16) B LABEL_26 @RT00395 DS 0H * DO; * evalblock_evlen = 19; L 10,INPUTPTRS1+20 L 2,0(,10) LA 3,19 ST 3,8(,2) * evalblock_evdata(1:24) = 'TOO MANY PARAMETERS'; MVC 16(24,2),=CL24'TOO MANY PARAMETERS' * END; * WHEN(20) B LABEL_26 @RT00400 DS 0H * DO; * evalblock_evlen = 29; L 10,INPUTPTRS1+20 L 2,0(,10) LA 3,29 ST 3,8(,2) * evalblock_evdata(1:29) = 'INVALID DATASET NAME SUPPLIED'; MVC 16(29,2),=CL29'INVALID DATASET NAME SUPPLIED' * END; * WHEN(24) B LABEL_26 @RT00405 DS 0H * DO; * evalblock_evlen = 32; L 10,INPUTPTRS1+20 L 2,0(,10) LA 3,32 ST 3,8(,2) * evalblock_evdata(1:32) = 'DATASET ALLOCATION OR OPEN ERROR'; MVC 16(32,2),=CL32'DATASET ALLOCATION OR OPEN ERROR' * END; * WHEN(28) B LABEL_26 @RT00410 DS 0H * DO; * evalblock_evlen = 29; L 10,INPUTPTRS1+20 L 2,0(,10) LA 3,29 ST 3,8(,2) * evalblock_evdata(1:32) = 'SYNAD ERROR READING DIRECTORY'; MVC 16(32,2),=CL32'SYNAD ERROR READING DIRECTORY' * END; * WHEN(32) B LABEL_26 @RT00415 DS 0H * DO; * evalblock_evlen = 30; L 10,INPUTPTRS1+20 L 2,0(,10) LA 3,30 ST 3,8(,2) * evalblock_evdata(1:32) = 'DATASET MAY NOT BE PARTITIONED'; MVC 16(32,2),=CL32'DATASET MAY NOT BE PARTITIONED' * END; * OTHERWISE B LABEL_26 @RT00420 DS 0H * DO; * evalblock_evlen = 5; L 10,INPUTPTRS1+20 L 2,0(,10) LA 3,5 ST 3,8(,2) * evalblock_evdata(1:5) = 'ERROR'; MVC 16(5,2),=CL5'ERROR' * ; * END; * END; LABEL_26 DS 0H * RETURN code(0); /* Always return code zero */ LR 1,11 L 13,4(,13) LA 15,0 L 0,DSECT_SZ+4 FREEMAIN RU,LV=(0),A=(1),SP=(15) SLR 15,15 L 14,12(,13) LM 0,12,20(13) BR 14 * END memlist; INSTRUCTION1 MVC PREFIX(0),16(7) INSTRUCTION2 MVC TEMPSTRING1(0),0(8) INSTRUCTION3 MVC 0(0,10),DATASET INSTRUCTION4 MVC VARNAME+7(0),0(5) INSTRUCTION5 MVC VARNAME(0),0(2) INSTRUCTION6 MVC TEMPSTRING1(0),VARNAME ADDRLST1 DS 0A ADDRLST2 DS 0A ADDRLST3 DS 0A ADDRLST4 DS 0A ADDRLST5 DC A(CL8_IRXEXCOM,FIXED_0,FIXED_0) FIXED_0 DC F'0' LTORG CL8_IRXEXCOM DC CL8'IRXEXCOM' @CB03881 DC XL32'000000000000000000000000000000000100000002000000030* 0000004000000' TRTAB1 DC XL256'000102030405060708090A0B0C0D0E0F101112131415161718* 191A1B1C1D1E1F202122232425262728292A2B2C2D2E2F3031323334* 35363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F50* 5152535455565758595A5B5C5D5E5F606162636465666768696A6B6C* 6D6E6F707172737475767778797A7B7C7D7E7F808182838485868788* 898A8B8C8D8E8F909192939495969798999A9B9C9D9E9FA0A1A2A3A4* A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0* C1C2C3C4C5C6C7C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDC* DDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEFF0F1F2F3F4F5F6F7F8* F9FAFBFCFDFEFF' SPFS0001 DC X'0002',AL2(1,44) DS CL44 DC X'0055',AL2(1,8) SVC99RETDD DC CL8' ',X'0057',AL2(1,2) SVC99RETOR DC X'0000',X'0004',AL2(1,1),X'08',X'0052',AL2(0) SPFS0002 DC X'0001',AL2(1,8) DS CL8 DC X'0007',AL2(0,0) SPFS0003 DC X'0002',AL2(1,44) DS CL44 DC X'0001',AL2(1,8) DS CL8 DC X'0004',AL2(1,1),X'08',X'003C',AL2(1,2),X'4000' DC X'0049',AL2(1,1),AL1(144) TU0006 DC X'0042',AL2(1,2,255) TU0007 DC X'0030',AL2(1,2,255) TU0008 DC X'0021',AL2(1,1),X'80' TU0009 DC X'0034',AL2(1,1),AL1(8) TU0010 DC X'0052',AL2(0) SPFS0004 DC X'0001',AL2(1,8) DS CL8 DC X'0007',AL2(0,0) STATICDCB DCB DSORG=PS,MACRF=(GL),0=STATICDCBE,BLKSIZE=256, C* LRECL=256,RECFM=FB STATICDCBE DCBE RMODE31=BUFF STATICOPENIN OPEN (,),MF=L,MODE=31 STATICCLOSIN CLOSE (,),MF=L,MODE=31 DSECT_SZ DS 0A DC AL1(0),AL3(((@ENDDATD-@DATD+7)/8)*8) DC A(((@ENDDATD-@DATD+7)/8)*8) @DATD DSECT SAVEAREA_1 DS 18F INPUTPTRS1 DS 6F ADDRLST6 DS 4A @OT00001 DS F S99RBPTR DS 0F S99RBPND DS BL1 S99TUFP DS A PSCBPTR DS A UPTPTR DS A TCBPTR DS A COUNT DS F ENTEND DS A DDNAMEP DS A DIRCOUNT DS A R0SAVE DS A SHVBASEP DS A SHVCOUNT DS F DIRBLOCKSP DS A EMCOMP DS A TEMPSTRING1 DS CL302 DATASET DS CL46 TEMPDATASET DS CL44 DS CL4 SPFCTNW DS CL8 SPFCTNX DS CL16 AUTODCB DS CL96 AUTODCBE DS CL56 DIRLENGTH DS BL1 DDNAME DS CL8 PREFIX DS CL8 VARNAME DS CL16 DS CL7 VARNUM DS CL8 EOM DS BL1 DS CL7 OPENIN DS CL8 CLOSIN DS CL8 USERAREA DS CL256 ORG *+1-(*-@DATD)/(*-@DATD) @ENDDATD DS 0X END ,(PL/X-370,0104,00166)