1 /****^  HISTORY COMMENTS:
   2   1) change(2016-03-10,GDixon), approve(2016-10-13,MCR10014),
   3      audit(2016-10-13,Swenson), install(2016-10-13,MR12.6f-0002):
   4      Test program to declare/invoke other program entrypoints from the command line.
   5   2) change(2016-06-29,GDixon), approve(2016-10-13,MCR10014),
   6      audit(2016-10-13,Swenson), install(2016-10-13,MR12.6f-0002):
   7      Version 01.01 of the user interface for call.
   8   3) change(2016-12-19,GDixon), approve(2017-01-14,MCR10014),
   9      audit(2017-01-14,Swenson), install(2017-01-14,MR12.6f-0014):
  10      call version 01.04, supporting revisions to call_dtype_fcns.incl.pl1.
  11                                                    END HISTORY COMMENTS */
  12 
  13 
  14           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
  15           /*                                                                                                */
  16           /* It would be nice to support:                                                                   */
  17           /*  - complex data types.                                                                         */
  18           /*                                                                                                */
  19           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
  20 
  21 
  22 
  23 call:
  24      proc;
  25 cl:  entry;
  26 
  27 /* ------------------------------------ *
  28  * Usage
  29  * ------------------------------------ */
  30 display_usage:
  31      proc;
  32 
  33      call ioa_ ("^(^a^)",
  34 "Syntax as a command:
  35   call {global_opts} virtual_entry {arg_value_specifiers}
  36 
  37 Syntax as an active function:
  38   [call {global_opts} virtual_entry {arg_value_specifiers}]",
  39           "
  40 
  41 Arguments:
  42 virtual_entry
  43   character representation of an external entrypoint to be invoked.
  44   Format of this string is described in: virtual_entries.gi.info",
  45           "
  46 arg_value_specifier
  47   one or more strings and options defining an argument to be passed to
  48   the entrypoint.  See ""List of arg_value_specifiers"".",
  49           "
  50 
  51 
  52 List of arg_value specifiers:
  53 -input arg_value {arg_options},
  54    -in arg_value {arg_options},
  55     -i arg_value {arg_options},
  56        arg_value {arg_options}",
  57           "
  58   gives an initial value for an entrypoint input argument before the
  59   call is made.  -input is the default if no direction option is
  60   given with an arg_value.",
  61           "
  62 -inout arg_value {arg_options},
  63    -io arg_value {arg_options}
  64   sets the initial value of an entrypoint input-output argument
  65   before the call is made.  The argument value is displayed after
  66   the entrypoint returns.",
  67           "
  68 
  69 -output {arg_options},
  70    -out {arg_options},
  71      -o {arg_options}
  72   no arg_value is provided; entrypoint argument value is displayed
  73   after the entrypoint returns. ",
  74           "
  75 -outignore {arg_options},
  76    -ignore {arg_options},
  77        -ig {arg_options}
  78   argument value is not displayed after the entrypoint returns.",
  79           "
  80 
  81 
  82 List of arg_options:
  83 -id ID
  84   gives a PL/I identifier naming the argument.
  85 -return, -ret
  86   return this argument when call is invoked as an active function.",
  87           "
  88 -octal, -oc
  89   displays an octal representation of storage for the argument,
  90   as well as the character string interpretation.",
  91           "
  92 
  93 -code, -cd
  94   argument is a Multics status code.  For an input argument,
  95   arg_value is a string naming a status code value.",
  96           "
  97 -date_time,
  98    -date, -dt,
  99    -time, -tm
 100   argument is a Multics clock value (fixed bin(71) aligned).  For an
 101   input argument, arg_value is a string representation of a date or
 102   time value.  For an output argument, clock value is converted to",
 103           "
 104   default process date_time, date, or time format.",
 105           "
 106 
 107 -declare DECLARATION,
 108     -dcl DECLARATION
 109   argument has the attributes given in DECLARATION.  A descriptor
 110   with these attributes is passed with this argument.",
 111           "
 112 -addr DECLARATION
 113   for a pointer argument, set its value to point to storage
 114   described by the PL/I DECLARATION, which is a single string
 115   defining data type and length attributes (e.g., ""char(20)"").",
 116           "
 117   For an input argument, the arg_value initializes this storage.
 118   For an output argument, the addressed storage is displayed.",
 119           "
 120 
 121 -max_length M, -ml M
 122   for a string or area parameter with star extents (e.g., char(*),
 123   char(*) var, bit(*), bit(*) var, area(*)), M is the length in
 124   characters, bits or area words of the corresponding argument.",
 125           "
 126 -length L, -ln L
 127 -length ID, -ln ID
 128   for a string argument, L gives the length in characters or bits to
 129   be displayed upon return from the entrypoint.  The ID format gives
 130   the identifier of another argument whose output value specifies",
 131           "
 132   the display length.",
 133           "
 134 
 135 
 136 List of global options:
 137 -all, -a
 138   Display all arguments upon return from virtual_entry.
 139 -octal, -oc
 140   Display all arguments with an octal representation of their
 141   storage.",
 142           "
 143 -debug INT, -db INT
 144   Display debug information as calling the virtual_entry proceeds.
 145   An INT equaling 1 provides basic debugging data; 2, 3, 4, or 5
 146   provides more details.",
 147           "
 148 
 149 
 150 Example:
 151 initiate_file_ has the following PL/I calling sequence:
 152 
 153    call initiate_file_( dir, entry, access_mode, ptr, bit_count, code);
 154 
 155 The display_entry_point_dcl (depd) command displays the parameter types:
 156 
 157    depd initiate_file_",
 158           "
 159      dcl initiate_file_ entry(char(*), char(*), bit(*), ptr,
 160            fixed bin(24), fixed bin(35));
 161 
 162 Invoke initiate_file_, specifying an initial value for each parameter:
 163 
 164    call initiate_file_ [wd]  my_file  100  -o  -o  -o -cd");
 165      call ioa_ ("^/^4-version:^-^a", CALL_VERSION);
 166 
 167      end display_usage;
 168 %page;
 169 
 170           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 171           /*                                                                                                */
 172           /* Include file containing constants referenced in other static declarations below.  PL/I         */
 173           /* requires such constants to appear in program source before these references.                   */
 174           /*                                                                                                */
 175           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 176 
 177 %include std_descriptor_types;
 178 %page;
 179           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 180           /*                                                                                                */
 181           /* Main control flow of the call program.  Look for the following major tasks performed by the    */
 182           /* code below:                                                                                    */
 183           /*  1) Determine whether call was invoked as a command or active function (AF).                   */
 184           /*  2) Look for first positional argument to call, which names the virtual_entry (a subroutine    */
 185           /*     or function) to be called.  While accessing this first positional argument, global         */
 186           /*     options may also be read.                                                                  */
 187           /*  3) Convert the virtual entry to basic information about the routine to be called:             */
 188           /*      A) a PL/I entry variable corresponding to the virtual entry;                              */
 189           /*      B) entrypoint attributes:                                                                 */
 190           /*          - subroutine or function                                                              */
 191           /*          - fixed parameter list or options(variable)                                           */
 192           /*      C) for entrypoint with a fixed parameter list:                                            */
 193           /*          - count of parameters                                                                 */
 194           /*          - for each parameter: data type, alignment, and aggregate information                 */
 195           /*     The call_entry_info_ subroutine performs this task.  This routine also creates a           */
 196           /*     translator_temp_ storage area, which call uses for most of its dynamic storage.            */
 197           /*      - For an options(variable) entrypoint, entrypoint parameter information (C above) is not  */
 198           /*        available.                                                                              */
 199           /*         - There is no information about parameter count or data types.                         */
 200           /*         - Such entrypoint must therefore be a subroutine; it cannot be a function, because     */
 201           /*           there are no parameter descriptors which could describe a returns attribute.         */
 202           /*         - The call user must provide arg_value_specifications to indicate count of arguments   */
 203           /*           to be passed to the entrypoint in the arg_list.                                      */
 204           /*         - Each passed argument has data type: char(*) unaligned, unless its corresponding      */
 205           /*           arg_value_specification includes -dcl DECLARATION or -addr DECLARATION to specify a  */
 206           /*           different data type.                                                                 */
 207           /*         - call must pre-count the arg_value_specifications to get a subroutine argument count. */
 208           /*  4) Knowing the count of parameters declared for the target entry, or number of                */
 209           /*     arg_value_specifications provided by the user for an options(variable) subroutine,         */
 210           /*     allocate array storage holding:                                                            */
 211           /*      - information about each parameter of the target entry;                                   */
 212           /*      - information about each positional argument to call that corresponds to a parameter; and */
 213           /*      - space for the arg_list call must produce in order to call the target entry.             */
 214           /*  5) Initialize the arg_list header, including argument counts.                                 */
 215           /*  6) Expand information about each target parameter (coming from the actual parameter           */
 216           /*     descriptors, or from the user's -dcl or -addr DECLARATIONs).                               */
 217           /*      - Information from each descriptor is stored in the t array of target structures.         */
 218           /*  7) Loop through call's remaining arguments, looking for arg_value_specification info:         */
 219           /*      - a direction option for each argument;                                                   */
 220           /*      - an initial value for an input argument;                                                 */
 221           /*      - options specifying alternate data type for the argument, or actual argument size for    */
 222           /*        arguments passed to parameter having star extents; and                                  */
 223           /*      - information about how to display an output argument.                                    */
 224           /*     Information for each arg_value_specification is stored in the s array of source structures.*/
 225           /*  8) Loop through the target parameters, allocating and initializing storage for each           */
 226           /*     corresponding argument.                                                                    */
 227           /*      - All arguments are stored in the translator_temp_ storage area (step 3 above).           */
 228           /*         - Exception: returns(char(*)... ) or returns(bit(*)...) return values get appended to  */
 229           /*           call's stack frame by the called routine.  No storage is created for such return     */
 230           /*           values before the routine is invoked.                                                */
 231           /*      - A pointer to each argument's storage location goes into arg_list.arg_ptr(parmI).        */
 232           /*         - Exception: for returns(...(*)...), arg_list.arg_ptr(parmI) points to a storage       */
 233           /*           location which the called routine fills in with a pointer to the return value that   */
 234           /*           it appends to call's stack frame.                                                    */
 235           /*      - A pointer to the (perhaps modified) target descriptor for parameter the goes into       */
 236           /*        arg_list.desc_ptr(parmI).                                                               */
 237           /*         - Exception: for returns(...(*)...), arg_list.desc_ptr(parmI) points to storage for    */
 238           /*           an empty descriptor, which the called routine fills in with type/length of the       */
 239           /*           returned string.                                                                     */
 240           /*  9) Generate the call to the target entry, with our arg_list locating/describing its           */
 241           /*     the arguments.                                                                             */
 242           /* 10) After the target entry returns to call, display any output arguments to the user; or       */
 243           /*     return one of them as call's AF return string.  This involves:                             */
 244           /*      - Capturing data for returns(char(*)) or returns(bit(*)) functions that was appended to   */
 245           /*        call's stack when the target function returned.                                         */
 246           /*      - Converting each parameter to be returned into a character string (or other requested    */
 247           /*        format) that is meaningful to (or requested by) the user.                               */
 248           /*                                                                                                */
 249           /* Please look for these major tasks, which are identified by TASK n in the comments below.       */
 250           /*                                                                                                */
 251           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 252 %page;
 253 
 254 /* ----------------------------------------- *
 255  * Declarations used throughout the program. *
 256  * ----------------------------------------- */
 257 
 258   dcl  CALL_VERSION char(20) varying int static options(constant) init("call.01.04");
 259   dcl (F init("0"b), T init("1"b)) bit(1) aligned int static options(constant);
 260 
 261   dcl  MaxLineLen fixed bin int static options(constant) init(80);
 262   dcl  NEG_SIGN_BITS bit(72) aligned int static options(constant) init((72)"1"b);
 263   dcl  NL char(1) int static options(constant) init("
 264 ");
 265   dcl  NULL_POINTER char(4) int static options(constant) init("-1|1");
 266   dcl  PROC char (4) int static options (constant) init ("call");
 267   dcl  ZEROb bit(1) int static options(constant) init("0"b);
 268 
 269   dcl (call_et_$array_unsupported,
 270        call_et_$bad_declaration,
 271        call_et_$dtype_unsupported,
 272        call_et_$no_entrypoint_info,
 273        call_et_$overflow_error,
 274        call_et_$parameter_type_unsupported,
 275        call_et_$star_extent_unresolved,
 276        call_et_$structure_unsupported,
 277        call_et_$underflow_error,
 278        error_table_$bad_arg,
 279        error_table_$bad_conversion,
 280        error_table_$bad_index,
 281        error_table_$badopt,
 282        error_table_$bigarg,
 283        error_table_$fatal_error,
 284        error_table_$inconsistent,
 285        error_table_$noarg,
 286        error_table_$no_r_permission,
 287        error_table_$not_act_fnc,
 288        error_table_$oldnamerr,
 289        error_table_$size_error,
 290        error_table_$smallarg,
 291        error_table_$too_many_args) fixed bin (35) ext static;
 292 
 293   dcl  assign_ entry (ptr, fixed bin, fixed bin(35), ptr, fixed bin, fixed bin(35));
 294   dcl  ioa_ entry () options (variable);
 295   dcl  ioa_$nnl entry () options (variable);
 296   dcl  ioa_$rsnnl entry() options(variable);
 297 
 298   dcl (addr, addrel, after, before, binary, char, codeptr, copy, divide, environmentptr,
 299        hbound, index, lbound, length, ltrim, maxlength, min, mod, null,
 300        reverse, rtrim, size, substr, unspec) builtin;
 301 
 302   dcl cleanup condition;
 303 %page;
 304 
 305 /* --------------------------------------------------------------------- *
 306  * TASK 1) Is call being invoked as a command or an active function?     *
 307  *         Display a usage message, if invoked with no arguments.        *
 308  * --------------------------------------------------------------------- */
 309 
 310      entry_info_ptr = null;                                 /* Initialize cleanup-related variable referenced at      */
 311                                                             /*  EXIT_call label (far below).                          */
 312                                                             /*  This variable declared in: call_entry_info_.incl.pl1  */
 313 
 314   dcl  command bit (1) aligned;                             /* =T:  call invoked as a  command;                       */
 315                                                             /* =F:  call invoked as an active function (AF)           */
 316   dcl  af_retL fixed bin (21);
 317   dcl  af_retP ptr;
 318   dcl  af_ret char (af_retL) varying based(af_retP);        /* When called as active function, this is return value.  */
 319 
 320   dcl  gripe entry variable options(variable);              /* Either: com_err_ or active_fnc_err_                    */
 321   dcl  code fixed bin (35);
 322 
 323   dcl  cu_$arg_list_ptr entry() returns (ptr);              /* Internal procedure implements body of Task 1, as part  */
 324                                                             /*  of the general arg processing mechanism used by call. */
 325      call argSetup( cu_$arg_list_ptr(), command, af_retP, af_retL, gripe);
 326 
 327      if ^argsRemain() then do;                              /* If virtualEntry not given, just display usage message. */
 328           call display_usage();
 329           go to EXIT_call;
 330           end;
 331 
 332 /* ------------------------------------------------------------------ *
 333  * TASK 2)                                                            *
 334  * First positional argument gives virtualEntry to be called.         *
 335  *  - Global options may also be set at this time with certainty.     *
 336  *  NB: Some positional arguments may never be processed, if more are *
 337  *      given than correspond to parameters declared for virtualEntry.*
 338  * ------------------------------------------------------------------ */
 339 
 340   dcl 1 globalOpt aligned,                                  /* Structure to hold global options.                      */
 341       2 debug fixed bin(3) unsigned init(0),                /*  -debug: print debug info as call args are processed.  */
 342                                                             /*   Accepts values: 0 - 5                                */
 343       2 xtra fixed bin(2);                                  /*  -all or -octal (given after virtualEntry)             */
 344                                                             /*   Output all arguments with octal representation.      */
 345 
 346   dcl 1 veArg aligned like source;                          /* Structure to hold virtual_entry information.  It uses  */
 347                                                             /*  just a part of the more general 'source' struct, in   */
 348   dcl  virtualEntry char (veArg.argL) based (veArg.argP);   /*  which each arg_value_specification data is kept.      */
 349                                                             /*  That structure is declared below (in Task 4).         */
 350 
 351      unspec(veArg) = ZEROb;                                 /* Initialize arg_value_specification data                */
 352      veArg.argP = null();
 353      veArg.M, veArg.L, veArg.L_idX = Lunset;
 354      veArg.id = "virtual_entry";
 355 
 356      call argValue (0, veArg, globalOpt, code);             /* Get first positional_arg, describing virtualEntry.     */
 357      if code ^= 0 then do;
 358           call gripe (code, PROC, "Failed to get virtual_entry to be called.");
 359           return;
 360           end;
 361 
 362      globalOpt.xtra = veArg.xtra;                           /* Copy positional -all or -octal option to globalOpt.    */
 363 %page;
 364 /* ----------------------------------------------------------------------- *
 365  * TASK 3) Convert virtualEntry to an entry variable.                      *
 366  * Get:                                                                    *
 367  *  1) Subroutine/function flag;                                           *
 368  *  2) Parameter count from calling sequence information;                  *
 369  *  3) Pointer to each parameter descriptor.                               *
 370  *  4) Entry variable for entrypoint to be called.                         *
 371  *  5) Pointer to our (translator_temp_-style) allocation area.            *
 372  * ----------------------------------------------------------------------- */
 373 
 374      if globalOpt.debug >= 5 then
 375           call ioa_ ("Task 3 begins...");
 376 
 377   dcl 1 ei aligned like entry_info_header based(entry_info_ptr);
 378                                                             /* Structure to hold general entrypoint info.             */
 379 
 380   dcl  entry_description char(2000) varying;                /* String to hold a complete description of virtualEntry  */
 381                                                             /*  for display purposes, and perhaps as source from      */
 382                                                             /*  which to fabricate entry descriptors.                 */
 383   dcl  entry_annotation char(100) var;                      /* Details found by get_entry_point_dcl_$emacs.           */
 384 
 385   dcl  get_entry_point_dcl_$emacs entry (char(*), fixed bin, fixed bin, char(*) var, char(32) var, char(100) var);
 386 
 387                                                             /* Check whether entrypoint comes from PL/I generated     */
 388                                                             /*  entry sequence and parameter descriptors; or from     */
 389                                                             /*  a declaration string (in >sss>pl1.dcl, or user's      */
 390                                                             /*  XXX_pl1.dcl file).                                    */
 391      call get_entry_point_dcl_$emacs (virtualEntry, 0, 0, entry_description, "", entry_annotation);
 392      if entry_description = "" then do;                     /* Out-of-luck if this routine fails to return anything.  */
 393           call gripe (call_et_$no_entrypoint_info, PROC, "(^a) ^a", entry_annotation, virtualEntry);
 394           go to EXIT_call;
 395           end;
 396 
 397      on cleanup begin;                                      /* Release storage created by call_entry_info_$from_XXX.  */
 398           call call_entry_info_$cleanup(entry_info_ptr);    /*  This is mostly our (translator_temp_-style) area.     */
 399           end;                                              /*  NB: entry_point_info was initialized in Task 1 above. */
 400 
 401      if entry_annotation = "dcl via parm descriptors" | entry_annotation = "abbrev" then do;
 402                                                             /* Try to get the parm descriptors ourself, directly from */
 403                                                             /*  the object segment's entrypoint parameter list.       */
 404                                                             /*  "abbrev" annotation means entrypoint was not found in */
 405                                                             /*  declare search paths (>sss>pl1.dcl, or user's .dcl)   */
 406           call call_entry_info_$from_virtual_entry (PROC, virtualEntry,
 407                globalOpt.debug, entry_info_ptr, code);
 408           if code ^= 0 then do;                             /* Error, if virtualEntry could not be converted directly,*/
 409                                                             /*  or no entry calling sequence was found.               */
 410                call gripe(code, PROC, "Getting entry parameter descriptors for virtual_entry ^a", virtualEntry);
 411                go to EXIT_call;
 412                end;
 413           end;
 414 
 415      else do;                                               /* get_entry_point_dcl_ returned declaration as a string. */
 416                                                             /* Convert that string to an entrypoint parameter list.   */
 417           entry_description = "dcl " ||
 418                reverse (before (reverse (virtualEntry), ">")) || " " || entry_description || ";";
 419 
 420           call call_entry_info_$from_declaration (PROC, virtualEntry, entry_description,
 421                globalOpt.debug, entry_info_ptr, code);
 422           if code ^= 0 then do;
 423                call gripe(code, PROC, "Calling call_entry_info_$from_declaration.");
 424                go to EXIT_call;
 425                end;
 426           end;
 427 
 428      if ei.parm_count <= eiParmCountNotDetermined then do;  /* Be sure something gets reported to user if cannot get  */
 429                                                             /*  entrypoint calling sequence.  Above calls to          */
 430                                                             /*  call_entry_info_$from_XXX should have returned a code */
 431                                                             /*  in such cases.                                        */
 432           call gripe(call_et_$no_entrypoint_info, PROC, "Could not determine parameter count from entry sequence.");
 433           go to EXIT_call;
 434           end;
 435 
 436      if ei.options_variable then do;                        /* An options(variable) entrypoint is NEVER a function,   */
 437                                                             /*  because it does not have a PL/I-defined calling       */
 438                                                             /*  sequence that includes a <returns descriptor>, or     */
 439                                                             /*  any <parameter descriptor>s.                          */
 440           call argValueGetCount(globalOpt.debug);           /*   - Allow our user to specify how many arguments to    */
 441           ei.parm_count = argValueCount;                    /*     pass to the entrypoint.                            */
 442           end;
 443 %page;
 444 /* --------------------------------------------------------------------------- *
 445  * TASK 4) Declare data structures describing:                                 *
 446  *  source:                                                                    *
 447  *    Each describes an arg_value_specification in the call command line that  *
 448  *    corresponds to one of the arguments to be passed to the virtualEntry.    *
 449  *  target:                                                                    *
 450  *    Each describes attributes of a parameter in the virtualEntry calling     *
 451  *    sequence; for an options(variable) entrypoint, each describes argument   *
 452  *    data attributes derived from corresponding arg_value_specification info. *
 453  * --------------------------------------------------------------------------- */
 454 
 455   dcl 1 source structure aligned based,                     /* Argument passed to call by command processor.          */
 456       2 argP ptr,                                           /*  - ptr to the call argument for initial value.         */
 457       2 argL fixed bin(21),                                 /*  - length of call argument for initial value.          */
 458       2 argOpt,                                             /*  Per-arg_value options:                                */
 459         3 dir fixed bin(3),                                 /*  -in, -inout, -out, -ig                                */
 460         3 ret bit (1),                                      /*  -return given (identifies call AF return value)       */
 461         3 fmt  fixed bin(3),                                /*  -code, -date, -time, -date_time                       */
 462         3 xtra fixed bin(2),                                /*  -octal (given with -inout or -out)                    */
 463         3 meta fixed bin(2),                                /*  -dcl, -addr                                           */
 464         3 dcl char(100) var,                                /*  -dcl  DECLARATION                                     */
 465                                                             /*  -addr DECLARATION given for a ptr arg_value           */
 466         3 id char(20) var,                                  /*  -id ID                                                */
 467         3 M fixed bin(24),                                  /*  -max_length M  given for a string/area arg_value      */
 468         3 L fixed bin(24),                                  /*  -length L     given for a string arg_value            */
 469         3 L_id char(20) var,                                /*  -length ID    given for a string arg_value            */
 470       2 ad,                                                 /*  -addr DECLARATION mapped to a descriptor.             */
 471         3 desc like target.desc aligned,
 472         3 given bit(1) aligned,
 473         3 M_id char(20) var,                                /*  -addr "char(M_id)" given for string/area arg_value    */
 474                                                             /*   where M_id names another source.id which is a        */
 475                                                             /*   input fixed-point size parameter.  That input value  */
 476                                                             /*   is assigned to source.M.                             */
 477       2 argXref,                                            /* source(parmI) whose .id matches our source.L_id:       */
 478         3 L_idX fixed bin,                                  /*   s(source.L_idX).id = source.L_id                     */
 479         3 pad fixed bin;                                    /* Fill structure to even-word boundary.                  */
 480 
 481   dcl (DIRunset init(0), DIRin init(1), DIRinout init(2), DIRout init(3), DIRignore init(4))
 482        fixed bin(3) int static options(constant);
 483   dcl 1 DIR int static options(constant),
 484       2 name (0:4) char(10) var  init("", "-input", "-inout", "-output", "-outignore" ),
 485       2 abbr (0:4) char( 7) var  init("", "-in",    "-io",    "-out",    "-ignore"    ),
 486       2 tiny (0:4) char( 3) var  init("", "-i",     "",       "-o",      "-ig"        );
 487 
 488   dcl (FMTunset init(0),  FMTcode init(1), FMTdate init(2), FMTtime init(3), FMTdate_time init(4))
 489       fixed bin(3) int static options(constant);
 490   dcl 1 FMT int static options(constant),
 491       2 name (0:4) char(10) var init("", "-code", "-date", "-time", "-date_time"),
 492       2 abbr (0:4) char(5)  var init("", "-cd",   "-dt",   "-tm",   ""),
 493       2 kywd (0:4) char(9)      init("", "",      "date",  "time",  "date_time");
 494 
 495   dcl (METAunset init(0), METAdcl init(1), METAaddr init(2))
 496       fixed bin(2) int static options(constant);
 497   dcl 1 META int static options(constant),
 498       2 name (0:2) char(5) var  init("", "-dcl",     "-addr"),
 499       2 abbr (0:2) char(8) var  init("", "-declare", "");
 500                                                             /* -declare is longer than -dcl, but less often used.     */
 501 
 502   dcl (XTRAunset init(0), XTRAall init(1), XTRAoctal init(2)) fixed bin(2) int static options(constant);
 503   dcl 1 XTRA int static options(constant),
 504       2 name (0:2) char(8) var  init("", "-all", "-octal"),
 505       2 abbr (0:2) char(8) var  init("", "-a",   "-oc");
 506 
 507   dcl  Lunset   init(-1)                                    fixed bin(24) int static options(constant);
 508 %page;
 509   dcl 1 target structure aligned based,                     /* Each parameter of virtualEntry is described by this    */
 510                                                             /*  structure.  Info comes from a descriptor found in one */
 511                                                             /*  of three ways:                                        */
 512                                                             /*   - call_entry_info_$from_virtual_entry provides a     */
 513                                                             /*     descriptor from calling sequence of virtualEntry;  */
 514                                                             /*   - call_entry_info_$from_declaration produces a       */
 515                                                             /*     descriptor from declaration's <parameter-set>s.    */
 516                                                             /*   - for options(variable) entrypoint, arg_value_spec   */
 517                                                             /*     provides info to create an argument <descriptor>.  */
 518       2 descP ptr,                                          /* ptr to calling seq parameter descriptor.               */
 519       2 desc,                                               /* descriptor components (most from decode_descriptor_):  */
 520         3 fcnReturnValue bit(1) aligned,                    /*   - On for last target, if ei.function is TRUE.        */
 521         3 type fixed bin,                                   /*   - type (see: std_descriptor_types.incl.pl1)          */
 522         3 aligned bit(1) aligned,                           /*   - alignment (^packed)                                */
 523         3 size fixed bin(24),                               /*   - precision or size                                  */
 524         3 scale fixed bin,                                  /*   - scale (for fixed-point numbers)                    */
 525         3 dimensionsCount fixed bin,                        /*   - number of dimension descriptors following the      */
 526                                                             /*     parameter descriptor.                              */
 527                                                             /*      =N means parm is an array with N dimensions.      */
 528                                                             /*      =0 means parm is a scalar.                        */
 529       2 dcl char(100) var,                                  /* descP converted to PL/I attributes.                    */
 530       2 storage,                                            /*                                                        */
 531         3 case fixed bin,                                   /* See CASEname and argCase below for possible values.    */
 532         3 wordCount fixed bin(24),                          /* Words needed to store this parameter.                  */
 533         3 P ptr,                                            /* Location of allocated storage for this target.         */
 534         3 modifiedDesc aligned like arg_descriptor,         /* Storage to hold replacement descriptor with actual     */
 535                                                             /*  size of parm with star extents (char/bit/area).       */
 536         3 dcl_desc_bv bit(36) aligned;                      /* arg_descriptor generated by -dcl DECLARATION           */
 537 
 538   dcl (CASEnumeric init(1), CASEpointer init(2), CASEentry       init(3),
 539        CASEarea    init(4), CASEstring  init(5), CASEreturnsStar init(6))
 540            fixed bin int static options(constant);
 541   dcl  CASEname (6) init("numeric", "pointer", "entry", "area", "string", "returns_star") char(20) var;
 542 
 543   dcl  SizeStar fixed bin (24) int static options (constant) init (16777215);  /* = "77777777"b3  */
 544                                                             /* size value in descriptor for parm with star extents    */
 545                                                             /*   (bit/char/area parameter).                           */
 546 
 547 
 548 argCase:                                                    /* Classify target.desc.type in one of five CASE groups.  */
 549      proc (dtype) returns (fixed bin(3) unsigned);          /*  (returns char(*)... or returns(bit(*)... decision     */
 550                                                             /*   is made in the argAssign(...) subroutine.)           */
 551   dcl  dtype fixed bin;
 552 
 553      if      numeric_dtype(dtype)    then return(CASEnumeric);
 554      else if string_dtype(dtype)     then return(CASEstring);
 555      else if (dtype = pointer_dtype) then return(CASEpointer);
 556      else if (dtype = entry_dtype)   then return(CASEentry);
 557      else if (dtype = area_dtype)    then return(CASEarea); /* call makes many decisions based upon groups of         */
 558                                                             /*  descriptor types.  Functions defining these groups    */
 559                                                             /*  are in call_dtype_fcns.incl.pl1                       */
 560 
 561      else return(0);
 562 
 563      end argCase;
 564 %page;
 565 /* ---------------------------------------------------------------------------------------------------------------------- *
 566  * Notes on CASEreturnsStar:
 567            [Information gathered from examining PL/I compiler-generated calls to returns(char(*)) functions.]
 568  *  Functions with returns(char(*)) and returns(char(*) varying) are special cases in the call/return mechanism,
 569  *  because the caller has no idea how much storage will be needed to hold the actual returned values; only the
 570  *  called routine (the callee) knows.
 571  *  Same special handling is needed for returns(bit(*)) and returns(bit(*) varying) strings.
 572  *    NB: Mechanism is the same for return values that are aligned or unaligned.  The value always ends up
 573  *        aligned on word boundary.
 574  *
 575  *  A standard argument list (which is prepared by the caller when calling any subroutine or function) has the
 576  *  features described below.
 577  *   - Assume C is called entrypoint's parameter count.  For a function, this count includes the return value.
 578           argListP -> 2 header,
 579                         3 arg_count fixed bin(17) unsigned unal init(C),
 580                         ...
 581                         3 desc_count fixed bin(17) unsigned unal init(C),
 582                         ...
 583                       2 parmP (C) ptr,
 584                       2 descP (C) ptr;
 585  *  So for a function, the Cth parameter is the function return value.
 586  *
 587  *  BEFORE calling a function having one of the returns(xxx(*)...) values:
 588  *   - The caller provides storage in his stack frame for two temporary variables (fabricated by PL/I compiler):
 589  *      - rvP, an aligned pointer which the callee will set to location of the actual function return value.
 590  *             The storage holding rvP is usually unset, but may be set to a null() value.
 591  *      - rv_desc, an argument descriptor which the callee sets to describe the actual length of the return value.
 592  *             The storage holding rv_desc is usually unset, but may be unspec(rv_desc)="0"b before the call.
 593  *   - The caller then constructs the argument list used to invoke the function.  For the return value, the caller sets:
 594          argListP -> parmP(C) = addr(rvP)
 595          argListP -> descP(C) = addr(rv_desc)
 596  *   - The call command (this program) must actually declare storage locations to hold the rvP and rv_desc values.
 597  *      - rvP is stored in target.storage.P
 598  *      - rv_desc is stored in target.storage.modifiedDesc
 599  *
 600  *  DURING the call, the callee provides its own space to hold storage for its return value.  Either
 601  *  the callee calculates how much space is needed, and allocates just that amount.  Or perhaps the callee declares a
 602  *  an extra-large variable; but wants to return only the space actually used within that variable.  In either case,
 603  *  the actual value to be returned is referred to as actual_return_value in the next paragraphs.
 604  *
 605  *  RETURNING to the caller, the callee:
 606      - extends the caller's stack, adding enough storage to hold the actual_return_value;
 607      - copies the actual_return_value to this storage location (at end of the caller's stack).  This overwrites data
 608        formerly in the callee's stack; but since the callee is about to return, this data is no longer needed.
 609      - sets information in the caller-supplied argument list for the location and size of the actual_return_value:
 610         case: when actual_return_value is char(*); or
 611         case: when actual_return_value is bit(*):
 612           argListP -> parmP(C) -> rvP = addr(actual_return_value);
 613           argListP -> descP(C) -> rv_desc = descriptor_with(type(actual_return_value), length(actual_return_value))
 614  *
 615         case: when actual_return_value is char(*) varying; or
 616         case: when actual_return_value is bit(*)  varying:
 617           argListP -> parmP(C) -> rvP = addrel(addr(actual_return_value),+1);
 618                               [that is, rvP points after length word of varying string, at start of string chars/bits]
 619           argListP -> descP(C) -> rv_desc = descriptor_with(type(actual_return_value), maxlength(actual_return_value))
 620        Remember that rvP and rv_desc are variables created/known by the caller, and located in the caller's stack frame.
 621 
 622      NB: if rv_desc.flag = "1"b, then rv_desc.size is fixed bin(24) unsigned; else rv_desc.size is fixed bin(12) unsigned.
 623  *
 624  *  AFTER the call, the caller uses rvP and rv_desc to access the actual_return_value, either:
 625  *   - assigning it to a local variable known to the caller program; or
 626  *   - passing it as an argument to some other subroutine; etc.
 627  *  The call command (this program) uses rvP and rv_desc to display/return this actual_return_value.
 628  * ---------------------------------------------------------------------------------------------------------------------- */
 629 %page;
 630 /* -------------------------------------------------------------------- *
 631  * TASK 4) continues:                                                   *
 632  * Allocate adjustable-size arrays of the above structures, one element *
 633  * for each parameter defined by the entrypoint's calling sequence.     *
 634  *  NB: For an entrypoint having no parameters, and when user gave no   *
 635  *      arg_value_specifications, these ARRAYS ARE NOT ALLOCATED.       *
 636  * -------------------------------------------------------------------- */
 637 
 638      if globalOpt.debug >= 5 then
 639           call ioa_ ("Task 4 begins...");
 640 
 641   dcl (lP, sP, tP) ptr init(null);
 642   dcl 1 s (ei.parm_count) aligned like source based(sP);    /* Source elements: one for each argument to be passed.   */
 643 
 644   dcl 1 t (ei.parm_count) aligned like target based(tP);    /* Target elements: one for each entrypoint parameter, or */
 645                                                             /*   arg_value_specification.                             */
 646 
 647   dcl 1 l aligned based(lP),                                /* Standard Multics arg_list.                             */
 648       2 header like arg_list.header,
 649       2 argP  (ei.parm_count) ptr,                          /*  - argP  for each parameter passed to virtualEntry     */
 650       2 descP (ei.parm_count) ptr;                          /*  - descP for each parameter passed to virtualEntry     */
 651 
 652   dcl 1 auto_l aligned automatic,                           /* Use this arg_list stub when no arguments are passed.   */
 653       2 header like arg_list.header;
 654 
 655   dcl  parmI fixed bin;                                     /* Index for selecting elements from structures above.    */
 656   dcl  refI fixed bin;
 657 
 658   dcl  areaP ptr;                                           /* Allocation area provided by call_entry_info_$from_XXX  */
 659      areaP = ei.areaP;
 660 
 661      if ei.parm_count > 0 then do;                          /* Allocate structure arrays, and arg_list.               */
 662           sP = allocate(areaP, size(s));                    /*  allocate routine in: translator_temp_alloc.incl.pl1   */
 663           tP = allocate(areaP, size(t));
 664           lP = allocate(areaP, size(l));
 665           end;
 666      else lP = addr(auto_l);                                /*  - Use arg_list header, if no parameters needed.       */
 667 
 668 
 669 /* ----------------------------------------------------------------- *
 670  * TASK 5) Initialize arg_list to be used in calling the subroutine. *
 671  * ----------------------------------------------------------------- */
 672 
 673      if globalOpt.debug >= 5 then
 674           call ioa_ ("Task 5 begins...");
 675 
 676      unspec(l) = ZEROb;                                     /* Not initializing pad bits in l can cause erroneous     */
 677                                                             /*  gate_error condition: Wrong number of arguments given.*/
 678      l.call_type = Interseg_call_type;                      /* Initialize argument list type.                         */
 679      l.arg_count  = ei.parm_count;                          /* Set counts in header.                                  */
 680      l.desc_count = ei.parm_count;
 681 
 682 %page;
 683 /* ----------------------------------------------------------------- *
 684  * TASK 6) Examine entrypoint calling sequence information.          *
 685  *  - Get a PL/I declare statement for each parameter.               *
 686  * ----------------------------------------------------------------- */
 687 
 688      if globalOpt.debug >= 5 then
 689           call ioa_ ("Task 6 begins...");
 690                                                             /* Default descriptor for options(variable) arguments.    */
 691   dcl 1 charStarUnal_Descriptor aligned int static options(constant),
 692       2 flag              bit (1) unal init(T),
 693       2 type              fixed bin (6) unsigned unal init(char_dtype),
 694       2 packed            bit (1) unal init(T),
 695       2 number_dims       fixed bin (4) unsigned unal init(0),
 696       2 size              fixed bin (24) unsigned unal init(SizeStar);
 697 
 698      if tP ^= null then do;
 699           unspec(t) = ZEROb;                                /* Initialize t array of target structure elements.       */
 700 
 701           if ^ei.options_variable then do;                  /* For non-options(variable) entrypoint:                  */
 702                t(*).descP = entry_info.descriptor_ptrs(*);  /*  - Store ptr to each entry parameter descriptor in t.  */
 703                                                             /*    These were provided by call_entry_info_$from_XXX.   */
 704 
 705                if globalOpt.debug >= 3 then call ioa_("");  /* Put blank line before parameter desc debug output.     */
 706 
 707                do parmI = lbound(t,1) to hbound(t,1);       /* Decode parameter descriptor data for each target elem. */
 708                     call get_entry_parm_info(parmI, ei, t(parmI), globalOpt.debug);
 709                     end;
 710                end;
 711           else do;                                          /* For options(variable) subroutine:                      */
 712                t(*).descP = addr(charStarUnal_Descriptor);  /*  - assume all parameters are: char(*) unaligned.  This */
 713                t(*).desc.type = char_dtype;                 /*    assumption may be overridden, as arguments to call  */
 714                t(*).desc.size = SizeStar;                   /*    are processed.                                      */
 715                t(*).dcl = "char(*)";
 716                end;
 717           end;
 718 %page;
 719 /* --------------------------------------------------------------------------- *
 720  * TASK 7)                                                                     *
 721  * Loop through arguments to call; look for arg_value_specification info.      *
 722  * Each specifies a DIRxxx value, and perhaps an initial value, for its        *
 723  * corresponding argument passed to an entrypoint parameter.                   *
 724  *  - Info about each arg_value is stored in a source structure.               *
 725  *  - Any per-parameter option following the parameter is stored in            *
 726  *    source.aOpt substructure.                                                *
 727  *  - Any options(variable) parameter info (-dcl DECLARATION) is stored in     *
 728  *    a t structure array element.                                             *
 729  * --------------------------------------------------------------------------- */
 730 
 731      if globalOpt.debug >= 5 then
 732           call ioa_ ("Task 7 begins...");
 733 
 734   dcl 1 src  aligned like source based(addr(s(parmI)));     /* Create a short name for s(parmI) structure element.    */
 735   dcl 1 targ aligned like target based(addr(t(parmI)));     /* Create a short name for t(parmI) structure element.    */
 736 
 737      if sP ^= null then
 738 HAVE_ARGUMENTS:
 739      do;
 740           unspec(s) = ZEROb;                                /* Initialize arg_value_specification data                */
 741           s(*).argP = null();
 742           s(*).M, s(*).L, s(*).L_idX = Lunset;
 743 
 744 ARG_VALUES_LOOP:
 745           do parmI = lbound(s,1) to hbound(s,1);            /* Try to get arg_value_specification for each argument.  */
 746 
 747                if ei.function & (parmI = ei.parm_count) then
 748                     src.id = "retValue";                    /* Assign a default value for source.id                   */
 749                else src.id = "parm" || int2digits(parmI);
 750 
 751 
 752           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 753           /*                                                                                                */
 754           /* Note:  It's OK for a function return value to not have a corresponding arg_value spec.  If it  */
 755           /* has one, it might include: an -out direction or -return option, and -octal format, or even an  */
 756           /* -addr DECLARATION, telling call how to format data pointed to by a return pointer.             */
 757           /*                                                                                                */
 758           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 759 
 760                if argsRemain() then                         /* Try only as long as more arguments to call remain      */
 761 ARGS_REMAIN:   do;                                          /*  to be examined.                                       */
 762                     call argValue(parmI, src, globalOpt, code);
 763                                                             /* argValue reports some errors itself; but it always     */
 764                                                             /*  returns the noarg error without reporting.  Only this */
 765                                                             /*  code knows how to report meaning of such an error.    */
 766                     if code ^= 0 then do;                   /*  Here, it means "User forgot to initialize parameter." */
 767                          call gripe(code, PROC, "No argument value for: dcl ^a ^a", src.id, targ.dcl);
 768                          go to EXIT_call;
 769                          end;
 770 
 771 
 772   dcl 1 parmDesc aligned like arg_descriptor based(targ.descP);
 773                                                             /* Create an overlay for the actual target descriptor.    */
 774 
 775   dcl 1 d aligned like target.desc based(dP);               /* Create a short name for target.desc substructure.      */
 776   dcl  dP ptr;                                              /*  This substructure changes if -addr is given.          */
 777      dP = addr(targ.desc);
 778 
 779                     if (src.fmt = FMTcode) then
 780                          if substr(src.id,1,length("parm")) = "parm" then
 781                               substr(src.id,1,length("parm")) = "code";
 782                          else if src.id = "retValue" then
 783                               src.id = "retCode";           /* Change default ID field to better identify code parms. */
 784 
 785 
 786   dcl  arg_desc_bv bit(36) aligned;                         /* Provide a descriptor representing -addr DECLARATION.   */
 787   dcl  call_scalar_dcl_ entry (ptr, char(*), uns fixed bin(3), char(256) var, bit(36) aligned, char(*) var,
 788           fixed bin(35));
 789                                                             /* Provide a pointer descriptor if -addr DECLARATION      */
 790                                                             /*  given for an argument of options(variable) subr.      */
 791   dcl 1 pointer_Descriptor aligned int static options(constant),
 792       2 flag              bit (1) unal init(T),
 793       2 type              fixed bin (6) unsigned unal init(pointer_dtype),
 794       2 packed            bit (1) unal init(F),
 795       2 number_dims       fixed bin (4) unsigned unal init(0),
 796       2 size              fixed bin (24) unsigned unal init(0);
 797 
 798                     /* Verify that -addr DECLARATION given only for parm that is a scalar pointer_dtype.              */
 799                     if src.meta = METAaddr & length(src.argOpt.dcl) > 0 then do;
 800                          if ei.options_variable then do;    /* For options(variable) entrypoint, make this arg a ptr. */
 801                               targ.descP = addr(pointer_Descriptor);
 802                               targ.desc.type = pointer_dtype;
 803                               targ.desc.aligned = T;
 804                               targ.dcl = "ptr";
 805                               end;
 806                          else if ^((d.type = pointer_dtype) & (d.dimensionsCount = 0)) then do;
 807                               call gripe(error_table_$bad_arg, PROC,
 808                                    "-addr argument given for non-pointer variable: dcl ^a ^a;", src.id, targ.dcl);
 809                               go to EXIT_call;
 810                               end;
 811                                                             /* Is -addr DECLARATION valid?                            */
 812                          call call_scalar_dcl_ (areaP, "dcl " || src.argOpt.id || " " || src.argOpt.dcl || ";",
 813                               globalOpt.debug, "", arg_desc_bv, src.ad.M_id, code);
 814                          if code ^= 0 then do;
 815                               call gripe(code, PROC, "DECLARATION error: -addr ""^a"" ", src.argOpt.dcl);
 816                               go to EXIT_call;
 817                               end;
 818                          call decode_descriptor(addr(arg_desc_bv), src.ad.desc);
 819                          if ^supported_by_call_dtype(src.ad.desc.type) then do;
 820                                                             /* Validate that descriptor type is one call can handle.  */
 821                                                             /* call makes many decisions based upon groups of         */
 822                                                             /*  descriptor types.  Functions defining these groups    */
 823                                                             /*  are in call_dtype_fcns.incl.pl1                       */
 824                               call gripe(error_table_$bad_arg, PROC,
 825                                    "DECLARATION not supported by call: -addr ""^a"" ", src.argOpt.dcl);
 826                               go to EXIT_call;
 827                               end;
 828                          src.ad.given = T;
 829                          dP = addr(src.ad.desc);            /* NB: Remaining tests depend on DECLARATION storage type,*/
 830                          end;                               /*  rather than the pointer parameter, itself.            */
 831 
 832                     /* Verify that -dcl DECLARATION is valid.                                                         */
 833                     if src.meta = METAdcl & length(src.argOpt.dcl) > 0 then do;
 834   dcl  dcl_id char(20) var;
 835                          call call_scalar_dcl_ (areaP, "dcl " || src.argOpt.id || " " || src.argOpt.dcl || ";",
 836                               globalOpt.debug, "", targ.dcl_desc_bv, dcl_id, code);
 837                          if code ^= 0 then do;
 838                               call gripe(code, PROC, "DECLARATION error: -dcl ""^a"" ", src.argOpt.dcl);
 839                               go to EXIT_call;
 840                               end;
 841                          if dcl_id ^= "" then do;
 842                               call gripe(call_et_$bad_declaration, PROC, "invalid size: -dcl ""^a"" ", src.argOpt.dcl);
 843                               go to EXIT_call;
 844                               end;
 845                          call decode_descriptor(addr(targ.dcl_desc_bv), targ.desc);
 846                          if ^supported_by_call_dtype(targ.desc.type) then do;
 847                                                             /* Validate that descriptor type is one call can handle.  */
 848                               call gripe(error_table_$bad_arg, PROC,
 849                                    "DECLARATION not supported by call: -dcl ""^a"" ", src.argOpt.dcl);
 850                               go to EXIT_call;
 851                               end;
 852                          targ.descP = addr(targ.storage.dcl_desc_bv);
 853                          targ.dcl = src.argOpt.dcl;
 854                          end;
 855 
 856                     /* Verify that arg_value -code corresponds to parm that is fixed bin(35), or fixed bin(17)        */
 857                     if src.fmt = FMTcode then do;
 858                          if ^((d.type = FIXED_BIN) & ((d.size = 35 | d.size = 17)) &
 859                               (d.scale = 0) & d.aligned & (d.dimensionsCount = 0)) then do;
 860                               call gripe(error_table_$bad_arg, PROC,
 861                                    "-code argument given for non-status code parameter: dcl ^a ^a;", src.id, targ.dcl);
 862                               go to EXIT_call;
 863                               end;
 864                          end;
 865 
 866                     /* Verify that arg_value -date_time, -date, or -time corresponds to parm that is fixed bin(71)    */
 867                     if src.fmt = FMTdate_time | src.fmt = FMTdate | src.fmt = FMTtime then do;
 868                          if ^((d.type = real_fix_bin_2_dtype) & (d.size = 71) &
 869                               (d.scale = 0) & d.aligned & (d.dimensionsCount = 0)) then do;
 870                               call gripe(error_table_$bad_arg, PROC,
 871                                    "^a argument given for non-clock parameter: dcl ^a ^a;",
 872                                    FMT.name(src.fmt), src.id, targ.dcl);
 873                               go to EXIT_call;
 874                               end;
 875                          end;
 876 
 877                     /* Verify that -max_length count given only for string/area data types with star extents.         */
 878                     if src.M ^= Lunset then do;
 879                          if ^star_extent_dtype(d.type) then do;
 880                               call gripe (error_table_$bad_arg, PROC,
 881                                    "-max_length ^d given^[ with -addr ""^a""^;^s^] for data type
 882         which is not a string or an area: dcl ^a ^a;",
 883                                    src.M, src.ad.given, src.dcl, src.id, targ.dcl);
 884                               go to EXIT_call;
 885                               end;
 886                          if ^(d.size = SizeStar) then do;
 887                               call gripe (error_table_$bad_arg, PROC,
 888                                    "-max_length ^d given^[ with -addr ""^a""^;^s^] without star extent: dcl ^a ^a;",
 889                                    src.M, src.ad.given, src.dcl, src.id, targ.dcl);
 890                               go to EXIT_call;
 891                               end;
 892                          end;
 893 
 894                     /* Verify that -length L given only for string data types.   */
 895                     if src.L ^= Lunset then do;
 896                          if ^string_dtype(d.type) then do;
 897                               call gripe (error_table_$bad_arg, PROC,
 898                                    "-length ^d given^[ with -addr ""^a""^;^s^] for non-string: dcl ^a ^a;",
 899                                    src.L, src.ad.given, src.dcl, src.id, targ.dcl);
 900                               go to EXIT_call;
 901                               end;
 902                          end;
 903 
 904                     /* Verify that -length ID given only for string data types.                                       */
 905                     if length(src.L_id) > 0 then do;
 906                          if ^string_dtype(d.type) then do;
 907                               call gripe (error_table_$bad_arg, PROC,
 908                                    "-length ^a given^[ with -addr ""^a""^;^s^] for non-string: dcl ^a ^a;",
 909                                    src.L_id, src.ad.given, src.dcl, src.id, targ.dcl);
 910                               go to EXIT_call;
 911                               end;
 912                          end;
 913                     end ARGS_REMAIN;
 914 
 915                else if ^targ.desc.fcnReturnValue then do;
 916                                                             /* OK if no arg_value spec given for function return val, */
 917                     call gripe(error_table_$noarg, PROC, "No argument value for: parm^d ^a", parmI, targ.dcl);
 918                     go to EXIT_call;                        /*  but other parameters need corresponding arg_value.    */
 919                     end;
 920 
 921                end ARG_VALUES_LOOP;
 922           end HAVE_ARGUMENTS;
 923 %page;
 924 /* --------------------------------------------------------------------------- *
 925  * TASK 7) continues:                                                          *
 926  *  1) Check -addr "char(M_id)" arg_value, to make sure corresponding          *
 927  *     s(parmI).id = M_id is an input, fixed binary variable that can be       *
 928  *     assigned to source.M.                                                   *
 929  *  2) Check -length L_id arg_value, to make sure corresponding                *
 930  *     s(parmI).id = L_id is an output, fixed binary variable that can be      *
 931  *     assigned to source.L.                                                   *
 932  * --------------------------------------------------------------------------- */
 933 
 934      if sP ^= null then
 935 HAVE_SOURCE_SPECS:
 936      do;
 937 SOURCE_SPECS_LOOP:
 938           do parmI = lbound(s,1) to hbound(s,1);
 939                if length(src.ad.M_id) > 0 then
 940 ADDR_DECL_REFERENCE:
 941                do;
 942                     refI = sourceWithID(src.ad.M_id);
 943                     if refI > 0 then do;
 944                          if ^parmIsFixedBin(s(refI), t(refI)) | s(refI).ad.given then do;
 945                               call gripe (error_table_$bad_arg, PROC,
 946                                    "-addr ""^a"" references arg_value not fixed binary (unsuitable as a length): dcl ^a ^a;",
 947                                    src.dcl, src.id, targ.dcl);
 948                               go to EXIT_call;
 949                               end;
 950                          else if s(refI).dir > DIRinout then do;
 951                               call gripe (error_table_$bad_arg, PROC,
 952                                    "-addr ""^a"" references arg_value not an input value: dcl ^a ^a; (^a)",
 953                                    src.dcl, s(refI).id, t(refI).dcl, DIR.name(s(refI).dir));
 954                               go to EXIT_call;
 955                               end;
 956                          else if refI = parmI then do;
 957                               call gripe (error_table_$bad_arg, PROC,
 958                                    "-addr ""^a"" references its own parameter: dcl ^a ^a;",
 959                                    src.dcl, src.id, targ.dcl);
 960                               go to EXIT_call;
 961                               end;
 962                          else do;
 963                               src.M = argFixedBinValue(s(refI), t(refI), null());
 964                               if src.M = SizeStar then do;  /* Error converting s(refI).argP/argL to fixed bin(24).   */
 965                                    call gripe (error_table_$bad_conversion, PROC,
 966                                         "-addr ""^a"" references an arg_value with -id ^a not convertible to fixed bin(24)",
 967                                         src.dcl, src.ad.M_id);
 968                                    go to EXIT_call;
 969                                    end;
 970                               src.ad.desc.size = src.M;     /* Change char(*) to char(M)                              */
 971                               end;
 972                          end;
 973                     else do;
 974                          call gripe (error_table_$oldnamerr, PROC,
 975                               "-addr ""^a"" references an ID not found on any other arg_value specification.", src.dcl);
 976                          go to EXIT_call;
 977                          end;
 978                     end ADDR_DECL_REFERENCE;
 979 
 980                if length(src.L_id) > 0 then
 981 LENGTH_REFERENCE:
 982                do;
 983                     refI = sourceWithID(src.L_id);
 984                     if refI > 0 then do;
 985                          if ^parmIsFixedBin(s(refI), t(refI)) then do;
 986                               call gripe (error_table_$bad_arg, PROC,
 987                                    "-length ^a is not fixed binary (unsuitable as a length): dcl ^a ^a;",
 988                                    src.L_id, src.id, targ.dcl);
 989                               go to EXIT_call;
 990                               end;
 991                          else if refI = parmI then do;
 992                               call gripe (error_table_$bad_arg, PROC,
 993                                    "-length ^a references its own parameter: dcl ^a ^a;",
 994                                    src.L_id, src.id, targ.dcl);
 995                               go to EXIT_call;
 996                               end;
 997                          else
 998                               src.argXref.L_idX = refI;
 999                          end;
1000                     else do;
1001                          call gripe (error_table_$oldnamerr, PROC,
1002                               "-length ^a references an ID not found on any other arg_value specification.", src.L_id);
1003                          go to EXIT_call;
1004                          end;
1005                     end LENGTH_REFERENCE;
1006 
1007                end SOURCE_SPECS_LOOP;
1008           end HAVE_SOURCE_SPECS;
1009 %page;
1010 /* ---------------------------------------------------------------- *
1011  * TASK 8)                                                          *
1012  * - Loop through parameters, allocating parameter storage, and     *
1013  *   initializing storage per arg_value specs.                      *
1014  * - Set arg_list.parmP(i) and arg_list.descP(i) values.            *
1015  * ---------------------------------------------------------------- */
1016 
1017      if globalOpt.debug >= 5 then
1018           call ioa_ ("Task 8 begins...");
1019 
1020   dcl 1 parmSummary aligned,
1021       2 parmsNotSupported fixed bin,                        /* Count of parameter data types not supported by call.   */
1022       2 convertFailed fixed bin,                            /* Count of positional args corresponding to parm         */
1023                                                             /*  initial values, encountering conversion errors.       */
1024       2 totalStorageNeeded fixed bin(35);                   /* Count of word-aligned storage words needed to hold     */
1025                                                             /*  large-size parameters.                                */
1026 
1027      if tP ^= null then do;
1028           parmSummary = 0;                                  /* Initialize all summary structure elements to 0.        */
1029           do parmI = lbound(t,1) to hbound(t,1);
1030                call argAssign (parmI, s(parmI), t(parmI), globalOpt.debug,
1031                     l.argP(parmI), l.descP(parmI), areaP, parmSummary);
1032                end;
1033           if ^((parmSummary.parmsNotSupported = 0) & (parmSummary.convertFailed = 0)) then
1034                go to EXIT_call;                             /* Any errors were reported by argAssign.  Exit after     */
1035                                                             /*   all parameters were examined.                        */
1036           end;
1037 %page;
1038 /* ------------------------------------------------------------------ *
1039  * TASK 9)                                                            *
1040  *  - All parms are of supported type, and all storage is assigned.   *
1041  *  - Our arg_list has been allocated and set.                        *
1042  *  - Now ready to call the subroutine or function.                   *
1043  * Call to a function differs only in how call command post-processes *
1044  *   its final parameter, which is the function return value.         *
1045  * ------------------------------------------------------------------ */
1046 
1047      if globalOpt.debug >= 5 then
1048           call ioa_ ("Task 9 begins...");
1049 
1050   dcl output char(3000) varying;                            /* Variables to hold debug information about a parameter. */
1051   dcl outputD char(80) varying;
1052   dcl outPrefix char(100) varying;
1053 
1054      outPrefix = ei.entrypoint.nameString;                  /* Possibly use entrypoint name (w/o path) in msgs.       */
1055 
1056      if globalOpt.debug >= 2 & tP ^= null() then do;        /* Display arguments in the constructed arg list before   */
1057                                                             /*  calling the subroutine?  This includes showing how    */
1058                                                             /*  any function return value has been initialized.       */
1059           call ioa_ ("-- Argument List --------------------");
1060           do parmI = lbound(t,1) to hbound(t,1);
1061                call debugOutputArg(parmI, s(parmI), t(parmI), l.argP(parmI), l.descP(parmI), command, output, outputD);
1062                call ioa_(" ^va @ ^p = ^a", maxlength(s(parmI).id), s(parmI).id, l.argP(parmI), output);
1063                call ioa_(" ^vx desc @ ^p^42t^a", maxlength(s(parmI).id)-length("desc "), l.descP(parmI), outputD);
1064                end;
1065           end;
1066      else if globalOpt.debug >= 2 then
1067           call ioa_ ("-- No Arguments- --------------------");
1068 
1069      if globalOpt.debug > 0 then do;                        /* Separate our debug data from called subr's output      */
1070           call ioa_ ("-- Calling ^a -----------------------", outPrefix);
1071           outPrefix = NL || "--  returns: -----------------------" || copy("-",length(outPrefix)) || NL;
1072           end;
1073      else do;
1074           outPrefix = "-- Return from: " || outPrefix || " -------" || NL;
1075           if command then call ioa_("");                    /* Separate command from its output by a blank line.      */
1076           end;
1077 
1078   dcl  cu_$generate_call entry (entry, ptr);
1079 
1080      call cu_$generate_call (ei.entryVar, addr (l));        /* Actually call the subroutine with our arg_list.        */
1081 
1082 %page;
1083           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1084           /*                                                                                                */
1085           /* TASK 10)                                                                                       */
1086           /* Process output parameters and/or function return values from the target entry.  Display those  */
1087           /* values to the user; or for an AF invocation, return one of the values as the AF return string. */
1088           /*                                                                                                */
1089           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1090 
1091      if globalOpt.debug >= 5 then
1092           call ioa_ ("Task 10 begins...");
1093 
1094 
1095      do parmI = 1 to ei.parm_count;                         /* Resolve source.L_id references, storing L_id's output  */
1096           refI = s(parmI).L_idX;                            /*  value in source.L                                     */
1097           if refI ^= Lunset then
1098                s(parmI).L = argFixedBinValue(s(refI), t(refI), l.argP(refI));
1099           end;
1100 
1101      if command then do;                                    /* call as a COMMAND: display output parameters.          */
1102   dcl  outS bit(1) aligned;
1103           do parmI = 1 to ei.parm_count;
1104                if globalOpt.xtra = XTRAoctal then src.xtra = XTRAoctal;
1105                                                             /* Map global -octal onto per-parameter -octal setting.   */
1106                outS = (globalOpt.xtra = XTRAall) | (src.xtra = XTRAoctal ) |
1107                       (src.dir >= DIRinout & src.dir < DIRignore) |
1108                       targ.desc.fcnReturnValue;
1109                if (src.dir = DIRin) | (src.dir = DIRignore) then outS = F;
1110                                                             /* Allow -in and -ignore to override global -all, -octal  */
1111                if outS then do;
1112                     call convertOutputArg(parmI, s(parmI), t(parmI), l.argP(parmI), l.descP(parmI), command, output);
1113                     call ioa_("^a ^va ^a", outPrefix, maxlength(src.id), src.id, output);
1114                     outPrefix = "";
1115                     end;
1116                end;
1117           end;
1118      else do;                                               /* call as an AF: Return only one value.  But which one?  */
1119           do parmI = 1 to ei.parm_count;                    /*  - Foremost, return any nonzero -code value            */
1120                if s(parmI).dir = DIRout & s(parmI).fmt = FMTcode then do;
1121                     call convertOutputArg(parmI, s(parmI), t(parmI), l.argP(parmI), l.descP(parmI), command, af_ret);
1122                     if af_ret ^= "" then go to EXIT_call;
1123                     end;
1124                end;
1125           do parmI = 1 to ei.parm_count;                    /*  - Otherwise, return FIRST parm with -return.          */
1126                if s(parmI).ret & (s(parmI).fmt ^= FMTcode) then do;
1127                     call convertOutputArg(parmI, s(parmI), t(parmI), l.argP(parmI), l.descP(parmI), command, af_ret);
1128                     go to EXIT_call;
1129                     end;
1130                end;
1131           parmI = ei.parm_count;                            /*  - Otherwise, return any function return value.        */
1132           if (parmI > 0) then
1133                if targ.fcnReturnValue & (s(parmI).dir ^= DIRignore) then
1134                     call convertOutputArg(parmI, s(parmI), t(parmI), l.argP(parmI), l.descP(parmI), command, af_ret);
1135           end;
1136 
1137 EXIT_call:                                                  /* Label used to exit entire call program.                */
1138      call call_entry_info_$cleanup(entry_info_ptr);         /*  Cleanup any translator_temp_ storage created by       */
1139      return;                                                /*  call_entry_info_$from_XXX routines.                   */
1140 %page;
1141           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1142           /*                                                                                                */
1143           /* Major subroutines that perform the tasks needed to construct an argument list and call the     */
1144           /* virtual_entry.                                                                                 */
1145           /*                                                                                                */
1146           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1147 
1148 
1149 /* ----------------------------------------------------------------- *
1150  * Get information about each parameter from entrypoint parameter    *
1151  * descriptor.  Store information for each parameter in a            *
1152  * target structure entry (passed as the t parameter below).         *
1153  * ----------------------------------------------------------------- */
1154 
1155 get_entry_parm_info:
1156      proc (i, e, t, debug);
1157 
1158   dcl  i fixed bin;                                         /* index of parameter whose info is wanted.          (in) */
1159   dcl 1 e aligned like entry_info_header;                   /* entry point header information, needed to         (in) */
1160                                                             /*  determine if callee is a function.                    */
1161   dcl 1 t aligned like target;                              /* structure in which parameter info is stored.   (inout) */
1162   dcl  debug fixed bin(3) unsigned;                         /* debug setting.                                    (in) */
1163 
1164      call decode_descriptor(t.descP, t.desc);
1165      if ^supported_by_pl1_dtype(t.desc.type) then do;       /* call makes many decisions based upon groups of         */
1166           t.dcl = "";                                       /*  descriptor types.  Functions defining these groups    */
1167           return;                                           /*  are in call_dtype_fcns.incl.pl1                       */
1168           end;
1169 
1170      t.desc.fcnReturnValue = ((i = ei.parm_count) & ei.function);
1171      t.dcl = descriptorString (t.descP);
1172 
1173      if debug >= 3 then
1174           if t.desc.fcnReturnValue
1175           then call ioa_ ("    returns(^a);", t.dcl);
1176           else call ioa_ ("    dcl parm^a ^a;", int2digits(i), t.dcl);
1177 
1178      end get_entry_parm_info;
1179 
1180 
1181 /* ------------------------------------------------------------ *
1182  * Decode the descriptor info.                                  *
1183  *  - This subroutine called in many places, so centralize the  *
1184  *    code here.                                                *
1185  * ------------------------------------------------------------ */
1186 
1187 decode_descriptor:
1188      proc (descP, desc);
1189 
1190   dcl  descP ptr;
1191   dcl 1 desc aligned like target.desc;
1192 
1193   dcl  decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin (24), fixed bin);
1194 
1195   dcl  packed bit (1) aligned;
1196 
1197      call decode_descriptor_(descP, 0, desc.type, packed, desc.dimensionsCount, desc.size, desc.scale);
1198      desc.aligned = ^packed;
1199 
1200      end decode_descriptor;
1201 
1202 
1203 /* ------------------------------------------------------------ *
1204  * Find source structure in s array whose .id matches a         *
1205  * given input.                                                 *
1206  *  - Caller has tested that s array has been allocated.        *
1207  * ------------------------------------------------------------ */
1208 
1209 sourceWithID:                                               /* ID lookup function.                                    */
1210      proc (idNeeded) returns(fixed bin);
1211 
1212   dcl  idNeeded char(20) var;
1213   dcl  i fixed bin;
1214 
1215      do i = lbound(s,1) to hbound(s,1);
1216           if s(i).id = idNeeded then
1217                return(i);
1218           end;
1219      return(0);
1220      end sourceWithID;
1221 
1222 %page;
1223           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1224           /*                                                                                                */
1225           /* Name: argAssign                                                                                */
1226           /*                                                                                                */
1227           /* Functions:  For each parameter in the calling sequence, create a corresponding argument:       */
1228           /*  1) Validate that parameter type is supported by this call program.  Call does not support:    */
1229           /*       complex numbers, array or structure parameters.                                          */
1230           /*       non-PL/I data types                                                                      */
1231           /*  2) Place parameter into one of six parameter cases used by call.                              */
1232           /*  3) For fixed bin numbers, and bit strings, an initial value may be specified as an octal or   */
1233           /*     hexadecimal representation.  Set the octHex flag as a modifier for the target case.        */
1234           /*  4) Determine how much space is needed to hold the actual argument.                            */
1235           /*  5) Allocate space to hold the argument in our area (created by call_entry_info_$from_XXX).    */
1236           /*  6) For output arguments, determine an appropriate initial value (since caller did not         */
1237           /*     specify one.)                                                                              */
1238           /*  7) Initialize argument storage with the given (or determined) initial value.  Modify          */
1239           /*     descriptor for parameter types with star extents, specifying actual (max)length of the     */
1240           /*     argument being passed.                                                                     */
1241           /*  8) Fill-in call's generated arg_list, with:                                                   */
1242           /*      - ptr to (perhaps modified) parameter descriptor                                          */
1243           /*      - ptr to the allocated, initialized argument storage                                      */
1244           /*                                                                                                */
1245           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1246 
1247 argAssign:
1248      proc (i, src, targ, debugI, listArgP, listDescP, areaP, pl);
1249 
1250   dcl  i fixed bin;                                         /* parameter index being assigned.                   (in) */
1251   dcl 1 src structure aligned like source;                  /* parameter arg_value specification.                (in) */
1252   dcl 1 targ structure aligned like target;                 /* parameter descriptor information.                 (in) */
1253   dcl  debugI fixed bin(3) unsigned;                        /* debug:  >=3 means display allocation size info.   (in) */
1254   dcl  listArgP ptr;                                        /* ptr to our arg_list.argP(i) for this parameter   (out) */
1255   dcl  listDescP ptr;                                       /* ptr to our arg_list.descP(i) for this parameter  (out) */
1256   dcl  areaP ptr;                                           /* ptr to our translator_temp_ allocation area.     (out) */
1257   dcl 1 pl structure aligned like parmSummary;              /* summary structure which counts errors.         (inout) */
1258 
1259   dcl 1 parmDesc aligned like arg_descriptor based(targ.descP);
1260                                                             /* Create an overlay for the actual target descriptor.    */
1261 
1262   dcl 1 d aligned like target.desc based(dP);               /* Create a short name for target.desc substructure.      */
1263   dcl  dP ptr;                                              /*  This substructure changes if -addr is given.          */
1264 
1265      if src.ad.given then                                   /* When -addr DECLARATION is given, get storage for that  */
1266           dP = addr(src.ad.desc);                           /*  declaration, rather than for the pointer parameter.   */
1267      else dP = addr(targ.desc);                             /* Otherwise, get storage to hold the parameter defined   */
1268                                                             /*  by the entrypoint calling sequence.                   */
1269                                                             /*  (For options(variable) subroutine, get either         */
1270                                                             /*   character storage, or storage to hold -dcl data type)*/
1271 
1272      if ^supported_by_call_dtype(d.type) then do;           /* Check for structures, non-PL/I types, complex numbers  */
1273 ASSIGN_bad_type:
1274           if d.type = structure_dtype then
1275                call gripe (call_et_$structure_unsupported, PROC, "dcl 1 ^a ^a;^[ -addr ""^a""^;^s^]",
1276                     src.id, substr(targ.dcl,2), src.ad.given, src.dcl);
1277           else call gripe (call_et_$parameter_type_unsupported, PROC, "^a (^d): dcl ^a ^a;^[ -addr ""^a""^;^s^]",
1278                     pl1_dtype_name(d.type), d.type, src.id, targ.dcl, src.ad.given, src.dcl);
1279           go to ASSIGN_unsupported;
1280           end;
1281      if d.dimensionsCount > 0 then do;                      /* Check for arrays, which call does not support.         */
1282           call gripe(call_et_$array_unsupported, PROC,
1283                "dcl ^a ^a;^[ -addr ""^a""^;^s^]", src.id, targ.dcl, src.ad.given, src.dcl);
1284           go to ASSIGN_unsupported;
1285           end;
1286 
1287      targ.case = argCase(d.type);                           /* Place parameter type into one of five parameter cases. */
1288      if targ.case = 0 then go to ASSIGN_bad_type;
1289 
1290      if d.fcnReturnValue & targ.case = CASEstring & d.size = SizeStar & ^src.ad.given  then do;
1291                                                             /* Check for a possible sixth case:                       */
1292           targ.case = CASEreturnsStar;                      /*    returns(char(*)... )  or  returns(bit(*)... )       */
1293           targ.storage.wordCount = 0;                       /*  must be handled without pre-allocating storage to hold*/
1294           targ.storage.P = null;                            /*  the returned data.  Instead that data is pushed onto  */
1295           go to ASSIGN_for(targ.case);                      /*  call's stack frame.                                   */
1296           end;
1297 
1298   dcl  octHex bit(1) aligned init(F);                       /* For fixed bin or bit arguments, input value may be     */
1299   dcl  sourceBits bit(200) varying aligned;                 /*  given in an octal or hex representation, where last   */
1300                                                             /*  two digits indicate base (b3=octal, b4=hexadecimal).  */
1301                                                             /*  For example, decimal 133 is input as:                 */
1302                                                             /*    octal:  205b3          hexadecimal:  85b4           */
1303      if (fixed_bin_dtype(d.type) | bit_string_dtype(d.type)) then
1304           octHex = T;
1305 
1306                                                             /* Determine actual extent for parameter with star extent.*/
1307   dcl  desiredSize fixed bin(24);                           /* Size in bits, characters, or (area) words.             */
1308      desiredSize =  d.size;                                 /*  - Start out using size from the target descriptor.    */
1309 
1310      if star_extent_dtype(d.type) & d.size = SizeStar then do;
1311           if src.M ^= Lunset then                           /* For strings and areas, map xxx(*) to specific length.  */
1312                desiredSize = src.M;                         /*  -max_length M                                         */
1313           else if char_string_dtype(d.type) & src.argL > 0 then
1314                desiredSize = src.argL;                      /*  length(input_arg_value)                               */
1315           else if bit_string_dtype(d.type)  & src.argL > 0 then do;
1316                if octHex & oct_or_hex_source(srcArg, sourceBits) then
1317                     desiredSize = length(sourceBits);
1318                else desiredSize = src.argL;
1319                end;
1320           end;
1321      if star_extent_dtype(d.type) & desiredSize = SizeStar then do;
1322           call gripe(call_et_$star_extent_unresolved, PROC,
1323                "Use -max_length M to give a size: dcl ^a ^a; ^[-addr ""^a""^;^s^]",
1324                src.id, targ.dcl, src.ad.given, src.dcl);
1325           go to ASSIGN_unsupported;
1326           end;
1327 
1328 
1329   dcl  code fixed bin(35);                                  /* Get count of storage needed (in words).                */
1330      call argStorageWords (d.type, d.aligned, desiredSize, targ.storage.wordCount, code);
1331      if code ^= 0 then do;
1332           call gripe (code, PROC, "Unsupported storage type: ^a (^d): dcl ^a ^a;^[ -addr ""^a""^;^s^]",
1333                pl1_dtype_name(d.type), d.type, src.id, targ.dcl, src.ad.given, src.dcl);
1334           go to ASSIGN_unsupported;
1335           end;
1336 
1337      targ.storage.P = allocate(areaP, (targ.storage.wordCount));
1338                                                             /* Allocate the storage.                                  */
1339 
1340   dcl srcArg char(src.argL) based(src.argP);                /* Declare an overlay for the initial value argument.     */
1341 
1342   dcl emptyString char(0) int static options(constant) init("");
1343                                                             /* An empty string as the initial value:                  */
1344      if src.dir >= DIRout then do;                          /*  - Zeroes (numeric, bit) output arguments.             */
1345           src.argP = addr(emptyString);                     /*  - Set string output arguments to "".                  */
1346           src.argL = length(emptyString);
1347           end;
1348 
1349      go to ASSIGN_for(targ.case);
1350 %page;
1351 
1352 ASSIGN_for (CASEpointer):
1353 
1354   dcl cv_ptr_ entry (char(*), fixed bin(35)) returns(ptr);
1355   dcl convPtr ptr;
1356   dcl assignPtr       ptr      based(targ.storage.P);
1357   dcl assignPtrPacked ptr unal based(targ.storage.P);
1358 
1359      if src.argL = 0 then                                   /* User gave no initialization for pointer?               */
1360           convPtr = null();                                 /*   Default initial value is a null() pointer.           */
1361      else do;                                               /* CONVERT                                                */
1362           convPtr =  cv_ptr_(srcArg, code);                 /*   src (initial arg_value) to an aligned ptr.           */
1363           if code ^= 0 then go to ASSIGN_failed;
1364           end;
1365      if targ.desc.aligned then                              /* ASSIGN                                                 */
1366           assignPtr = convPtr;
1367      else assignPtrPacked = convPtr;
1368      listDescP = targ.descP;
1369      go to ASSIGN_ok;
1370 
1371 
1372 ASSIGN_for (CASEentry):
1373 
1374   dcl  cv_entry_ entry (char(*), ptr, fixed bin(35)) returns(entry);
1375   dcl  cu_$make_entry_value entry (ptr, entry);
1376   dcl  convEntry entry variable options(variable);
1377   dcl  assignEntry entry variable options(variable) based(targ.storage.P);
1378 
1379      if src.argL = 0 then                                   /* STORAGE                                                */
1380           call cu_$make_entry_value (null(), convEntry);    /* User gave no initialization for entry value?           */
1381                                                             /*   Create equivalent of a null entry value.             */
1382      else do;
1383           convEntry =  cv_entry_(srcArg, null(), code);     /* CONVERT                                                */
1384           if code ^= 0 then go to ASSIGN_failed;
1385           end;
1386      assignEntry = convEntry;                               /* ASSIGN                                                 */
1387      listDescP = targ.descP;                                /*  Entry variables are always aligned.                   */
1388      go to ASSIGN_ok;
1389 
1390 
1391 ASSIGN_for (CASEnumeric):
1392      if src.dir <= DIRinout & src.fmt = FMTcode & src.argL > 0 then do;
1393 
1394   dcl  statusCodeE entry variable;
1395   dcl  statusCodeP ptr;
1396   dcl  statusCode fixed bin(35) aligned based(statusCodeP);
1397   dcl  assignCode fixed bin(35) aligned based(targ.storage.P);
1398 
1399           statusCodeE = cv_entry_(srcArg, null(), code);    /* CONVERT input status code name to fixed bin(35) value. */
1400           if code ^= 0 then go to ASSIGN_failed;
1401           statusCodeP = codeptr(statusCodeE);
1402           assignCode = statusCode;                          /* ASSIGN                                                 */
1403           end;
1404 
1405      else if src.dir <= DIRinout & ((src.fmt = FMTdate_time) | (src.fmt = FMTdate) | (src.fmt = FMTtime))  then do;
1406 
1407   dcl  clockN fixed bin(71) aligned based(targ.storage.P);
1408   dcl  convert_date_to_binary_ entry (char(*), fixed bin(71), fixed bin(35));
1409 
1410           call convert_date_to_binary_(srcArg, clockN, code);
1411           if code ^= 0 then go to ASSIGN_failed;            /* CONVERT input date/time string to fixed bin(71) value. */
1412           end;
1413 
1414      else do;                                               /* CONVERT initial value to numeric form.                 */
1415           call assign(srcArg, octHex, targ.P, d.type, d.aligned, d.size, d.scale, code);
1416           if code ^= 0 then go to ASSIGN_failed;
1417           end;
1418      listDescP = targ.descP;
1419      go to ASSIGN_ok;
1420 
1421 
1422 ASSIGN_for (CASEarea):
1423 
1424   dcl 1 ai aligned like area_info;
1425   dcl  assignArea area(desiredSize) based(targ.storage.P);  /* STORAGE                                                */
1426   dcl  define_area_ entry (ptr, fixed bin(35));
1427 
1428      unspec(ai) = ZEROb;                                    /* CONVERT/ASSIGN                                         */
1429      ai.version = area_info_version_1;
1430      ai.control.zero_on_free = T;
1431      ai.owner = PROC;
1432      ai.size = desiredSize;
1433      ai.areap = targ.storage.P;
1434      call define_area_ (addr(ai), code);
1435      if code ^= 0 then go to ASSIGN_area_failed;
1436 
1437      if ^src.ad.given & d.size = SizeStar then do;
1438           targ.modifiedDesc = parmDesc;
1439           targ.modifiedDesc.size = desiredSize;
1440           listDescP = addr(targ.modifiedDesc);
1441           end;
1442      else if src.ad.given then do;
1443           listDescP = targ.descP;
1444           src.ad.desc.size = desiredSize;                   /* Created area size not recorded anywhere else.  So      */
1445           end;                                              /*  put it in src.ad.desc.                                */
1446      else listDescP = targ.descP;
1447      go to ASSIGN_ok;
1448 
1449 
1450 ASSIGN_for (CASEstring):                                    /* CONVERT/ASSIGN                                         */
1451      call assign(srcArg, octHex, targ.P, d.type, d.aligned, desiredSize, 0, code);
1452      if ^src.ad.given & d.size = SizeStar then do;
1453           targ.modifiedDesc = parmDesc;
1454           targ.modifiedDesc.size = desiredSize;
1455           listDescP = addr(targ.modifiedDesc);
1456           end;
1457      else listDescP = targ.descP;
1458      go to ASSIGN_ok;
1459 
1460 
1461 ASSIGN_for (CASEreturnsStar):                               /* For returns(xxx(*)... ) function return value:         */
1462      unspec(targ.modifiedDesc) = ZEROb;                     /*  - Zero storage in which callee will store descriptor. */
1463      listDescP = addr(targ.modifiedDesc);                   /*  - Make arg_list point to that descriptor.             */
1464      targ.storage.P = null;                                 /*  - Null out pointer to callee-returned storage.        */
1465      listArgP = addr(targ.storage.P);                       /*  - Make arg_list point to that parameter storage ptr.  */
1466      go to ASSIGN_debug;
1467 
1468 
1469 ASSIGN_ok:
1470      if src.ad.given then                                   /* For -addr DECLARATION, parm is pointer to DECLARATION  */
1471           listArgP = addr(targ.P);                          /*   storage.                                             */
1472      else if varying_string_dtype(d.type) then              /* For varying string, arg_list.parmP(i) points just      */
1473           listArgP = addrel(targ.P, 1);                     /*   after length word of the varying string.             */
1474      else listArgP = targ.P;                                /* Otherwise, argument list points to allocated parm.     */
1475 ASSIGN_debug:
1476      if debugI >= 4 then
1477           call ioa_(" ^va @ ^p   ^2d word^[^;s^]", maxlength(src.id), src.id, listArgP, targ.storage.wordCount,
1478                targ.storage.wordCount = 1);
1479      return;
1480 
1481 ASSIGN_failed:
1482      call gripe(code, PROC, "Converting ""^a"" ^a  to: dcl ^a ^a;^[ -addr ""^a""^;^s^]",
1483           srcArg, FMT.name(src.fmt), src.id, targ.dcl, src.ad.given, src.dcl);
1484      pl.convertFailed = pl.convertFailed + 1;
1485      return;
1486 
1487 ASSIGN_area_failed:
1488      call gripe(code, PROC, "Emptying area: ^a -id ^a (dcl: ^a)^[ -addr ""^a""^;^s^]",
1489                DIR.name(src.dir), src.id, targ.dcl, src.ad.given, src.dcl);
1490      pl.convertFailed = pl.convertFailed + 1;
1491      return;
1492 
1493 ASSIGN_unsupported:
1494      pl.parmsNotSupported = pl.parmsNotSupported + 1;
1495      return;
1496 
1497      end argAssign;
1498 
1499 
1500 argStorageBits:                                             /* This routine uses PL/I rules to determine how much     */
1501      proc (dtype, daligned, dsize) returns(fixed bin(24));  /*  storage is needed.  Count is always returned in bits. */
1502 
1503   dcl  dtype fixed bin;
1504   dcl  daligned bit(1) aligned;
1505   dcl  dsize fixed bin(24);
1506 
1507   dcl  code fixed bin(35);
1508   dcl  count fixed bin(24);
1509 
1510   dcl  boundary fixed bin(2) unsigned;
1511 
1512      call storage_for_pl1_dtype(dtype, ^daligned, dsize, boundary, count, code);
1513      if code = 0 then do;
1514           if boundary = BOUNDARY.Word then
1515                count = count * bits_per_word;
1516           else if boundary = BOUNDARY.Byte then
1517                count = count * bits_per_character;
1518           end;
1519      else count = 36;                                       /* Assert: code should never be non-zero.                 */
1520                                                             /*  call already restricted dtype's to those supported by */
1521                                                             /*  the storage_for_pl1_dtype function.                   */
1522      return (count);
1523      end argStorageBits;
1524 
1525 
1526 argStorageWords:                                            /* This routine uses PL/I rules to determine how much     */
1527      proc (dtype, daligned, dsize, count, code);            /*  storage is needed.  call always has even-word aligned */
1528                                                             /*  storage (even for packed scalars), so code below      */
1529   dcl  dtype fixed bin;                                     /*  converts bit/byte lengths to word length (just as the */
1530   dcl  daligned bit(1) aligned;                             /*  PL/I size builtin would do).                          */
1531   dcl  dsize fixed bin(24);
1532   dcl  count fixed bin(24);
1533   dcl  code fixed bin(35);
1534 
1535   dcl  boundary fixed bin(2) unsigned;
1536 
1537      call storage_for_pl1_dtype(dtype, ^daligned, dsize, boundary, count, code);
1538      if code = 0 then do;
1539           if boundary = BOUNDARY.Byte then
1540                count = divide(count+characters_per_word-1, characters_per_word, 24, 0);
1541           else if boundary = BOUNDARY.Bit then
1542                count = divide(count+bits_per_word-1, bits_per_word, 24, 0);
1543           end;
1544 
1545      end argStorageWords;
1546 %page;
1547           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1548           /*                                                                                                */
1549           /* Name:  argFixedBinValue                                                                        */
1550           /*                                                                                                */
1551           /* Function: Does a quick conversion of a fixed binary variable to a fixed bin(24) string/area    */
1552           /* length count.  It is called for two different purposes:                                        */
1553           /*  1) For a ptr parameter declared with:  -addr "char(lengthParmID)", call has found another     */
1554           /*     source arg_value with -id lengthParmID.  This "reference" arg_value must be an -input      */
1555           /*     (or -inout) fixed binary arg_value.  Before calling virtualEntry, argFixedBinValue is      */
1556           /*     called to convert the reference initial value to the length count.  Since this conversion  */
1557           /*     has not been tested before, a conversion or size condition might occur.                    */
1558           /*  2) For a string parameter declared with -length lengthParmID, call has found another          */
1559           /*     source arg_value with -id lengthParmID.  This "reference" arg_value must be a              */
1560           /*     fixed binary arg_value, whose output value is used as the length count.                    */
1561           /*                                                                                                */
1562           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1563 
1564 argFixedBinValue:
1565      proc (src, targ, argP) returns(fixed bin(24));
1566 
1567   dcl 1 src aligned like source;
1568   dcl 1 targ aligned like target;
1569   dcl  argP ptr;                                            /* arg_list.arg_ptr(parmI)                           (in) */
1570                                                             /*  =null():   purpose 1, use src initial value.          */
1571                                                             /*  otherwise: purpose 2, use parm output value.          */
1572 
1573   dcl  PACKED fixed bin int static options(constant) init(1);
1574 
1575   dcl 1 desc aligned like target.desc;
1576   dcl  fbSourceP ptr;
1577   dcl  fbAddressedSource ptr based(argP);
1578   dcl  value fixed bin(24);
1579 
1580   dcl (conversion, size) condition;
1581 
1582      if src.ad.given then do;                               /* We have: parmValuePtr -> number                        */
1583           desc = src.ad.desc;
1584           fbSourceP = fbAddressedSource;
1585           end;
1586      else do;                                               /* We have: parmNumber                                    */
1587           desc = targ.desc;
1588           fbSourceP = argP;
1589           end;
1590 
1591      on conversion begin;                                   /* The following calls to assign_ can raise conditions    */
1592           code = error_table_$bad_conversion;               /* Trap them so we can gracefully report them to user.    */
1593           go to EXIT_parm_value;
1594           end;
1595      on size begin;
1596           code = error_table_$size_error;
1597           go to EXIT_parm_value;
1598           end;
1599 
1600      if argP = null() then                                  /* Purpose 1: convert call arg_value initial string to a  */
1601                                                             /*  fixed bin(24) length.                                 */
1602           call assign_ (addr(value), 2*FIXED_BIN, 24, src.argP , 2*char_dtype+PACKED, binary(src.argL,35,0));
1603      else                                                   /* Purpose 2: convert virtualEntry outout fixed-point     */
1604                                                             /*  value to a fixed bin(24) length.                      */
1605           call assign_ (addr(value), 2*FIXED_BIN, 24, fbSourceP, 2*desc.type + binary(^desc.aligned,1,0), binary(desc.size,35,0));
1606      return(value);
1607 
1608 EXIT_parm_value:
1609      if argP = null() then                                  /* Purpose 1: SizeStar result diagnoses an error.         */
1610           return(SizeStar);
1611      else do;                                               /* Purpose 2: report conversion/size error to the user,   */
1612                                                             /*  and returns an arbitrary length count of 10.          */
1613           call gripe(code, PROC, "Converting bin length value; returning 10 instead.");
1614           return(10);
1615           end;
1616 
1617      end argFixedBinValue;
1618 
1619 
1620 parmIsFixedBin:
1621      proc (src, targ) returns(bit(1) aligned);
1622 
1623   dcl 1 src aligned like source;
1624   dcl 1 targ aligned like target;
1625 
1626      if src.ad.given then do;
1627           if fixed_bin_dtype(src.ad.desc.type) & src.ad.desc.scale = 0  then return(T);
1628           else return(F);
1629           end;
1630      if fixed_bin_dtype(targ.desc.type) & targ.desc.scale = 0  then return(T);
1631      else return(F);
1632 
1633      end parmIsFixedBin;
1634 %page;
1635 
1636 /* ----------------------------------------------------------------- *
1637  * Internal procedure to handle the details/idiosyncrasies of        *
1638  * calling the Multics assign_ subroutine, which is the advertised   *
1639  * subroutine interface to the PL/I any_to_any_ conversion operator. *
1640  * ----------------------------------------------------------------- */
1641 
1642                                                             /* Clearer names for commonly-used arg descriptor types.  */
1643   dcl  FIXED_BIN fixed bin aligned int static options(constant) init(real_fix_bin_1_dtype);
1644   dcl  FIXED_BIN_UNS fixed bin aligned int static options(constant) init(real_fix_bin_1_uns_dtype);
1645 
1646                                                             /* Constants for the targetAligned parameter (below).     */
1647   dcl  ALIGNED bit(1) aligned int static init("1"b) options (constant);
1648   dcl  UNALIGNED bit(1) aligned int static init("0"b) options (constant);
1649 
1650 assign:
1651      proc( source, octHex, targetP, targetType, targetAligned, targetPrecision, targetScale, code);
1652 
1653   dcl  source char(*);                                      /* input arg from call command line.                      */
1654   dcl  octHex bit(1) aligned;                               /* =T: attempt to handle octal/hex input values.          */
1655   dcl  targetP ptr;                                         /* ptr to target storage for converted parameter          */
1656   dcl  targetType fixed bin;                                /* One of std_descriptor_types.incl.pl1 values for target */
1657   dcl  targetAligned bit(1) aligned;                        /* F if target is packed; T if targetP is on              */
1658                                                             /*  appropriate storage boundary for targetType.          */
1659   dcl  targetPrecision fixed bin(24);                       /* Length of non-computational target (in approp. units); */
1660                                                             /*  or computational precision of target.                 */
1661   dcl  targetScale fixed bin;                               /* Scale of computational target.  0 (ignored) otherwise. */
1662   dcl  code fixed bin(35);                                  /* Return code diagnosing bad conversions. (out)          */
1663 
1664   dcl (conversion, overflow, size, underflow) condition;
1665 
1666   dcl  sourcePacked fixed bin int static options(constant) init(1);
1667   dcl  targetPacked fixed bin init(1);                      /* Assume target is packed when we start.                 */
1668 
1669 
1670   dcl  targetL fixed bin(35) init(targetPrecision);         /* In usual case, targetL (passed to assign_) is the same */
1671                                                             /*   as input targetPrecision value.  For fixed-point     */
1672                                                             /*   numbers, this is not so.                             */
1673   dcl 1 encp aligned like encoded_precision;
1674 
1675      if fixed_point_dtype(targetType) then do;              /* For fixed-point types, store scale/precision in targetL*/
1676           encp.prec  = targetPrecision;
1677           encp.scale = targetScale;
1678           unspec(targetL) = unspec(encp);
1679           end;
1680 
1681      code = 0;                                              /* Initialize output variables.                           */
1682 
1683      if targetAligned then targetPacked = 0;                /* Adjust for an appropriately aligned target.            */
1684 
1685      on conversion begin;                                   /* The following calls to assign_ can raise conditions    */
1686           code = error_table_$bad_conversion;               /* Trap them so we can gracefully report them to user.    */
1687           go to EXIT_ASSIGN;
1688           end;
1689      on overflow begin;                                     /* Occurs only for floating-point target assignment.      */
1690           code = call_et_$overflow_error;
1691           go to EXIT_ASSIGN;
1692           end;
1693      on size begin;
1694           code = error_table_$size_error;
1695           go to EXIT_ASSIGN;
1696           end;
1697      on underflow begin;                                    /* Occurs only for floating-point target assignment.      */
1698           code = call_et_$underflow_error;
1699           go to EXIT_ASSIGN;
1700           end;
1701 
1702      if octHex then                                         /* Look for octal and hex character string representations*/
1703 LOOK_FOR_OCTHEX:                                            /*  of a bit string, to be stored in bit or fixed bin.    */
1704      do;
1705   dcl  sourceBits bit(200) var;
1706           if oct_or_hex_source(source, sourceBits) then     /* Is bit string of form: "3577"b3 (without the quotes)   */
1707 HAVE_OCTHEX_SOURCE:                                         /*            or of form: "9aBc"b4 (without the quotes)   */
1708           do;
1709                if unsigned_dtype(targetType) then           /* Bits are assigned to storage for numbers right-to-left */
1710                     sourceBits = ltrimZeroes(sourceBits);   /*  so remove leading 0-bits; avoid any size condition.   */
1711                else if fixed_bin_dtype(targetType) then     /* Signed fixed bin's require special handling of sign    */
1712 OCTHEX_FIXED_BIN:                                           /*  bit.  It must be left-filled across storage to left   */
1713                do;                                          /*  of targetPrecision bits.                              */
1714                     if length(sourceBits) > targetPrecision then
1715                          sourceBits = ltrimZeroes(sourceBits);
1716                                                             /*  Remove leading 0-bits; avoid possible size condition. */
1717                     if length(sourceBits) > targetPrecision+1 then do;
1718                          code = error_table_$size_error;    /* Too many bits given for precision of fixed bin parm.   */
1719                          go to EXIT_ASSIGN;
1720                          end;
1721                     if length(sourceBits) = targetPrecision+1 then do;
1722                                                             /* Negative sign bit given.  Must extend it to left of    */
1723                                                             /*  precision, if parameter is aligned.                   */
1724   dcl  signHolder bit(72) aligned;
1725   dcl  signBits bit(targetL-targetPrecision) aligned based(addr(signHolder));
1726   dcl  targetBits bit(targetL) aligned based(targetP);
1727 
1728                          targetL = argStorageBits( targetType, targetAligned, targetPrecision);
1729                          sourceBits = substr(sourceBits,2);
1730                          signBits = NEG_SIGN_BITS;
1731                          sourceBits = signBits || sourceBits;
1732                          targetBits = sourceBits;
1733                          go to EXIT_ASSIGN;
1734                          end;
1735                     end OCTHEX_FIXED_BIN;
1736 
1737                call assign_(targetP, 2*targetType + targetPacked, targetL,
1738                     addr(sourceBits),2*varying_bit_dtype,         length(sourceBits));
1739                go to EXIT_ASSIGN;
1740 
1741                end HAVE_OCTHEX_SOURCE;
1742           end LOOK_FOR_OCTHEX;
1743 
1744      call assign_(targetP, 2*targetType + targetPacked, targetL,
1745           addr(source),    2*char_dtype + sourcePacked, length(source));
1746 
1747 EXIT_ASSIGN:
1748      end assign;
1749 %page;
1750           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1751           /*                                                                                                */
1752           /* Utility routines used by assign.                                                               */
1753           /*                                                                                                */
1754           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1755 
1756 ltrimZeroes:
1757      proc(s) returns(bit(200) varying aligned);
1758   dcl  s bit(200) varying aligned;
1759 
1760   dcl  i fixed bin;
1761   dcl  foundOneI fixed bin;
1762 
1763      do i = 1 to length(s);                                 /* Search left-to-right for first 1-bit in string.        */
1764           if substr(s,i,1) = "1"b then do;
1765                foundOneI = i;
1766                go to LTRIM;
1767                end;
1768           end;
1769      return(""b);
1770 
1771 LTRIM:
1772      return (substr(s,foundOneI));                          /* Return bit string starting with first 1-bit.           */
1773      end ltrimZeroes;
1774 
1775 
1776   dcl  sourceBits bit (200) varying aligned init(""b);      /* Enough to hold 1e59 (max fixed decimal number)         */
1777 
1778 oct_or_hex_source:                                          /* Look for source initial value in form of octal or hex  */
1779      proc (s, bv) returns(bit(1) aligned);                  /*  PL/I bit string literal (without the quote chars).    */
1780 
1781   dcl  s char(*);
1782   dcl  bv bit(200) varying aligned;
1783 
1784      if index(reverse(s), "3b") = 1 then do;                /* Bit string of form: "3577"b3 (without the quotes)      */
1785           if verify(s, "01234567") = length(s)-1 then do;
1786                call bitsFromOctal(s, bv);
1787                return (T);
1788                end;
1789           return(F);
1790           end;
1791      if index(reverse(s), "4b") = 1 then do;                /* Bit string of form: "9abc"b4 (without the quotes)      */
1792           if verify(s, "0123456789abcdefABCDEF") = 0 then do;
1793                call bitsFromHex(s, bv);
1794                return (T);
1795                end;
1796           return(F);
1797           end;
1798      return (F);
1799 
1800      end oct_or_hex_source;
1801 
1802 
1803 bitsFromOctal:                                              /* These conversion routines assume caller has verified   */
1804      proc(s, bv);                                           /* input contains only octal or hex chars, followed by    */
1805                                                             /* the PL/I bit-radix indicator: b3 for octal, b4 for hex */
1806 
1807   dcl  s char(*);
1808   dcl  bv bit(200) varying aligned;
1809 
1810   dcl  i fixed bin;
1811   dcl  sa (length(s)) char(1) based(addr(s));
1812   dcl  oct (8) bit(3) int static options(constant) init(
1813            "000"b, "001"b, "010"b, "011"b, "100"b, "101"b, "110"b, "111"b);
1814 
1815      bv = ""b;
1816 
1817      do i = 1 to length(s)-length("b3");
1818           bv = bv || oct(index("01234567", sa(i)));
1819           end;
1820      return;
1821 
1822 
1823 bitsFromHex:
1824      entry(s, bv);
1825 
1826   dcl  hex (22) bit(4) int static options(constant) init(
1827            "0000"b, "0001"b, "0010"b, "0011"b, "0100"b, "0101"b, "0110"b, "0111"b,
1828            "1000"b, "1001"b, "1010"b, "1011"b, "1100"b, "1101"b, "1110"b, "1111"b,
1829                              "1010"b, "1011"b, "1100"b, "1101"b, "1110"b, "1111"b);
1830      bv = ""b;
1831      do i = 1 to length(s)-length("b4");
1832           bv = bv || hex(index("0123456789abcdefABCDEF", sa(i)));
1833           end;
1834      return;
1835 
1836      end bitsFromOctal;
1837 
1838 %page;
1839           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1840           /*                                                                                                */
1841           /* Name: convertOutputArg                                                                         */
1842           /*                                                                                                */
1843           /* Function:                                                                                      */
1844           /* Routine to convert a return value from its parameter data type back to a string, so it can be  */
1845           /* displayed/returned to the user.                                                                */
1846           /*                                                                                                */
1847           /* Name: debugOutputArg                                                                           */
1848           /*                                                                                                */
1849           /* Function:                                                                                      */
1850           /* A debug entrypoint is used prior to invoking virtualEntry, to display parameters just after    */
1851           /* our arg_list is initialized.  It provides information about descriptors in the arg_list, as    */
1852           /* well.                                                                                          */
1853           /*                                                                                                */
1854           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1855 
1856 
1857 convertOutputArg:
1858      proc (i, src, targ, listArgP, listDescP, command, out);
1859                                                             /* All parms are (in) except as marked.                   */
1860   dcl  i fixed bin;                                         /*  - target parameter number.                            */
1861   dcl 1 src aligned like source;                            /*  - source structure for initial value.                 */
1862   dcl 1 targ aligned like target;                           /*  - target structure for parameter storage info.        */
1863   dcl  listArgP ptr;                                        /*  - our arg_list.parmP for this parameter.              */
1864   dcl  listDescP ptr;                                       /*  - our arg_list.descP for this parameter.              */
1865   dcl  command bit(1) aligned;                              /*  - were we called as command or active function?       */
1866   dcl  out char(*) varying;                                 /*  - return parm converted to string, with an            */
1867                                                             /*    optional octal dump.                          (out) */
1868   dcl 1 desc aligned like target.desc;
1869   dcl  ioaL fixed bin(21);
1870   dcl  outDump char(1000) varying;
1871   dcl  packed bit(1) aligned;
1872   dcl  parmP ptr init(listArgP);
1873 
1874   dcl  debugOutput bit(1) aligned init(T);
1875 
1876      debugOutput = F;
1877 
1878 debugOutputArg:
1879      entry (i, src, targ, listArgP, listDescP, command, out, outD);
1880                                                             /* NB: debugOutputArg is invoked only before calling     */
1881                                                             /*     the subroutine or function.  It is displaying      */
1882                                                             /*     how the call command prepared the arg_list, and    */
1883                                                             /*     initialized the parameters.                        */
1884 
1885   dcl  outD char(*) varying;                                /* Debug output describing descriptor.              (out) */
1886 
1887      out = "";                                              /* Initialize return string.                              */
1888 
1889      if targ.case = CASEreturnsStar then do;                /* Special cases: returns(xxx(*)), returns(xxx(*) var)    */
1890           if debugOutput then do;                           /* BEFORE calling the function:                           */
1891                unspec(desc) = "0"b;
1892                desc.type = pointer_dtype;                   /*  - parmP points to a pointer which is null, but        */
1893                desc.aligned = T;                            /*    will point to the actual_return_value string.       */
1894                parmP = listArgP;
1895                go to CONV(CASEpointer);                     /*    So show the null pointer at this stage.             */
1896                end;
1897           else do;                                          /* AFTER calling the function:                            */
1898                parmP = parmToPtrAligned(parmP, T);          /*  - parmP points to a pointer set by callee to the      */
1899                                                             /*    actual return value.                                */
1900                if parmP ^= null() & varying_string_dtype(targ.desc.type) then
1901                     parmP = addrel(parmP, -1);              /*  - set parmP to point to the actual return value.      */
1902                                                             /*     We'll use this ptr below.                          */
1903                                                             /*  - Callee also provided a descriptor, giving actual    */
1904                end;                                         /*    length of return value.  Decode this next.          */
1905           end;
1906 
1907      call decode_descriptor(listDescP, desc);               /* Get perhaps modified descriptor, with star extent      */
1908                                                             /*  replaced by an actual string/area size.               */
1909 
1910      if  src.ad.given then do;                              /* For -addr DECLARATION parameter, use the descriptor    */
1911           parmP = parmToPtrAligned(parmP, desc.aligned);    /*  created from DECLARATION.  Make parmP point to this   */
1912           if parmP ^= null  then                            /*  declared storage.                                     */
1913                desc = src.ad.desc;
1914           else parmP = listArgP;
1915           end;
1916      else if targ.case ^= CASEreturnsStar then do;          /* returns(char(*)...) parmP was set above.               */
1917           if varying_string_dtype(desc.type) then           /*  - Argument list points just after length word of a    */
1918                parmP = addrel(listArgP, -1);                /*    varying string parameter.  Back up to length word.  */
1919           else parmP = listArgP;
1920           end;
1921 
1922      go to CONV(argCase(desc.type));                        /* Recalculate argCase to account for -addr DECLARATION   */
1923                                                             /*  desc.type                                             */
1924 
1925 CONV (CASEnumeric):
1926      if (src.fmt = FMTcode) & (^debugOutput | src.dir <= DIRinout)  then do;
1927                                                             /* Numeric case includes status code: special handling.   */
1928   dcl  codeN fixed bin(35) aligned based(parmP);
1929   dcl  shortMsg char(8) aligned;
1930   dcl  longMsg char(100) aligned;
1931   dcl  codeName char(128) var;
1932 
1933   dcl  call_status_code_name_ entry (fixed bin(35)) returns(char(128) var);
1934   dcl  convert_status_code_ entry (fixed bin(35), char(8) aligned, char(100) aligned);
1935 
1936           if codeN ^= 0 then do;
1937                codeName = call_status_code_name_(codeN);
1938                call convert_status_code_(codeN, shortMsg, longMsg);
1939                if length(codeName) > 0 then
1940                     out = codeName || "  " || rtrim(longMsg);
1941                else out = rtrim(longMsg);
1942                end;
1943           else if command then out = "OK";
1944           else out = "";
1945           end;
1946 
1947      else if ((src.fmt = FMTdate_time) | (src.fmt = FMTdate) | (src.fmt = FMTtime)) &
1948              (^debugOutput | src.dir <= DIRinout)  then do;
1949                                                             /* Numeric case includes a clock value: special handling. */
1950   dcl  clockN fixed bin(71) aligned based(parmP);
1951   dcl  date_time char(250) var;
1952   dcl  date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
1953   dcl (process_default_zone, process_default_lang) char(0) init("") int static options(constant);
1954 
1955           date_time = date_time_$format(FMT.kywd(src.fmt), clockN, process_default_zone, process_default_lang);
1956           out = date_time;
1957           end;
1958 
1959      else do;                                               /* Otherwise, let assign convert number to character form */
1960 
1961   dcl 1 encp aligned like encoded_precision;
1962   dcl  sourceL fixed bin(35);
1963 
1964           if fixed_point_dtype(desc.type) then do;
1965                encp.prec = desc.size;
1966                encp.scale = desc.scale;
1967                unspec(sourceL) = unspec(encp);
1968                end;
1969           else sourceL = desc.size;
1970           call assign_(addr(out), 2*varying_char_dtype, maxlength(out),
1971                parmP, desc.type*2 + binary(^desc.aligned), sourceL);
1972           out = ltrim(out);
1973           end;
1974      go to CONV_return;
1975 
1976 
1977 CONV (CASEstring):                                          /* For strings, bits and varying strings need special     */
1978                                                             /*  handling.                                             */
1979   dcl  bitS bit(sourceL) based(parmP);
1980   dcl  bitV bit(sourceL) varying based(parmP);
1981   dcl  varS bit(1) aligned init(F);
1982 
1983      if src.L ^= Lunset then                                /* -length L tells us how much data user wants output.    */
1984           sourceL = src.L;
1985      else sourceL = desc.size;                              /* Otherwise, use the desc.size amount.                   */
1986 
1987      if varying_string_dtype(desc.type) then do;            /* For varying strings, don't exceed cur string length.   */
1988   dcl  lengthWord fixed bin(24) aligned based(parmP);
1989           varS = T;
1990           sourceL = min(sourceL, lengthWord);
1991           end;
1992 
1993      if sourceL = SizeStar then                             /* Somehow, we have a star-extent.  Just note that fact.  */
1994           out = "[STRING of star extent]";
1995      else do;                                               /* For bit strings, let ioa_ do the conversion.           */
1996           if bit_string_dtype(desc.type) then do;
1997                if mod(sourceL,4) = 0 then do;               /*   - if mod(output_bit_count,4)=0, output hex format.   */
1998                     if varS then
1999                          call ioa_$rsnnl("""^v.4b""b4", out, ioaL, divide(sourceL,4,35,0), bitV);
2000                     else call ioa_$rsnnl("""^v.4b""b4", out, ioaL, divide(sourceL,4,35,0), bitS);
2001                     end;
2002                else if mod(sourceL,3) = 0 then do;          /*   - if mod(output_bit_count,3)=0, output octal format. */
2003                     if varS then
2004                          call ioa_$rsnnl("""^v.3b""b3", out, ioaL, divide(sourceL,3,35,0), bitV);
2005                     else call ioa_$rsnnl("""^v.3b""b3", out, ioaL, divide(sourceL,3,35,0), bitS);
2006                     end;
2007                else do;                                     /*   - otherwise, output a bit string constant.           */
2008                     if varS then
2009                          call ioa_$rsnnl("""^vb""b", out, ioaL, sourceL, bitV);
2010                     else call ioa_$rsnnl("""^vb""b", out, ioaL, sourceL, bitS);
2011                     end;
2012                end;
2013                                                             /* For character strings, let assign copy the string.     */
2014           else call assign_(addr(out), 2*varying_char_dtype, maxlength(out),
2015                     parmP, desc.type*2 + binary(^desc.aligned), sourceL);
2016           end;
2017      go to CONV_return;
2018 
2019 
2020 CONV (CASEpointer):                                         /* For pointers, let ioa_ do the conversion.              */
2021   dcl  my_ptr ptr;
2022      my_ptr = parmToPtrAligned (parmP, desc.aligned);       /* Convert packed ptr parameter to aligned pointer.       */
2023 
2024      call ioa_$rsnnl("^p", out, ioaL, my_ptr);
2025      go to CONV_return;
2026 
2027 
2028 CONV (CASEentry):                                           /* For entry variables, output as a pair of pointers.     */
2029                                                             /*  probe command uses this same format.                  */
2030   dcl  my_ent entry variable based(parmP);                  /* Entry variables always aligned on even-word boundary.  */
2031      call ioa_$rsnnl("^p :: ^p", out, ioaL, codeptr(my_ent), environmentptr(my_ent));
2032      go to CONV_return;
2033 
2034 
2035 CONV (CASEarea):                                            /* For area variables, just report area size.             */
2036      call ioa_$rsnnl("area(^d)", out, ioaL, desc.size);     /*  NOTE: perhaps could call area_info_ here, and report  */
2037      go to CONV_return;                                     /*        on what it finds.  However, this is infrequent  */
2038                                                             /*        data type as a parameter.                       */
2039 
2040 CONV (0):                                                   /* Complain if argCase does not support desc.type.        */
2041      call gripe(call_et_$dtype_unsupported, PROC,           /*   [Earlier tests of dtype should have ruled this out.] */
2042           "Output parameter type (^d) for: dcl parm^d ^a;", desc.type, i, descriptorString(listDescP) );
2043      return;
2044 
2045 
2046 CONV_return:
2047 
2048   dcl  desc_bv bit(36) aligned based(listDescP);
2049   dcl  descOut char(200) var;
2050   dcl  outP char(20) varying;
2051 
2052      if src.ad.given & command then do;                     /* For -addr DECLARATION, given indication that the       */
2053           call ioa_$rsnnl("^p -> ", outP, ioaL, parmP);     /*  output value was pointed to by the parameter.         */
2054           out = outP || out;
2055           end;
2056      if debugOutput then do;                                /* For debug entry, attach octal dump of parameter storage*/
2057           outDump = dump(parmP, desc);                      /*  and set outD to information about parm descriptor.    */
2058           if length(out) + length(outDump) <= MaxLineLen then
2059                out = out || outDump;
2060           else out = out || NL || outDump;
2061           call ioa_$rsnnl("^12.3b  type=^a,^36t packed=^[T^;F^], size/prec=^d^[, scale=^d^;^s^]^[, dimensions=^d^;^s^]",
2062                outD, ioaL, desc_bv,
2063                before(pl1_dtype_name(desc.type), "_dtype"), ^desc.aligned, desc.size,
2064                desc.scale ^= 0, desc.scale,
2065                desc.dimensionsCount ^= 0, desc.dimensionsCount);
2066           end;
2067      else if command & src.xtra = XTRAoctal then do;        /* For non-debug entry, attach octal dump if -octal was   */
2068           outDump = dump(parmP, desc);                      /*  given in arg_value_specification.                     */
2069           if length(out) + length(outDump) <= MaxLineLen then
2070                out = out || outDump;
2071           else out = out || NL || outDump;
2072           end;
2073      if ^debugOutput & command & targ.case = CASEreturnsStar then do;
2074           call ioa_$rsnnl(                                  /* For non-debug entry, attach info about parm descriptor */
2075                                                             /*  for returns(xxx(*)...) parameter.  Callee only set    */
2076                                                             /*  this descriptor during the call.  We've never seen it */
2077                                                             /*  until callee returns to call.                         */
2078                " ^vx desc @ ^p^42t^12.3b  type=^a,^36t packed=^[T^;F^], size/prec=^d^[, scale=^d^;^s^]^[, dimensions=^d^;^s^]",
2079                descOut, ioaL, maxlength(s(parmI).id)-length("desc "), listDescP, desc_bv,
2080                before(pl1_dtype_name(desc.type), "_dtype"), ^desc.aligned, desc.size,
2081                desc.scale ^= 0, desc.scale,
2082                desc.dimensionsCount ^= 0, desc.dimensionsCount);
2083           out = out || NL || descOut;
2084           end;
2085      return;
2086 
2087 
2088 parmToPtrAligned:                                           /* Convert packed pointer parm to aligned pointer.        */
2089      proc(P, isAligned) returns(ptr);
2090 
2091   dcl  P ptr;
2092   dcl  isAligned bit(1) aligned;
2093 
2094   dcl  my_ptr ptr;
2095   dcl  parm_ptr ptr based(P);
2096   dcl  parm_ptr_packed ptr unaligned based(P);
2097 
2098      if isAligned then
2099           return(parm_ptr);
2100      else return(parm_ptr_packed);
2101 
2102      end parmToPtrAligned;
2103 %page;
2104 /* ---------------------------------------- *
2105  * Internal proc of convertOutputArg that   *
2106  * creates octal dump of storage holding a  *
2107  * parameter of a given data type.          *
2108  * ---------------------------------------- */
2109 
2110 dump:
2111      proc(storeP, d) returns(char(1000) varying);
2112 
2113   dcl  storeP ptr;                                          /* ptr to storage to be dumped.                           */
2114   dcl 1 d aligned like target.desc;                         /* decoded descriptor information                         */
2115 
2116   dcl  wordCount fixed bin(24);                             /* length to be dumped (in words)                         */
2117   dcl  dumpRet char(1000) varying;                          /* return string                                          */
2118 
2119   dcl  ignoreCode fixed bin(35);
2120   dcl  maxDumpableWords fixed bin int static options(constant) init(76);
2121   dcl  outPrefix char(5) int static options(constant) init("     ");
2122 
2123   dcl  store (12*wordCount) fixed bin(3) unsigned unaligned based(storeP);
2124                                                             /* Words to dump, as array of 3-bit nibbles (octal digits)*/
2125   dcl  i fixed bin;                                         /* Number digit being dumped.                             */
2126 
2127      call argStorageWords (d.type, d.aligned, d.size, wordCount, ignoreCode);
2128      wordCount = min(wordCount, maxDumpableWords);          /* Descriptor info determines count of words to dump.     */
2129 
2130      dumpRet = outPrefix;
2131      do i = lbound(store,1) to hbound(store,1);
2132           dumpRet = dumpRet || ltrim(char(store(i)));       /* Convert each 3-bit nibble to octal digit.              */
2133           if mod(i,48) = 0 then dumpRet = dumpRet || NL || outPrefix;
2134                                                             /* Start a new line after 4 words of storage.             */
2135           else if mod(i,12) = 0 then dumpRet = dumpRet || " ";
2136                                                             /* Separate each dumped word block.                       */
2137           end;
2138      return (dumpRet);
2139      end dump;
2140 
2141      end convertOutputArg;
2142 %page;
2143 
2144           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
2145           /*                                                                                                */
2146           /* Routine to setup argument handling for the main procedure.  It determines:                     */
2147           /*   invocation type:  command/active function                                                    */
2148           /*   gripe routine:    com_err_ or active_fnc_err_                                                */
2149           /*   argument count                                                                               */
2150           /*   af return arg                                                                                */
2151           /*                                                                                                */
2152           /* It records argListP and argCount for use by argValue and argsRemain routines.                  */
2153           /*                                                                                                */
2154           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
2155 
2156 argSetup:
2157      proc( arg_list, command, af_retP, af_retL, gripe);
2158 
2159   dcl  arg_list ptr;                                        /* ptr to main procedure's argument list.            (in) */
2160   dcl  command bit(1) aligned;                              /* =T for command, =F for active function           (out) */
2161   dcl  af_retP ptr;                                         /* active function return string info.              (out) */
2162   dcl  af_retL fixed bin(21);
2163   dcl  gripe entry options(variable) variable;              /* error reporting routine suited to command-type.  (out) */
2164 
2165   dcl  code fixed bin(35);                                  /* status code                                            */
2166 
2167   dcl  active_fnc_err_ entry options (variable);
2168   dcl  com_err_ entry () options (variable);
2169   dcl  cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr);
2170   dcl  cu_$arg_count_rel entry (fixed bin, ptr, fixed bin(35));
2171 
2172      argListP = arg_list;                                   /* Save arg_list pointer for use in other arg-related fcns*/
2173 
2174      call cu_$af_return_arg_rel (argCount, af_retP, af_retL, code, arg_list);
2175      if code = error_table_$not_act_fnc then do;            /* Get all the data.                                      */
2176           command = T;
2177           gripe = com_err_;
2178           call cu_$arg_count_rel (argCount, arg_list, code);
2179           code = 0;
2180           end;
2181      else do;
2182           command = F;
2183           gripe = active_fnc_err_;
2184           end;
2185 
2186      if code ^= 0 then do;
2187           call gripe (code, PROC, "When getting argument count and invocation method for ^a.", PROC);
2188           go to EXIT_call;
2189           end;
2190 
2191      end argSetup;
2192 
2193 
2194   dcl  argCount fixed bin;                                  /* Count of arguments in call command line.               */
2195   dcl  argI fixed bin init (0);                             /* Index of call argument last examined by code below.    */
2196   dcl  argListP ptr;                                        /* Ptr to our argument list, needed when non-quick proc   */
2197                                                             /*  is used to examine the arguments.                     */
2198   dcl  argValueCount fixed bin init(0);                     /* Count of arg_value_specifiers in command line.         */
2199 
2200 argsRemain:                                                 /* Function to report whether any arguments to call       */
2201      proc () returns (bit (1) aligned);                     /*  remain to be processed.                               */
2202      return (argI < argCount);
2203      end argsRemain;
2204 
2205 argValueGetCount:                                           /* Subroutine to scan all command line arguments,         */
2206      proc (debug);                                          /*  counting the arg_value_specifier arg/option groups.   */
2207 
2208   dcl  debug fixed bin(3) unsigned;
2209 
2210   dcl  argI_saved fixed bin;
2211   dcl  gripe_saved entry variable;
2212   dcl 1 s aligned like source;
2213   dcl 1 o aligned like globalOpt;
2214   dcl  code fixed bin(35);
2215 
2216      if argsRemain() then do;
2217           argI_saved = argI;                                /* Saved position in arg list.                            */
2218           gripe_saved = gripe;                              /* Scan args silently (no errors).                        */
2219           gripe = argValueGetCount;
2220 
2221           call argValue (argValueCount+1, s, o, code);      /* Count arg_value_specifiers.                            */
2222           do while (code ^= error_table_$noarg);
2223                argValueCount = argValueCount + 1;
2224                call argValue (1, s, o, code);
2225                end;
2226 
2227           argI = argI_saved;                                /* Restore saved values.                                  */
2228           gripe = gripe_saved;
2229 
2230           if debug >= 4 then do;                            /* Report if user really wants to know.                   */
2231                call ioa_ ("argValueCount = ^d", argValueCount);
2232                end;
2233           end;
2234 
2235      end argValueGetCount;
2236 
2237 %page;
2238           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
2239           /*                                                                                                */
2240           /* Routine to access positional arguments to call, one by one as they are needed.  It also        */
2241           /* handles:                                                                                       */
2242           /*  - per-positional-arg options, if any follow them;                                             */
2243           /*  - global options that impact overall operation of call.                                       */
2244           /*                                                                                                */
2245           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
2246 
2247 argValue:
2248      proc (n, s, gOpt, code);
2249 
2250   dcl  n fixed bin;                                         /*  positional argument number. (in)                      */
2251   dcl 1 s aligned like source;                              /*  arg_value_specification data (in)                     */
2252   dcl 1 gOpt aligned like globalOpt;                        /*  global options in command line so far. (inout)        */
2253   dcl  code fixed bin (35);                                 /*  status code, reporting missing arg, conversion        */
2254                                                             /*   error, unknown options, etc.                         */
2255 
2256   dcl  arg char(argL) based(argP);                          /*  Next argument in call's argument list.  This may      */
2257   dcl  argFirst char(1) based(argP);                        /*   be an option, or initial value for an argument       */
2258   dcl  argL fixed bin(21);                                  /*   to pass to virtualEntry, or the string               */
2259   dcl  argP ptr;                                            /*   representation virtualEntry, itself.                 */
2260 
2261   dcl (argDcl,                                              /*  Operand following -addr is a string.                  */
2262        argDebug,                                            /*  Operand following -debug is an integer.               */
2263        argID,                                               /*  Operand following -id is an identifier (ID).          */
2264        argInitVal,                                          /*  Operand following -in, -inout is the positional arg.  */
2265        argLen,                                              /*  Operand following -length is an integer or an ID.     */
2266        argMLen   ) bit(1) aligned init(F);                  /*  Operand following -max_length is an integer.          */
2267 
2268   dcl  dirValue fixed bin(3);
2269 
2270   dcl  startedArgValue bit(1) aligned init(F);              /*  Seen -in, -inout, -out, -ignore or non-control yet?   */
2271 
2272      code = 0;
2273 
2274   dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr);
2275 
2276      do while (argsRemain());
2277           call cu_$arg_ptr_rel (argI+1, argP, argL, code, argListP);
2278                                                             /* Conditionally read next argument to call command/af.   */
2279 
2280           /* process operands of control arguments. */
2281           if argInitVal then do;                            /* Operand following -in or -inout                        */
2282                argInitVal = F;
2283                s.argP = argP; s.argL = argL;                /* Arg is the next positional arg (an initial value)      */
2284                end;
2285 
2286           else if argDcl then do;                           /* Operand following -dcl or -addr                        */
2287                argDcl = F;
2288                if  length(arg) > maxlength(s.dcl) & gripe ^= argValueGetCount  then do;
2289                     call gripe (error_table_$bigarg, PROC,
2290                          "Maximum declaration length (^d) exceeded: -addr ^a", maxlength(s.dcl), arg);
2291                     go to ERROR_argValue;
2292                     end;
2293                s.dcl = arg;
2294                end;
2295 
2296           else if argID then do;                            /* Operand following -id                                  */
2297                argID = F;
2298                call argNotID_Error(arg);                    /*   Report an error for an invalid ID operand.           */
2299                s.id = arg;
2300                end;
2301 
2302           else if argLen & argIsID(arg) then do;            /* Operand following -length looked like an ID            */
2303                argLen = F;
2304                s.L = Lunset;
2305                s.L_id = arg;
2306                end;
2307 
2308           else if argLen | argMLen then do;                 /* Operand for -length or -max_length                     */
2309 
2310   dcl  lengthVar fixed bin(24) aligned based(lengthP);
2311   dcl  lengthP ptr;
2312   dcl  option char(11) var;
2313 
2314                if argLen then do;  argLen  = F;  lengthP = addr(s.L);  option = "-length";      s.L_id = "";  end;
2315                else           do;  argMLen = F;  lengthP = addr(s.M);  option = "-max_length";                end;
2316 
2317                call assign(arg, F, lengthP, FIXED_BIN, ALIGNED, 24, 0, code);
2318                if  code ^= 0 & gripe ^= argValueGetCount  then do;
2319                     call gripe(error_table_$bad_conversion, PROC, "^a ^a", option, arg);
2320                     go to ERROR_argValue;
2321                     end;
2322                else if  lengthVar < 0 & gripe ^= argValueGetCount  then do;
2323                     call gripe(error_table_$bad_conversion, PROC,
2324                          "Option value must be non-negative: ^a ^a", option, arg);
2325                     go to ERROR_argValue;
2326                     end;
2327                end;
2328 
2329           else if argDebug then do;                         /* Operand for global option: -debug                      */
2330                argDebug = F;
2331                call assign(arg, F, addr(gOpt.debug), FIXED_BIN_UNS, ALIGNED, 3, 0, code);
2332                if  code ^= 0 & gripe ^= argValueGetCount  then do;
2333                     call gripe(error_table_$bad_conversion, PROC, "-debug ^a", arg);
2334                     go to ERROR_argValue;
2335                     end;
2336                else if  gOpt.debug > 5 & gripe ^= argValueGetCount  then do;
2337                     call gripe(error_table_$bad_conversion, PROC, "Option value is an INT in range 0-5: -debug ^a", arg);
2338                     go to ERROR_argValue;
2339                     end;
2340                end;
2341 
2342           /* Global options */
2343           else if arg = "-debug" | arg = "-db" then argDebug = T;
2344           else if arg = "-octal" | arg = "-oc" then s.xtra = XTRAoctal;
2345           else if arg = "-all"   | arg = "-a"  then s.xtra = XTRAall;
2346 
2347           /* arg_value directions (or direction-related options) */
2348           else if argValueStarter(arg, dirValue) then do;
2349                if startedArgValue then go to EXIT_argValue; /* Argument starts next argValue; so exit this loop.      */
2350                go to ARG_VALUE_DIR(dirValue);
2351 
2352 ARG_VALUE_DIR(DIRunset):                                    /*  Arg is the next positional arg (an initial value)     */
2353                s.argP = argP; s.argL = argL;        go to ARG_VALUE_DIR_end;
2354 
2355 ARG_VALUE_DIR(DIRin):
2356 ARG_VALUE_DIR(DIRinout):
2357                s.dir = dirValue;   argInitVal = T;  go to ARG_VALUE_DIR_end;
2358 
2359 ARG_VALUE_DIR(DIRout):
2360 ARG_VALUE_DIR(DIRignore):
2361                s.dir = dirValue;                    go to ARG_VALUE_DIR_end;
2362 
2363 ARG_VALUE_DIR_end:
2364                startedArgValue = T;
2365                end;
2366 
2367           /* arg_value options */
2368           else if startedArgValue then do;
2369                     if argIsFMT (arg, s) then;
2370                else if arg = "-id"                         then   argID   = T;
2371                else if arg = "-return"     | arg = "-ret"  then   s.ret   = T;
2372                else if arg = "-length"     | arg = "-ln"   then   argLen  = T;
2373                else if arg = "-max_length" | arg = "-ml"   then   argMLen = T;
2374                else if arg = "-declare"    | arg = "-dcl"  then   do;  s.meta  = METAdcl;   argDcl  = T;  end;
2375                else if arg = "-addr"                       then   do;  s.meta  = METAaddr;  argDcl  = T;  end;
2376                else call gripe (error_table_$badopt, PROC, "Ignoring unsupported option: ^a", arg);
2377                end;
2378           else call gripe (error_table_$inconsistent, PROC, "Must start an arg_value before using: ^a", arg);
2379 
2380           argI = argI + 1;                                  /* Count as processed the arg just examined above.        */
2381           end;
2382 
2383 EXIT_argValue:
2384      code = error_table_$noarg;                             /* Missing arg error, if any condition below is met.      */
2385 
2386      /* Exhausted arg_list without finding operand for one of our control args. */
2387      if argDebug then
2388           call gripe (code, PROC, "-debug operand is an integer between 0 and 5.");
2389      else if argLen then
2390           call gripe (code, PROC, "-length operand is a non-negative integer or ID of another argument.");
2391      else if argMLen then
2392           call gripe (code, PROC, "-max_length operand is a non-negative integer.");
2393      else if argID then
2394           call gripe (code, PROC, "-id operand is a PL/I identifier.");
2395      else if argDcl then
2396           call gripe (code, PROC, "^a operand is a scalar PL/I declaration.", META.name(s.meta));
2397 
2398      /* Exhausted arg_list without finding an arg_value => error; otherwise, no error */
2399      else if startedArgValue then
2400           code = 0;
2401 
2402 
2403 ERROR_argValue:
2404      if gOpt.debug >= 5 then do;                            /* Debug code.                                            */
2405 
2406   dcl  src char(s.argL) based(s.argP);
2407 
2408           call ioa_$nnl ("^[-- ^;    ^]^21a^[ ^;^] ^[^;-in ^;-inout ^;-out ^;-ignore ^]^[^a ^;^s^]^[^;-octal ^]",
2409                n=0, s.id || ":", n=0, s.dir+1, length(src)>0, src, s.xtra+1);
2410           if n = 0 & gOpt.debug > 0 then
2411                call ioa_$nnl ("-debug ^d ", gOpt.debug);
2412           call ioa_ ("^[^s^;-dcl ""^a"" ^;-addr ""^a"" ^]^[^;-code ^;-date ^;-time ^;-date_time ^]^[-max_length ^d ^;^s^]^[-length ^d ^;^s^]^[-return ^;^]",
2413                s.meta+1, s.dcl, s.fmt+1, s.M>0, s.M, s.L>0, s.L, s.ret);
2414           end;
2415      return;
2416 %page;
2417 
2418 argValueStarter:                                            /* Returns T if argument starts a new arg_value_spec      */
2419           proc (arg, dirValue) returns (bit(1) aligned);
2420 
2421   dcl  arg char(*);
2422   dcl  dirValue fixed bin(3);
2423 
2424   dcl  argFirst char(1) defined(arg);
2425 
2426   dcl  NUMERIC char(17) int static options(constant) init("+-.0123456789efEF");
2427 
2428           if  length(arg) = 0  then do;                     /* Null char string is a valid input value.               */
2429 STARTER:       dirValue = DIRunset;  return(T);  end;
2430 
2431           if  argFirst ^= "-" | arg = NULL_POINTER  then  go to STARTER;
2432                                                             /* Any string not a -control_arg or null() pointer is     */
2433                                                             /*  a valid input value.                                  */
2434           if  verify(arg,NUMERIC) = 0               then  go to STARTER;
2435                                                             /* Any negative number is a valid input value.            */
2436           if  oct_or_hex_source(arg, ""b)           then  go to STARTER;
2437                                                             /* Any octal/hex bit representation starts arg_value      */
2438           dirValue = isMember (arg, DIR.tiny);              /* Of course, DIR values (-in, -out, ...) start an        */
2439           if  dirValue > -1  then return(T);                /*  arg_value_specification.                              */
2440 
2441           dirValue = isMember (arg, DIR.abbr);
2442           if  dirValue > -1  then return(T);
2443 
2444           dirValue = isMember (arg, DIR.name);
2445           if  dirValue > -1  then return(T);
2446 
2447           return(F);                                        /* Anything else does not start an arg_value_spec.        */
2448 
2449 
2450 argIsFMT: entry (arg, s) returns (bit(1) aligned);          /* Returns T if argument is one of the FMT strings        */
2451 
2452   dcl 1 s aligned like source;                              /*  arg_value_specification data (in)                     */
2453   dcl  fmtValue fixed bin(3);
2454 
2455           if argFirst ^= "-" then return(F);
2456 
2457           fmtValue = isMember (arg, FMT.name);
2458           if  fmtValue > FMTunset then do;
2459 FMT_yes:       s.fmt = fmtValue;
2460                return(T);
2461                end;
2462 
2463           fmtValue = isMember (arg, FMT.abbr);
2464           if  fmtValue > FMTunset then go to FMT_yes;
2465           return(F);
2466 
2467 
2468 argNotID_Error:                                             /* Complains and exit argValue if -id ID has bad format.  */
2469           entry (arg);
2470 
2471   dcl  IDENTIFIER char(64) int static options(constant) init("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_$");
2472   dcl  IDENTIFIERfirst char(52) int static options(constant) init("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz");
2473 
2474           if length(arg) < 1 then do;
2475                if gripe ^= argValueGetCount then do;
2476                     call gripe (error_table_$smallarg, PROC, "Empty identifier follows: -id");
2477                     go to ERROR_argValue;
2478                     end;
2479                else return;
2480                end;
2481           if  length(arg) > maxlength(s.id) & gripe ^= argValueGetCount  then do;
2482                call gripe (error_table_$bigarg, PROC,
2483                     "Maximum identifier length (^d) exceeded: -id ^a", maxlength(s.id), arg);
2484                go to ERROR_argValue;
2485                end;
2486           if (verify(argFirst, IDENTIFIERfirst) ^= 0) | (verify(arg, IDENTIFIER) ^= 0) then do;
2487                if gripe ^= argValueGetCount then do;
2488                     call gripe (error_table_$badopt, PROC, "-id ^a is not a PL/I identifier.
2489 <identifier> ::= <letter>[<letter>|<digit>|_|$]...", arg);
2490                     go to ERROR_argValue;
2491                     end;
2492                end;
2493           return;
2494 
2495 
2496 argIsID:  entry (arg) returns (bit(1) aligned);             /* Returns T if arg has ID format                         */
2497 
2498           if length(arg) < 1 then return(F);
2499           if length(arg) > maxlength(s.id) then return(F);
2500           if (verify(argFirst, IDENTIFIERfirst) ^= 0) | (verify(arg, IDENTIFIER) ^= 0) then return(F);
2501           return(T);
2502 
2503           end argValueStarter;
2504 
2505 
2506 isMember: proc (item, array) returns(fixed bin);            /* Returns T if item is a member of string array.         */
2507 
2508   dcl  item  char(*);
2509   dcl  array (*) char(*) var;
2510 
2511   dcl  i fixed bin;
2512           do i = lbound(array,1) to hbound(array,1);
2513                if item = array(i) then return(i);
2514                end;
2515           return(-1);
2516 
2517           end isMember;
2518 
2519      end argValue;
2520 %page;
2521 /* ------------------------------------------------------------------- *
2522  * Convert argument descriptor to a string of PL/I data attributes.    *
2523  * ------------------------------------------------------------------- */
2524 
2525 descriptorString:                                           /* Returns character string declaration corresponding to  */
2526      proc (descP) returns (char (100) var);                 /*  an argument descriptor.                               */
2527 
2528   dcl  descP ptr aligned;
2529 
2530   dcl  desc bit(36) aligned based(descP);
2531 
2532   dcl  code fixed bin(35);
2533   dcl  ret char(2000) var;
2534 
2535   dcl  get_pl1_parm_desc_string_ entry (ptr, char(*) var, fixed bin(35));
2536 
2537      ret = "";
2538      call get_pl1_parm_desc_string_ (descP, ret, code);
2539      if code ^= 0 then
2540           call gripe (code, PROC, "Error converting descriptor to string: ^.3b", desc);
2541      if length(ret) > 100 then
2542           call gripe (code, PROC, "Long descriptor string shortened to 100 chars: ^a", ret);
2543      return (ret);
2544 
2545      end descriptorString;
2546 
2547 int2digits:                                                 /* Converts an int to a 2-digit (or longer) string        */
2548      proc (int) returns(char(8) var);
2549 
2550   dcl  int fixed bin;
2551   dcl  digits char(8) var;
2552 
2553      if int < 10 then
2554           digits = "0";
2555      else digits = "";
2556      digits = digits || ltrim(char(int));
2557 
2558      return (digits);
2559 
2560      end int2digits;
2561 %page;
2562 
2563           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
2564           /*                                                                                                */
2565           /* Include files used by call.                                                                    */
2566           /*   NB: A few include files define constants that are used to initialize declared constants.     */
2567           /*       These include files must appear before those declarations, and are therefore near the    */
2568           /*       top of call.pl1.  Most of the include files are shown below.                             */
2569           /*                                                                                                */
2570           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
2571 
2572 %page;
2573 %include translator_temp_alloc;
2574 %page;
2575 %include area_info;
2576 %page;
2577 %include arg_list;
2578 %page;
2579 %include arg_descriptor;
2580 %page;
2581 %include call_entry_info_;
2582 %page;
2583 %include encoded_precision;
2584 %page;
2585 %include system;
2586 %page;
2587 %include call_dtype_fcns;
2588      end call;