ftp.uv.es

home *** CD-ROM | disk | FTP | other *** search

/ ftp.uv.es / 2014.11.ftp.uv.es.tar / ftp.uv.es / pub / mvs / TSOREXX.DISTRIB.CNTL.V1R1 < prev

Wrap

Text File | 1993-08-17 | 261KB | 3,219 lines

//JOBNAME JOB ACCOUNT,'NAME' //*------------------------------------------------------------------*/ //* */ //* Copyright (c) The Charles Stark Draper Laboratory, Inc., 1993 */ //* */ //* This software is provided on an "AS IS" basis. All warranties, */ //* including the implied warranties of merchantability and fitness, */ //* are expressly denied. */ //* */ //* Provided this copyright notice is included, this software may */ //* be freely distributed and not offered for sale. */ //* */ //* Changes or modifications may be made and used only by the maker */ //* of same, and not further distributed. Such modifications should */ //* be mailed to the author for consideration for addition to the */ //* software and incorporation in subsequent releases. */ //* */ //*------------------------------------------------------------------*/ //* //* TSO/REXX Utilities //* //* Author: Steve Bacher <seb@draper.com> //* //* Date: 7 May 1993 //* //*------------------------------------------------------------------- //* //* This job creates the distribution libraries (PDS's). //* //* Run this JCL to create the PDS's, after customizing to suit. //* (Obviously, put in a good JOB statement first.) //* To customize the JCL, change the defaults on the //MDLOAD PROC //* statement to your liking, particularly the PREFIX default. //* You might also want to change the final qualifiers of the PDS's //* created - to do this, find the // EXEC MDLOAD statements and //* change the value of the TO parameter. //* //* See the $$README file (of the CNTL PDS, first in this stream) //* for the rest of the installation instructions. //* //MDLOAD PROC CLS='*',BS='6160',U='3380',V='', // TRK1='30',TRK2='10',DIR='35',RLSE='RLSE', // PREFIX='SYS8.TSOREXX.INSTALL.' //* //IEBUPDTE EXEC PGM=IEBUPDTE,PARM=NEW //SYSPRINT DD SYSOUT=&CLS //SYSUT2 DD DISP=(NEW,CATLG,DELETE),DSN=&PREFIX.&TO, // DCB=(RECFM=FB,LRECL=80,BLKSIZE=&BS), // SPACE=(TRK,(&TRK1,&TRK2,&DIR),&RLSE),UNIT=&U,VOL=SER=&V //* // PEND //* //CNTL EXEC MDLOAD,TRK1='5',TO='CNTL' //SYSIN DD DATA,DLM='?!' ./ ADD NAME=$$README TSO/REXX Utilities: XPROC and XWRITENR XPROC provides the capability of the CLIST PROC statement for TSO REXX execs. Similarly, XWRITENR provides the capability of the CLIST WRITENR statement for TSO REXX execs. To install these utilities: (1) Pick a load library. Probably you will need these to be in one of your MVS system link list libraries, but you might want to put it in a user library first. The JCL (see next step) references this library and assumes it already exists, so make sure that it exists and that you can update it before you proceed. (2) Assemble and link all of the utilities. The JCL is in the corresponding member of the CNTL dataset (called either SYS8.TSOREXX.INSTALL.CNTL or blah.CNTL, where blah is what you changed the MDLOAD prefix to). Before submitting the JCL, customize it so that it will run on your system. In particular, change the names of the referenced data sets from SYS8.TSOREXX.INSTALL.ASM and SYS8.TSOREXX.LOAD to whatever you are using. The .ASM was created when you built this distribution. The .LOAD was decided upon by you in step (1). It was NOT allocated by building the distribution. (3) Install the TSO HELP files. The HELP is in the corresponding member of the HELP dataset (called either SYS8.TSOREXX.INSTALL.HELP or blah.HELP, where blah is what you changed the MDLOAD prefix to). (4) Get the load modules into a system load library, refresh LLA if applicable to your system, and enjoy. (5) Send all gripes, compliments and suggestions to seb@draper.com. ./ ADD NAME=XPROC //ASSEMBLE EXEC PGM=IEV90,PARM='LIST,NODECK,OBJECT' //SYSPRINT DD SYSOUT=A //SYSPUNCH DD DUMMY //SYSLIB DD DISP=SHR,DSN=SYS1.MACLIB //SYSLIN DD DISP=(,PASS),UNIT=SYSALLDA,SPACE=(1680,(10,50)) //SYSUT1 DD UNIT=VIO,SPACE=(TRK,(100,100)) //SYSIN DD DISP=SHR,DSN=SYS8.TSOREXX.INSTALL.ASM(XPROC) //* //LINKEDIT EXEC PGM=IEWL,PARM='LIST,LET,RENT,REUS,MAP',COND=(0,NE) //SYSPRINT DD SYSOUT=A //SYSLMOD DD DISP=SHR,DSN=SYS8.TSOREXX.LOAD(XPROC) //SYSLIN DD DISP=(OLD,DELETE),DSN=*.ASSEMBLE.SYSLIN //SYSUT1 DD UNIT=VIO,SPACE=(TRK,(100,100)) ./ ADD NAME=XWRITENR //ASSEMBLE EXEC PGM=IEV90,PARM='LIST,NODECK,OBJECT' //SYSPRINT DD SYSOUT=A //SYSPUNCH DD DUMMY //SYSLIB DD DISP=SHR,DSN=SYS1.MACLIB //SYSLIN DD DISP=(,PASS),UNIT=SYSALLDA,SPACE=(1680,(10,50)) //SYSUT1 DD UNIT=VIO,SPACE=(TRK,(100,100)) //SYSIN DD DISP=SHR,DSN=SYS8.TSOREXX.INSTALL.ASM(XWRITENR) //* //LINKEDIT EXEC PGM=IEWL,PARM='LIST,LET,RENT,REUS,MAP',COND=(0,NE) //SYSPRINT DD SYSOUT=A //SYSLMOD DD DISP=SHR,DSN=SYS8.TSOREXX.LOAD(XWRITENR) //SYSLIN DD DISP=(OLD,DELETE),DSN=*.ASSEMBLE.SYSLIN //SYSUT1 DD UNIT=VIO,SPACE=(TRK,(100,100)) ./ ENDUP ?! //* //ASM EXEC MDLOAD,TRK1='5',TO='ASM' //SYSIN DD DATA,DLM='?!' ./ ADD NAME=XPROC TITLE 'XPROC copyright notice' 00010000 *********************************************************************** 00020000 * * 00030000 * Copyright (c) 1989 The Charles Stark Draper Laboratory, Inc. * 00040000 * * 00050000 * This program is provided on an "as is" basis. It may be freely * 00060000 * distributed as long as it is not offered for commercial sale, * 00070000 * and as long as this copyright notice is included. * 00080000 * * 00090000 *********************************************************************** 00100000 TITLE 'XPROC macros' 00110000 MACRO 00120000 &SYM ERROR &MSG,&FLUSH=YES 00130000 &SYM L R1,=A(&MSG) Get address of error message 00140000 LA R0,L'&MSG Get length of error message 00150000 BAL R14,PUTLINE Display error message 00160000 AIF ('&FLUSH' EQ 'NO').MEND 00170000 B FLUSHIT Fail 00180000 .MEND MEND 00190000 TITLE 'XPROC - CLIST-style command line parser for REXX' 00200000 *********************************************************************** 00210000 * * 00220000 * XPROC - CLIST-style command line parser for REXX * 00230000 * * 00240000 * Author: S. Bacher 06/89 * 00250000 * * 00260000 * Syntax: XPROC {inputvar} number {positional-parameter-variables}* * 00270000 * {keyword-and-maybe-value-specs}* * 00280000 * * 00290000 * where: "inputvar" is a valid CLIST/REXX variable name * 00300000 * and the part of the command that follows "inputvar" * 00310000 * looks exactly like the syntax of the CLIST "PROC" * 00320000 * statement. * 00330000 * * 00340000 * Example: /* REXX */ * 00350000 * PARSE ARG OPERANDS * 00360000 * "XPROC OPERANDS 2 FILE DSN VOL() SHR COUNT(1) KEY('A B')" * 00370000 * * 00380000 * Note that everything, including "inputvar", must be quoted * 00390000 * under REXX to prevent substitution. * 00400000 * * 00410000 * Function: To parse the value of a string (accessed as "inputvar") * 00420000 * according to the PROC-style specifications and place * 00430000 * the results in REXX variables. If "inputvar" is * 00440000 * omitted, the argument to the REXX exec is parsed. * 00450000 * * 00460000 * Return codes: * 00470000 * * 00480000 * 0 - normal operation * 00490000 * 12 - error(s) occurred, prompting not possible * 00500000 * * 00510000 * Note: This can be used in CLISTs as well. One use might be to * 00520000 * parse a non-command-buffer line, e.g. edit macro text. * 00530000 * #TSO147 00540000 * Change activity: #TSO147 00550000 * #TSO147 00560000 * 10/24/89 - SEB1525 - Bug fix when bigger keyword area needed. #TSO147 00570000 * 01/30/91 - SEB1525 - Extended to permit the specification of * 00580000 * options via the syntax keyword/option. * 00590000 * First option so supported is lowercase. * 00600000 * 04/13/92 - SEB1525 - Bug fix when prototype has quoted data. #TSO159 00610000 * 12/15/92 - SEB1525 - Pass REXX env block from ECT to IRXEXCOM #TSO162 00620000 * to solve problem with IPCS/ISPF #TSO162 00630000 * * 00640000 *********************************************************************** 00650000 SPACE 1 00660000 R0 EQU 0 00670000 R1 EQU 1 00680000 R2 EQU 2 Miscellaneous uses 00690000 R3 EQU 3 Used by SCAN and PUTLINE; other temporary uses 00700000 R4 EQU 4 Positional parameter info 00710000 R5 EQU 5 Positional parameter info 00720000 R6 EQU 6 Keyword count 00730000 R7 EQU 7 Address of IKJPARS PDL answer area 00740000 R8 EQU 8 Used to loop through parameters 00750000 R9 EQU 9 Dynamic base register 00760000 R10 EQU 10 Static base register 00770000 R11 EQU 11 Static base register 00780000 R12 EQU 12 Static base register 00790000 R13 EQU 13 Save area pointer 00800000 R14 EQU 14 00810000 R15 EQU 15 00820000 SPACE 1 00830000 XPROC CSECT 00840000 XPROC AMODE 31 00850000 XPROC RMODE ANY 00860000 SAVE (14,12),,XPROC_&SYSDATE._&SYSTIME 00870000 LR R12,R15 00880000 USING XPROC,R12 00890000 LA R11,4095(,R12) 00900000 USING XPROC+4095,R11 00910000 LA R10,4095(,R11) 00920000 USING XPROC+4095+4095,R10 00930000 * 00940000 * Allocate storage to hold work area plus copies of positional and 00950000 * keyword parameters. Since the maximum length required to hold 00960000 * all the parameters is obviously the length of the command buffer, 00970000 * use that as the amount to add. 00980000 * 00990000 LR R2,R1 Save input parameter address 01000000 LA R4,SIZDATD Get length of basic workarea 01010000 L R3,CPPLCBUF-CPPL(,R2) Point to command buffer 01020000 AH R4,0(,R3) Add length of command buffer 01030000 LR R0,R4 01040000 GETMAIN R,LV=(0) 01050000 ST R13,4(,R1) 01060000 ST R1,8(,R13) 01070000 LR R13,R1 01080000 LR R9,R13 01090000 USING DATD,R9 01100000 ST R4,DATDLEN Save length of getmained area 01110000 LA R0,WORDCOPY Point to variable area 01120000 ST R0,WORDPTR Save address of it 01130000 MVC CPPL(16),0(R2) Set up our copy of CPPL 01140000 MVC IOPLUPT,CPPLUPT Pointer TO UPT 01150000 MVC IOPLECT,CPPLECT Pointer TO ECT 01160000 LA R0,ECB 01170000 ST R0,IOPLECB Pointer to user's ECB 01180000 MVC PTLIST(LENPUTL),MPTLIST Set up PUTLINE list form 01190000 LA R0,1 Define 1 message segment 01200000 LA R1,MSGHDR 01210000 STM R0,R1,OLD Make PUTLINE output line descriptor 01220000 * Initialize other data areas 01230000 STM R11,R12,MYBASES Base registers used in PARSE exits 01240000 MVI FLAGS,X'00' Clear flags 01250000 XR R0,R0 Make a zero 01260000 ST R0,APOSD 01270000 ST R0,LPOSD 01280000 ST R0,AKEYD 01290000 ST R0,LKEYD 01300000 ST R0,AKEYE 01310000 ST R0,POSCOUNT 01320000 ST R0,KEYCOUNT 01330000 ST R0,PWADDR 01340000 ST R0,PWLEN 01350000 ST R0,VBUFADDR 01360000 ST R0,VBUFLEN 01370000 ST R0,ARGADDR 01380000 ST R0,ARGLEN 01390000 * 01400000 EJECT 01410000 * 01420000 *********************************************************************** 01430000 * 01440000 * First, set things up so that SCAN can start scanning. On entry to 01450000 * the command, CPPLCBUF points to the command buffer. Halfword 1 is 01460000 * the length of the buffer plus 4, and halfword 2 is the offset of the 01470000 * first operand (if any) past the command name in the buffer (set by 01480000 * TSO's call to IKJSCAN). 01490000 * 01500000 *********************************************************************** 01510000 * 01520000 L R2,CPPLCBUF 01530000 LR R1,R2 01540000 AH R1,0(,R2) 01550000 ST R1,SCANEPTR Save end of command buffer 01560000 LA R1,4(,R2) 01570000 AH R1,2(,R2) 01580000 ST R1,SCANPTR Initialize scan pointer 01590000 XR R0,R0 01600000 ST R0,PARCOUNT Initialize parenthesis count 01610000 * 01620000 *********************************************************************** 01630000 * * 01640000 * Scan command buffer for first operand - must be input variable name * 01650000 * * 01660000 *********************************************************************** 01670000 * 01680000 BAL R14,SCAN Return R15 -> arg 01690000 B NOOPERANDS No value 01700000 B ARG1OK Unquoted name 01710000 B ERROR_NO_WANT_QS Quoted string found 01720000 B ERROR_NO_WANT_LP "(" found 01730000 B ERROR_NO_WANT_RP ")" found 01740000 B ERROR_NO_WANT_SL "/" found 01750000 SPACE 1 01760000 ARG1OK DS 0H 01770000 SPACE 1 01780000 * 01790000 *********************************************************************** 01800000 * * 01810000 * Validate first argument as a variable name so that it can be used * 01820000 * to retrieve CLIST/REXX variable value. * 01830000 * * 01840000 * We may not really have to do that here - just verify that it's not * 01850000 * a positional count. If it is a positional count, set the address * 01860000 * and length of the input variable to zero (extension to XPROC will * 01870000 * get value to parse from REXX argument string in that case). * 01880000 * * 01890000 *********************************************************************** 01900000 * 01910000 LR R3,R1 Save address 01920000 LR R4,R2 Save length 01930000 CH R2,=H'256' If it's too long for EX instruction 01940000 BH ERROR_FIRST_ARG then first arg is invalid 01950000 BCTR R2,0 Reduce for execute 01960000 EX R2,TRTPOSCT Scan for numerics 01970000 BNZ NOTPOSCOUNT If any non-numerics, not a count 01980000 XR R0,R0 Else make a zero 01990000 ST R0,PVARADDR Clear address of the variable 02000000 ST R0,PVARLEN Clear length of the variable 02010000 B ISACOUNT Process this as the pos parm count 02020000 SPACE 1 02030000 NOTPOSCOUNT DS 0H Not a count - assume a variable name 02040000 LR R14,R3 Get address of variable name 02050000 LA R1,PVAR Point to place to build var name 02060000 ST R1,PVARADDR Save address of the variable 02070000 ST R4,PVARLEN Save length of the variable 02080000 BCTR R4,0 Reduce for execute 02090000 EX R4,MVCWORD Move word to PVAR 02100000 EX R4,UPWORD Translate to uppercase 02110000 SPACE 1 02120000 * 02130000 *********************************************************************** 02140000 * * 02150000 * Scan command buffer for next operand - must be count of positionals * 02160000 * * 02170000 *********************************************************************** 02180000 * 02190000 BAL R14,SCAN 02200000 B NOPOSCOUNT No value 02210000 B ARG2OK Unquoted name 02220000 B ERROR_NO_WANT_QS Quoted string found 02230000 B ERROR_NO_WANT_LP "(" found 02240000 B ERROR_NO_WANT_RP ")" found 02250000 B ERROR_NO_WANT_SL "/" found 02260000 SPACE 1 02270000 ARG2OK DS 0H We have what should be a count... 02280000 LR R3,R1 Get address of argument 02290000 LR R4,R2 Get length of argument 02300000 ISACOUNT DS 0H Here for first non-alpha arg... 02310000 * 02320000 *********************************************************************** 02330000 * * 02340000 * Validate this argument as a number so that it can be used to count * 02350000 * the number of positional parameters. * 02360000 * * 02370000 *********************************************************************** 02380000 * 02390000 BCTR R4,0 Reduce for execute 02400000 CH R4,=H'7' If positional count more than 8 digs 02410000 BH BADPOSCOUNT then invalid value 02420000 EX R4,TRTPOSCT Scan for numerics 02430000 BNZ BADPOSCOUNT If any non-numerics, invalid value 02440000 EX R4,PACKIT Convert to numeric 02450000 CVB R0,DOUBLE Get binary value 02460000 ST R0,POSCOUNT Store positional parameter count 02470000 SPACE 1 02480000 * 02490000 *********************************************************************** 02500000 * * 02510000 * We are about to start collecting all parameter names, both * 02520000 * positional and keyword. While we do this, we determine how much * 02530000 * space will be needed for IKJPARS control blocks. * 02540000 * * 02550000 * Compute storage needed for the PCL (built by us): * 02560000 * * 02570000 * For initial overhead: 7 * 02580000 * For each positional parameter: 56 + (2 * length(min(name,234))) * 02590000 * For each keyword with a value: 66 + (2 * length(min(name,237))) * 02600000 * + length(name) * 02610000 * For each keyword without value: 11 + length(name) * 02620000 * * 02630000 * Compute storage reserved for the PDL (built by IKJPARS): * 02640000 * * 02650000 * For initial overhead: 8 * 02660000 * For each positional parameter: 8 * 02670000 * For each keyword: 2 * 02680000 * For each value subfield: 8 * 02690000 * * 02700000 *********************************************************************** 02710000 * 02720000 LA R0,7 Set PCL amount to initial value 02730000 ST R0,PCLLEN 02740000 XR R0,R0 Set quoted-value-strings length 02750000 ST R0,QVALLEN 02760000 LA R0,8 Set PDL initial total length 02770000 ST R0,PDLLEN 02780000 * 02790000 *********************************************************************** 02800000 * * 02810000 * Get storage to hold information for as many positional parameters * 02820000 * as we have defined. * 02830000 * * 02840000 *********************************************************************** 02850000 * 02860000 ICM R5,15,POSCOUNT Get count of positional parameters 02870000 BZ NOPOZZES If zero, no positional parameters 02880000 MH R5,=Y(POSDDATL) Get total length to acquire 02890000 GETMAIN RC,LV=(R5),LOC=ANY Get storage 02900000 LTR R15,R15 If GETMAIN failed, 02910000 BNZ BADPOSCOUNT then positional count too big 02920000 ST R1,APOSD Save address of this area 02930000 ST R5,LPOSD Save length of this area 02940000 LR R4,R1 Address first entry in area 02950000 USING POSDDATA,R4 02960000 * 02970000 *********************************************************************** 02980000 * * 02990000 * Loop (positional-parameter-count) times, collecting variable names. * 03000000 * * 03010000 *********************************************************************** 03020000 * 03030000 NI FLAGS,255-FLAGPOSD Not currently processing anything 03040000 NI FLAGS,255-FLAGKEYD 03050000 XR R0,R0 Zero out error fields 03060000 ST R0,LASTADDR 03070000 ST R0,LASTLEN 03080000 ST R0,LASTAREA 03090000 L R8,POSCOUNT Get count of positional parameters 03100000 PPLOOP DS 0H R5 contains count of parms to get 03110000 BAL R14,SCAN Get a positional parame 03120000 B PPMISSING No value 03130000 B PPADD Unquoted name 03140000 B ERROR_NO_WANT_QS Quoted string found 03150000 B PPLP "(" found 03160000 B ERROR_NO_WANT_RP ")" found 03170000 B PPSLASH "/" found 03180000 SPACE 1 03190000 PPLP DS 0H "(" found when a positional expected 03200000 C R8,POSCOUNT If no pos. parms found yet 03210000 BE ERROR_NO_WANT_LP then this is truly an error; else 03220000 * (future extension, but error now) 03230000 L R3,LASTADDR Get address of last processed P.P. 03240000 L R2,LASTLEN Get length of last processed P.P. 03250000 B ERROR_PP_WITH_LP say value spec not allowed 03260000 SPACE 1 03270000 PPSLASH DS 0H "/" found when a positional expected 03280000 BAL R14,DOOPTS Process options 03290000 B PPLOOP 03300000 SPACE 1 03310000 PPADD DS 0H Add a positional parameter 03320000 * 03330000 * Check parameter for validity, and (if it's OK) make uppercase copy 03340000 * of it in our area. 03350000 * 03360000 CH R2,=H'255' If too long 03370000 BH ERROR_PARM_TOO_LONG then error 03380000 LR R14,R1 Address 03390000 LR R15,R2 Length 03400000 BCTR R15,0 Reduce length for execute 03410000 EX R15,VERIFYP Check syntax of parameter 03420000 BNZ ERROR_PARM_INVALID If bad, error 03430000 CLI 0(R14),C'0' Must not begin with numeric 03440000 BNL ERROR_PARM_INVALID If bad, error 03450000 L R1,WORDPTR Get next available word slot 03460000 EX R15,MVCWORD Move word to slot 03470000 EX R15,UPWORD Translate to uppercase 03480000 LA R0,1(R15,R1) Update slot pointer 03490000 ST R0,WORDPTR for next time 03500000 * 03510000 * Check for duplicates. R1 -> new word, R15 = length-1 03520000 * 03530000 L R2,APOSD Get address of first positional 03540000 LA R0,1(,R15) Get true length 03550000 CDPPLOOP DS 0H Loop to check for duplicates 03560000 CR R2,R4 until we hit current PP slot 03570000 BNL CDPPLEND 03580000 C R0,POSDLEN-POSDDATA(,R2) 03590000 BNE CDPPNEXT If lengths don't match, continue 03600000 L R14,POSDADDR-POSDDATA(,R2) Point to old parameter 03610000 EX R15,COMPWORD If values are equal, 03620000 BE ERROR_PARM_DUPLICATE then error 03630000 CDPPNEXT LA R2,POSDDATL(,R2) Else continue 03640000 B CDPPLOOP 03650000 CDPPLEND DS 0H End loop to check for duplicates 03660000 LA R2,1(,R15) Get length 03670000 ST R1,POSDADDR Save address of this pos. parm. 03680000 ST R2,POSDLEN Save length of this pos. parm. 03690000 XR R0,R0 Clear other fields 03700000 ST R0,POSDPCEA 03710000 MVI POSDFLGS,0 03720000 ST R4,LASTAREA Save for option/error processing 03730000 ST R1,LASTADDR Save for option/error processing 03740000 ST R2,LASTLEN Save for option/error processing 03750000 OI FLAGS,FLAGPOSD Say currently processing positional 03760000 NI FLAGS,255-FLAGKEYD 03770000 * 03780000 * PCE length for positional param: 56 + (2 * length(min(name,234))) 03790000 * PDE length for positional param: 8 03800000 * 03810000 LR R15,R2 Get length of positional parm name 03820000 CH R15,=H'234' If longer than 255-21 03830000 BNH *+8 then 03840000 LA R15,255-21 set length to 255-21 03850000 ST R15,POSDMAXL Store this length 03860000 SLA R15,1 2 * length(min(name,234)) 03870000 LA R15,56(,R15) 56 + (2 * length(min(name,234))) 03880000 ST R15,POSDPCEL Set length of PCE for this parameter 03890000 A R15,PCLLEN Accumulate PCL length 03900000 ST R15,PCLLEN 03910000 LA R1,8 Length of PDE for positional = 8 03920000 A R1,PDLLEN Accumulate PDL length 03930000 ST R1,PDLLEN 03940000 LA R4,POSDDATL(,R4) Bump pointer 03950000 BCT R8,PPLOOP Loop until count exhausted 03960000 SPACE 1 03970000 NOPOZZES DS 0H Here if no positional parameters 03980000 SPACE 1 03990000 * 04000000 *********************************************************************** 04010000 * * 04020000 * Get storage to hold information for keyword and value parameters. * 04030000 * We don't know how much we'll need yet, so we'll get a chunk of it * 04040000 * and hope for the best. * 04050000 * * 04060000 *********************************************************************** 04070000 * 04080000 L R5,KEYDINCR Get estimated initial length 04090000 GETMAIN RC,LV=(R5),LOC=ANY Get storage 04100000 LTR R15,R15 04110000 BNZ GETMAIN_FAILURE 04120000 ST R1,AKEYD Save address of this area 04130000 ST R5,LKEYD Save length of this area 04140000 XR R4,R4 Start things off 04150000 USING KEYDDATA,R4 04160000 LA R0,0(R1,R5) Point to end of area 04170000 ST R0,AKEYE Save address of end 04180000 * 04190000 *********************************************************************** 04200000 * * 04210000 * Loop collecting keywords and keyword/value pairs. * 04220000 * * 04230000 *********************************************************************** 04240000 * 04250000 XR R6,R6 Clear keyword count 04260000 KVLOOP DS 0H 04270000 BAL R14,SCAN Get a keyword parameter 04280000 B KVEND No more 04290000 B KVADD Unquoted name 04300000 B ERROR_NO_WANT_QS Quoted string found 04310000 B KVLP "(" found 04320000 B ERROR_NO_WANT_RP ")" found 04330000 B KVSLASH "/" found 04340000 SPACE 1 04350000 KVLP DS 0H "(" found when a keyword expected 04360000 LTR R6,R6 If we've seen keyword parms already 04370000 BNZ ERROR_NO_WANT_LP then this is truly an error 04380000 ICM R0,15,POSCOUNT Else if no positional parameters 04390000 BZ ERROR_NO_WANT_LP then this is truly an error. Else, 04400000 * (future extension, but error now) 04410000 L R3,LASTADDR Get address of last processed P.P. 04420000 L R2,LASTLEN Get length of last processed P.P. 04430000 B ERROR_PP_WITH_LP say value spec w/p.p. not allowed 04440000 SPACE 1 04450000 KVSLASH DS 0H "/" found when a keyword expected 04460000 BAL R14,DOOPTS Process options 04470000 B KVLOOP 04480000 SPACE 1 04490000 KVADD DS 0H Add a keyword parameter 04500000 OI FLAGS,FLAGKEYD Say we're currently processing 04510000 NI FLAGS,255-FLAGPOSD keyword/value parameters 04520000 LTR R4,R4 If we haven't got any keywords yet 04530000 BNZ KVNZ then 04540000 L R4,AKEYD point to first entry in area 04550000 B KVA and do our stuff. 04560000 KVNZ DS 0H Else... 04570000 LA R4,KEYDDATL(,R4) Bump pointer 04580000 C R4,AKEYE If this takes us past end of buffer 04590000 BL KVA then... #TSO147 04600000 STM R1,R2,SCANRES Store result of scan 04610000 L R5,LKEYD get length of current area 04620000 A R5,KEYDINCR increment it 04630000 GETMAIN RC,LV=(R5),LOC=ANY get storage 04640000 LTR R15,R15 04650000 BNZ GETMAIN_FAILURE 04660000 LR R2,R1 Address of new key area 04670000 LR R0,R2 Address of new key area 04680000 L R14,AKEYD Address of old key area 04690000 L R1,LKEYD Length of old key area 04700000 LR R15,R1 Length of old key area 04710000 MVCL R0,R14 Move old key data to new key data 04720000 LR R4,R0 Point to slot in new key area 04730000 L R1,AKEYD Address of old key area 04740000 L R0,LKEYD Length of old key area 04750000 FREEMAIN RC,LV=(0),A=(1) Free the old key area 04760000 ST R2,AKEYD Save address of new area 04770000 ST R5,LKEYD Save length of new area 04780000 LA R0,0(R2,R5) Point to end of area 04790000 ST R0,AKEYE Save address of end 04800000 LM R1,R2,SCANRES Load results of scan 04810000 KVA DS 0H 04820000 * 04830000 * Check parameter for validity, and (if it's OK) make uppercase copy 04840000 * of it in our area. 04850000 * 04860000 CH R2,=H'255' If too long 04870000 BH ERROR_PARM_TOO_LONG then error 04880000 LR R14,R1 Address 04890000 LR R15,R2 Length 04900000 BCTR R15,0 Reduce length for execute 04910000 EX R15,VERIFYP Check syntax of parameter 04920000 BNZ ERROR_PARM_INVALID If bad, error 04930000 CLI 0(R14),C'0' Must not begin with numeric 04940000 BNL ERROR_PARM_INVALID If bad, error 04950000 L R1,WORDPTR Get next available word slot 04960000 EX R15,MVCWORD Move word to slot 04970000 EX R15,UPWORD Translate to uppercase 04980000 LA R0,1(R15,R1) Update slot pointer 04990000 ST R0,WORDPTR for next time 05000000 * 05010000 * Check for duplicates. R1 -> new word, R15 = length-1 05020000 * 05030000 ICM R8,15,POSCOUNT Get count of positionals 05040000 BZ KVPPLEND If none, don't check 'em, obviously 05050000 L R2,APOSD Get address of first positional 05060000 LA R0,1(,R15) Get true length 05070000 KVPPLOOP DS 0H Loop to check for duplicates 05080000 C R0,POSDLEN-POSDDATA(,R2) 05090000 BNE KVPPNEXT If lengths don't match, continue 05100000 L R14,POSDADDR-POSDDATA(,R2) Point to old parameter 05110000 EX R15,COMPWORD If values are equal, 05120000 BE ERROR_PARM_DUPLICATE then error 05130000 KVPPNEXT LA R2,POSDDATL(,R2) Else continue 05140000 BCT R8,KVPPLOOP until no more positionals 05150000 KVPPLEND DS 0H End loop to check for duplicates 05160000 * Now check against keywords so far 05170000 LTR R8,R6 Get count of keywords 05180000 BZ KVKWLEND If none so far, don't check 'em 05190000 L R2,AKEYD Get address of first keyword 05200000 LA R0,1(,R15) Get true length 05210000 KVKWLOOP DS 0H Loop to check for duplicates 05220000 C R0,KEYWORDL-KEYDDATA(,R2) 05230000 BNE KVKWNEXT If lengths don't match, continue 05240000 L R14,KEYWORDA-KEYDDATA(,R2) Point to old parameter 05250000 EX R15,COMPWORD If values are equal, 05260000 BE ERROR_PARM_DUPLICATE then error 05270000 KVKWNEXT LA R2,KEYDDATL(,R2) Else continue 05280000 BCT R8,KVKWLOOP until no more keywords 05290000 KVKWLEND DS 0H End loop to check for duplicates 05300000 LA R6,1(,R6) Increment keyword count 05310000 LA R2,1(,R15) Get length 05320000 ST R1,KEYWORDA Save address of this pos. parm. 05330000 ST R2,KEYWORDL Save length of this pos. parm. 05340000 ST R4,LASTAREA Save for option/error processing 05350000 ST R1,LASTADDR Save for option/error processing 05360000 ST R2,LASTLEN Save for option/error processing 05370000 XR R0,R0 Clear other keyword/value fields 05380000 ST R0,KEYDVALA 05390000 ST R0,KEYDVALL 05400000 ST R0,KEYDPCEA 05410000 ST R0,KEYDPCEL 05420000 ST R0,KEYDMAXL 05430000 ST R0,KEYSUBOF 05440000 MVI KEYFLAGS,0 05450000 KVOLOOP DS 0H 05460000 * 05470000 * Now get the next thing, which might be a parenthesized default value 05480000 * or a slashed keyword processing option 05490000 * 05500000 BAL R14,SCAN Get a keyword parameter 05510000 B KVFINEND No more 05520000 B KVFINADD Unquoted name, it's another keyword 05530000 B ERROR_NO_WANT_QS Quoted string found 05540000 B KVVALUE "(" found 05550000 B ERROR_NO_WANT_RP ")" found 05560000 B KVOPTION "/" found 05570000 SPACE 1 05580000 KVOPTION DS 0H We (probably) have a /option... 05590000 BAL R14,DOOPTS Process options 05600000 B KVOLOOP 05610000 SPACE 1 05620000 KVVALUE DS 0H We (probably) have a value... 05630000 SPACE 1 05640000 * 05650000 * Scan for the value (can be any kind of string). 05660000 * 05670000 BAL R14,SCAN Get a value string 05680000 B KVNULL End of buffer, value is null 05690000 B KVWORD Unquoted name, it's a value 05700000 B KVSTRING Quoted string found, it's a value 05710000 B KVERROR "(" found, should never happen 05720000 B KVNULL ")" found, value is null 05730000 B KVERROR "/" found, should never happen 05740000 SPACE 1 05750000 KVWORD DS 0H Unquoted word is the value 05760000 ST R1,KEYDVALA Store address of default value 05770000 ST R2,KEYDVALL Store length of default value 05780000 OI KEYFLAGS,KEYFDVAL Indicate a default value present 05790000 B KVGETRP Go get right paren 05800000 SPACE 1 05810000 KVSTRING DS 0H Quoted string is the value 05820000 ST R1,KEYDVALA Store address of default value 05830000 ST R2,KEYDVALL Store length of default value 05840000 OI KEYFLAGS,KEYFDVAL Indicate a default value present 05850000 OI KEYFLAGS,KEYFQUOT Indicate it's a quoted string 05860000 B KVGETRP Go get right paren 05870000 SPACE 1 05880000 KVGETRP DS 0H Time to terminate the value... 05890000 * 05900000 * Scan for the right parenthesis that ends the value spec 05910000 * 05920000 BAL R14,SCAN Get a value string 05930000 B KVFINEND End of buffer 05940000 B KVEXTRA Unquoted name, shouldn't be there 05950000 B KVEXTRA Quoted string, shouldn't be there 05960000 B KVERROR "(" found, should never happen 05970000 B KVFINLOP ")" found, OK, continue looping 05980000 B KVERROR "/" found, should never happen 05990000 SPACE 1 06000000 KVEXTRA DS 0H 06010000 * (future extension, but for now) 06020000 LR R3,R1 Get address of extraneous data 06030000 ******** LR R2,R2 Get length of extraneous data 06040000 LA R1,MSG_EXTRANEOUS Ignore extraneous info 06050000 LA R0,L'MSG_EXTRANEOUS 06060000 BAL R14,PUTLINE 06070000 B KVGETRP Keep looking for that right paren 06080000 SPACE 1 06090000 KVNULL DS 0H 06100000 OI KEYFLAGS,KEYFDVAL Indicate a default value present 06110000 LA R14,KVLOOP (but it's null) 06120000 B KVACCUM Accumulate length, then get next KW 06130000 SPACE 1 06140000 KVFINLOP DS 0H End keyword(value), another follows 06150000 LA R14,KVLOOP Proceed to KVLOOP after doing... 06160000 B KVACCUM accumulation for this keyword 06170000 SPACE 1 06180000 KVFINADD DS 0H End this keyword, another follows 06190000 LA R14,KVADD Proceed to KVADD after doing... 06200000 B KVACCUM accumulation for this keyword 06210000 SPACE 1 06220000 KVFINEND DS 0H End this keyword, no more follow 06230000 LA R14,KVEND Proceed to KVEND after doing... 06240000 ******** B KVACCUM accumulation for this keyword 06250000 SPACE 1 06260000 KVACCUM DS 0H 06270000 * 06280000 * Calculate PCE and PDE lengths for keyword parameter 06290000 * For each keyword with a value: 06300000 * 66 + (2 * length(min(name,237))) + length(name) 06310000 * For each keyword without value: 06320000 * 11 + length(name) 06330000 * 06340000 * We're going to use the same storage to build unquoted values of 06350000 * keywords, so add that length in too. 06360000 * 06370000 STM R1,R2,SCANRES Save results of scan 06380000 L R15,KEYWORDL Get length of keyword name 06390000 TM KEYFLAGS,KEYFDVAL If a value specified 06400000 BNO PCKWNVAL then... 06410000 CH R15,=H'237' min(name,237) 06420000 BNH *+8 06430000 LA R15,237 06440000 ST R15,KEYDMAXL Save this length 06450000 SLA R15,1 2 * length(min(name,237)) 06460000 LA R15,66(,R15) 66 + (2 * length(min(name,237))) 06470000 A R15,KEYWORDL 66 + ... + length(name) 06480000 LA R1,8 Accumulate PDL length for subfield 06490000 A R1,PDLLEN 06500000 ST R1,PDLLEN 06510000 TM KEYFLAGS,KEYFQUOT If value is quoted string 06520000 BNO PCKWNEXT then... 06530000 L R1,KEYDVALL accumulate value length 06540000 A R1,QVALLEN 06550000 ST R1,QVALLEN (actual'll be less, but never more) 06560000 B PCKWNEXT 06570000 PCKWNVAL DS 0H No value specified... 06580000 LA R15,11(,R15) just 11 + length(name) 06590000 PCKWNEXT DS 0H 06600000 ST R15,KEYDPCEL Save PCE length 06610000 A R15,PCLLEN Accumulate PCL length for keyword 06620000 ST R15,PCLLEN 06630000 LA R1,2 Accumulate PDL length for keyword 06640000 A R1,PDLLEN 06650000 ST R1,PDLLEN 06660000 LM R1,R2,SCANRES Load results of scan 06670000 BR R14 Go to KVADD or KVEND or KVLOOP 06680000 SPACE 1 06690000 KVEND DS 0H No more parameters of any kind 06700000 SPACE 1 06710000 ST R6,KEYCOUNT Save number of keywords 06720000 SPACE 1 06730000 EJECT 06740000 *********************************************************************** 06750000 * * 06760000 * Prepare to build control blocks for IKJPARS for the parameters, * 06770000 * like so: * 06780000 * * 06790000 * IKJPARM * 06800000 * * 06810000 * For each positional parameter "pp": * 06820000 * * 06830000 * IKJIDENT 'POSITIONAL PARAMETER pp', * 06840000 * ASIS, /* only if the /ASIS option is specified */ * 06850000 * CHAR, /* only if /QUOTABLE option is specified */ * 06860000 * FIRST=ANY,OTHER=ANY, * 06870000 * PROMPT='POSITIONAL PARAMETER pp' * 06880000 * * 06890000 * For each keyword parameter "kv" with a value "val"; * 06900000 * * 06910000 * IKJKEYWD * 06920000 * IKJNAME 'kv',SUBFLD=kvsubfld * 06930000 * * 06940000 * For each keyword parameter "kw" without a value: * 06950000 * * 06960000 * IKJKEYWD * 06970000 * IKJNAME 'kv' * 06980000 * * 06990000 * For each keyword parameter "kv" with a value "val", as above: * 07000000 * * 07010000 * kvsubfld IKJSUBF * 07020000 * IKJIDENT 'VALUE FOR KEYWORD kv', * 07030000 * ASIS, /* only if the /ASIS option is specified */ * 07040000 * CHAR, * 07050000 * PROMPT='VALUE FOR KEYWORD kv' * 07060000 * * 07070000 * IKJENDP * 07080000 * * 07090000 * Note that the default value from the specifications is not part of * 07100000 * the IKJPARS parameters. Rather, the absence of the keyword is * 07110000 * detected after the call to PARSE and, at that point, the default * 07120000 * value is used if the terminal user did not provide one. * 07130000 * * 07140000 * Compute storage needed for the PCL (built by us): * 07150000 * * 07160000 * For initial overhead: 7 * 07170000 * For each positional parameter: 56 + (2 * length(name)) * 07180000 * For each keyword with a value: 66 + (3 * length(name)) * 07190000 * For each keyword without value: 11 + length(name) * 07200000 * * 07210000 * Compute storage reserved for the PDL (built by IKJPARS): * 07220000 * * 07230000 * For initial overhead: 8 * 07240000 * For each positional parameter: 8 * 07250000 * For each keyword: 2 * 07260000 * For each value subfield: 8 * 07270000 * * 07280000 * We're going to use the same storage to build unquoted values of * 07290000 * keywords, so add that length in too. Also, we want to include * 07300000 * storage for the final call to IKJCT441 to update all parameters. * 07310000 * How much storage is needed to build the parameter list: 9 words * 07320000 * for each parameter, plus 4 extra words = 13*4. * 07330000 * * 07340000 *********************************************************************** 07350000 EJECT 07360000 * 07370000 * Get storage for the PCL plus dequoted value strings plus IKJCT441 PL 07380000 * 07390000 L R1,PDLLEN 07400000 LA R1,7(,R1) Round PDL length 07410000 N R1,=X'FFFFFFF8' up to doubleword boundary 07420000 ST R1,PDLLEN Store length of PDL 07430000 LA R1,8 07440000 A R1,QVALLEN Quoted-string-length + fudge factor 07450000 ST R1,QVALLEN Store length of quoted-value area 07460000 A R1,PCLLEN Get length of PCL plus quoted area 07470000 L R0,POSCOUNT Get count of positional parameters 07480000 A R0,KEYCOUNT Add count of positional parameters 07490000 MH R0,=Y(13*4) Compute # of plists required 07500000 ST R0,VUPLEN Store length of IKJCTT41 parm list 07510000 AR R0,R1 Add to total length 07520000 ST R0,PWLEN Store length of this area 07530000 GETMAIN RC,LV=(0),LOC=ANY Get it 07540000 LTR R15,R15 If didn't get it, error 07550000 BNZ GETMAIN_FAILURE 07560000 ST R1,PWADDR Save address thereof 07570000 LR R4,R1 Initialize PCL entry pointer 07580000 LA R5,8 Initialize PDL offset value 07590000 XR R0,R0 Clear other PCE-related junk 07600000 ST R0,FIRSTKEY 07610000 ST R0,SUBTOSET 07620000 * 07630000 * Build the IKJPARM part of the PCL. 07640000 * 07650000 * PCE contents: +0 (2) Length of entire PCL 07660000 * +2 (2) Length of PDL returned by PARSE 07670000 * +4 (2) Offset in PDL to first IKJKEYWD PCE 07680000 * (or to end-of-field indicator, i.e. 07690000 * the x'0000' in an IKJSUBF or IKJENDP) 07700000 * 07710000 * ... ..,0(,R4) Leave this unset for now... 07720000 L R0,PDLLEN 07730000 STH R0,2(,R4) IKJPARM +2 (2) Length of PDL 07740000 * ... ..,4(,R4) Leave this unset for now... 07750000 LA R4,6(,R4) Bump past this PCE 07760000 * 07770000 * For each positional parameter, build an IKJIDENT PCE. 07780000 * 07790000 * PCE contents: +0 (1) Flags: B'1001 0100' (IKJIDENT, PROMPT) 07800000 * +1 (1) Flags: B'0x00 0000' (x = 1 if ASIS, else 0) 07810000 * +2 (2) Length of this PCE: 56 + 2*length(name) 07820000 * +4 (2) Offset in PDL to PDE for this parameter 07830000 * +6 (1) Flags: B'0000 x000' (x = 1 if CHAR, else 0) 07840000 * +7 (1) X'00' (FIRST=ANY) 07850000 * +8 (1) X'00' (OTHER=ANY) 07860000 * +9 (2) Length of 'POSITIONAL PARAMETER pp' + 4 07870000 * (25 + length(name)) 07880000 * +B (2) X'0012' 07890000 * +D (*) 'POSITIONAL PARAMETER pp' (21 + length(name)) 07900000 * +* (1) Length of 'POSITIONAL PARAMETER pp' - 1 07910000 * (20 + length(name)) 07920000 * +* (*) 'POSITIONAL PARAMETER pp' (21 + length(name)) 07930000 * 07940000 ICM R8,15,POSCOUNT Get count of positionals 07950000 BZ PBPPLEND If none, skip 07960000 L R2,APOSD Get address of first positional 07970000 PBPPLOOP DS 0H Loop to build PCE's 07980000 ST R4,POSDPCEA-POSDDATA(,R2) Set address of PCE for this 07990000 MVI 0(R4),B'10010100' +0 (1) Flags 08000000 TM POSDFLGS-POSDDATA(R2),POSDASIS If /ASIS option given 08010000 BZ PBPPNASI then 08020000 MVI 1(R4),B'01000000' +1 (1) Flags 08030000 B PBPPAEND else 08040000 PBPPNASI MVI 1(R4),B'00000000' +1 (1) Flags 08050000 PBPPAEND DS 0H 08060000 L R14,POSDPCEL-POSDDATA(,R2) Get length of PCE 08070000 STH R14,2(,R4) +2 (2) Length of this PCE 08080000 STH R5,4(,R4) +4 (2) Offset in PDL to PDE for this 08090000 TM POSDFLGS-POSDDATA(R2),POSDCHAR If /QUOTABLE option given 08100000 BZ PBPPNCHA then 08110000 MVI 6(R4),B'00001000' +6 (1) Flags 08120000 B PBPPCEND else 08130000 PBPPNCHA MVI 6(R4),B'00000000' +6 (1) Flags 08140000 PBPPCEND DS 0H 08150000 MVI 7(R4),X'00' +7 (1) X'00' (FIRST=ANY) 08160000 MVI 8(R4),X'00' +8 (1) X'00' (OTHER=ANY) 08170000 L R15,POSDMAXL-POSDDATA(,R2) Get length of name for prompt 08180000 LA R0,25(,R15) 21 + length(name) + 4 08190000 STH R0,9(,R4) +9 (2) Length of '...' + 4 08200000 MVC 11(2,R4),=X'0012' +B (2) X'0012' 08210000 MVC 13(21,R4),=C'POSITIONAL PARAMETER ' 08220000 LA R4,13+21(,R4) Point to where to move param name 08230000 BCTR R15,0 Reduce length for execute 08240000 L R1,POSDADDR-POSDDATA(,R2) Get address of parameter name 08250000 EX R15,MVCTOPCE Move parameter name to PCL 08260000 LA R4,1(R15,R4) Bump PCE pointer 08270000 LA R0,21(,R15) 21 + length(name) - 1 08280000 STC R0,0(,R4) Length of prompt data 08290000 MVC 1(21,R4),=C'POSITIONAL PARAMETER ' 08300000 LA R4,1+21(,R4) Point to where to move param name 08310000 EX R15,MVCTOPCE Move parameter name to PCL 08320000 LA R4,1(R15,R4) Bump PCE pointer 08330000 LA R5,8(,R5) Increment PDE offset 08340000 LA R2,POSDDATL(,R2) Continue 08350000 BCT R8,PBPPLOOP until no more positionals 08360000 PBPPLEND DS 0H End loop 08370000 * 08380000 * For each keyword parameter, build an IKJKEYWD PCE. 08390000 * 08400000 * PCE contents: +0 (1) Flags: B'0100 0000' (IKJKEYWD) 08410000 * +1 (1) Flags: B'0000 0000' 08420000 * +2 (2) Length of this PCE: 6 08430000 * +4 (2) Offset in PDL to PDE for this parameter 08440000 * 08450000 * If the keyword has a value, build an IKJNAME PCE as follows: 08460000 * 08470000 * PCE contents: +0 (1) Flags: B'0110 0100' (IKJNAME, has subfield) 08480000 * +1 (1) Flags: B'0000 0000' 08490000 * +2 (2) Length of this PCE: 7 + length(name) 08500000 * +4 (1) Length of keyword name minus 1 08510000 * +5 (*) the keyword name 08520000 * +* (2) offset (plus 1) in PCL to subfield PCE 08530000 * 08540000 * A subfield will be built as well. But not now. 08550000 * 08560000 * If the keyword doesn't have a value, build an IKJNAME PCE as follows: 08570000 * 08580000 * PCE contents: +0 (1) Flags: B'0110 0000' (IKJNAME, no subfield) 08590000 * +1 (1) Flags: B'0000 0000' 08600000 * +2 (2) Length of this PCE: 5 + length(name) 08610000 * +4 (1) Length of keyword name minus 1 08620000 * +5 (*) the keyword name 08630000 * 08640000 ICM R8,15,KEYCOUNT Get count of keywords 08650000 BZ PBKWLEND If none, skip 08660000 L R2,AKEYD Get address of first keyword 08670000 PBKWLOOP DS 0H Loop to build PCE's 08680000 * 08690000 * Build IKJKEYWD PCE 08700000 * 08710000 ICM R0,15,FIRSTKEY If this is first keyword 08720000 BNZ *+8 then 08730000 ST R4,FIRSTKEY set address of first keyword PCE 08740000 ST R4,KEYDPCEA-KEYDDATA(,R2) Set address of PCE for this 08750000 MVI 0(R4),B'01000000' +0 (1) Flags (IKJKEYWD) 08760000 MVI 1(R4),B'00000000' +1 (1) Flags 08770000 LA R0,6 08780000 STH R0,2(,R4) +2 (2) Length of this PCE 08790000 STH R5,4(,R4) +4 (2) Offset in PDL to PDE for this 08800000 LA R4,6(,R4) Bump PCE pointer 08810000 * 08820000 * Build IKJNAME PCE, format of which depends if with value or not. 08830000 * 08840000 TM KEYFLAGS-KEYDDATA(R2),KEYFDVAL If a value specified 08850000 BNO PBKWNVAL then... 08860000 MVI 0(R4),B'01100100' +0 (1) Flags (IKJNAME, has subfield) 08870000 MVI 1(R4),B'00000000' +1 (1) Flags 08880000 L R15,KEYWORDL-KEYDDATA(,R2) Get length of parameter name 08890000 LA R0,7(,R15) 7 + length(name) 08900000 STH R0,2(,R4) +2 (2) Length of this PCE 08910000 BCTR R15,0 Length minus 1 for store & execute 08920000 STC R15,4(,R4) +4 (1) Length of keyword name - 1 08930000 LA R4,5(,R4) Point to where to move keyword name 08940000 L R1,KEYWORDA-KEYDDATA(,R2) Get address of keyword name 08950000 EX R15,MVCTOPCE Move keyword name to PCE 08960000 LA R4,1(R15,R4) Bump past name 08970000 ST R4,KEYSUBOF-KEYDDATA(,R2) Save where to set subfield off 08980000 * ... ...0(,R4) Leave subfield offset out for now 08990000 LA R4,2(,R4) Bump to end of PCE 09000000 B PBKWNEXT 09010000 PBKWNVAL DS 0H No value specified... 09020000 TM KEYFLAGS-KEYDDATA(R2),KEYFASIS If /ASIS was specified 09030000 BO ERROR_ASIS_NEEDS_VAL then error 09040000 MVI 0(R4),B'01100000' +0 (1) Flags (IKJNAME, no subfield) 09050000 MVI 1(R4),B'00000000' +1 (1) Flags 09060000 L R15,KEYWORDL-KEYDDATA(,R2) Get length of parameter name 09070000 LA R0,5(,R15) 5 + length(name) 09080000 STH R0,2(,R4) +2 (2) Length of this PCE 09090000 BCTR R15,0 Length minus 1 for store & execute 09100000 STC R15,4(,R4) +4 (1) Length of keyword name - 1 09110000 LA R4,5(,R4) Point to where to move keyword name 09120000 L R1,KEYWORDA-KEYDDATA(,R2) Get address of keyword name 09130000 EX R15,MVCTOPCE Move keyword name to PCE 09140000 LA R4,1(R15,R4) Bump past name 09150000 ******** LA R4,0(,R4) Bump to end of PCE 09160000 PBKWNEXT DS 0H 09170000 LA R5,2(,R5) Increment PDE offset 09180000 LA R2,KEYDDATL(,R2) Continue 09190000 BCT R8,PBKWLOOP until no more keywords 09200000 PBKWLEND DS 0H End loop 09210000 * 09220000 * For each keyword parameter with a value, build subfield PCE's. 09230000 * 09240000 * Build an IKJSUBF PCE. 09250000 * 09260000 * PCE contents: +0 (1) Flags: B'0000 0000' (end-of-field indicator) 09270000 * +1 (2) Offset in PCL to next end-of-field indicator 09280000 * (either the next IKJSUBF or the IKJENDP). 09290000 * If the subfield had keywords, this would have 09300000 * to point to the next IKJKEYWD PCE therein. 09310000 * 09320000 * Build an IKJIDENT PCE for the keyword value. 09330000 * 09340000 * PCE contents: +0 (1) Flags: B'1001 0100' (IKJIDENT, PROMPT) 09350000 * +1 (1) Flags: B'0x00 0000' (x = 1 if ASIS, else 0) 09360000 * +2 (2) Length of this PCE: 50 + 2*length(name) 09370000 * +4 (2) Offset in PDL to PDE for this parameter 09380000 * +6 (1) Flags: B'0000 1000' (CHAR) 09390000 * +7 (1) X'01' (FIRST= is not applicable) 09400000 * +8 (1) X'01' (OTHER= is not applicable) 09410000 * +9 (2) Length of 'VALUE FOR KEYWORD pp' + 4 09420000 * (22 + length(name)) 09430000 * +B (2) X'0012' 09440000 * +D (*) 'VALUE FOR KEYWORD pp' (18 + length(name)) 09450000 * +* (1) Length of 'VALUE FOR KEYWORD pp' - 1 09460000 * (17 + length(name)) 09470000 * +* (*) 'VALUE FOR KEYWORD pp' (18 + length(name)) 09480000 * 09490000 ICM R8,15,KEYCOUNT Get count of keywords 09500000 BZ PSKWLEND If none, skip 09510000 L R2,AKEYD Get address of first keyword 09520000 PSKWLOOP DS 0H Loop to build subfield PCE's 09530000 ICM R14,15,KEYSUBOF-KEYDDATA(R2) Get where to put sub offset 09540000 BZ PSNOSUB If none, skip 09550000 LA R0,1(,R4) Get address of PCE we're building 09560000 S R0,PWADDR Convert to offset plus 1 09570000 STH R0,0(,R14) Set keyword PCE's subfield offset 09580000 * 09590000 * Build IKJSUBF PCE 09600000 * 09610000 ICM R1,15,SUBTOSET If there's a previous IKJSUBF PCE 09620000 BZ PSNSUBST to set, then 09630000 LR R0,R4 get address of this IKJSUBF PCE 09640000 S R0,PWADDR convert to offset 09650000 STH R0,1(,R1) set offset to next subfield 09660000 PSNSUBST DS 0H 09670000 ST R4,SUBTOSET Set address of subfield to set 09680000 MVI 0(R4),B'00000000' +0 (1) Flags (end-of-field indicator 09690000 * ... ...,1(,R4) +1 (1) Offset of next SUBF or ENDP 09700000 LA R4,3(,R4) Bump PCE pointer 09710000 MVI 0(R4),B'10010100' +0 (1) Flags (IKJIDENT, PROMPT) 09720000 TM KEYFLAGS-KEYDDATA(R2),KEYFASIS If /ASIS option given 09730000 BZ PSNASIS then 09740000 MVI 1(R4),B'01000000' +1 (1) Flags 09750000 B PSNAEND else 09760000 PSNASIS MVI 1(R4),B'00000000' +1 (1) Flags 09770000 PSNAEND DS 0H 09780000 L R15,KEYDMAXL-KEYDDATA(,R2) Get length of name for prompt 09790000 LR R14,R15 09800000 SLA R14,1 2 * length(name) 09810000 LA R14,50(,R14) 50 + (2 * length(name)) 09820000 STH R14,2(,R4) +2 (2) Length of this PCE 09830000 STH R5,4(,R4) +4 (2) Offset in PDL to PDE for this 09840000 MVI 6(R4),B'00001000' +6 (1) Flags (CHAR) 09850000 MVI 7(R4),X'01' +7 (1) X'01' (FIRST=n/a) 09860000 MVI 8(R4),X'01' +8 (1) X'01' (OTHER=n/a) 09870000 LA R0,22(,R15) 18 + length(name) + 4 09880000 STH R0,9(,R4) +9 (2) Length of '...' + 4 09890000 MVC 11(2,R4),=X'0012' +B (2) X'0012' 09900000 MVC 13(18,R4),=C'VALUE FOR KEYWORD ' 09910000 LA R4,13+18(,R4) Point to where to move keyword name 09920000 BCTR R15,0 Length minus 1 for store & execute 09930000 L R1,KEYWORDA-KEYDDATA(,R2) Get address of keyword name 09940000 EX R15,MVCTOPCE Move keyword name to PCL 09950000 LA R4,1(R15,R4) Bump PCE pointer 09960000 LA R0,18(,R15) 18 + length(name) - 1 09970000 STC R0,0(,R4) Length of prompt data 09980000 MVC 1(18,R4),=C'VALUE FOR KEYWORD ' 09990000 LA R4,1+18(,R4) Point to where to move keyword name 10000000 EX R15,MVCTOPCE Move keyword name to PCL 10010000 LA R4,1(R15,R4) Bump PCE pointer 10020000 LA R5,8(,R5) Increment PDE offset 10030000 PSNOSUB DS 0H 10040000 LA R2,KEYDDATL(,R2) Continue 10050000 BCT R8,PSKWLOOP until no more keywords 10060000 PSKWLEND DS 0H End loop 10070000 SPACE 1 10080000 * 10090000 * Build the IKJENDP part of the PCL. 10100000 * 10110000 * PCE contents: +0 (1) Flags: B'0000 0000' (end-of-field indicator) 10120000 * 10130000 MVI 0(R4),B'00000000' +0 (1) Flags 10140000 ICM R1,15,SUBTOSET If there's a previous IKJSUBF PCE 10150000 BZ PENSUBST to set, then 10160000 LR R0,R4 get address of this IKJENDP PCE 10170000 S R0,PWADDR convert to offset 10180000 STH R0,1(,R1) set offset to next subfield 10190000 PENSUBST DS 0H 10200000 ICM R1,15,FIRSTKEY If no keyword PCE built 10210000 BNZ PEGOTKEY then 10220000 ST R4,FIRSTKEY make this the one 10230000 PEGOTKEY DS 0H 10240000 L R15,PWADDR Get address of start of PCE 10250000 L R0,FIRSTKEY Load offset of first key/or/etc.PCE 10260000 SR R0,R15 Convert to offset 10270000 STH R0,4(,R15) Set offset in IKJPARM PCE 10280000 LA R4,1(,R4) Bump past this PCE 10290000 LR R0,R4 10300000 S R0,PWADDR Convert to offset 10310000 ST R0,PCLLEN Set actual PCL length 10320000 L R1,PWADDR Get address of IKJPARM PCE 10330000 STH R0,0(,R1) IKJPARM +0 (2) Length of PCL 10340000 ST R4,QOFF Save address of where to build 10350000 * unquoted strings 10360000 * 10370000 * Note that unquoted strings won't be built until/unless we assign 10380000 * default values from them after a successful parse of the arguments. 10390000 * 10400000 EJECT 10410000 * 10420000 * Next steps: If initial variable specified, use IKJCT441 to get its 10430000 * value. Otherwise use REXX call to get at arguments. 10440000 * Make a command buffer out of this and call IKJPARS. 10450000 * If parsing successful, go thru each positional and 10460000 * keyword parameter, getting its value, and assign all 10470000 * the values using IKJCT441. 10480000 * 10490000 ICM R0,15,PVARADDR Get address of first-arg variable 10500000 BZ NOVAR If none, try REXX arg call 10510000 ST R0,CVNAMEA Set address of variable name 10520000 L R0,PVARLEN Get length of first-arg variable 10530000 ST R0,CVNAMEL Set length of variable name 10540000 LA R0,TSVERETR Return variable value 10550000 * (create variable if doesn't exist) 10560000 ST R0,CVENTRY Set entry code 10570000 XR R0,R0 10580000 ST R0,CVVALUEA Address of variable value 10590000 ST R0,CVVALUEL Length of variable value 10600000 ST R0,CVTOKEN Token 10610000 LA R14,CVENTRY Store into IKJCT441 parameter list 10620000 LA R15,CVNAMEA 10630000 LA R0,CVNAMEL 10640000 LA R1,CVVALUEA 10650000 LA R2,CVVALUEL 10660000 LA R3,CVTOKEN 10670000 STM R14,R3,CVPARMS 10680000 OI CVPARM6,X'80' Set VL bit 10690000 LA R1,CVPARMS Point to parameter list 10700000 L R15,X'10' Get address of CVT 10710000 L R15,CVTTVT-CVT(,R15) Get address of TSO vector table 10720000 L R15,TSVTVACC-TSVT(,R15) Get address of IKJCT441 10730000 BALR R14,R15 Call variable access routine 10740000 CH R15,=H'4' Get return code 10750000 BNH GETVAROK If not 0 or 4, error 10760000 BAL R14,ERROR_GETTING_VAR 10770000 B FLUSHIT 10780000 SPACE 1 10790000 NOVAR DS 0H No variable, try REXX arg call 10800000 SPACE 1 10810000 * 10820000 *********************************************************************** 10830000 * * 10840000 * Invoke the IRXEXCOM routine to fetch the ARG information. * 10850000 * * 10860000 * Reference: TSO/E Version 2 REXX Reference, pp. 240-246 * 10870000 * * 10880000 *********************************************************************** 10890000 * 10900000 * Build the SHVBLOCK 10910000 * 10920000 * To store the argument value, we try using ARGWA, a 512-byte area 10930000 * that is already part of our workarea, to avoid unnecessary GETMAINs. 10940000 * 10950000 * If that doesn't turn out to be big enough, we'll have to GETMAIN, 10960000 * but it's best to avoid that. 10970000 * 10980000 XC SHVBLOCK(SHVBLEN),SHVBLOCK 10990000 MVI SHVCODE,SHVPRIV Fetch private information 11000000 LA R1,L'ARGWA 11010000 ST R1,SHVBUFL Length of 'fetch' value buffer 11020000 LA R1,ARGWA 11030000 ST R1,SHVVALA Address of value buffer 11040000 LA R1,=C'ARG' Name of thing to be fetched 11050000 ST R1,SHVNAMA Address of variable name 11060000 LA R1,3 Length('ARG') 11070000 ST R1,SHVNAML Length of variable name 11080000 LA R14,=CL8'IRXEXCOM' IRXEXCOM parm 1 11090000 XR R15,R15 IRXEXCOM parm 2 11100000 LR R0,R15 Parm 3 must be same as Parm 2 11110000 LA R1,SHVBLOCK IRXEXCOM parm 4 11120000 STM R14,R1,IRPARMS 11130000 OI IRPARM4,X'80' 11140000 RETRYIRX DS 0H 11150000 * XR R0,R0 Don't specify an environment #TSO162 11160000 L R1,CPPLECT Get passed ECT address #TSO162 11170000 L R0,ECTENVBK-ECT(,R1) Get addr of REXX envir. blk #TSO162 11180000 LA R1,IRPARMS Point to parameter list 11190000 L R15,X'10' Get address of CVT 11200000 L R15,CVTTVT-CVT(,R15) Get address of TSO vector table 11210000 L R15,TSVTEXCO-TSVT(,R15) Get address of IRXEXCOM 11220000 BALR R14,R15 Call REXX arg access routine 11230000 LTR R15,R15 If rc zero 11240000 BZ OKIRX then OK 11250000 CH R15,=Y(SHVTRUNC) If value was truncated 11260000 BE OOPSIRX then need more room to hold value 11270000 B ERROR_IRXEXCOM Else error 11280000 OOPSIRX DS 0H Not enough room to hold value 11290000 ICM R1,15,ARGADDR Get address of arg buffer 11300000 BZ NOARGYET If nonzero, then... 11310000 L R0,ARGLEN Get length 11320000 FREEMAIN RC,LV=(0),A=(1) 11330000 NOARGYET DS 0H 11340000 LA R0,1024 Increment arg len so far 11350000 A R0,ARGLEN 11360000 ST R0,ARGLEN 11370000 ST R0,SHVBUFL Reset length of fetch buffer 11380000 GETMAIN RC,LV=(0),LOC=ANY 11390000 LTR R15,R15 11400000 BNZ GETMAIN_FAILURE 11410000 ST R1,ARGADDR 11420000 ST R1,SHVVALA Reset address of value buffer 11430000 B RETRYIRX Try again 11440000 OKIRX DS 0H Everything OK 11450000 MVC CVVALUEL,SHVVALL Set length of arg value 11460000 MVC CVVALUEA,SHVVALA Set address of arg value 11470000 SPACE 1 11480000 GETVAROK DS 0H 11490000 EJECT 11500000 * 11510000 *********************************************************************** 11520000 * * 11530000 * Build a fake command buffer containing the value of the variable, * 11540000 * for use by IKJPARS. Format: * 11550000 * ___________________________________________________________________ * 11560000 * | | | | * 11570000 * | valuelen+4 | zero | value text | * 11580000 * |____________|_______|____________________________________________| * 11590000 * * 11600000 *********************************************************************** 11610000 * 11620000 LA R2,4 Get 4 + ... 11630000 A R2,CVVALUEL length of variable value 11640000 ST R2,VBUFLEN Save length 11650000 GETMAIN RC,LV=(R2),LOC=ANY Get a fake command buffer 11660000 LTR R15,R15 11670000 BNZ GETMAIN_FAILURE 11680000 ST R1,VBUFADDR Save address of fake command buffer 11690000 SLL R2,16 Make buffer prefix 11700000 ST R2,0(,R1) Store into fake command buffer 11710000 LA R2,4(,R1) Address of fake command buffer text 11720000 L R14,CVVALUEA Address of variable value 11730000 L R15,CVVALUEL Length of variable value 11740000 LR R3,R15 Length of fake command buffer text 11750000 MVCL R2,R14 Move variable value to fake buffer 11760000 * 11770000 *********************************************************************** 11780000 * * 11790000 * Set up to call IKJPARS. * 11800000 * * 11810000 *********************************************************************** 11820000 * 11830000 XC ANSWER,ANSWER Clear PDL address field 11840000 MVC PPLUPT,CPPLUPT Address of UPT 11850000 MVC PPLECT,CPPLECT Address of ECT 11860000 LA R14,ECB Address of ECB 11870000 L R15,PWADDR Address of the PCL we built 11880000 LA R0,ANSWER Address of PARSE answer area 11890000 L R1,VBUFADDR Address of our fake command buffer 11900000 STM R14,R1,PPLECB Set rest of PPL 11910000 ST R9,PPLUWA User work area = "DATD" 11920000 ST R9,PPLVEWA (we don't use verify exit, but...) 11930000 SPACE 1 11940000 CALLTSSR EP=IKJPARS,MF=(E,PPL) 11950000 LTR R15,R15 11960000 BNZ ERROR_PARSE_FAILURE 11970000 EJECT 11980000 * 11990000 *********************************************************************** 12000000 * * 12010000 * Now that PARSE has successfully gotten values for all parameters, * 12020000 * go through them and retrieve their values, which will be used to * 12030000 * set variables via IKJCT441. * 12040000 * * 12050000 *********************************************************************** 12060000 * 12070000 L R7,ANSWER Get address of PDL 12080000 L R5,PWADDR Get address of PCL-et-al work area 12090000 A R5,PCLLEN Bump past PCL part 12100000 A R5,QVALLEN Bump past unquoted-string part 12110000 LA R5,3(,R5) Round up to 12120000 N R5,=X'FFFFFFFC' fullword boundary 12130000 ST R5,VUPADDR Save address of this plist 12140000 * 12150000 * Format of each block of IKJCT441 parameter list: 12160000 * 12170000 * +00 -> Entry code (TSVEUPDT) 12180000 * +04 -> Address of variable name 12190000 * +08 -> Length of variable name 12200000 * +0C -> Address of variable value 12210000 * +10 -> Length of variable value 12220000 * +14 -> Token (zero, not used) 12230000 * +18 -> ECT (X'FFFFFFFF', not used) 12240000 * +1C -> Return code from IKJCT441 12250000 * +20 -> Address of next block of this parameter list or X'80000000' 12260000 * +24 ... not part of plist, but space to hold the address of value 12270000 * +28 ... not part of plist, but space to hold the length of value 12280000 * +2C ... not part of plist, but space to hold the return code 12290000 * +30 ... not part of plist, but space to hold the address of link 12300000 * 12310000 XR R0,R0 12320000 ST R0,CVTOKEN 12330000 MVC CVECT,=X'FFFFFFFF' 12340000 LA R15,TSVEUPDT Entry code = update variable 12350000 ST R15,CVENTRY Set entry code 12360000 L R4,POSCOUNT Get # of positionals 12370000 A R4,KEYCOUNT + # of keywords 12380000 BZ NOUPDATE If no parameters, no updating. 12390000 L R15,VUPADDR Get address of the plist 12400000 BPLOOP DS 0H 12410000 LR R5,R15 Point to this element of parm list 12420000 LA R15,CVENTRY 12430000 ST R15,X'00'(,R5) Parameter 1: entry code 12440000 * Set later... 12450000 * ST ,X'04'(,R5) Parameter 2: address of var name 12460000 * Set later... 12470000 * ST ,X'08'(,R5) Parameter 3: length of var name 12480000 LA R15,X'24'(,R5) Value address slot 12490000 ST R15,X'0C'(,R5) Parameter 4: address of var value 12500000 LA R15,X'28'(,R5) Value length slot 12510000 ST R15,X'10'(,R5) Parameter 5: length of var value 12520000 LA R15,CVTOKEN Dummy token 12530000 ST R15,X'14'(,R5) Parameter 6: token (not used) 12540000 LA R15,CVECT Dummy ECT 12550000 ST R15,X'18'(,R5) Parameter 7: ECT (not used) 12560000 LA R15,X'2C'(,R5) Return code slot 12570000 ST R15,X'1C'(,R5) Parameter 8: IKJCT441 return code 12580000 LA R15,X'30'(,R5) Link slot 12590000 ST R15,X'20'(,R5) Parameter 9: next element in list 12600000 LA R15,X'34'(,R5) 12610000 ST R15,X'30'(,R5) Address of next plist block 12620000 OI X'20'(R5),X'80' Set VL bit 12630000 BCT R4,BPLOOP Continue 12640000 L R0,=X'00000000' At end, 12650000 ST R0,X'30'(,R5) clear last link pointer in list 12660000 L R5,VUPADDR Point to first plist block again 12670000 EJECT 12680000 * 12690000 *********************************************************************** 12700000 * * 12710000 * Now go through positional parameters, setting things up. * 12720000 * * 12730000 * Format of PDE for a positional parameter (IKJIDENT): * 12740000 * * 12750000 * +0 (4) Pointer to the positional operand * 12760000 * +4 (2) Length thereof * 12770000 * +6 (1) Flags * 12780000 * +7 (1) Reserved * 12790000 * * 12800000 * Meaning of flags: 0... .... The operand is not present. * 12810000 * 1... .... The operand is present. * 12820000 * .xxx xxxx Reserved bits. * 12830000 * * 12840000 *********************************************************************** 12850000 * 12860000 ICM R8,15,POSCOUNT Get count of positionals 12870000 BZ BPPPLEND If none, skip 12880000 L R2,APOSD Get address of first positional 12890000 BPPPLOOP DS 0H Loop to fill in IKJCT441 plist 12900000 LA R15,POSDADDR-POSDDATA(,R2) Get address of param name 12910000 ST R15,X'04'(,R5) Parameter 2: address of var name 12920000 LA R15,POSDLEN-POSDDATA(,R2) Get length of param name 12930000 ST R15,X'08'(,R5) Parameter 3: length of var name 12940000 L R15,POSDPCEA-POSDDATA(,R2) Get address of PCE 12950000 LH R1,4(,R15) Get offset of PDE for this PCE 12960000 AR R1,R7 Convert to address of PDE 12970000 * 12980000 * Note: Of course it's impossible for the operand not to be present 12990000 * under the current implementation. But a future extension 13000000 * might make this possible. 13010000 * 13020000 TM 6(R1),X'80' If operand is not present, 13030000 BO BPPPPRES then... 13040000 XR R14,R14 say it's set to a null value 13050000 XR R15,R15 say it's set to a null value 13060000 B BPPPSET else... 13070000 BPPPPRES DS 0H (operand is present) 13080000 L R14,0(,R1) get address of value 13090000 LH R15,4(,R1) get length of value 13100000 BPPPSET DS 0H else (operand is present) 13110000 ST R14,X'24'(,R5) Set address of variable value 13120000 ST R15,X'28'(,R5) Set length of variable value 13130000 L R5,X'20'(,R5) Go to 13140000 L R5,0(,R5) next element of param list 13150000 LA R2,POSDDATL(,R2) Continue 13160000 BCT R8,BPPPLOOP until no more positionals 13170000 BPPPLEND DS 0H End loop 13180000 EJECT 13190000 * 13200000 *********************************************************************** 13210000 * * 13220000 * Now go through keyword parameters, setting things up. * 13230000 * * 13240000 * Format of PDE for a keyword parameter (IKJKEYWD): * 13250000 * * 13260000 * +0 (2) Number (0 if not specified, 1 if specified) * 13270000 * * 13280000 *********************************************************************** 13290000 * * 13300000 * Format of PDE for a keyword value parameter (IKJIDENT): * 13310000 * * 13320000 * +0 (4) Pointer to the positional operand * 13330000 * +4 (2) Length thereof * 13340000 * +6 (1) Flags * 13350000 * +7 (1) Reserved * 13360000 * * 13370000 * Meaning of flags: 0... .... The operand is not present. * 13380000 * 1... .... The operand is present. * 13390000 * .xxx xxxx Reserved bits. * 13400000 * * 13410000 *********************************************************************** 13420000 * 13430000 ICM R8,15,KEYCOUNT Get count of keywords 13440000 BZ BPKWLEND If none, skip 13450000 L R2,AKEYD Get address of first keyword 13460000 BPKWLOOP DS 0H Loop to fill in IKJCT441 plist 13470000 ST R2,SAVER2 Save register to protect from TRT's 13480000 LA R15,KEYWORDA-KEYDDATA(,R2) Get address of keyword name 13490000 ST R15,X'04'(,R5) Parameter 2: address of var name 13500000 LA R15,KEYWORDL-KEYDDATA(,R2) Get length of keyword name 13510000 ST R15,X'08'(,R5) Parameter 3: length of var name 13520000 TM KEYFLAGS-KEYDDATA(R2),KEYFDVAL If keyword(value), 13530000 BO BPKWDVAL then process value subfield 13540000 * 13550000 * Keyword without value is set to keyword name if specified, else null 13560000 * 13570000 L R15,KEYDPCEA-KEYDDATA(,R2) Get address of PCE 13580000 LH R1,4(,R15) Get offset of PDE for this PCE 13590000 AR R1,R7 Convert to address of PDE 13600000 CLC 0(2,R1),=X'0000' If keyword is not specified, 13610000 BNE BPKWWPRS then... 13620000 XR R15,R15 say it's set to a null value 13630000 ST R15,X'24'(,R5) set address of variable value 13640000 ST R15,X'28'(,R5) set length of variable value 13650000 B BPKWNEXT else... 13660000 BPKWWPRS DS 0H (operand is present) 13670000 L R14,X'04'(,R5) get address of variable name 13680000 L R15,X'08'(,R5) get length of variable name 13690000 ST R14,X'0C'(,R5) Parameter 4: address of var value 13700000 ST R15,X'10'(,R5) Parameter 5: length of var value 13710000 B BPKWNEXT 13720000 SPACE 1 13730000 BPKWDVAL DS 0H Else keyword with a value specified 13740000 * 13750000 * Keyword with value: If keyword is present, set from value subfield 13760000 * (which must be present according to the PARS rules). Otherwise, 13770000 * set value from default from XPROC statement, unquoting if needed. 13780000 * 13790000 L R15,KEYDPCEA-KEYDDATA(,R2) Get address of PCE 13800000 LH R1,4(,R15) Get offset of PDE for this PCE 13810000 AR R1,R7 Convert to address of PDE 13820000 CLC 0(2,R1),=X'0000' If keyword is not specified, 13830000 BNE BPKWVPRS then... 13840000 L R14,KEYDVALA-KEYDDATA(,R2) get address of default value 13850000 L R15,KEYDVALL-KEYDDATA(,R2) get length of default value 13860000 TM KEYFLAGS-KEYDDATA(R2),KEYFQUOT If value is quoted, 13870000 BNO BPKWVSET then... 13880000 * unquote it 13890000 LA R1,1(,R14) Get address of quoted string + 1 13900000 LR R3,R15 Get length of quoted string 13910000 SH R3,=H'2' minus 2 to get length between quotes 13920000 BZ BPKWNULL If '', set variable to null value 13930000 LR R15,R1 13940000 LR R14,R1 Save address of string input 13950000 ST R14,SCANPTR 13960000 AR R14,R3 Save address of end of it 13970000 ST R14,SCANEPTR 13980000 L R14,QOFF Get where to build unquoted string 13990000 LA R0,256 Make a constant value of 256 14000000 BPGOTQL CR R3,R0 If length greater than 256 14010000 BNH BPGOTQX then... 14020000 TRT 0(256,R15),STBLQUOT scan for "'" 14030000 BNZ BPGOTQT If we found it, go. Else 14040000 MVC 0(256,R14),0(R15) copy unquoted data to area 14050000 AR R14,R0 Increment output pointer by 256 14060000 AR R15,R0 Increment input pointer by 256 14070000 SR R3,R0 Decrement length by 256 14080000 BP BPGOTQL Either continue scanning 14090000 B BPGOTQE or, if length zero, finished 14100000 BPGOTQX DS 0H Else... 14110000 BCTR R3,0 Reduce length for execute 14120000 EX R3,BPGQTRT Scan for "'" 14130000 BNZ BPGOTQT If found something, go 14140000 B BPGOTQE else end of string 14150000 BPGOTQT DS 0H Reached "'" 14160000 CLI 1(R1),C'''' Another "'" has to follow 14170000 BNE 0(0) (else abend) 14180000 LR R3,R1 Get length we just scanned 14190000 SR R3,R15 14200000 EX R3,BPGQMVC Move data so far (R15 -> it) 14210000 BPGQNMV DS 0H (including quote, so no BCTR) 14220000 LA R14,1(R14,R3) Bump past it and following quote 14230000 LA R15,2(,R1) Bump to location past "''" 14240000 L R3,SCANEPTR 14250000 SR R3,R15 R3 := length remaining to scan 14260000 BP BPGOTQL If something left, continue scan 14270000 BPGOTQE DS 0H End of quoted string 14280000 L R3,SCANEPTR 14290000 SR R3,R15 Get length remaining to move 14300000 BZ BPGENMV If zero, skip move 14310000 EX R3,BPGQMVC Move data so far (R15 -> it) 14320000 BPGENMV DS 0H (including quote, so no BCTR) 14330000 LA R14,0(R14,R3) Bump past it 14340000 LR R15,R14 14350000 S R15,QOFF Get length of unquoted string 14360000 L R1,QOFF Get address of unquoted string 14370000 ST R14,QOFF Update where to build next string 14380000 LR R14,R1 14390000 B BPKWDSET Set address and length of string 14400000 BPKWVSET DS 0H else (operand is present) 14410000 ST R14,X'24'(,R5) Set address of variable value 14420000 ST R15,X'28'(,R5) Set length of variable value 14430000 B BPKWNEXT 14440000 BPKWVPRS DS 0H (operand is present) 14450000 L R15,KEYSUBOF-KEYDDATA(,R2) Get where subfield offset is 14460000 LH R15,0(,R15) Get offset+1 of IKJSUBF PCE 14470000 LA R15,2(,R15) Bump to associated IKJIDENT PCE 14480000 A R15,PWADDR Convert to address of subfield 14490000 LH R1,4(,R15) Get offset of PDE for this PCE 14500000 AR R1,R7 Convert to address of PDE 14510000 * 14520000 * Note: Of course it's impossible for the operand not to be present 14530000 * under the current implementation. But a future extension 14540000 * might make this possible. 14550000 * 14560000 TM 6(R1),X'80' If operand is not present, 14570000 BO BPKWDPRS then... 14580000 BPKWNULL DS 0H 14590000 XR R14,R14 say it's set to a null value 14600000 XR R15,R15 say it's set to a null value 14610000 B BPKWDSET else... 14620000 BPKWDPRS DS 0H (operand is present) 14630000 L R14,0(,R1) get address of value 14640000 LH R15,4(,R1) get length of value 14650000 BPKWDSET DS 0H else (operand is present) 14660000 ST R14,X'24'(,R5) Set address of variable value 14670000 ST R15,X'28'(,R5) Set length of variable value 14680000 BPKWNEXT DS 0H Continue 14690000 L R5,X'20'(,R5) Go to 14700000 L R5,0(,R5) next element of param list 14710000 L R2,SAVER2 Restore register clobbered by TRT 14720000 LA R2,KEYDDATL(,R2) Continue 14730000 BCT R8,BPKWLOOP until no more positionals 14740000 BPKWLEND DS 0H End loop 14750000 * 14760000 * Now call IKJCT441 to do all the variable updates. 14770000 * 14780000 L R1,VUPADDR Point to parameter list 14790000 L R15,X'10' Get address of CVT 14800000 L R15,CVTTVT-CVT(,R15) Get address of TSO vector table 14810000 L R15,TSVTVACC-TSVT(,R15) Get address of IKJCT441 14820000 BALR R14,R15 Call variable access routine 14830000 L R5,VUPADDR 14840000 RCLOOP DS 0H 14850000 LA R5,0(,R5) Clear VL bit if any 14860000 LTR R5,R5 14870000 BZ RCEND 14880000 L R15,X'2C'(,R5) Get return code set by IKJCT441 14890000 CH R15,=H'4' If return code 14900000 BNH RCNEXT If not 0 or 4, error 14910000 BAL R14,ERROR_PUTTING_VAR 14920000 OI FLAGS,FLAGPUTE 14930000 RCNEXT L R5,X'20'(,R5) Go to 14940000 L R5,0(,R5) next element of param list 14950000 B RCLOOP 14960000 RCEND DS 0H 14970000 TM FLAGS,FLAGPUTE If a variable update error, 14980000 BO FLUSHIT then flush 14990000 SPACE 1 15000000 NOUPDATE DS 0H Here if no call to IKJCT441 needed 15010000 SPACE 1 15020000 B RETURN0 Everything fine, return code(0) 15030000 EJECT 15040000 * 15050000 TRTPOSCT TRT 0(*-*,R3),NUMTBL Executed: scan word for numerics 15060000 PACKIT PACK DOUBLE(8),0(*-*,R3) Executed: convert word to decimal 15070000 VERIFYP TRT 0(*-*,R14),VERTBL Executed: verify syntax of parameter 15080000 MVCWORD MVC 0(*-*,R1),0(R14) Executed: move parameter to wordarea 15090000 UPWORD TR 0(*-*,R1),UPTBL Executed: translate to uppercase 15100000 COMPWORD CLC 0(*-*,R1),0(R14) Executed: compare parameters 15110000 MVCTOPCE MVC 0(*-*,R4),0(R1) Executed: move parameter name to PCE 15120000 BPGQTRT TRT 0(*-*,R15),STBLQUOT Executed: scan for "'" mark 15130000 BPGQMVC MVC 0(*-*,R14),0(R15) Executed: copy unquoted data to area 15140000 * 15150000 EJECT 15160000 * 15170000 *********************************************************************** 15180000 * * 15190000 * Various error conditions. * 15200000 * * 15210000 *********************************************************************** 15220000 * 15230000 ERROR_GETTING_VAR DS 0H 15240000 ST R14,E44114 Save return register 15250000 ST R15,RC441 Save IKJCT441 return code 15260000 L R2,CVNAMEL Length of variable name 15270000 L R3,CVNAMEA Address of variable name 15280000 ERROR MSG_GETTING_VAR,FLUSH=NO 15290000 B ERROR441 15300000 SPACE 1 15310000 ERROR_PUTTING_VAR DS 0H 15320000 ST R14,E44114 Save return register 15330000 ST R15,RC441 Save IKJCT441 return code 15340000 L R2,X'08'(,R5) -> Length of variable name 15350000 L R2,0(,R2) Length of variable name 15360000 L R3,X'04'(,R5) -> Address of variable name 15370000 L R3,0(,R3) Address of variable name 15380000 ERROR MSG_PUTTING_VAR,FLUSH=NO 15390000 ******** B ERROR441 15400000 SPACE 1 15410000 ERROR441 DS 0H 15420000 XR R2,R2 No additional information for... 15430000 XR R3,R3 15440000 L R4,RC441 Load IKJCT441 return code 15450000 CH R4,=H'81' Check IKJCT441 return code 15460000 BH ERROR441_MISC > 81 15470000 BE ERROR441_RC81 = 81 15480000 B *(R4) Else branch based on return code 15490000 B ERROR441_MISC 04: Variable cannot be rescanned 15500000 * (not treated as an error here) 15510000 B ERROR441_RC08 08: Variable is a CLIST BIF 15520000 B ERROR441_RC12 12: Variable is a CLIST label 15530000 B ERROR441_RC16 16: Variable is unmodifiable 15540000 B ERROR441_MISC 20: n/a 15550000 B ERROR441_RC24 24: Variable is a CLIST subprocedure 15560000 B ERROR441_MISC 28: n/a 15570000 B ERROR441_RC32 32: GETMAIN/FREEMAIN failure 15580000 B ERROR441_RC36 36: Variable length is invalid 15590000 B ERROR441_RC40 40: Not in CLIST or REXX environment 15600000 B ERROR441_MISC 44: invalid entry code 15610000 B ERROR441_MISC 48: n/a 15620000 B ERROR441_MISC 52: n/a 15630000 B ERROR441_MISC 56: n/a 15640000 B ERROR441_MISC 60: n/a 15650000 B ERROR441_MISC 64: n/a 15660000 B ERROR441_MISC 68: n/a 15670000 B ERROR441_MISC 72: n/a 15680000 B ERROR441_RC76 76: Variable is undefined &SYSX... 15690000 B ERROR441_RC80 80: Variable name invalid for REXX 15700000 ERROR441_RC08 ERROR MSG_IKJCT441_RC08,FLUSH=NO 15710000 L R14,E44114 15720000 BR R14 15730000 ERROR441_RC12 ERROR MSG_IKJCT441_RC12,FLUSH=NO 15740000 L R14,E44114 15750000 BR R14 15760000 ERROR441_RC16 ERROR MSG_IKJCT441_RC16,FLUSH=NO 15770000 L R14,E44114 15780000 BR R14 15790000 ERROR441_RC24 ERROR MSG_IKJCT441_RC24,FLUSH=NO 15800000 L R14,E44114 15810000 BR R14 15820000 ERROR441_RC32 ERROR MSG_IKJCT441_RC32,FLUSH=NO 15830000 L R14,E44114 15840000 BR R14 15850000 ERROR441_RC36 ERROR MSG_IKJCT441_RC36,FLUSH=NO 15860000 L R14,E44114 15870000 BR R14 15880000 ERROR441_RC40 ERROR MSG_IKJCT441_RC40,FLUSH=NO 15890000 L R14,E44114 15900000 BR R14 15910000 ERROR441_RC76 ERROR MSG_IKJCT441_RC76,FLUSH=NO 15920000 L R14,E44114 15930000 BR R14 15940000 ERROR441_RC80 ERROR MSG_IKJCT441_RC80,FLUSH=NO 15950000 L R14,E44114 15960000 BR R14 15970000 ERROR441_RC81 ERROR MSG_IKJCT441_RC81,FLUSH=NO 15980000 L R14,E44114 15990000 BR R14 16000000 ERROR441_MISC DS 0H 16010000 CVD R4,DOUBLE 16020000 UNPK DOUBLE(2),DOUBLE(8) 16030000 OI DOUBLE+1,X'F0' 16040000 LA R2,2 Length of error code 16050000 LA R3,DOUBLE Address of error code 16060000 ERROR MSG_IKJCT441_RC,FLUSH=NO 16070000 L R14,E44114 16080000 BR R14 16090000 SPACE 1 16100000 NOOPERANDS DS 0H No input variable 16110000 XR R2,R2 No accompanying data 16120000 XR R3,R3 " " " 16130000 ERROR MSG_NO_OPERANDS 16140000 SPACE 1 16150000 NOPOSCOUNT DS 0H No count of positional parameters 16160000 XR R2,R2 No accompanying data 16170000 XR R3,R3 " " " 16180000 ERROR MSG_NO_POS_COUNT 16190000 SPACE 1 16200000 BADPOSCOUNT DS 0H Bad count of positional parameters 16210000 LA R2,1(,R4) Get length of bad data 16220000 ERROR MSG_BAD_POS_COUNT 16230000 SPACE 1 16240000 ERROR_NO_WANT_LP DS 0H Left parenthesis found, not wanted 16250000 XR R2,R2 No accompanying data 16260000 XR R3,R3 " " " 16270000 ERROR MSG_NO_WANT_LP 16280000 SPACE 1 16290000 ERROR_NO_WANT_RP DS 0H Right parenthesis found, not wanted 16300000 XR R2,R2 No accompanying data 16310000 XR R3,R3 " " " 16320000 ERROR MSG_NO_WANT_RP 16330000 SPACE 1 16340000 ERROR_NO_WANT_QS DS 0H Quoted string found, not wanted 16350000 XR R2,R2 No accompanying data 16360000 XR R3,R3 " " " 16370000 ERROR MSG_NO_WANT_QS 16380000 SPACE 1 16390000 ERROR_NO_WANT_SL DS 0H Slash found, not wanted 16400000 XR R2,R2 No accompanying data 16410000 XR R3,R3 " " " 16420000 ERROR MSG_NO_WANT_SL 16430000 SPACE 1 16440000 PPMISSING DS 0H Positional parm not found, expected 16450000 XR R2,R2 No accompanying data 16460000 XR R3,R3 " " " 16470000 ERROR MSG_TOO_FEW_PPARMS 16480000 SPACE 1 16490000 ERROR_PARM_TOO_LONG DS 0H 16500000 LA R2,252 Display only up to maximum length 16510000 LR R3,R1 Address of offending parameter 16520000 ERROR MSG_PARM_TOO_LONG 16530000 SPACE 1 16540000 ERROR_PARM_INVALID DS 0H 16550000 LA R2,1(,R15) Length of offending parameter 16560000 LR R3,R14 Address of offending parameter 16570000 ERROR MSG_PARM_INVALID 16580000 SPACE 1 16590000 ERROR_PARM_DUPLICATE DS 0H 16600000 LA R2,1(,R15) Length of offending parameter 16610000 LR R3,R14 Address of offending parameter 16620000 ERROR MSG_PARM_DUPLICATE 16630000 SPACE 1 16640000 ERROR_OPT_TOO_LONG DS 0H 16650000 LA R2,L'OPTION Display only up to maximum length 16660000 LR R3,R1 Address of offending parameter 16670000 ERROR MSG_OPT_TOO_LONG 16680000 SPACE 1 16690000 ERROR_OPT_INVALID DS 0H 16700000 LA R2,1(,R15) Length of offending parameter 16710000 LR R3,R14 Address of offending parameter 16720000 ERROR MSG_OPT_INVALID 16730000 SPACE 1 16740000 ERROR_OPT_POS_ONLY DS 0H 16750000 LA R2,1(,R15) Length of offending parameter 16760000 LR R3,R14 Address of offending parameter 16770000 ERROR MSG_OPT_POS_ONLY 16780000 SPACE 1 16790000 ERROR_ASIS_NEEDS_VAL DS 0H 16800000 L R3,KEYWORDA-KEYDDATA(,R2) 16810000 L R2,KEYWORDL-KEYDDATA(,R2) 16820000 ERROR MSG_ASIS_NEEDS_VAL 16830000 SPACE 1 16840000 ERROR_PP_WITH_LP DS 0H Positional parm with left paren 16850000 ERROR MSG_PP_WITH_LP 16860000 SPACE 1 16870000 ERROR_FIRST_ARG DS 0H Bad first argument 16880000 LR R2,R4 Length of offending parameter 16890000 ERROR MSG_VAR_TOO_LONG 16900000 SPACE 1 16910000 ERROR_IRXEXCOM DS 0H IRXEXCOM failed 16920000 C R15,=F'-2' Insufficient storage? 16930000 BE GETMAIN_FAILURE 16940000 C R15,=F'-1' No valid REXX environment? 16950000 BE ERROR_REXX_REQUIRED 16960000 CVD R15,DOUBLE 16970000 UNPK DOUBLE(3),DOUBLE(8) 16980000 OI DOUBLE+2,X'F0' 16990000 LA R2,3 Length of error code 17000000 LA R3,DOUBLE Address of error code 17010000 ERROR MSG_IRXEXCOM_FAIL 17020000 SPACE 1 17030000 ERROR_REXX_REQUIRED DS 0H 17040000 XR R2,R2 17050000 XR R3,R3 17060000 ERROR MSG_REXX_REQUIRED 17070000 ERROR_PARSE_FAILURE DS 0H IKJPARS failed 17080000 CH R15,=H'4' 17090000 BE FLUSHIT 17100000 CH R15,=H'20' 17110000 BE FLUSHIT 17120000 CH R15,=H'32' 17130000 BE FLUSHIT 17140000 CVD R15,DOUBLE 17150000 UNPK DOUBLE(2),DOUBLE(8) 17160000 OI DOUBLE+1,X'F0' 17170000 LA R2,2 Length of error code 17180000 LA R3,DOUBLE Address of error code 17190000 ERROR MSG_PARSE_FAILURE 17200000 SPACE 1 17210000 GETMAIN_FAILURE DS 0H Insufficient storage 17220000 XR R2,R2 No accompanying data 17230000 XR R3,R3 " " " 17240000 ERROR MSG_GETMAIN_FAIL 17250000 SPACE 1 17260000 KVERROR DS 0H This should never happen 17270000 XR R2,R2 No accompanying data 17280000 XR R3,R3 " " " 17290000 ERROR MSG_KV_ERROR 17300000 SPACE 1 17310000 FLUSHIT DS 0H Return in failure 17320000 SPACE 1 17330000 TCLEARQ INPUT Flush terminal input 17340000 MVC FLUSH(LENFLUSH),MFLUSH Set up STACK list form 17350000 XC ECB,ECB Clear ECB and flush the input stack 17360000 STACK PARM=FLUSH,MF=(E,IOPL) 17370000 LTR R15,R15 If STACK failed, 17380000 BZ RETURN12 then... 17390000 CVD R15,DOUBLE 17400000 UNPK DOUBLE(2),DOUBLE(8) 17410000 OI DOUBLE+1,X'F0' 17420000 LA R2,2 Length of error code 17430000 LA R3,DOUBLE Address of error code 17440000 ERROR MSG_STACK_ERROR,FLUSH=NO 17450000 RETURN12 DS 0H 17460000 LA R2,12 Set return code to 12 17470000 B RETURN 17480000 SPACE 1 17490000 RETURN0 DS 0H Return with code 0 17500000 XR R2,R2 Set return code to zero 17510000 ******** B RETURN 17520000 SPACE 1 17530000 RETURN DS 0H R2 contains return code 17540000 SPACE 1 17550000 ICM R1,15,PWADDR If there was a parse work area 17560000 BZ NOFREEPW then free it 17570000 L R0,PWLEN 17580000 FREEMAIN RC,LV=(0),A=(1) 17590000 NOFREEPW DS 0H 17600000 SPACE 1 17610000 ICM R1,15,VBUFADDR If there was a fake command buffer 17620000 BZ NOFREEVBUF then free it 17630000 L R0,VBUFLEN 17640000 FREEMAIN RC,LV=(0),A=(1) 17650000 NOFREEVBUF DS 0H 17660000 SPACE 1 17670000 ICM R1,15,ARGADDR If there was an arg buffer 17680000 BZ NOFREEARG then free it 17690000 L R0,ARGLEN Get length 17700000 FREEMAIN RC,LV=(0),A=(1) 17710000 NOFREEARG DS 0H 17720000 SPACE 1 17730000 ICM R1,15,AKEYD If there was a keyword/value area 17740000 BZ NOFREEKEYD then free it 17750000 L R0,LKEYD 17760000 FREEMAIN RC,LV=(0),A=(1) 17770000 NOFREEKEYD DS 0H 17780000 SPACE 1 17790000 ICM R1,15,APOSD If there was a pos parm area, 17800000 BZ NOFREEPOSD then free it 17810000 L R0,LPOSD 17820000 FREEMAIN RC,LV=(0),A=(1) 17830000 NOFREEPOSD DS 0H 17840000 SPACE 1 17850000 IKJRLSA ANSWER Free IKJPARS storage if any 17860000 SPACE 1 17870000 L R0,DATDLEN Get length of work area 17880000 LR R1,R13 Get address of work area 17890000 L R13,4(,R13) Unchain save area 17900000 ST R2,16(,R13) Store return code in save area 17910000 FREEMAIN R,LV=(0),A=(1) 17920000 LM R14,R12,12(R13) 17930000 BR R14 17940000 EJECT 17950000 *********************************************************************** 17960000 * Subroutines * 17970000 *********************************************************************** 17980000 EJECT 17990000 DOOPTS DS 0H Process options following "/" 18000000 SPACE 1 18010000 ST R14,DOOPT14 Save return address 18020000 TM FLAGS,FLAGPOSD+FLAGKEYD Must be processing either a 18030000 BZ ERROR_NO_WANT_SL positional or a keyword 18040000 * 18050000 * Process the option following the slash. 18060000 * 18070000 BAL R14,SCAN Scan for option name 18080000 B DOOPTRET None, skip 18090000 B OPTNAME Unquoted name, process 18100000 B ERROR_NO_WANT_QS Quoted string found 18110000 B ERROR_NO_WANT_LP "(" found 18120000 B ERROR_NO_WANT_RP ")" found 18130000 B ERROR_NO_WANT_SL "/" found 18140000 SPACE 1 18150000 OPTNAME DS 0H Option name found 18160000 * 18170000 * Validate option name and process it. 18180000 * 18190000 CH R2,=Y(L'OPTION) If too long 18200000 BH ERROR_OPT_TOO_LONG then error 18210000 MVI OPTION,C' ' Clear option field to blanks 18220000 MVC OPTION+1(L'OPTION-1),OPTION 18230000 LR R14,R1 Address 18240000 LR R15,R2 Length 18250000 BCTR R15,0 Reduce length for execute 18260000 LA R1,OPTION Point to place to move option name 18270000 EX R15,MVCWORD Move option name to option area 18280000 EX R15,UPWORD Translate to uppercase 18290000 * 18300000 * Time to process the options 18310000 * 18320000 TM FLAGS,FLAGPOSD If currently processing positional 18330000 BO DOOPTP then check positional options 18340000 B DOOPTK else check keyword options 18350000 SPACE 1 18360000 DOOPTP DS 0H 18370000 L R1,LASTAREA Point to current PP area 18380000 ******** CLC =C'OPTIONAL ',OPTION 18390000 ******** BE DOOPTP_OPTIONAL 18400000 CLC =C'ASIS ',OPTION 18410000 BE DOOPTP_ASIS 18420000 CLC =C'QUOTABLE ',OPTION 18430000 BE DOOPTP_CHAR 18440000 B ERROR_OPT_INVALID All other options are bad, error 18450000 SPACE 1 18460000 DOOPTP_OPTIONAL DS 0H 18470000 OI POSDFLGS-POSDDATA(R1),POSDOPT 18480000 B DOOPTRET 18490000 SPACE 1 18500000 DOOPTP_ASIS DS 0H 18510000 OI POSDFLGS-POSDDATA(R1),POSDASIS 18520000 B DOOPTRET 18530000 SPACE 1 18540000 DOOPTP_CHAR DS 0H 18550000 OI POSDFLGS-POSDDATA(R1),POSDCHAR 18560000 B DOOPTRET 18570000 SPACE 1 18580000 DOOPTK DS 0H 18590000 L R1,LASTAREA Point to current KV area 18600000 CLC =C'ASIS ',OPTION 18610000 BE DOOPTK_ASIS 18620000 CLC =C'QUOTABLE ',OPTION 18630000 BE ERROR_OPT_POS_ONLY 18640000 B ERROR_OPT_INVALID All other options are bad, error 18650000 SPACE 1 18660000 DOOPTK_ASIS DS 0H 18670000 OI KEYFLAGS-KEYDDATA(R1),KEYFASIS 18680000 B DOOPTRET 18690000 SPACE 1 18700000 DOOPTRET DS 0H 18710000 L R14,DOOPT14 18720000 BR R14 18730000 EJECT 18740000 SCAN DS 0H 18750000 * 18760000 *********************************************************************** 18770000 * * 18780000 * This routine scans the command buffer for operands. It returns the * 18790000 * address of the next operand in R1 and its length in R2 (when there * 18800000 * are no more operands, R1 and R2 are zeroed). The operand may be a * 18810000 * name, a number, a parenthesis, or a quoted string. If it's a quoted * 18820000 * string, it will be returned as is, quotes and all. * 18830000 * * 18840000 * Return is as follows: * 18850000 * * 18860000 * To return address + 0 ... no value found * 18870000 * To return address + 4 ... unquoted string found * 18880000 * To return address + 8 ... quoted string found * 18890000 * To return address + 12 ... left parenthesis found * 18900000 * To return address + 16 ... right parenthesis found * 18910000 * * 18920000 * SCANPTR -> area to scan; SCANEPTR -> end thereof * 18930000 * * 18940000 *********************************************************************** 18950000 * 18960000 L R1,SCANPTR Point to data to scan 18970000 XR R2,R2 Clear TRT register 18980000 L R3,SCANEPTR Point to end of data to scan 18990000 SR R3,R1 Get length of data to scan 19000000 LA R0,256 Set up constant 256 19010000 LTR R3,R3 If length is zero 19020000 BZ SCANEND then finished, return no value 19030000 SCANLOOP DS 0H Do TRT for remaining length 19040000 CR R3,R0 If length greater than 256 19050000 BNH SCANLEFF then... 19060000 TRT 0(256,R1),STBL0 scan for important characters 19070000 BNZ SCANGOT1 If we found something, process it 19080000 AR R1,R0 Else increment text pointer by 256 19090000 SR R3,R0 Decrement length by 256 19100000 BP SCANLOOP Either continue scanning 19110000 B SCANEND or exit (no value), length now zero 19120000 SCANLEFF DS 0H Else... 19130000 BCTR R3,0 Reduce length for execute 19140000 EX R3,SCANTRT Scan for important characters 19150000 BNZ SCANGOT1 If we found something, process it 19160000 ******** B SCANEND If none found, exit in failure 19170000 SCANEND DS 0H Reached end of data 19180000 XR R1,R1 Clear scanning registers 19190000 XR R2,R2 19200000 BR R14 Return with no value 19210000 SCANGOT1 DS 0H R1 -> something we found 19220000 L R3,SCANEPTR 19230000 SR R3,R1 R3 := length remaining to scan 19240000 B *(R2) R2 tells what kind it is 19250000 B GOTWORD 4: Found nonblank 19260000 B GOTLP 8: Found ( 19270000 B GOTRP 12: Found ) 19280000 B GOTSLASH 16: Found / 19290000 B GOTQUOTE 20: Found ' 19300000 SPACE 1 19310000 GOTWORD DS 0H Found a nonblank (word) 19320000 * R1 -> it, R3 = length to scan 19330000 * 19340000 * Scan for end-of-word 19350000 * 19360000 LR R15,R1 Save address of the word 19370000 GOTWORDL CR R3,R0 If length greater than 256 19380000 BNH GOTWORDX then... 19390000 TRT 0(256,R1),STBLWORD scan for important characters 19400000 BNZ GOTWORDT If we found it, go. Else 19410000 AR R1,R0 Increment text pointer by 256 19420000 SR R3,R0 Decrement length by 256 19430000 BP GOTWORDL Either continue scanning 19440000 B GOTWORDE or go if length zero 19450000 GOTWORDX DS 0H Else... 19460000 BCTR R3,0 Reduce length for execute 19470000 EX R3,GOTWTRT Scan for important characters 19480000 BNZ GOTWORDT If found something, go 19490000 L R1,SCANEPTR Else end of text = end of word 19500000 B GOTWORDE 19510000 GOTWORDT L R3,SCANEPTR R3 := length remaining to scan 19520000 SR R3,R1 R1 -> character 19530000 B *(R2) Branch depending on R2 19540000 B GOTWORDE 4: Found whitespace, end of word 19550000 B GOTWLP 8: Found ( 19560000 B GOTWRP 12: Found ) 19570000 B GOTWS 16: Found / 19580000 SPACE 1 19590000 GOTWORDE DS 0H Found whitespace or end of word 19600000 LR R2,R1 Set length of word found 19610000 SR R2,R15 19620000 ST R1,SCANPTR Set scan pointer for next scan 19630000 LR R1,R15 Set pointer to found item 19640000 B 4(,R14) Return to caller with unquoted word 19650000 GOTWLP DS 0H Found "(" in word 19660000 ICM R2,15,PARCOUNT Get parenthesis count 19670000 BZ GOTWORDE If was zero, not nested, end of word 19680000 LA R2,1(,R2) Increment it 19690000 ST R2,PARCOUNT 19700000 B GOTWNEXT Else process as constituent char 19710000 GOTWRP DS 0H Found a right parenthesis ")" 19720000 ICM R2,15,PARCOUNT Get parenthesis count 19730000 BZ GOTWORDE If was zero, not nested, end of word 19740000 BCTR R2,0 Decrement count 19750000 ST R2,PARCOUNT 19760000 LTR R2,R2 19770000 BZ GOTWORDE If now zero, not nested, end of word 19780000 B GOTWNEXT Else process as constituent char 19790000 GOTWS DS 0H Found a slash "/" 19800000 ICM R2,15,PARCOUNT Get parenthesis count 19810000 BNZ GOTWNEXT If inside (), treat as constituent 19820000 B GOTWORDE Else treat as end of word 19830000 SPACE 1 19840000 GOTWNEXT LA R1,1(,R1) Bump text pointer 19850000 BCT R3,GOTWORDL Decrement count, scan if nonzero 19860000 B GOTWORDE end of word 19870000 SPACE 1 19880000 GOTLP DS 0H Found a left parenthesis "(" 19890000 * R1 -> it, R3 = length to scan 19900000 ICM R2,15,PARCOUNT Get parenthesis count 19910000 BNZ GOTWORD If count was nonzero, start of word 19920000 LA R2,1(,R2) Increment it 19930000 ST R2,PARCOUNT 19940000 LA R2,1 Else set length to 1 19950000 LA R15,1(,R1) Set pointer past it 19960000 ST R15,SCANPTR Update scan pointer 19970000 B 12(,R14) Return single left parenthesis 19980000 SPACE 1 19990000 GOTRP DS 0H Found a right parenthesis ")" 20000000 * R1 -> it, R3 = length to scan 20010000 ICM R2,15,PARCOUNT Get parenthesis count 20020000 BZ SCANRETP If was zero, not nested, return ")" 20030000 BCTR R2,0 Decrement count 20040000 ST R2,PARCOUNT 20050000 LTR R2,R2 20060000 BNZ GOTWORD If now nonzero, part of word 20070000 SCANRETP DS 0H Return the parenthesis 20080000 LA R2,1 Set length to 1 20090000 LA R15,1(,R1) Set pointer past it 20100000 ST R15,SCANPTR Update scan pointer 20110000 B 16(,R14) Return single right parenthesis 20120000 SPACE 1 20130000 GOTQUOTE DS 0H Found a single quote "'" 20140000 * R1 -> it, R3 = length to scan 20150000 LR R15,R1 Save address of the quoted string 20160000 LA R1,1(,R1) Bump past initial quote 20170000 BCT R3,GOTQL Decrement length to scan 20180000 B ERRQUOTE If nothing left, error 20190000 GOTQL CR R3,R0 If length greater than 256 20200000 BNH GOTQX then... 20210000 TRT 0(256,R1),STBLQUOT scan for "'" 20220000 BNZ GOTQT If we found it, go. Else 20230000 AR R1,R0 Increment text pointer by 256 20240000 SR R3,R0 Decrement length by 256 20250000 BP GOTQL Either continue scanning 20260000 B ERRQUOTE or, if length zero, error 20270000 GOTQX DS 0H Else... 20280000 BCTR R3,0 Reduce length for execute 20290000 EX R3,GOTQTRT Scan for "'" 20300000 BNZ GOTQT If found something, go 20310000 B ERRQUOTE Else error 20320000 GOTQT DS 0H Reached "'" 20330000 L R3,SCANEPTR 20340000 SR R3,R1 R3 := length remaining to scan 20350000 BNP GOTQE If zero, it's the ending quote 20360000 CLI 1(R1),C'''' If not "''" 20370000 BNE GOTQE then it's the ending quote 20380000 LA R1,2(,R1) Else bump past "''" 20390000 SH R3,=H'2' Decrement scan length 20400000 BP GOTQL If something left, continue scan 20410000 B ERRQUOTE Else error 20420000 GOTQE DS 0H End of quoted string 20430000 LA R1,1(,R1) Bump past final quote mark 20440000 LR R2,R1 Set length of string including "'"s 20450000 SR R2,R15 20460000 ST R1,SCANPTR Set scan pointer for next scan 20470000 LR R1,R15 Set pointer to found item 20480000 B 8(,R14) Return quoted string to caller 20490000 SPACE 1 20500000 GOTSLASH DS 0H Found a slash "/" 20510000 * R1 -> it, R3 = length to scan 20520000 CH R3,=H'2' If not enough room for "/*" 20530000 BL GOTSL then treat as real slash 20540000 CLI 1(R1),C'*' If not "/*" 20550000 BNE GOTSL then treat as real slash 20560000 LA R1,2(,R1) Else start of comment: bump text ptr 20570000 SH R3,=H'2' Decrement length to scan 20580000 BNP SCANEND If nothing left, end of text 20590000 GOTCOMML CR R3,R0 If length greater than 256 20600000 BNH GOTCOMMX then... 20610000 TRT 0(256,R1),STBLCOMM scan for "*" 20620000 BNZ GOTCOMME If we found it, go. Else 20630000 AR R1,R0 Increment text pointer by 256 20640000 SR R3,R0 Decrement length by 256 20650000 BP GOTCOMML Either continue scanning 20660000 B SCANEND or, if length zero, end of text 20670000 GOTCOMMX DS 0H Else... 20680000 BCTR R3,0 Reduce length for execute 20690000 EX R3,GOTCTRT Scan for "*" 20700000 BNZ GOTCOMME If found something, go 20710000 B SCANEND Else end of text 20720000 GOTCOMME DS 0H Reached an "*" 20730000 L R3,SCANEPTR 20740000 SR R3,R1 R3 := length remaining to scan 20750000 CH R3,=H'2' If not enough room for "*/" 20760000 BL GOTCOMMC then continue scanning for it 20770000 CLI 1(R1),C'/' If not "*/" 20780000 BNE GOTCOMMC then continue scanning for it 20790000 LA R1,2(,R1) Else bump past "*/" 20800000 SH R3,=H'2' Decrement scan length 20810000 BP SCANLOOP If something left, continue scan 20820000 B SCANEND Else end of text 20830000 GOTCOMMC DS 0H "*" but no "/" 20840000 LA R1,1(,R1) Bump past "*" 20850000 BCT R3,GOTCOMML Decrement length, continue if nzero 20860000 B SCANEND Else end of text 20870000 GOTSL DS 0H Found a slash "/" without a "*" 20880000 ICM R2,15,PARCOUNT Get parenthesis count 20890000 BNZ GOTWORD If inside (), treat as constituent 20900000 RETSLASH DS 0H Else treat as single slash "/" 20910000 LA R2,1 Set length to 1 20920000 LA R15,1(,R1) Set pointer past it 20930000 ST R15,SCANPTR Update scan pointer 20940000 B 20(,R14) Return single slash 20950000 SPACE 1 20960000 ERRQUOTE DS 0H Mismatched quotes 20970000 XR R2,R2 No accompanying data 20980000 XR R3,R3 " " " 20990000 ERROR MSG_QUOTE_ERROR 21000000 SPACE 1 21010000 SCANTRT TRT 0(*-*,R1),STBL0 (Executed instruction) 21020000 GOTWTRT TRT 0(*-*,R1),STBLWORD (Executed instruction) 21030000 GOTCTRT TRT 0(*-*,R1),STBLCOMM (Executed instruction) 21040000 GOTQTRT TRT 0(*-*,R1),STBLQUOT (Executed instruction) 21050000 SPACE 1 21060000 STBL0 DC 256YL1(4) Table to scan for good stuff 21070000 ORG STBL0+C' ' Blank 21080000 DC YL1(0) is whitespace 21090000 ORG STBL0+C',' Comma 21100000 DC YL1(0) is whitespace 21110000 ORG STBL0+X'05' Tab 21120000 DC YL1(0) is whitespace 21130000 ORG STBL0+C'(' Left parenthesis 21140000 DC YL1(8) is special 21150000 ORG STBL0+C')' Right parenthesis 21160000 DC YL1(12) is special 21170000 ORG STBL0+C'/' Slash 21180000 DC YL1(16) might be part of /* 21190000 ORG STBL0+C'''' Quote 21200000 DC YL1(20) is special 21210000 ORG , 21220000 SPACE 1 21230000 STBLWORD DC 256YL1(0) Table to scan for end of word 21240000 ORG STBLWORD+C' ' Blank 21250000 DC YL1(4) is whitespace 21260000 ORG STBLWORD+C',' Comma 21270000 DC YL1(4) is whitespace 21280000 ORG STBLWORD+X'05' Tab 21290000 DC YL1(4) is whitespace 21300000 ORG STBLWORD+C'(' Left parenthesis 21310000 DC YL1(8) is special 21320000 ORG STBLWORD+C')' Right parenthesis 21330000 DC YL1(12) is special 21340000 ORG STBLWORD+C'/' Slash 21350000 DC YL1(16) might be part of /* 21360000 ORG , 21370000 SPACE 1 21380000 STBLCOMM DC 256YL1(0) Table to scan for "*/" 21390000 ORG STBLCOMM+C'*' 21400000 DC 1YL1(1) 21410000 ORG , 21420000 SPACE 1 21430000 STBLQUOT DC 256YL1(0) Table to scan for "'" 21440000 ORG STBLQUOT+C'''' 21450000 DC 1YL1(1) 21460000 ORG , 21470000 VERTBL DC 256YL1(1) Table to verify parameter syntax 21480000 ORG VERTBL+C'_' Underscore is valid (?) 21490000 DC YL1(0) valid? 21500000 ORG VERTBL+C'@' National character is valid (?) 21510000 DC YL1(0) 21520000 ORG VERTBL+C'#' National character is valid (?) 21530000 DC YL1(0) 21540000 ORG VERTBL+C'$' National character is valid (?) 21550000 DC YL1(0) 21560000 ORG VERTBL+C'a' Lower case alphabetics are valid 21570000 DC 9YL1(0) 21580000 ORG VERTBL+C'j' 21590000 DC 9YL1(0) 21600000 ORG VERTBL+C's' 21610000 DC 8YL1(0) 21620000 ORG VERTBL+C'A' Upper case alphabetics are valid 21630000 DC 9YL1(0) 21640000 ORG VERTBL+C'J' 21650000 DC 9YL1(0) 21660000 ORG VERTBL+C'S' 21670000 DC 8YL1(0) 21680000 ORG VERTBL+C'0' Numerics are valid (except 1st pos) 21690000 DC 10YL1(0) 21700000 ORG , 21710000 UPTBL DC 256YL1(*-UPTBL) Table to translate to uppercase 21720000 ORG UPTBL+C'a' 21730000 DC C'ABCDEFGHI' 21740000 ORG UPTBL+C'j' 21750000 DC C'JKLMNOPQR' 21760000 ORG UPTBL+C's' 21770000 DC C'STUVWXYZ' 21780000 ORG , 21790000 EJECT 21800000 PUTLINE DS 0H 21810000 * 21820000 *********************************************************************** 21830000 * * 21840000 * This routine displays messages to the TSO user using the TSO * 21850000 * PUTLINE service routine. At entry R1 contains the address of the * 21860000 * message to be displayed, and R0 contains the length of the message. * 21870000 * R3 points to additional data to be displayed, and R2 is its length. * 21880000 * If R1 is zero, the message has already been built in the workarea * 21890000 * MSGWA. The message is assumed to begin with a message ID unless * 21900000 * the first character is blank, in which case the initial blank is * 21910000 * stripped off by PUTLINE anyhow. * 21920000 * * 21930000 *********************************************************************** 21940000 * 21950000 ST R14,PUTL14 Save return register 21960000 LTR R15,R0 Load length value 21970000 BNP PUTLRET If zero, don't do anything 21980000 BCTR R15,0 Else reduce length for execute 21990000 LTR R1,R1 If R1 is zero, 22000000 BZ PUTIT then message already set up. 22010000 EX R15,MVCPUT Else move message to work area 22020000 LTR R2,R2 If additional data, 22030000 BZ PUTIT then 22040000 LA R1,MSGWA+1(R15) Point to end of message 22050000 CH R2,=H'256' (Use max length of 256) 22060000 BNH *+8 22070000 LA R2,256 22080000 BCTR R2,0 Reduce data length for execute 22090000 EX R2,MVCPUT2 Move additional data to work area 22100000 LA R15,1(R15,R2) Add length of data to msg length 22110000 PUTIT DS 0H 22120000 LA R15,5(,R15) Restore length + 4 for header 22130000 SLL R15,16 Shift length into left half of hdr 22140000 STCM R15,15,MSGHDR Put zeroes into right half of hdr 22150000 PUTLINE_RETRY DS 0H 22160000 XC ECB,ECB Clear ECB 22170000 PUTLINE PARM=PTLIST, X22180000 MF=(E,IOPL), X22190000 OUTPUT=(OLD,TERM,SINGLE,INFOR) 22200000 LTR R15,R15 If PUTLINE OK 22210000 BZ PUTLRET then return 22220000 CH R15,=H'8' Else if attention interrupt 22230000 BE PUTLRET then OK 22240000 CH R15,=H'12' Else if pending 2nd level message 22250000 BE PUTL12 then OK 22260000 PUTERROR DS 0H Else PUTLINE error 22270000 CVD R15,DOUBLE 22280000 UNPK DOUBLE(2),DOUBLE(8) 22290000 OI DOUBLE+1,X'F0' 22300000 MVC MSGWA+1(L'MSG_PUTLINE_FAILURE1),MSG_PUTLINE_FAILURE1 22310000 MVC MSGWA+1+L'MSG_PUTLINE_FAILURE1(2),DOUBLE 22320000 MVC MSGWA+1+L'MSG_PUTLINE_FAILURE1+2(L'MSG_PUTLINE_FAILURE2)X22330000 ,MSG_PUTLINE_FAILURE2 22340000 TPUT MSGWA+1,L'MSG_PUTLINE_FAILURE1+2+L'MSG_PUTLINE_FAILURE2 22350000 LA R1,MSGWA 22360000 LH R0,MSGHDR 22370000 SH R0,=H'4' 22380000 TPUT (1),(0),R Try to display original message 22390000 PUTLRET L R14,PUTL14 Restore return register 22400000 BR R14 Return 22410000 * 22420000 PUTL12 DS 0H Try putting out pending 2nd level ms 22430000 XC ECB,ECB Clear ecb 22440000 PUTLINE PARM=PTLIST,MF=(E,IOPL),OUTPUT=(0,TERM,SINGLE,INFOR) 22450000 B PUTLINE_RETRY 22460000 * 22470000 MVCPUT MVC MSGWA(*-*),0(R1) Executed 22480000 MVCPUT2 MVC 0(*-*,R1),0(R3) Executed 22490000 EJECT 22500000 MFLUSH STACK MF=L,DELETE=ALL 22510000 LENFLUSH EQU *-MFLUSH 22520000 * 22530000 MPTLIST PUTLINE MF=L,OUTPUT=(0,TERM,SINGLE,INFOR) 22540000 LENPUTL EQU *-MPTLIST 22550000 * 22560000 EJECT 22570000 LTORG 22580000 EJECT 22590000 *********************************************************************** 22600000 * Messages * 22610000 *********************************************************************** 22620000 SPACE 1 22630000 MSG_NO_OPERANDS DC C'XPROC001 No operands specified.' 22640000 MSG_REXX_REQUIRED DC C'XPROC002 Not in REXX: input variable required.' 22650000 MSG_NO_POS_COUNT DC C'XPROC003 Missing positional parameter count.' 22660000 MSG_BAD_POS_COUNT DC C'XPROC004 Invalid positional parameter count: ' 22670000 MSG_QUOTE_ERROR DC C'XPROC005 Missing end quote.' 22680000 MSG_NO_WANT_LP DC C'XPROC006 "(" found where not expected.' 22690000 MSG_NO_WANT_RP DC C'XPROC007 ")" found where not expected.' 22700000 MSG_NO_WANT_QS DC C'XPROC008 Quoted string in invalid position.' 22710000 MSG_TOO_FEW_PPARMS DC C'XPROC009 Fewer positional parms than expected.' 22720000 MSG_PP_WITH_LP DC C'XPROC010 Value not allowed on positional: ' 22730000 MSG_PARM_TOO_LONG DC C'XPROC011 Parameter name too long (> 255): ' 22740000 MSG_PARM_INVALID DC C'XPROC012 Invalid syntax in parameter name: ' 22750000 MSG_PARM_DUPLICATE DC C'XPROC013 Duplicate parameter name: ' 22760000 MSG_EXTRANEOUS DC C'XPROC014 Extraneous data ignored in value: ' 22770000 MSG_VAR_TOO_LONG DC C'XPROC015 Variable name too long (> 256): ' 22780000 MSG_GETTING_VAR DC C'XPROC016 Error accessing value of variable: ' 22790000 MSG_PUTTING_VAR DC C'XPROC017 Error storing value of variable: ' 22800000 MSG_IKJCT441_RC DC C'XPROC018 IKJCT441 return code is: ' 22810000 MSG_PARSE_FAILURE DC C'XPROC019 PARSE service routine failure, code: ' 22820000 MSG_GETMAIN_FAIL DC C'XPROC020 Not enough main storage to execute.' 22830000 MSG_IRXEXCOM_FAIL DC C'XPROC021 IRXEXCOM failure, error code: ' 22840000 MSG_STACK_ERROR DC C'XPROC022 STACK service routine failure, code: ' 22850000 MSG_NO_WANT_SL DC C'XPROC023 "/" found where not expected.' 22860000 MSG_OPT_TOO_LONG DC C'XPROC024 Option name too long: ' 22870000 MSG_OPT_INVALID DC C'XPROC025 Invalid option name: ' 22880000 MSG_ASIS_NEEDS_VAL DC C'XPROC026 ASIS invalid with valueless keyword: ' 22890000 MSG_OPT_POS_ONLY DC C'XPROC027 Option valid only for positional: ' 22900000 * 22910000 MSG_KV_ERROR DC C'XPROC999 Internal error in keyword value scan.' 22920000 * 22930000 MSG_PUTLINE_FAILURE1 DC C'*** XPROC: PUTLINE error code ' 22940000 MSG_PUTLINE_FAILURE2 DC C' trying to issue the following message:' 22950000 * 22960000 ISMSG DC C'*** XPROC ignoring slash after this parameter: ' dummy 22970000 SPACE 1 22980000 EJECT 22990000 *********************************************************************** 23000000 * Constants * 23010000 *********************************************************************** 23020000 SPACE 1 23030000 KEYDINCR DC A(100*KEYDDATL) Initial & increment key area length 23040000 SPACE 1 23050000 NUMTBL DC 256YL1(1) Table to validate numerics 23060000 ORG NUMTBL+C'0' 23070000 DC 10YL1(0) 23080000 ORG , 23090000 EJECT 23100000 MSG_IKJCT441_RC08 DC C'XPROC508 Variable is a CLIST built-in function.' 23110000 MSG_IKJCT441_RC12 DC C'XPROC512 Variable is a CLIST label.' 23120000 MSG_IKJCT441_RC16 DC C'XPROC516 CLIST variable cannot be updated.' 23130000 MSG_IKJCT441_RC24 DC C'XPROC524 Variable is a CLIST subprocedure.' 23140000 MSG_IKJCT441_RC32 DC C'XPROC532 GETMAIN or FREEMAIN storage failure.' 23150000 MSG_IKJCT441_RC36 DC C'XPROC536 Variable name or value too long.' 23160000 MSG_IKJCT441_RC40 DC C'XPROC540 No valid CLIST or REXX environment.' 23170000 MSG_IKJCT441_RC76 DC C'XPROC576 Undefined &&SYSX CLIST variable.' 23180000 MSG_IKJCT441_RC80 DC C'XPROC580 Variable name invalid for REXX.' 23190000 MSG_IKJCT441_RC81 DC C'XPROC581 Internal REXX routine failure.' 23200000 EJECT 23210000 *********************************************************************** 23220000 * Work area * 23230000 *********************************************************************** 23240000 SPACE 1 23250000 DATD DSECT , Dynamically acquired work area 23260000 SPACE 1 23270000 SAVEAREA DS 18F OS save area 23280000 SAVE2 DS 18F Save area for PARSE exit routines 23290000 DOUBLE DS D Conversion work area 23300000 DATDLEN DS F Length of this work area 23310000 PUTL14 DS F Return register save 23320000 E44114 DS F Return register save 23330000 DOOPT14 DS F Return register save 23340000 SAVER2 DS A Save for TRT register 23350000 MYBASES DS 2A Base regs for IKJPARS exit routines 23360000 SCANRES DS 2A Used to save output from SCAN 23370000 WORDPTR DS A Address of next slot for word copy 23380000 PWADDR DS A Address of IKJPARS PCL area 23390000 PWLEN DS F Length of IKJPARS PCL area 23400000 PCLLEN DS F Actual length of the IKJPARS PCL 23410000 QOFF DS A Address of quoted-value-string area 23420000 QVALLEN DS F Length of quoted-value-string area 23430000 VUPADDR DS F Address of IKJCT441 update parm list 23440000 VUPLEN DS F Length of IKJCT441 update parm list 23450000 PDLLEN DS F Length of the IKJPARS PDL 23460000 VBUFADDR DS A Address of fake command buffer 23470000 VBUFLEN DS A Length of fake command buffer 23480000 ARGADDR DS A Address of ARG buffer 23490000 ARGLEN DS F Length of ARG buffer 23500000 SCANPTR DS A Scanning pointer 23510000 SCANEPTR DS A Scanning end pointer 23520000 PARCOUNT DS F Parenthesis count 23530000 PVARADDR DS A Address of input variable name 23540000 PVARLEN DS F Length of input variable name 23550000 POSCOUNT DS F Positional parameter count 23560000 KEYCOUNT DS F Keyword count 23570000 LASTAREA DS A Address of last pos or key area 23580000 LASTADDR DS A Address of last processed thing 23590000 LASTLEN DS F Length of last processed thing 23600000 APOSD DS A Address of positional parm area 23610000 LPOSD DS A Length of positional parm area 23620000 AKEYD DS A Address of keyword/value area 23630000 LKEYD DS A Length of keyword/value area 23640000 AKEYE DS A Address of end of keyword/value area 23650000 FIRSTKEY DS A Address of first IKJKEYWD PCE 23660000 SUBTOSET DS A Address of previous IKJSUBF PCE 23670000 FLAGS DS X Flags 23680000 FLAGPUTE EQU B'10000000' 1 = error putting variable values 23690000 FLAGPOSD EQU B'01000000' 1 = currently processing positionals 23700000 FLAGKEYD EQU B'00100000' 1 = currently processing keywords 23710000 * EQU B'00010000' Reserved 23720000 * EQU B'00001000' Reserved 23730000 * EQU B'00000100' Reserved 23740000 * EQU B'00000010' Reserved 23750000 * EQU B'00000001' Reserved 23760000 * 23770000 ECB DS F ECB for TSO routines 23780000 * 23790000 OLD DS 0F PUTLINE output line descriptor 23800000 OLDF1 DS F'1' Number of message segments 23810000 OLDMSG DS A(*-*) Address of the first message segment 23820000 * 23830000 MSGHDR DS F PUTLINE message header 23840000 MSGWA DS CL512 PUTLINE message work area 23850000 ARGWA DS CL512 ARG message work area 23860000 * 23870000 FLUSH STACK MF=L,DELETE=ALL 23880000 * 23890000 PTLIST PUTLINE MF=L,OUTPUT=(0,TERM,SINGLE,INFOR) 23900000 * 23910000 CPPL DS 0A 23920000 *********************************************************************** 23930000 * THE COMMAND PROCESSOR PARAMETER LIST (CPPL) IS A LIST OF * 23940000 * ADDRESSES PASSED FROM THE TMP TO THE CP VIA REGISTER 1 * 23950000 *********************************************************************** 23960000 * 23970000 CPPLCBUF DS A PTR TO COMMAND BUFFER 23980000 CPPLUPT DS A PTR TO UPT 23990000 CPPLPSCB DS A PTR TO PSCB 24000000 CPPLECT DS A PTR TO ECT 24010000 * 24020000 IOPL DS 0A 24030000 *********************************************************************** 24040000 * THE I/O SERVICE ROUTINE PARAMETER LIST (IOPL) IS A LIST OF * 24050000 * FULLWORD ADDRESSES PASSED BY THE INVOKER OF ANY I/O SERVICE * 24060000 * ROUTINE TO THE APPROPRIATE SERVICE ROUTINE VIA REGISTER ONE. * 24070000 *********************************************************************** 24080000 * 24090000 IOPLUPT DS A PTR TO UPT 24100000 IOPLECT DS A PTR TO ECT 24110000 IOPLECB DS A PTR TO USER'S ECB 24120000 IOPLIOPB DS A PTR TO THE I/O SERVICE RTN PARM BLOCK 24130000 * 24140000 PPL DS 0A 24150000 *********************************************************************** 24160000 * THE PARSE PARAMETER LIST (PPL) IS A LIST OF ADDRESSES PASSED * 24170000 * FROM THE INVOKER TO PARSE VIA REGISTER 1 * 24180000 *********************************************************************** 24190000 SPACE 24200000 PPLUPT DS A PTR TO UPT 24210000 PPLECT DS A PTR TO ECT 24220000 PPLECB DS A PTR TO CP'S ECB 24230000 PPLPCL DS A PTR TO PCL 24240000 PPLANS DS A PTR TO ANS PLACE 24250000 PPLCBUF DS A PTR TO CMD BUFFER 24260000 PPLUWA DS A PTR TO USER WORK AREA (FOR VALIDITY CK RTNS) 24270000 PPLVEWA DS A PTR TO USER WORK AREA FOR VERIFY EXITS 24280000 * 24290000 ANSWER DS F ANSWER AREA FOR PARSE 24300000 SPACE 1 24310000 CVPARMS DS 0F Variable access facility parm list 24320000 CVPARM1 DS A Parameter 1: entry code 24330000 CVPARM2 DS A Parameter 2: address of var name 24340000 CVPARM3 DS A Parameter 3: length of var name 24350000 CVPARM4 DS A Parameter 4: address of var value 24360000 CVPARM5 DS A Parameter 5: length of var value 24370000 CVPARM6 DS A Parameter 6: token (not used) 24380000 * 24390000 CVENTRY DS A Entry code 24400000 CVNAMEA DS A Address of variable name 24410000 CVNAMEL DS A Length of variable name 24420000 CVVALUEA DS A Address of variable value 24430000 CVVALUEL DS A Length of variable value 24440000 CVTOKEN DS A Token (not used) 24450000 CVECT DS A ECT (not used) 24460000 * 24470000 RC441 DS F Return code from IKJCT441 24480000 SPACE 1 24490000 SPACE 1 24500000 IRPARMS DS 0F IRXEXCOM parameter list 24510000 IRPARM1 DS A Parameter 1: CL8'IRXEXCOM' 24520000 IRPARM2 DS A Parameter 2: same as parameter 3 24530000 IRPARM3 DS A Parameter 3: same as parameter 2 24540000 IRPARM4 DS A Parameter 4: SHVBLOCK 24550000 * 24560000 *********************************************************************** 24570000 * * 24580000 * Copied from 'SYS1.MACLIB(IRXSHVB)'. * 24590000 * * 24600000 *********************************************************************** 24610000 * 24620000 SHVBLOCK DS 0D SHARED VARIABLE REQUEST BLOCK 24630000 SHVNEXT DS A Chain pointer to next SHVBLOCK 24640000 SHVUSER DS F Used during "FETCH NEXT" 24650000 * Contains length of buffer 24660000 * pointed to by SHVNAMA 24670000 SHVCODES DS 0F 24680000 SHVCODE DS CL1 Function code - indicates type 24690000 * of variable access request 24700000 SHVRET DS XL1 Return codes 24710000 DS H'0' Reserved (should be 0) 24720000 SHVBUFL DS F Length of fetch value buffer 24730000 SHVNAMA DS A Address of variable name 24740000 SHVNAML DS F Length of variable name 24750000 SHVVALA DS A Address of value buffer 24760000 SHVVALL DS F Length of value buffer 24770000 * (Set on fetch) 24780000 SHVBLEN EQU *-SHVBLOCK Length of SHVBLOCK 24790000 SPACE 1 24800000 **********************************************************************/ 24810000 * SHARED VARIABLE REQUEST BLOCK - function codes */ 24820000 **********************************************************************/ 24830000 SPACE 1 24840000 SHVFETCH EQU C'F' Copy value of shared variable 24850000 SHVSTORE EQU C'S' Set variable from given value 24860000 SHVDROPV EQU C'D' Drop variable 24870000 SHVSYFET EQU C'f' Symbolic name retrieve 24880000 SHVSYSET EQU C's' Symbolic name set 24890000 SHVSYDRO EQU C'd' Symbolic name drop 24900000 SHVNEXTV EQU C'N' Fetch "next" variable 24910000 SHVPRIV EQU C'P' Fetch private information 24920000 SPACE 1 24930000 **********************************************************************/ 24940000 * SHARED VARIABLE REQUEST BLOCK - return codes (SHVRET) */ 24950000 **********************************************************************/ 24960000 SPACE 1 24970000 SHVCLEAN EQU X'00' Execution was OK 24980000 SHVNEWV EQU X'01' Variable did not exist 24990000 SHVLVAR EQU X'02' Last variable transferred ("N") 25000000 SHVTRUNC EQU X'04' Truncation occurred for "Fetch" 25010000 SHVBADN EQU X'08' Invalid variable name 25020000 SHVBADV EQU X'10' Invalid value specified 25030000 SHVBADF EQU X'80' Invalid function code (SHVCODE) 25040000 SPACE 1 25050000 **********************************************************************/ 25060000 * R15 return codes */ 25070000 **********************************************************************/ 25080000 SPACE 1 25090000 SHVRCOK EQU 0 Entire Plist chain processed 25100000 SHVRCINV EQU -1 Invalid entry conditions 25110000 SHVRCIST EQU -2 Insufficient storage available 25120000 SPACE 25130000 * 25140000 PVAR DS CL256 Area to build input variable name 25150000 OPTION DS CL16 Area to build option name 25160000 SPACE 1 25170000 SIZDATD EQU *-DATD Length of fixed part of work area 25180000 SPACE 1 25190000 WORDCOPY EQU * Area to put copies of keyword names 25200000 EJECT 25210000 POSDDATA DSECT , Info on positional parameter specs 25220000 SPACE 1 25230000 * (POSCOUNT) occurrences of... 25240000 * 25250000 POSDADDR DS A Address of positional parameter name 25260000 POSDLEN DS A Length of positional parameter name 25270000 POSDPCEA DS A Address of PCE for this parameter 25280000 POSDPCEL DS A Length of PCE for this parameter 25290000 POSDMAXL DS A Maximum length for prompting message 25300000 POSDFLGS DS X Flags 25310000 POSDOPT EQU B'10000000' 1 = parameter is optional 25320000 POSDCHAR EQU B'01000000' 1 = value is possibly-quoted string 25330000 POSDASIS EQU B'00100000' 1 = value is to be processed asis 25340000 * EQU B'00010000' Reserved 25350000 * EQU B'00001000' Reserved 25360000 * EQU B'00000100' Reserved 25370000 * EQU B'00000010' Reserved 25380000 * EQU B'00000001' Reserved 25390000 DS 0D Round to doubleword length 25400000 SPACE 1 25410000 POSDDATL EQU *-POSDDATA Length of an occurrence 25420000 EJECT 25430000 KEYDDATA DSECT , Info on keyword/value specs 25440000 SPACE 1 25450000 * some # of occurrences of... 25460000 * 25470000 KEYWORDA DS A Address of keyword 25480000 KEYWORDL DS A Length of keyword 25490000 KEYDVALA DS A Address of keyword's default value 25500000 KEYDVALL DS A Length of keyword's default value 25510000 KEYDPCEA DS A Address of PCE for this parameter 25520000 KEYDPCEL DS A Length of PCE for this parameter 25530000 KEYDMAXL DS A Maximum length for prompting message 25540000 KEYSUBOF DS A Where to store subfield offset 25550000 KEYFLAGS DS X Flags 25560000 KEYFDVAL EQU B'10000000' 1 = a default value was specified 25570000 KEYFQUOT EQU B'01000000' 1 = default value is quoted string 25580000 KEYFASIS EQU B'00100000' 1 = value is to be processed asis 25590000 * EQU B'00010000' Reserved 25600000 * EQU B'00001000' Reserved 25610000 * EQU B'00000100' Reserved 25620000 * EQU B'00000010' Reserved 25630000 * EQU B'00000001' Reserved 25640000 DS 0D Round to doubleword length 25650000 SPACE 1 25660000 KEYDDATL EQU *-KEYDDATA Length of an occurrence 25670000 EJECT 25680000 *********************************************************************** 25690000 * Macro expansions * 25700000 *********************************************************************** 25710000 SPACE 1 25720000 IKJTSVT 25730000 SPACE 1 #TSO162 25740000 IKJECT , #TSO162 25750000 SPACE 1 25760000 CVT DSECT=YES 25770000 END 25780000 ./ ADD NAME=XWRITENR TITLE 'XWRITENR copyright notice' 00010001 *********************************************************************** 00020000 * * 00030000 * Copyright (c) 1989 The Charles Stark Draper Laboratory, Inc. * 00040000 * * 00050000 * This program is provided on an "as is" basis. It may be freely * 00060000 * distributed as long as it is not offered for commercial sale, * 00070000 * and as long as this copyright notice is included. * 00080000 * * 00090000 *********************************************************************** 00100000 TITLE 'XWRITENR - REXX external function to simulate WRITENR' 00110000 XWRITENR CSECT 00120000 XWRITENR AMODE ANY 00130000 XWRITENR RMODE ANY 00140000 SPACE 00150000 *********************************************************************** 00160000 * 00170000 * Syntax: call XWRITENR "anything at all" 00180000 * 00190000 *********************************************************************** 00200000 * * 00210000 * Input: (R1) = address of IRXEFPL parameter list: * 00220000 * * 00230000 * Offset: * 00240000 * 00 = Reserved * 00250000 * 04 = Reserved * 00260000 * 08 = Reserved * 00270000 * 0C = Reserved * 00280000 * 10 = Address of the parsed argument list * 00290000 * 14 = Address of the address of the EVALBLOCK * 00300000 * * 00310000 ****************************************************************** 00320000 * * 00330000 * Output: R15 = return code from PUTLINE * 00340000 * * 00350000 ****************************************************************** 00360000 EJECT 00370000 R0 EQU 0 00380000 R1 EQU 1 00390000 R2 EQU 2 00400000 R3 EQU 3 00410000 R4 EQU 4 00420000 R5 EQU 5 00430000 R6 EQU 6 00440000 R7 EQU 7 00450000 R8 EQU 8 00460000 R9 EQU 9 00470000 R10 EQU 10 00480000 R11 EQU 11 00490000 R12 EQU 12 00500000 R13 EQU 13 00510000 R14 EQU 14 00520000 R15 EQU 15 00530000 EJECT 00540000 SAVE (14,12),,XWRITENR_&SYSDATE._&SYSTIME 00550000 BALR R12,0 00560000 USING *,R12 00570000 SPACE 00580000 L R2,16(,R1) R2 = address of parsed argument list 00590000 L R6,20(,R1) R6 = address of address of EVALBLOCK 00600000 L R6,0(,R6) R6 = address of EVALBLOCK 00610000 L R4,4(,R2) R4 = length of message 00620000 L R5,0(,R2) R5 = address of text of message 00630000 C R5,=X'FFFFFFFF' If number of arguments not 1 00640000 BE ERROR then error 00650000 L R0,8(,R2) 00660000 C R0,=X'FFFFFFFF' If number of arguments not 1 00670000 BNE ERROR then error 00680000 LTR R15,R4 If message length is zero 00690000 BZ RETURN then return code(zero) 00700000 LA R0,DYSIZE Get size of dynamic area w/o message 00710000 AR R0,R4 Add length of message 00720000 GETMAIN R,LV=(0) Get dynamic storage area 00730000 SPACE 00740000 ST R13,4(,R1) 00750000 ST R1,8(,R13) 00760000 LR R13,R1 00770000 USING DYNAM,R13 00780000 SPACE 00790000 LENOK DS 0H 00800000 CH R4,=H'256' If message is 256 chars or less 00810000 BH MOVELONG then... 00820000 LR R14,R4 00830000 BCTR R14,0 decrement length for move 00840000 EX R14,MOVEMSG Move message to buffer 00850000 B MSGMOVED else... 00860000 MOVELONG DS 0H 00870000 LA R0,PUTBUF+4 Address of message destination 00880000 LR R1,R4 Length of message destination 00890000 LR R14,R5 Address of message source 00900000 LR R15,R4 Length of message source 00910000 MVCL R0,R14 Move message to buffer 00920000 MSGMOVED DS 0H 00930000 LA R14,4(,R4) Add length of header 00940000 SLL R14,16 Shift: 1st HWD = hdr, 2nd = no 2ndary 00950000 ST R14,PUTBUF Put in first 2 halfwords in header 00960000 SPACE 00970000 LA R1,IOPLSP Set up IOPL 00980000 USING IOPL,R1 00990000 SPACE 01000000 USING PSA,0 01010000 L R8,PSATOLD GET TCB ADDRESS 01020000 USING TCB,R8 01030000 L R8,TCBJSCB GET JSCB ADDRESS 01040000 USING IEZJSCB,R8 01050000 L R8,JSCBACT GET ADDRESS OF ACTIVE JSCB 01060000 L R8,JSCBPSCB GET ADDRESS OF PSCB 01070000 USING PSCB,R8 01080000 MVC IOPLUPT,PSCBUPT PUT UPT ADDRESS IN IOPL 01090000 L R8,PSCBRLGB GET ADDR OF RELOGON BUFFER 01100000 USING RLGB,R8 01110000 MVC IOPLECT,RLGBECT PUT ADDRESS OF ECT IN IOPL 01120000 SPACE 01130000 SR R0,R0 01140000 ST R0,ECB Zero out ECB 01150000 ST R0,IOPLIOPB Zero out IOPL parm block address 01160000 LA R0,ECB 01170000 ST R0,IOPLECB Finish up IOPL 01180000 MVC PUTBLK(LPUTBLK),PUTMAST Build PUTLINE MF=L 01190000 DROP R1 01200000 EJECT 01210000 PUTLINE PARM=PUTBLK,OUTPUT=(PUTBUF,TERM,SINGLE,DATA), +01220000 TERMPUT=(ASIS), +01230000 MF=(E,(1)) 01240000 EJECT 01250000 ENDIT LR R3,R15 Save return code 01260000 LA R0,2 01270000 ST R0,8(,R6) Set EVLEN (in EVALBLOCK) to length 01280000 CVD R3,DOUBLE Return code 01290000 UNPK 16(2,R6),DOUBLE Generate 2 digits 01300000 OI 17(R6),X'F0' 01310000 CLI 16(R6),C'0' If first digit is 0 01320000 BNE NOTZ then 01330000 MVC 16(1,R6),17(R6) make it a 1-digit number 01340000 MVI 17(R6),C' ' 01350000 LA R0,1 set length to 1 01360000 ST R0,8(,R6) set EVLEN (in EVALBLOCK) to length 01370000 NOTZ DS 0H 01380000 LA R0,DYSIZE Get length of storage w/o message 01390000 AR R0,R4 Add length of message 01400000 LA R1,DYNAM Get address of storage 01410000 L R13,4(0,R13) 01420000 FREEMAIN R,LV=(0),A=(1) 01430000 RETURN DS 0H 01440000 RETURN (14,12),T,RC=0 01450000 SPACE 2 01460000 ERROR DS 0H Here if wrong # of arguments 01470000 LA R0,2 01480000 ST R0,8(,R6) Set EVLEN (in EVALBLOCK) to length 01490000 MVC 16(2,R6),=C'-2' Return value 01500000 B RETURN 01510000 SPACE 2 01520000 MOVEMSG MVC PUTBUF+4(0),0(R5) 01530000 EJECT 01540000 PUTMAST PUTLINE MF=L 01550000 EJECT 01560000 DYNAM DSECT 01570000 SPACE 01580000 SAVEAREA DS 9D 01590000 DOUBLE DS D Work area for conversions 01600000 SPACE 01610000 PUTBLK PUTLINE MF=L 01620000 LPUTBLK EQU *-PUTBLK 01630000 SPACE 01640000 IOPLSP DS 4F INPUT OUTPUT PARAMETER BLOCK 01650000 ECB DS F 01660000 SPACE 01670000 PUTBUF DS F MESSAGE HEADER 01680000 SPACE 01690000 * (Actual message buffer variable) 01700000 SPACE 01710000 DYSIZE EQU *-DYNAM Length of dynamic area w/o msg buf 01720000 EJECT 01730000 * 01740000 * STORAGE DEFINITIONS: 01750000 * 01760000 SPACE 01770000 IKJIOPL 01780000 SPACE 01790000 IKJCPPL 01800000 SPACE 01810000 IKJUPT 01820000 SPACE 01830000 IKJECT 01840000 SPACE 01850000 IKJPSCB 01860000 EJECT , 01870000 IHAPSA 01880000 EJECT , 01890000 IKJTCB 01900000 EJECT , 01910000 IEZJSCB 01920000 EJECT , 01930000 IKJRLGB 01940000 EJECT 01950000 SPACE 5 01960000 END 01970000 ./ ENDUP ?! //* //HELP EXEC MDLOAD,TRK1='5',TO='HELP' //SYSIN DD DATA,DLM='?!' ./ ADD NAME=XPROC *********************************************************************** * * * Copyright (c) 1989, 1992 The Charles Stark Draper Laboratory, Inc. * * * * This program is provided on an "as is" basis. It may be freely * * distributed as long as it is not offered for commercial sale, * * nd as long as this copyright notice is included. * * * *********************************************************************** * * XPROC 04/13/92 - SEB1525 - Version 2 - /quotable option added * )F FUNCTION - The XPROC command parses an argument string into positional and/or keyword parameters, similarly to the PROC statement of a CLIST. However, XPROC can be used inside a REXX exec to parse the argument to the exec, or inside a CLIST or REXX exec to process the value of a variable as if it were an argument string. The values of the parameters specified on the XPROC command cause the corresponding REXX or CLIST variables to be set, as they would in a CLIST PROC statement. The rules for entering parameters to be processed by the XPROC command are identical to those of the CLIST PROC statement - except that XPROC supports extensions to the CLIST PROC syntax by means of options preceded by the slash ("/") character. For more information on PROC syntax, consult a TSO/E CLIST manual, or use the local Draper command XHELPC PROC to view help for PROC. Notes: As for any TSO command, it is best to enclose the entire XPROC command in "double quotes" when using it from REXX. This includes the variable names. When XPROC is used, prompting is not available by default (unlike the PROC statement of a CLIST). Therefore, it is advisable to precede the call to XPROC with a statement that activates prompting, e.g. CALL PROMPT "ON" /* for REXX */ CONTROL PROMPT /* for CLIST */ Also, if there is an error in the XPROC command, or the parsing of the argument string fails, a REXX exec (or a CLIST with CONTROL NOFLUSH active) will NOT be flushed, but will continue to execute (with none of the parameters set). Therefore, you should check the value of RC (for REXX) or &LASTCC (for CLIST) afterwards and EXIT if it is not zero. )X SYNTAX - XPROC {input-variable} positional-number {positional-parameter{/option...} ...} {keyword-parameter{/option...}{({default-value})}{/option...}} The number of positional-parameters must be equal to the value of positional-number (which must be a number). Required: positional-number Note that the syntax of XPROC is exactly identical to that of the PROC statement of CLIST language, except for the optional "input-variable" and the "/option" feature. Examples: The following examples assume a REXX environment: Example 1: Define one positional parameter (DATASET), no keyword parameters: "XPROC 1 DATASET" Example 2: Define no positional parameters, and one keyword parameter (TESTING) which has a null default value: "XPROC 0 TESTING" Example 3: Define a positional parameter (LIBRARY), one keyword parameter (TRACE) which has a null default value, and one (SYSOUT) which has the default value "A": "XPROC 1 LIBRARY TRACE SYSOUT(A)" Example 4: Define three positional parameters (LIBRARY, TYPE and MEMBER) and a keyword (OWNER) with a default value of the user's TSO prefix. Note how we allow REXX to generate the desired default value so it appears in the XPROC command at execution time: "XPROC 3 LIBRARY TYPE MEMBER OWNER('"SYSVAR(SYSPREF)"')" Example 5: Define a positional parameter (NAME) and one keyword parameter (TITLE) which has a null default value, and one (SUBJECT) which has the default value "None". The values of all three parameters will be processed as is with respect to case. XPROC 1 NAME/ASIS TITLE/ASIS() SUBJECT(None)/ASIS The following examples work under REXX or CLIST (but be sure to enclose the command in "double quotes" under REXX): Example 6: Define a positional parameter (LIBRARY), one keyword parameter (TRACE) which has a null default value, and one (SYSOUT) which has the default value "A". The argument string to be parsed will be taken from the value of the variable "SYSDVAL". XPROC SYSDVAL 1 LIBRARY TRACE SYSOUT(A) Example 7: Define three positional parameters (LIBRARY, TYPE and MEMBER), and a keyword (MARK) with a default value of the current time. Note how we allow REXX to generate the desired default value so it appears in the XPROC command at execution time. The argument string to be parsed will be taken from the value of the variable "STRING". "XPROC STRING 3 LIBRARY TYPE MEMBER MARK('"TIME()"')" Under CLIST, this could be coded as: XPROC STRING 3 LIBRARY TYPE MEMBER MARK('&SYSTIME') but note that &SYSTIME gets resolved BEFORE the XPROC command executes. This is the only type of situation where an "&" is appropriate. )O OPERANDS - ))input-variable the NAME of a variable from which the argument string to be parsed is to be extracted. The name must conform to the rules for CLIST or REXX variable names. The specified variable must be set to the argument string to be processed (no command name included) before XPROC is invoked. The input-variable name may be omitted in a REXX exec ONLY, in which case the arguments to the REXX exec are accessed. This provides the same capability that the PROC statement of a CLIST would. ))positional-number a number (0 or greater) which specifies the number of positional parameters that follow. This is required. If there are no positional parameters, specify a 0. ))positional-parameter A variable name consisting of alphameric and national characters, of which the first cannot be numeric. The length of this name must be between 1 and 252 for CLISTs, and between 1 and 250 for REXX. Underscores may be part of the name. Note: Unlike the CLIST PROC statement, XPROC does not accept ampersands in parameter names. Ampersands in an XPROC command will cause normal symbolic substitution in CLISTS; they will cause errors under REXX. ))keyword-parameter A variable name consisting of alphameric and national characters, of which the first cannot be numeric. The length of this name must be between 1 and 252 for CLISTs, and between 1 and 250 for REXX. A default value in parentheses may optionally follow the parameter; if there is no default value, the keyword takes on its own name as a value if given by the caller, and a null string otherwise. Note: Unlike the CLIST PROC statement, XPROC does not accept ampersands ("&") in parameter names. Ampersands in an XPROC command will cause normal symbolic substitution in CLISTS; they will cause errors under REXX. ))default-value Any character string, including the null string. If it is present, it must follow a valid keyword parameter and be enclosed in parentheses (the right parenthesis may be omitted if this is at the end of the command). The value may be quoted (with single quotes, with two quotes representing one) or unquoted; however, if it contains any special characters (blanks, unbalanced parentheses, etc.), it must be quoted. If the caller provides an alternate value for the associated keyword, the keyword takes on the that value; otherwise it takes on the default value specified by XPROC. Note that although () may be specified in XPROC for a null string, a caller must type ('') to get the same result. ))option Processing options may be associated with positional or keyword parameters by specifying their names following the parameter name delimited by a slash. For example, assuming positional parameter name PP and keyword parameter name KP, and option name OP1 and OP2, the following are possible: PP/OP1 KP/OP1 KP/OP1(default) KP(default)/OP1 PP/OP1/OP2 KP/OP1(default)/OP2 The supported options at this time are ASIS and QUOTABLE. ))ASIS If the ASIS option is associated with a positional or keyword parameter that takes a value, the value specified by the user for that parameter is processed in case-retention mode. In other words, any lower-case characters present in the value are kept as is. This overrides the default behavior, which converts all parameter values to uppercase (the only behavior available via the PROC statement of CLIST). The ASIS option is not valid for keyword parameters that do not take a value (i.e. evaluate to themselves or null). Note that default values in the XPROC prototype are always processed asis, regardless of the presence of this option. Examples: XPROC 1 NAME/ASIS XPROC 0 TITLE/ASIS(default) XPROC 0 TITLE(default)/ASIS ))QUOTABLE If the QUOTABLE option is associated with a positional parameter, the value specified by the user for that parameter may be entered as a quoted string. In other words, embedded blanks or other special characters may be entered if the string is enclosed in single quotes by the user. The quotes do not become part of the resulting value; to pass in quotes, the user must provide doubled quotes, similar to the way quotes are specified for keyword values. This overrides the default behavior, which takes a blank-or-comma-delimited string as the value of the positional parameter, without honoring quotes specially. Thus, you may define a CLIST or REXX exec that takes a syntax like: MYCLIST 'hi there' 'how are you' and have the strings entered as positional parameters. The QUOTABLE option is valid only for positional parameters, not keyword parameters. Examples: XPROC 1 NAME/QUOTABLE XPROC 3 NAME/ASIS/QUOTABLE ADDRESS/QUOTABLE CITY/ASIS ./ ADD NAME=XWRITENR )F XWRITENR is a REXX external routine that functions like the WRITENR statement of CLIST language. In other words, it writes the evaluated <expression> to the TSO terminal, without a carriage return. This is available in TSO/E environments only. XWRITENR must be invoked via the REXX CALL instruction, in which case it places a return code (normally 0) in the RESULT variable. If XWRITENR is invoked as a REXX function, it returns the return code as the value. Exactly one argument must be specified; otherwise a return code of -2 is returned. In general, a call to XWRITENR should be followed by a statement that requests terminal input (PULL, PARSE PULL, or PARSE EXTERNAL). )X Syntax: CALL XWRITENR <expression> Note: Some hex control characters may be used in <expression> to produce certain effects: '24'x at the end of <expression> causes the keyboard to unlock following the message; anything typed in the field where the cursor is positioned is NOT DISPLAYED. A PULL or PARSE EXTERNAL instruction will pick up the entered data. This is useful for password prompts. '15'x at the end of <expression> acts as a "new line" character, so that the cursor is moved to the beginning of the next line. In other words, this makes XWRITENR behave like SAY. Normally this is not useful, but it may be useful in conjunction with 3270 data stream orders. Some 3270 data stream commands ('11'x for SBA, '1D'x for SF) may be embedded in <expression>. USE THESE WITH CAUTION! If the expression you want to display might contain invalid characters, use TRANSLATE() to remove them before attempting to display with XWRITENR, or use SAY instead. )O Example: call xwritenr "Enter name:" parse pull name /* Would display: Enter name: _ where _ represents the cursor */ call xwritenr "Enter password:" || '24'X parse pull password /* Would display: Enter password: _ where _ represents the cursor. The password would be entered in a print-inhibited input field. */ ./ ENDUP ?!