1 /* ***********************************************************
   2    *                                                         *
   3    *                                                         *
   4    * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   5    *                                                         *
   6    *                                                         *
   7    *********************************************************** */
   8 
   9 /* ******************************************************
  10    *                                                    *
  11    *                                                    *
  12    * Copyright (c) 1972 by Massachusetts Institute of   *
  13    * Technology and Honeywell Information Systems, Inc. *
  14    *                                                    *
  15    *                                                    *
  16    ****************************************************** */
  17 
  18 /* DESCRIPTION:
  19 
  20                           BEGIN_DESCRIPTION
  21    This procedure provides a command interface to the Multics Relational Data Store (MRDS)
  22    Data Sub Language (DSL).  This interface is not intended to be a true End User Facility, but
  23    rather is intended to  be used as an instructional tool when introducing new users to the
  24    MRDS.  Also, mrds_call will be useful to data base application programmers as an experimental
  25    vehicle during the development of MRDS application programs.
  26                            END_DESCRIPTION
  27 */
  28 
  29 /* PARAMETERS:
  30 
  31    operation - - (input) the first argument corresponding to the dsl routine
  32    to be called from command level, such as "open" for mrds_dsl_open
  33 
  34    operation_args - - (input) the second and succeeding arguments, this varies
  35    depending on the operation called, for example "ready_file database_index file_name file_ready_mode"
  36    are the arguments needed for ready_file
  37    most mrds_call operations and their arguments are documented in the MRDS manual AW53
  38 
  39    (output) error messages, ready/open lists, and terminal output of
  40    command results, such as tuples returned by retrieve
  41 */
  42 
  43 mrds_call: mrc: proc;
  44 ^L
  45 /* HISTORY:
  46 
  47    76-08-01 J. A. Weeldreyer: Initially written.
  48 
  49    76-10-01  J.  A.  Weeldreyer:  Modified  to  fix  arg.  aquisition  problem   in
  50    define_temp_rel operation.
  51 
  52    77-09-01 O. D. Friesen and J. A. Weeldreyer: Modified for MR6.0.
  53 
  54    79-07-01 Jim Gray: Modified to  1)  correct  MR7  version  of  list_dbs  2)  add
  55    list_files   operation,   and  incorporate  in  ready_file  3)  improve  integer
  56    conversion error messages  4)  add  set_modes  operation  with  list  and  error
  57    suboperations 5) add the "-all" option to the close, ready_file, and finish_file
  58    operations 6) add operations listing to the "no operation given  error"  7)  put
  59    work area in temp segment, instead of system_free_
  60 
  61    80-01-01 Mary Ward: Modified to eliminate ready_file,  finish_file,  list_files,
  62    set_fscope,  set_fscope_all,  dl_fscope,  and  dl_fscope_all, to require the old
  63    open syntax, and to improve error messages.
  64 
  65    80-06-01 Jim Gray: Modified  to  change  method  of  remembering  open  database
  66    pathnames and opening modes to accommadate new opening order.
  67 
  68    80-12-08 Rickie E. Brinegar: Use of the internal variable mode_list removed  and
  69    replaced  with the new mrds_dbs_modes_list.incl.pl1 structures. At the same time
  70    val_str and hd_str were replaced with control strings in the ioa_ calls.
  71 
  72    80-12-11 Jim Gray : added use of mrds_new_scope_modes include file in process of
  73    changing  from  old  r-u to r-s-m-d type scope modes. Now a is acceptable for s,
  74    and u now means a+d+m, but with an integer conversion of 14, not 2.
  75 
  76    80-12-12 Jim Gray : Changed declaration of wait_time to fixed bin(35)  from  71,
  77    the  fact  that mrds_dsl_set_scope expects a fb35 was causing 0 wait times to be
  78    sent by mrds_call, because the upper (zero) part of  a  fb71  number  was  being
  79    sent.
  80 
  81    81-1-12 Jim Gray : added get_scope function to interface to dsl_$get_scope.
  82 
  83    81-01-30  Jim  Gray  :   added   get_population   function   to   interface   to
  84    mrds_dsl_define_temp_rel$get_temp_rel_population.  The  routine  for  permantent
  85    relations  is  not  yet  available.  It  will  be  part  of  a  common   routine
  86    dsl_$get_population.
  87 
  88    81-01-30  Jim  Gray  :  changed  open  database  listing  routine  called   from
  89    mrds_dsl_lsit_dbs$list_dbs_with_modes  to  mrds_dsl_db_openings$list_openings to
  90    take advantage of the improved interface.
  91 
  92    81-03-25 Jim Gray : extended get_population to call general  dsl_$get_population
  93    routine that handles perm rels as well as temp rels.
  94 
  95    81-07-19 Jim Gray :  added  a  new  set_modes  option  no_retrieve_output/nro  -
  96    retreieve_output/ro that turns the output of values from retrieve off and on. If
  97    the output values are turned off, then -all is forced, and a  number  of  tuples
  98    retrieved  is  returned instead. Also deleted all commented out code, as removal
  99    of blocked file stuff makes it unuseable.
 100 
 101    81-09-22 Davids: added code to set the  num_ptrs  variable  right
 102    after  a  pointer to the arg_list is obtained. Also added code in
 103    build_arg_list to make sure that the value of num_ptrs is the max
 104    of  the  number  of  pointers in the arg_list that mrc was called
 105    with and the arg_list that is generated to call the  dsl_  entry.
 106    See the comment in build_arg_list
 107 
 108    82-06-14 Mike Kubicar : Rewrote the dashed argument parser for retrieve
 109    to work the way the manual desribes it.  This fixes TR phx12237.
 110 
 111 */
 112 ^L
 113 /* initialize */
 114 
 115           a_ptr, filen_ptr,
 116                num_ptr,
 117                mode_ptr,
 118                pm_ptr,
 119                pv_ptr,
 120                se_ptr,
 121                rmode_ptr,
 122                val_ptr = null;
 123           code = 0;
 124           ready_cnt = 0;
 125           on cleanup call cleanup_proc;
 126           on arg_err_ call arg_err_hndlr;
 127           if area_initialized then ;
 128           else do;
 129                     call get_temp_segment_ ("mrds_call", wa_ptr, code);
 130                     if code ^= 0 then do;
 131                               call com_err_ (code, MRC, "Creating temp segment");
 132                               go to Exit;
 133                          end;
 134                     wa_ptr -> work_area = empty ();
 135                     area_initialized = ON;
 136                end;
 137 
 138           call cu_$arg_list_ptr (al_ptr);
 139           num_ptrs = arg_list.arg_count;                    /* CHANGE 81-09-22 ********** */
 140           nargs = divide (arg_list.arg_count, 2, 17);
 141 
 142           on sub_error_
 143                begin;
 144                     if ^error_display_flag then ;           /* ignore, dont print extra info */
 145                     else call continue_to_signal_ (handler_found_code);
 146                end;
 147 
 148           call cu_$arg_ptr (1, f_ptr, f_len, code);         /* get operation name */
 149 
 150           if code ^= 0 then do;                             /* nothing there */
 151                     call com_err_ (code, MRC, " Usage: mrc opname {args} {control_args}.");
 152                     if error_display_flag                   /* if more info desired */
 153                     then call com_err_ (0, MRC, "Valid opnames: ^/^- ^a,^/^- ^a,^/^- ^a,^/^- ^a",
 154                               "open, o, close, c, store, s, modify, m, delete, d, retrieve, r",
 155                               "list_dbs, ld, set_scope, ss, set_scope_all, ssa, set_modes, sm",
 156                               "dl_scope, ds, dl_scope_all, dsa, define_temp_rel, dtr",
 157                               "get_scope, gs, get_population, gp, declare, dcl");
 158                end;
 159 ^L
 160           else if operation = "o" | operation = "open" then do;
 161 
 162                     call open_old_ver;
 163 
 164 /* if nargs >= 3 then do;
 165    call cu_$arg_ptr (3, arg_ptr, arg_len, code); ** is mode present? **
 166    if code ^= 0 then
 167    call error (code, "open");
 168    do i = 1 to 8
 169    while (arg ^= ms_array (i));
 170    end;
 171    end;
 172    if i > 8 | nargs < 3 then
 173    call open_new_ver;
 174    else call open_old_ver;
 175    */
 176 
 177                     al_ptr = a_ptr;
 178                     nargs = divide (arg_list.arg_count, 2, 17);
 179                     arg_list.arg_des_ptr (nargs) = addr (code);
 180                     arg_list.arg_des_ptr (nargs + desc_off_o) = addr (fb_35_desc);
 181 
 182                     call cu_$generate_call (mrds_dsl_open$open, al_ptr);
 183 
 184                     if code ^= 0 then do;
 185                               call com_err_ (code, MRC, "(From dsl_$open)");
 186                               go to Exit;
 187                          end;
 188 
 189                     free temp_mode_list in (work_area);
 190                     tml_ptr = null ();
 191 
 192                     if list_display_flag
 193                     then call print_dbi;                    /* tell user what he did */
 194 
 195                     free arg_list in (work_area);
 196                     free num in (work_area);
 197                     free mode in (work_area);
 198                end;                                         /* open */
 199 ^L
 200           else if operation = "c" | operation = "close" then do;
 201                     if nargs < 2                            /* not enough */
 202                     then call com_err_ (error_table_$wrong_no_of_args, MRC,
 203                               "^/^- Usage: mrc close [dbi1 {... dbiN} | -all]"); /* give user hint */
 204                     else do;
 205                               call cu_$arg_ptr (2, arg_ptr, arg_len, code); /* get 1st arg to close */
 206 
 207                               if code ^= 0                  /* should never happen */
 208                               then call com_err_ (code, MRC, "Getting second argument");
 209 
 210                               else if arg = "-all" | arg = "-a" then do;
 211                                         call mrds_dsl_close_all (code); /* go doit toit */
 212                                         call free_open_lists; /* free work space */
 213                                         if code ^= 0        /* now put out error, if any */
 214                                         then call com_err_ (code, MRC, "(From dsl_$close_all)");
 215                                    end;
 216 
 217                               else do;
 218                                         on conversion begin;/* for certain argument errors */
 219                                                   if a_ptr ^= null then free a_ptr -> arg_list in (work_area);
 220                                                   if num_ptr ^= null then free num in (work_area);
 221                                                   call com_err_ (0, MRC, "No data bases closed"); /* tell user no go */
 222                                                   goto Exit;
 223                                              end;
 224 
 225                                         call build_arg_list (nargs);
 226 
 227                                         open_cnt = nargs - 1;
 228                                         allocate num in (work_area);
 229 
 230                                         do i = 2 to nargs;
 231                                              num (i - 1) = conv_int (i, DBI);
 232                                              a_ptr -> arg_list.arg_des_ptr (i - 1) = addr (num (i - 1));
 233                                              a_ptr -> arg_list.arg_des_ptr (desc_off_o + i - 1) = addr (fb_35_desc);
 234                                         end;
 235 
 236 
 237                                         al_ptr = a_ptr;
 238                                         arg_list.arg_des_ptr (nargs) = addr (code);
 239                                         arg_list.arg_des_ptr (nargs + desc_off_o) = addr (fb_35_desc);
 240 
 241                                         call cu_$generate_call (mrds_dsl_close$close, al_ptr);
 242 
 243                                         free arg_list in (work_area);
 244                                         free num in (work_area);
 245 
 246                                         call mrds_dsl_db_openings$list_dbs (wa_ptr, database_list_ptr);
 247                                         if database_list_ptr = null () then
 248                                              call free_open_lists (); /* get rid of temp seg */
 249                                         else free database_list in (work_area);
 250 
 251                                         if code ^= 0        /* give out errors, if any */
 252                                         then call com_err_ (code, MRC, "(From dsl_$close)");
 253                                    end;
 254                          end;
 255                end;                                         /* close */
 256 ^L
 257           else if operation = "ld" | operation = "list_dbs" then
 258                call print_dbi;
 259 
 260 
 261           else if operation = "s" | operation = "store" then
 262                call call_mod_fun (mrds_dsl_store$store, 3);
 263 
 264 
 265           else if operation = "d" | operation = "delete" | operation = "dl" then
 266                call call_mod_fun (mrds_dsl_delete$delete, 1);
 267 
 268 
 269           else if operation = "m" | operation = "modify" then
 270                call call_mod_fun (mrds_dsl_modify$modify, 2);
 271 
 272 
 273           else if operation = "set_modes" | operation = "sm" then do;
 274                     if nargs < 2 then
 275                          call com_err_ (error_table_$wrong_no_of_args, MRC,
 276                               "^/^- Usage: mrc set_modes {list | no_list} {long_err | short_err}");
 277                     else do;
 278                               do arg_cnt = 2 by 1 to nargs;
 279 
 280                                    call cu_$arg_ptr (arg_cnt, mrc_mode_ptr, mrc_mode_len, code);
 281                                    if code ^= 0 then
 282                                         call com_err_ (code, MRC, "Getting mode argument.");
 283                                    else do;
 284 
 285                                              if mrc_mode = "no_list" then
 286                                                   list_display_flag = OFF;
 287                                              else if mrc_mode = "list" then
 288                                                   list_display_flag = ON;
 289                                              else if mrc_mode = "long_err" then
 290                                                   error_display_flag = ON;
 291                                              else if mrc_mode = "short_err" then
 292                                                   error_display_flag = OFF;
 293 
 294 /* BEGIN CHANGE 81-07-19 ******************************************** */
 295 
 296                                              else if mrc_mode = "no_retrieve_output" | mrc_mode = "nro" then
 297                                                   no_output_mode = ON;
 298                                              else if mrc_mode = "retrieve_output" | mrc_mode = "ro" then
 299                                                   no_output_mode = "0"b;
 300 
 301 /* END CHANGE 81-07-19 ************************************************ */
 302 
 303                                              else call com_err_ (error_table_$bad_arg, MRC, "Invalid mode ^a.", mrc_mode);
 304                                         end;
 305                               end;
 306                          end;
 307                end;
 308 ^L
 309           else if operation = "r" | operation = "retrieve" then do;
 310 
 311                     if nargs < 4
 312                     then call com_err_ (error_table_$wrong_no_of_args, MRC,
 313                               "^/^- Usage: mrc retrieve nvals dbi ^/^2-{selection_expression} {se_values} {-segment path} {-all}");
 314                     else do;
 315                               n_vals = conv_int (2, NVALS);
 316                               dbi = conv_int (3, DBI);
 317                               se_seg_sw = 0;                /* init switches */
 318                               all_sw = "0"b;
 319                               done_scanning = "0"b;
 320                               current_arg = nargs;
 321                               se_path = "";
 322 
 323 /*
 324 *
 325 *  Now check for the possible command argument (all two of them).  They
 326 *  (by the command definition) must appear as the last two control arguments
 327 *  in the command line.  So, we just start at the end and scan backwords.
 328 *  We check for -all, which is a single arg, or -sm which has to be two.
 329 *  If we find the wrong thing or both -all and -sm, we assume we're done
 330 *  and look no farther.  Thus, it is quite possible to have command lines of
 331 *  the form:
 332 *
 333 * mrc retrieve 4 1 a b c d -all -all -sm foo -sm foo.input -all
 334 *
 335 *  since scanning for arguments will stop when it sees -sm foo.input -all.
 336 *  This allows arbitrary and random things to be given for selection
 337 *  expression values.
 338 *
 339 */
 340 
 341                               do while (^done_scanning);
 342                                    call cu_$arg_ptr (current_arg, arg_ptr,
 343                                         arg_len, code);
 344                                    if code ^= 0 then do;
 345                                              call com_err_ (code, MRC,
 346                                                   "^/Could not get command argument.");
 347                                              go to Exit;
 348                                         end;
 349                                    if ^all_sw & ((arg = "-all") | (arg = "-a")) /* All is easy, it's a single arg */
 350                                    then if (se_seg_sw = 0) & se_path ^= "" /* Make sure we're not in the middle of a -segment argument */
 351                                         then done_scanning = "1"b; /* Impossible arg combination, must be se values */
 352                                         else do;            /* Saw a legal -all */
 353                                                   all_sw = "1"b;
 354                                                   nargs = nargs - 1;
 355                                                   done_scanning = all_sw & (se_seg_sw ^= 0);
 356                                              end;
 357                                    else if (se_seg_sw = 0) &
 358                                              ((arg = "-segment") | (arg = "-sm"))
 359                                    then if se_path = "" then do; /* Must have seen pathname */
 360                                                   call com_err_ (error_table_$noarg,
 361                                                        MRC, "^/A pathname must be given with the ^a argument.", arg);
 362                                                   go to Exit;
 363                                              end;
 364                                         else do;            /* Valid -segment arg */
 365                                                   se_seg_sw = 1;
 366                                                   call get_se (sea_ptr, sed_ptr);
 367                                                   nargs = nargs - 1;
 368                                                   done_scanning = all_sw;
 369                                              end;
 370                                    else if se_path ^= ""    /* End of arg scanning? */
 371                                    then done_scanning = "1"b; /* Yes, two non-recognized args in a row */
 372                                    else do;                 /* Assume it's an se_path */
 373                                              if length (arg) > length (se_path) then do;
 374                                                        se_path = substr (arg, 1, length (se_path));
 375                                                        se_len = length (se_path);
 376                                                   end;
 377                                              else do;
 378                                                        se_path = arg;
 379                                                        se_len = arg_len;
 380                                                   end;
 381                                         end;
 382                                    current_arg = current_arg - 1;
 383                               end;
 384 
 385                               call build_arg_list (nargs + n_vals - 1);
 386                               allocate values in (work_area);
 387 
 388                               if se_seg_sw > 0 then do;     /* if seg se. move in arg and desc. ptrs */
 389                                         a_ptr -> arg_list.arg_des_ptr (2) = sea_ptr;
 390                                         a_ptr -> arg_list.arg_des_ptr (desc_off_o + 2) = sed_ptr;
 391                                    end;
 392 
 393                               do i = 2 to nargs - 2 - se_seg_sw;
 394                                    a_ptr -> arg_list.arg_des_ptr (i + se_seg_sw) = arg_list.arg_des_ptr (i + 2);
 395                                    a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + se_seg_sw) =
 396                                         true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + i + 2));
 397                               end;
 398 
 399                               al_ptr = a_ptr;
 400                               arg_list.arg_des_ptr (1) = addr (dbi);
 401                               arg_list.arg_des_ptr (nargs + n_vals - 1) = addr (code);
 402                               arg_list.arg_des_ptr (desc_off_o + 1),
 403                                    arg_list.arg_des_ptr (desc_off_o + nargs + n_vals - 1) = addr (fb_35_desc);
 404 
 405                               do i = nargs - 1 to nargs + n_vals - 2;
 406                                    arg_list.arg_des_ptr (i) = addr (values (i - nargs + 2));
 407                                    arg_list.arg_des_ptr (i + desc_off_o) = addr (char_desc);
 408                               end;
 409 
 410                               call cu_$generate_call (mrds_dsl_retrieve$retrieve, al_ptr);
 411 
 412                               if code ^= 0 then do;
 413                                         call retr_cleanup;
 414                                         call com_err_ (code, MRC, "(From dsl_$retrieve)");
 415                                         go to Exit;
 416                                    end;
 417 
 418 /* BEGIN CHANGE 81-07-19 ******************************************** */
 419 
 420                               if ^no_output_mode then do;
 421                                         call ioa_ ("^/Value^[ is^;s are^]:^/", (n_vals = 1));
 422 
 423                                         do i = 1 to n_vals;
 424                                              call ioa_ ("^a", values (i));
 425                                         end;
 426                                    end;
 427                               else do;
 428 
 429 /* for no_retrieve_output mode, force -all,
 430    and just prepare a count of the tuples retrieved */
 431 
 432                                         tuples_retrieved = 1;
 433                                         all_sw = "1"b;
 434                                    end;
 435 
 436                               if all_sw then do;            /* if auto anothers */
 437                                         arg_list.arg_des_ptr (2) = addr (anoth_str); /* change select. expr. to -another */
 438                                         arg_list.arg_des_ptr (desc_off_o + 2) = addr (anoth_desc);
 439 
 440                                         do while (code = 0);/* for as long as we find something */
 441 
 442                                              call cu_$generate_call (mrds_dsl_retrieve$retrieve, al_ptr); /* $retrieve (-another) */
 443 
 444                                              if code = 0 then do; /* if got something */
 445                                                        tuples_retrieved = tuples_retrieved + 1;
 446                                                        if ^no_output_mode then do;
 447                                                                  call ioa_ ("^/******^/"); /* write separator */
 448                                                                  do i = 1 to n_vals; /* write out all found values */
 449                                                                       call ioa_ ("^a", values (i));
 450                                                                  end;
 451                                                             end;
 452                                                   end;
 453                                         end;
 454                                         if code = mrds_error_$tuple_not_found then do;
 455                                                   if no_output_mode then
 456                                                        call ioa_ ("^/Tuples retrieved:  ^d^/", tuples_retrieved);
 457                                                   else call ioa_ ("^/(END)^/"); /* let user know at end */
 458                                              end;
 459                                         else call com_err_ (code, MRC, "(From dsl_$retrieve)"); /* otherwise give error */
 460                                    end;                     /* if auto anothers */
 461 
 462 /* END CHANGE 81-07-19 **************************************************** */
 463 
 464 
 465                               else call ioa_ ("^/");
 466                               call retr_cleanup;
 467 
 468 retr_cleanup: procedure;
 469           free arg_list in (work_area);
 470           free values in (work_area);
 471      end retr_cleanup;
 472 
 473                          end;                               /* retrieve */
 474                end;
 475 ^L
 476           else if operation = "dtr" | operation = "define_temp_rel" then do;
 477                     if nargs < 4 then do;                   /* not enough */
 478                               call com_err_ (error_table_$wrong_no_of_args, MRC,
 479                                    "^/^- Usage: mrc define_temp_rel dbi ^/^2-^a^/^2-^a",
 480                                    "[selection_expression {se_values} rel_index",
 481                                    "| rel_index -sm path]");
 482                               go to Exit;
 483                          end;
 484 
 485                     dbi = conv_int (2, DBI);
 486 
 487                     call cu_$arg_ptr (nargs - 1, arg_ptr, arg_len, code); /* see if separate sel. expr. */
 488 
 489                     if code ^= 0 then do;
 490                               call com_err_ (code, MRC, "Getting argument ^i", nargs - 1);
 491                               go to Exit;
 492                          end;
 493                     if arg = "-sm" | arg = "-segment" then do; /* if separate */
 494                               call cu_$arg_ptr (nargs, arg_ptr, arg_len, code); /* get path */
 495                               if code ^= 0 then do;
 496                                         call com_err_ (code, MRC, "Pathname for -segment");
 497                                         go to Exit;
 498                                    end;
 499 
 500                               se_path = arg;
 501                               se_len = arg_len;
 502                               call get_se (sea_ptr, sed_ptr); /* init and set ptrs for sel. expr. */
 503                               nargs = nargs - 1;            /* dont look at ctl arg again */
 504                               se_seg_sw = 1;                /* remember */
 505                          end;
 506                     else se_seg_sw = 0;                     /* if sel. expr in command line */
 507 
 508                     rel_ind = conv_int (nargs - se_seg_sw, TRI);
 509 
 510                     call build_arg_list (nargs);
 511 
 512                     if se_seg_sw > 0 then do;               /* if se. in seg */
 513                               a_ptr -> arg_list.arg_des_ptr (2) = sea_ptr; /* move in arg and desc ptrs */
 514                               a_ptr -> arg_list.arg_des_ptr (desc_off_o + 2) = sed_ptr;
 515                          end;
 516 
 517                     do i = 2 to nargs - 2 - se_seg_sw;
 518                          a_ptr -> arg_list.arg_des_ptr (i + se_seg_sw) = arg_list.arg_des_ptr (i + 1);
 519                          a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + se_seg_sw) =
 520                               true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + i + 1));
 521                     end;
 522 
 523                     al_ptr = a_ptr;
 524                     arg_list.arg_des_ptr (1) = addr (dbi);
 525                     arg_list.arg_des_ptr (nargs - 1) = addr (rel_ind);
 526                     arg_list.arg_des_ptr (nargs) = addr (code);
 527                     arg_list.arg_des_ptr (desc_off_o + 1),
 528                          arg_list.arg_des_ptr (desc_off_o + nargs - 1),
 529                          arg_list.arg_des_ptr (desc_off_o + nargs) = addr (fb_35_desc);
 530 
 531                     call cu_$generate_call (mrds_dsl_define_temp_rel$define_temp_rel, al_ptr);
 532 
 533                     free arg_list in (work_area);
 534 
 535                     if code ^= 0
 536                     then call com_err_ (code, MRC, "(From dsl_$define_temp_rel)");
 537                     else call ioa_ ("^/Temporary relation index is:  ^d.^/", rel_ind);
 538 
 539                end;                                         /* retrieve */
 540 ^L
 541           else if operation = "set_scope" | operation = "ss" then
 542                call call_scope_fun (mrds_dsl_set_scope$set_scope, 1);
 543 
 544           else if operation = "ssa" | operation = "set_scope_all" then
 545                call call_set_scope_all_fun (mrds_dsl_set_scope$set_scope_all);
 546 
 547           else if operation = "ds" | operation = "dl_scope" then
 548                call call_scope_fun (mrds_dsl_set_scope$dl_scope, 2);
 549 
 550           else if operation = "dl_scope_all" | operation = "dsa" then do;
 551                     if nargs ^= 2
 552                     then call com_err_ (error_table_$wrong_no_of_args, MRC, " Usage: mrc dl_scope_all dbi");
 553                     else do;
 554                               dbi = conv_int (2, DBI);
 555                               call mrds_dsl_set_scope$dl_scope_all (dbi, code);
 556                               if code ^= 0
 557                               then call com_err_ (code, MRC, "(From dsl_$dl_scope_all)");
 558                          end;
 559                end;
 560           else if operation = "get_scope" | operation = "gs" then do;
 561                     if nargs ^= 3 then
 562                          call com_err_ (error_table_$wrong_no_of_args, MRC, "^/    Usage: mrc get_scope dbi relation_name");
 563                     else do;
 564                               dbi = conv_int (2, DBI);
 565                               call cu_$arg_ptr_rel (3, relation_name_ptr, relation_name_len, code, al_ptr);
 566                               if code ^= 0 then
 567                                    call com_err_ (code, MRC, "^/Cannot get relation name argument.");
 568                               else do;
 569                                         call mrds_dsl_get_scope (dbi, relation_name, permits, prevents, scope_version, code);
 570                                         if code ^= 0 then
 571                                              call com_err_ (code, MRC, "(From dsl_$get_scope)");
 572                                         else do;
 573                                                   permit_requests_ptr = addr (permits);
 574                                                   prevent_requests_ptr = addr (prevents);
 575                                                   if scope_version < 5 then
 576                                                        store_scope = "s";
 577                                                   else store_scope = "a";
 578                                                   permit_string = "";
 579                                                   if permit_requests.read_attr then permit_string = permit_string || "r";
 580                                                   if permit_requests.append_tuple then permit_string = permit_string || store_scope;
 581                                                   if permit_requests.modify_attr then permit_string = permit_string || "m";
 582                                                   if permit_requests.delete_tuple then permit_string = permit_string || "d";
 583                                                   if permit_string = "" then permit_string = "n";
 584                                                   prevent_string = "";
 585                                                   if prevent_requests.read_attr then prevent_string = prevent_string || "r";
 586                                                   if prevent_requests.append_tuple then prevent_string = prevent_string || store_scope;
 587                                                   if prevent_requests.modify_attr then prevent_string = prevent_string || "m";
 588                                                   if prevent_requests.delete_tuple then prevent_string = prevent_string || "d";
 589                                                   if prevent_string = "" then prevent_string = "n";
 590                                                   call ioa_ ("^/Permits:  ^a ^-Prevents:  ^a^/", permit_string, prevent_string);
 591                                              end;
 592                                    end;
 593                          end;
 594                end;
 595 ^L
 596           else if operation = "get_population" | operation = "gp" then do;
 597                     if nargs ^= 3 then
 598                          call com_err_ (error_table_$wrong_no_of_args, MRC,
 599                               "^/    Usage: mrc get_population dbi rel_id");
 600                     else do;
 601                               dbi = conv_int (2, DBI);
 602                               call cu_$arg_ptr_rel (3, relation_name_ptr, relation_name_len, code, al_ptr);
 603                               if code ^= 0 then
 604                                    call com_err_ (code, MRC, "^/Cannot get relation name argument.");
 605                               else do;
 606 
 607                                         call mrds_dsl_get_population (dbi, relation_name, tuple_count, code);
 608 
 609                                         if code ^= 0 then
 610                                              call com_err_ (code, MRC, "(From dsl_$get_population)");
 611                                         else do;
 612 
 613                                                   call ioa_ ("^/Tuple count:  ^d^/", tuple_count);
 614 
 615                                              end;
 616 
 617                                    end;
 618 
 619                          end;
 620 
 621                end;
 622 ^L
 623           else if operation = "declare" | operation = "dcl" then do;
 624                     if nargs ^= 3
 625                     then call com_err_ (error_table_$wrong_no_of_args, "^/^- Usage: mrc declare dbi function_name");
 626                     else do;
 627                               dbi = conv_int (2, DBI);
 628 
 629                               call cu_$arg_ptr_rel (3, fn_ptr, fn_len, code, al_ptr);
 630 
 631                               if code ^= 0
 632                               then call com_err_ (code, MRC, "Cannot get function_name");
 633                               else do;
 634                                         call mrds_dsl_declare (dbi, fn_name, code);
 635                                         if code ^= 0
 636                                         then call com_err_ (code, MRC, "(From dsl_$declare)");
 637                                    end;
 638                          end;
 639                end;
 640 
 641           else call com_err_ (error_table_$bad_arg, MRC, operation);
 642 Exit:
 643           if se_ptr ^= null                                 /* if any segment initiated */
 644           then call hcs_$terminate_noname (se_ptr, discard_code);
 645           return;
 646 ^L
 647 call_mod_fun: proc (dsl_entry, index);
 648           dcl     dsl_entry              entry;
 649           dcl     index                  fixed bin;
 650 
 651           if nargs < 3 then do;                             /* not right number */
 652                     if index = 3                            /* special call for store */
 653                     then call com_err_ (error_table_$wrong_no_of_args, MRC,
 654                               "^/^- Usage: mrc store dbi [rel_name | -another] new_values");
 655                     else call com_err_ (error_table_$wrong_no_of_args, MRC,
 656                               "^/^- Usage: mrc ^[delete^;modify^] dbi [selection_expression {se_values} ^[^;new_values^] | ^[^;new_values^] -sm path]", index, index, index);
 657                end;
 658 
 659           else do;
 660                     dbi = conv_int (2, DBI);
 661                     se_seg_sw = 0;                          /* init off */
 662 
 663                     if index ^= 3 then do;                  /* delete or modify */
 664                               call cu_$arg_ptr (nargs - 1, arg_ptr, arg_len, code); /* see if -sm given */
 665                               if code ^= 0 then do;
 666                                         call com_err_ (code, MRC, "Getting argument ^i", nargs - 1);
 667                                         go to Exit;
 668                                    end;
 669 
 670                               else if arg = "-segment" | arg = "-sm" then do;
 671                                         call cu_$arg_ptr (nargs, arg_ptr, arg_len, code);
 672                                         if code ^= 0 then do;
 673                                                   call com_err_ (code, MRC, "Unable to get pathname for -segment");
 674                                                   go to Exit;
 675                                              end;
 676                                         else do;
 677                                                   se_path = arg;
 678                                                   se_len = arg_len;
 679                                                   call get_se (sea_ptr, sed_ptr);
 680                                                   nargs = nargs - 1;
 681                                                   se_seg_sw = 1;
 682                                              end;
 683                                    end;
 684                          end;
 685 
 686                     call build_arg_list (nargs);            /* build dsl_ arg list */
 687 
 688                     if se_seg_sw > 0 then do;               /* if separate sel. expr. */
 689                               a_ptr -> arg_list.arg_des_ptr (2) = sea_ptr; /* move in sel. expr. ptrs */
 690                               a_ptr -> arg_list.arg_des_ptr (desc_off_o + 2) = sed_ptr;
 691                          end;
 692                     do i = 2 to nargs - 1 - se_seg_sw;
 693                          a_ptr -> arg_list.arg_des_ptr (i + se_seg_sw) = arg_list.arg_des_ptr (i + 1);
 694                          a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + se_seg_sw) =
 695                               true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + i + 1));
 696                     end;
 697 
 698                     al_ptr = a_ptr;
 699                     arg_list.arg_des_ptr (1) = addr (dbi);
 700                     arg_list.arg_des_ptr (nargs) = addr (code);
 701                     arg_list.arg_des_ptr (desc_off_o + 1),
 702                          arg_list.arg_des_ptr (desc_off_o + nargs) = addr (fb_35_desc);
 703 
 704                     call cu_$generate_call (dsl_entry, al_ptr);
 705 
 706                     free arg_list in (work_area);
 707 
 708                     if code ^= 0
 709                     then call com_err_ (code, MRC,          /* give user error */
 710                               "(From dsl_$^[delete^;modify^;store^])", index);
 711                end;
 712 
 713      end call_mod_fun;
 714 ^L
 715 call_scope_fun: proc (dsl_entry, index);
 716 
 717           dcl     dsl_entry              entry;
 718           dcl     index                  fixed bin;
 719 
 720 
 721           if nargs < 5
 722           then call com_err_ (error_table_$wrong_no_of_args, MRC,
 723                     "^/^- Usage: mrc ^[set^;dl^]_scope dbi ^a ^/^2-^a ^[{wait_sec}^]",
 724                     index,
 725                     "rel_name1 permit_ops1 prevent_ops1",
 726                     "{... rel_nameN permit_opsN prevent_opsN}",
 727                     index);
 728 
 729           else do;
 730                     dbi = conv_int (2, DBI);
 731 
 732                     wait_time = mod (nargs - 2, 3);
 733                     if wait_time ^= 0 then wait_time = conv_int (nargs, WT);
 734 
 735                     call build_arg_list (nargs);
 736 
 737                     scope_cnt = divide (nargs - 2, 3, 17);
 738                     allocate perm_ops in (work_area);
 739                     allocate prev_ops in (work_area);
 740 
 741                     do i = 2 to nargs - 2 by 3;
 742 
 743                          a_ptr -> arg_list.arg_des_ptr (i) = arg_list.arg_des_ptr (i + 1);
 744                          a_ptr -> arg_list.arg_des_ptr (i + desc_off_o) =
 745                               true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + i + 1));
 746                          perm_ops (divide (i + 1, 3, 17)) = conv_ops (i + 2);
 747                          prev_ops (divide (i + 1, 3, 17)) = conv_ops (i + 3);
 748                          a_ptr -> arg_list.arg_des_ptr (i + 1) = addr (perm_ops (divide (i + 1, 3, 17)));
 749                          a_ptr -> arg_list.arg_des_ptr (i + 2) = addr (prev_ops (divide (i + 1, 3, 17)));
 750                          a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + 1),
 751                               a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + 2) = addr (fb_17_desc);
 752 
 753                     end;
 754 
 755                     al_ptr = a_ptr;
 756                     arg_list.arg_des_ptr (1) = addr (dbi);
 757                     arg_list.arg_des_ptr (nargs) = addr (code);
 758                     if wait_time ^= 0 then do;              /* wait time specified */
 759                               arg_list.arg_des_ptr (nargs - 1) = addr (wait_time);
 760                               arg_list.arg_des_ptr (desc_off_o + nargs - 1) = addr (fb_35_desc);
 761                          end;
 762                     arg_list.arg_des_ptr (desc_off_o + 1),
 763                          arg_list.arg_des_ptr (desc_off_o + nargs) = addr (fb_35_desc);
 764 
 765                     call cu_$generate_call (dsl_entry, al_ptr); /* call out */
 766 
 767                     free perm_ops in (work_area);
 768                     free prev_ops in (work_area);
 769                     free arg_list in (work_area);
 770 
 771                     if code ^= 0
 772                     then call com_err_ (code, MRC,          /* give user sad story */
 773                               "(From dsl_$^[set^;dl^]_scope)", index);
 774                end;
 775 
 776      end call_scope_fun;
 777 ^L
 778 call_set_scope_all_fun: proc (dsl_entry);
 779 
 780           dcl     dsl_entry              entry;
 781 
 782           if nargs < 4 | nargs > 5
 783           then call com_err_ (error_table_$wrong_no_of_args, MRC,
 784                     "^/^- Usage: mrc set_scope_all dbi permit_ops prevent_ops {wait_sec}");
 785           else do;
 786 
 787                     dbi = conv_int (2, DBI);
 788 
 789                     if nargs = 5 then wait_time = conv_int (nargs, WT);
 790 
 791                     call build_arg_list (nargs);
 792 
 793                     scope_cnt = 1;
 794                     allocate perm_ops in (work_area);
 795                     allocate prev_ops in (work_area);
 796 
 797                     perm_ops (1) = conv_ops (3);
 798                     prev_ops (1) = conv_ops (4);
 799                     a_ptr -> arg_list.arg_des_ptr (2) = addr (perm_ops (1));
 800                     a_ptr -> arg_list.arg_des_ptr (3) = addr (prev_ops (1));
 801                     a_ptr -> arg_list.arg_des_ptr (desc_off_o + 2),
 802                          a_ptr -> arg_list.arg_des_ptr (desc_off_o + 3) = addr (fb_17_desc);
 803 
 804                     al_ptr = a_ptr;
 805                     arg_list.arg_des_ptr (1) = addr (dbi);
 806                     arg_list.arg_des_ptr (nargs) = addr (code);
 807 
 808                     if nargs = 5
 809                     then do;
 810                               arg_list.arg_des_ptr (nargs - 1) = addr (wait_time);
 811                               arg_list.arg_des_ptr (desc_off_o + nargs - 1) = addr (fb_35_desc);
 812                          end;
 813                     arg_list.arg_des_ptr (desc_off_o + 1),
 814                          arg_list.arg_des_ptr (desc_off_o + nargs) = addr (fb_35_desc);
 815 
 816                     call cu_$generate_call (dsl_entry, al_ptr); /* call out */
 817 
 818                     free perm_ops in (work_area);
 819                     free prev_ops in (work_area);
 820                     free arg_list in (work_area);
 821 
 822                     if code ^= 0 then
 823                          call com_err_ (code, MRC, "(From dsl_$set_scope_all)");
 824                end;
 825 
 826      end call_set_scope_all_fun;
 827 ^L
 828 open_old_ver: proc;
 829 
 830           dcl     odd                    fixed bin;         /* to see if odd num of args */
 831           dcl     al_index               fixed bin;         /* index for arg_list processing */
 832 
 833           odd = mod (nargs, 2);                             /* see if odd num */
 834 
 835           if nargs < 3 | odd = 0 then do;                   /* need odd num & at least 3 */
 836                     call com_err_ (error_table_$wrong_no_of_args, MRC,
 837                          "^/^- Usage: mrc open path1 mode1 {... pathN modeN}");
 838                     go to Exit;
 839                end;
 840 
 841           num_open,
 842                open_cnt = divide (nargs - 1, 2, 17);
 843           call build_arg_list (open_cnt * 3 + 1);
 844 
 845           allocate num in (work_area) set (num_ptr);
 846           allocate mode in (work_area) set (mode_ptr);
 847           if tml_ptr ^= null then free temp_mode_list in (work_area);
 848           allocate temp_mode_list set (tml_ptr) in (work_area);
 849 
 850           do i = 1 to (open_cnt);
 851                al_index = (i - 1) * 3;
 852 
 853                a_ptr -> arg_list.arg_des_ptr (al_index + 1) = arg_list.arg_des_ptr (2 * i);
 854                a_ptr -> arg_list.arg_des_ptr (al_index + 2) = addr (num (i));
 855                a_ptr -> arg_list.arg_des_ptr (al_index + 3) = addr (mode (i));
 856 
 857                call cu_$arg_ptr (2 * i + 1, ms_ptr, ms_len, code);
 858                if code ^= 0 then do;
 859                          call com_err_ (code, MRC, "Unable to get opening mode.");
 860                          go to Exit;
 861                     end;
 862 
 863                do j = 1 to 8 while (mode_string ^= ms_array (j)); /* look for specified mode */
 864                end;
 865                if j > 8 then do;
 866                          call com_err_ (code, MRC,
 867                               "Invalid opening mode ^a. ^/^-Valid modes are: r, u, er, and eu", mode_string);
 868                          go to Exit;
 869                     end;
 870                else mode (i) = mv_array (j);                /* if valid, pick up corr. number */
 871                a_ptr -> arg_list.arg_des_ptr (desc_off_o + al_index + 1) =
 872                     true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + 2 * i));
 873                a_ptr -> arg_list.arg_des_ptr (desc_off_o + al_index + 2),
 874                     a_ptr -> arg_list.arg_des_ptr (desc_off_o + al_index + 3) = addr (fb_35_desc);
 875 
 876                temp_mode_list (i) = ms_array (2 * mode (i) - 1); /* save expanded opening mode */
 877 
 878                call cu_$arg_ptr (2 * i, arg_ptr, arg_len, code); /* get and save submodel path */
 879                if code ^= 0 then do;                        /* not there */
 880                          call com_err_ (code, MRC, "Unable to get pathname");
 881                          go to Exit;
 882                     end;
 883 
 884                if code ^= 0 then do;
 885                          call com_err_ (code, MRC, arg);    /* let user know */
 886                          go to Exit;                        /* and get out */
 887                     end;
 888 
 889           end;
 890 
 891      end open_old_ver;
 892 ^L
 893 build_arg_list: proc (count);
 894 
 895           dcl     count                  fixed bin;
 896           dcl     old_num_ptrs           fixed bin;         /* CHANGE 81-09-22 ********** */
 897 
 898           old_num_ptrs = num_ptrs;                          /* CHANGE 81-09-22 ********** */
 899 
 900           num_ptrs = 2 * count;
 901           allocate arg_list in (work_area) set (a_ptr);
 902 
 903           a_ptr -> arg_list.arg_count,
 904                a_ptr -> arg_list.desc_count = 2 * count;
 905           a_ptr -> arg_list.code = 4;
 906 
 907           desc_off_o = count;
 908           desc_off_i = divide (arg_list.arg_count, 2, 17) + fixed (arg_list.code = 8);
 909 
 910 /* BEGIN CHANGE 81-09-22 ******************************
 911 
 912    old_num_ptrs contains the number of pointers in the argument list
 913    that  mrds_call  was called with. num_ptrs contains the number of
 914    pointers that the corresponding dsl_ entry will be  called  with.
 915    Since  only  1 structure is used (arg_list) the value of num_ptrs
 916    after it leaves this procedure must be  the  larger  of  the  two
 917    numbers  to  prevent  subscriptrange conditions from occuring, of
 918    course this means that subscriptrange conditions can occur on the
 919    other   structure.  Ideally  two  separate  structures  with  two
 920    separate limits should be used. This has not been  done  at  this
 921    time becuase while it is a simple change it is also extensive and
 922    it would be easy to make a mistake at  the  same  time  the  test
 923    routines  cannot  be  run  becuase  almost  every  routine  has a
 924    stringrange or subscriptrange condition  in  it.  After  mrds  is
 925    again running this change should be made. */
 926 
 927           if old_num_ptrs > num_ptrs
 928           then num_ptrs = old_num_ptrs;
 929 
 930 /* END   CHANGE 81-09-22 ****************************** */
 931 
 932      end build_arg_list;
 933 ^L
 934 conv_int: proc (index, argument_type) returns (fixed bin (35));
 935 
 936           declare argument_type          char (*);
 937           dcl     i                      fixed bin;
 938           dcl     num_char               char (nc_len) based (nc_ptr);
 939           dcl     nc_ptr                 ptr;
 940           dcl     (nc_len,
 941                   index)                 fixed bin;
 942 
 943           call cu_$arg_ptr_rel (index, nc_ptr, nc_len, code, al_ptr);
 944 
 945           if code ^= 0 then do;                             /* can't find arg */
 946                     call com_err_ (code, MRC, "Unable to get ^a", argument_type);
 947                     go to Exit;                             /* not much past this */
 948                end;
 949 
 950           if argument_type = TRI
 951           then i = verify (num_char, "-0123456789");
 952           else i = verify (num_char, "0123456789");         /* no negatives allowed */
 953 
 954           if i ^= 0 then do;                                /* not numeric */
 955                     call com_err_ (error_table_$bad_arg, MRC,
 956                          "Non-numeric ^a: ^a", argument_type, num_char);
 957                     if operation = "close" | operation = "c"/* special handling for close */
 958                     then signal conversion;                 /* so can clean up properly */
 959                     else go to Exit;                        /* otherwise, just die */
 960                end;
 961           return (fixed (num_char));
 962 
 963      end conv_int;
 964 ^L
 965 conv_ops: proc (index) returns (fixed bin (35));
 966 
 967 /* Internal procedure to create an operations number from a given scope operations string */
 968 
 969           dcl     st_ptr                 ptr;               /* points to input string */
 970           dcl     (st_len,                                  /* length of input str. */
 971                   index)                 fixed bin;         /* index of string arg. */
 972           dcl     string                 char (st_len) based (st_ptr); /* scope ops. string */
 973           dcl     op_num                 fixed bin (35);    /* scope ops number to be returned */
 974 
 975           call cu_$arg_ptr_rel (index, st_ptr, st_len, code, al_ptr); /* get input string */
 976           if code ^= 0 then do;
 977                     call com_err_ (code, MRC, "Unable to get scope code");
 978                     go to Exit;
 979                end;
 980           op_num = 0;                                       /* initialize */
 981 
 982           if string ^= "n" then do;                         /* if non-null op. */
 983                     op_num = verify (string, "nrasudm");
 984                     if op_num ^= 0 then do;                 /* invalid code */
 985                               call com_err_ (error_table_$bad_arg, MRC,
 986                                    "Invalid scope code: ^a. ^/^-Valid codes are: n, r, a or s, d, m, and u = ""a+d+m""",
 987                                    substr (string, op_num, 1));
 988                               go to Exit;
 989                          end;
 990                     if search (string, "r") ^= 0 then op_num = op_num + READ_ATTR; /* convert to number */
 991                     if search (string, "s") ^= 0 | search (string, "a") ^= 0 then op_num = op_num + APPEND_TUPLE;
 992                     if search (string, "d") ^= 0 then op_num = op_num + DELETE_TUPLE;
 993                     if search (string, "m") ^= 0 then op_num = op_num + MODIFY_ATTR;
 994                     if search (string, "u") ^= 0 then op_num = op_num + UPDATE_OPS;
 995                end;
 996 
 997           return (op_num);
 998 
 999      end conv_ops;
1000 ^L
1001 print_dbi: proc;
1002 
1003 /* Procedure to print open data bases, modes, and indices */
1004 
1005 
1006           call mrds_dsl_db_openings$list_openings (wa_ptr,
1007                mrds_database_openings_structure_version, mrds_database_openings_ptr, code);
1008           if code ^= 0 then
1009                call com_err_ (code, MRC, "(From dsl_$list_openings)");
1010           else do;
1011 
1012                     if mrds_database_openings.number_open = 0 then
1013                          call ioa_ ("^/No data bases open.^/"); /* if we dont have list */
1014 
1015                     else do;                                /* print out list */
1016                               call ioa_ ("^/Open data base^[ is^;s are^]:",
1017                                    (mrds_database_openings.number_open = 1)); /* write out header */
1018 
1019                               do i = 1 to mrds_database_openings.number_open; /* write out index,
1020                                                                mode, path of each db curr. open */
1021 
1022                                    call ioa_ ("^d^-^a^/^-^a", mrds_database_openings.db.index (i),
1023                                         mrds_database_openings.db.path (i),
1024                                         mrds_database_openings.db.mode (i));
1025                               end;
1026                               call ioa_ ("^/");
1027                          end;
1028 
1029                end;
1030 
1031 
1032           if mrds_database_openings_ptr ^= null () then
1033                free mrds_database_openings in (work_area);
1034 
1035      end print_dbi;
1036 ^L
1037 get_se: proc (a_ptr, d_ptr);
1038 
1039 /* Internal procedure to obtain selection expression if user has specified -segment.
1040    On output, a_ptr will point to the start of the selection expression, and d_ptr will point to a
1041    descriptor for the selection expression.
1042 */
1043 
1044           dcl     (a_ptr,                                   /* place to put arg ptr. for sel.exp. */
1045                   d_ptr)                 ptr;               /* place to put descr. ptr. for sel. exp. */
1046           dcl     dname                  char (168);        /* dir name of se. expr. */
1047           dcl     ename                  char (32);         /* entry name of se. expr. */
1048           dcl     bcount                 fixed bin (24);    /* se. expr. bit count */
1049           dcl     1 se_desc              aligned,           /* descriptor template */
1050                     2 const              bit (12) unal init ("101010110000"b),
1051                     2 len                fixed bin (23) unal;
1052 
1053           call expand_path_ (addr (se_path), se_len, addr (dname), addr (ename), code);
1054 
1055           if code ^= 0 then do;
1056                     call com_err_ (code, MRC, se_path);
1057                     go to Exit;                             /* can't do anything with it */
1058                end;
1059 
1060           call hcs_$initiate_count (dname, ename, "", bcount, 0, se_ptr, code); /* get ptr and length of sel. expr. */
1061 
1062           if se_ptr = null then do;                         /* couldn't init segment */
1063                     call com_err_ (code, MRC, "Initiating ^a>^a", dname, ename);
1064                     go to Exit;                             /* can't go any farther now */
1065                end;
1066 
1067           a_ptr = se_ptr;                                   /* arg ptr */
1068           d_ptr = addr (se_desc);                           /* point to descriptor */
1069           se_desc.len = divide (bcount, 9, 17);             /* set length in descriptor */
1070 
1071      end get_se;
1072 ^L
1073 true_ptr: proc (a_ptr, d_ptr) returns (ptr);
1074 
1075 /* Procedure to insure that descriptor pointers passed to dsl_ are its ptrs, rathher than offsets. */
1076 
1077           dcl     (a_ptr,                                   /* arg list ptr */
1078                   d_ptr)                 ptr;               /* descriptor ptr */
1079           dcl     1 its_wd1              based (addr (d_ptr)),
1080                     2 offset             bit (18) unal,
1081                     2 pad                bit (12) unal,
1082                     2 tag                bit (6) unal;
1083 
1084           if its_wd1.tag = "100011"b then return (d_ptr);   /* is already its ptr */
1085           else return (ptr (a_ptr, its_wd1.offset));        /* otherwise make its ptr */
1086 
1087      end true_ptr;
1088 ^L
1089 cleanup_proc: proc;
1090 
1091 /* cleanup procedure to free any temporary. storage */
1092 
1093           if a_ptr ^= null then free a_ptr -> arg_list in (work_area);
1094           if num_ptr ^= null then free num in (work_area);
1095           if mode_ptr ^= null then free mode in (work_area);
1096           if rmode_ptr ^= null then free rmode in (work_area);
1097           if val_ptr ^= null then free values in (work_area);
1098           if pm_ptr ^= null then free perm_ops in (work_area);
1099           if pv_ptr ^= null then free prev_ops in (work_area);
1100 
1101           if se_ptr ^= null then do;
1102                     call hcs_$terminate_noname (se_ptr, code);
1103                     se_ptr = null ();
1104                end;
1105 
1106 
1107      end cleanup_proc;
1108 ^L
1109 arg_err_hndlr: proc;
1110 
1111           call com_err_ (error_table_$noarg, "mrds_call");
1112           call cleanup_proc;
1113 
1114      end arg_err_hndlr;
1115 ^L
1116 free_open_lists: procedure;
1117 
1118 /* this procedure wipes out the temp seg used as a work area.  It is called
1119    whenever there is an error in open and after all data bases have
1120    been closed.  By deleting this area, we effectively free everything allocated
1121    in it. */
1122 
1123           if wa_ptr ^= null then do;                        /* got something to get rid of */
1124                     call release_temp_segment_ (MRC, wa_ptr, discard_code);
1125                     area_initialized = OFF;                 /* remember that its not there any more */
1126                end;
1127 
1128      end free_open_lists;
1129 ^L
1130 %include mdbm_arg_list;
1131 %page;
1132 %include mdbm_scope_requests;
1133 %page;
1134 %include mrds_new_scope_modes;
1135 %page;
1136 %include mrds_database_list;
1137 %page;
1138 %include mrds_database_openings;
1139 ^L
1140           dcl     (a_ptr,
1141                   arg_ptr,                                  /* ptr to arg. of interest */
1142                   f_ptr,
1143                   filen_ptr,
1144                   fn_ptr,
1145                   num_ptr,
1146                   mode_ptr,
1147                   ms_ptr,                                   /* ptr to input mode string */
1148                   pm_ptr,
1149                   pv_ptr,
1150                   rmode_ptr,
1151                   se_ptr,                                   /* ptr to selection expr to be passed to dsl_ */
1152                   sea_ptr,                                  /* arg ptr for seg se. */
1153                   sed_ptr,                                  /* desc ptr for seg se. */
1154                   val_ptr)               ptr;
1155 
1156           dcl     (arg_len,                                 /* length of arg of interest */
1157                   desc_off_i,
1158                   desc_off_o,
1159                   f_len,
1160                   fn_len,
1161                   i,
1162                   j,                                        /* internal index */
1163                   ms_len,                                   /* length of mode string */
1164                   n_vals,
1165                   nargs,
1166                   open_cnt,
1167                   ready_cnt,
1168                   scope_cnt,
1169                   se_len,                                   /* length of se. seg. path */
1170                   se_seg_sw)             fixed bin;         /* indicates if seg se. expr. */
1171 
1172           dcl     (code,
1173                   dbi,
1174                   rel_ind)               fixed bin (35);
1175 
1176           dcl     all_sw                 bit (1) unal;      /* on => outo anothers */
1177           dcl     anoth_desc             bit (36) aligned int static options (constant) init ("101010100000000000000000000000001000"b);
1178           dcl     anoth_str              char (8) aligned int static options (constant) init ("-another");
1179           dcl     arg                    char (arg_len) based (arg_ptr); /* arg of current interest */
1180           dcl     current_arg            fixed bin;         /* Used in retrieve argument scanning */
1181           dcl     done_scanning          bit (1);           /* Are we done parsing the dashed args */
1182           dcl     fn_name                char (fn_len) based (fn_ptr);
1183           dcl     mode                   (open_cnt) fixed bin (35) based (mode_ptr);
1184           dcl     mode_string            char (ms_len) based (ms_ptr); /* opening mode */
1185           dcl     num                    (open_cnt) fixed bin (35) based (num_ptr);
1186           dcl     num_open               fixed bin int static init (0); /* num. of open data bases */
1187           dcl     operation              char (f_len) based (f_ptr);
1188           dcl     perm_ops               (scope_cnt) fixed bin (35) based (pm_ptr);
1189           dcl     prev_ops               (scope_cnt) fixed bin (35) based (pv_ptr);
1190           dcl     rmode                  (ready_cnt) fixed bin (35) based (rmode_ptr);
1191           dcl     se_path                char (168) aligned;/* path name of selection expr. */
1192           dcl     values                 (n_vals) char (256) based (val_ptr);
1193           dcl     wa_ptr                 static pointer init (null); /* ptr to temp seg containing the above */
1194           dcl     wait_time              fixed bin (35);    /* optional maximum wait time for scope setting */
1195                                                             /* NOTE: this MUST be declared fixed bin 35 NOT 71,
1196                                                                since mrds_dsl_set_scope expects a fb35 number, and is documented that way for users */
1197 
1198           dcl     ms_array               (8) char (20) int static options (constant) init (/* allowable opening modes */
1199                                          "retrieval", "r",
1200                                          "update", "u",
1201                                          "exclusive_retrieval", "er",
1202                                          "exclusive_update", "eu");
1203 
1204           dcl     mv_array               (8) fixed bin int static options (constant) /* corresponding numeric values */
1205                                          init (1, 1, 2, 2, 3, 3, 4, 4);
1206 
1207           dcl     char_desc              bit (36) aligned init ("101010100000000000000000000100000000"b);
1208           declare fb_17_desc             bit (36) aligned init ("100000100000000000000000000000010001"b);
1209           dcl     fb_35_desc             bit (36) aligned init ("100000100000000000000000000000100011"b);
1210 
1211           dcl     work_area              area (sys_info$max_seg_size) based (wa_ptr);
1212 
1213           dcl     (error_table_$bad_arg,
1214                   error_table_$noarg,
1215                   mrds_error_$tuple_not_found,
1216                   sys_info$max_seg_size) fixed bin (35) ext;
1217 
1218           dcl     (addr,
1219                   divide,
1220                   empty,
1221                   fixed,
1222                   length,
1223                   mod,
1224                   null,
1225                   ptr,
1226                   search,
1227                   substr,
1228                   verify)                builtin;
1229 
1230           dcl     (arg_err_,
1231                   cleanup,
1232                   conversion,
1233                   sub_error_)            condition;         /* signaled when sub_error_ called */
1234 
1235           dcl     (com_err_,
1236                   ioa_,
1237                   mrds_dsl_close$close,
1238                   mrds_dsl_define_temp_rel$define_temp_rel,
1239                   mrds_dsl_delete$delete,
1240                   mrds_dsl_modify$modify,
1241                   mrds_dsl_open$open,
1242                   mrds_dsl_retrieve$retrieve,
1243                   mrds_dsl_set_scope$dl_scope,
1244                   mrds_dsl_set_scope$set_scope,
1245                   mrds_dsl_set_scope$set_scope_all,
1246                   mrds_dsl_store$store)  entry options (variable);
1247 
1248           dcl     mrds_dsl_declare       entry (fixed bin (35), char (*), fixed bin (35));
1249           declare mrds_dsl_get_scope     entry (fixed bin (35), char (*), fixed bin, fixed bin, fixed bin, fixed bin (35)); /* gets permits/prevents scope on rel */
1250           declare relation_name          char (relation_name_len) based (relation_name_ptr);
1251           declare relation_name_ptr      ptr;
1252           declare relation_name_len      fixed bin;
1253           declare (permits, prevents)    fixed bin;
1254           declare scope_version          fixed bin;         /* 5 => r-a-m-d, < 5 => r-s-m-d */
1255           declare store_scope            char (1);          /* either "s" or "a" */
1256           declare (permit_string, prevent_string) char (4) varying; /* for displaying scope */
1257           declare tuple_count            fixed bin (35);    /* number of tuples in relation */
1258           declare mrds_dsl_get_population entry options (variable); /* get population of rels */
1259           dcl     mrds_dsl_set_scope$dl_scope_all entry (fixed bin (35), fixed bin (35));
1260 
1261           dcl     (DBI                   char (15) init ("data_base_index"),
1262                   MRC                    char (9) init ("mrds_call"),
1263                   NVALS                  char (5) init ("nvals"),
1264                   TRI                    char (14) init ("temp_rel_index"),
1265                   WT                     char (9) init ("wait_time")) static options (constant);
1266 
1267           dcl     arg_cnt                fixed bin;         /* number of set_mode arguments + 1 */
1268           dcl     continue_to_signal_    entry (fixed bin (35)); /* to keep signaling */
1269           dcl     error_display_flag     bit (1) internal static init ("1"b); /* on => output sub error mesg */
1270           dcl     error_table_$wrong_no_of_args fixed bin (35) ext;
1271           dcl     handler_found_code     fixed bin (35);
1272           dcl     list_display_flag      bit (1) internal static init ("1"b); /* on => list open dbs, and ready files after open/ready */
1273           dcl     mrc_mode               char (mrc_mode_len) based (mrc_mode_ptr); /* set_modes mode arg */
1274           dcl     mrc_mode_len           fixed bin;         /* length of set_mode mode arg */
1275           dcl     mrc_mode_ptr           ptr;               /* set_mode mode pointer */
1276           dcl     mrds_dsl_close_all     entry (fixed bin (35)); /* close all open dbs */
1277           dcl     NL                     char (1) init ("
1278 ");                                                         /* new line character */
1279           dcl     ON                     bit (1) init ("1"b); /* true value */
1280           dcl     OFF                    bit (1) init ("0"b); /* false value */
1281 
1282           dcl     area_initialized       bit (1) internal static init ("0"b); /* on => work area created */
1283           dcl     discard_code           fixed bin (35);    /* unused */
1284           dcl     get_temp_segment_      entry (char (*), ptr, fixed bin (35)); /* gets space for work area */
1285           dcl     mrds_data_$max_dbs     fixed bin (35) ext;/* max num of open dbs */
1286           dcl     mrds_dsl_db_openings$list_dbs entry (ptr, ptr); /* gets list of open dbs */
1287           declare mrds_dsl_db_openings$list_openings entry (ptr, fixed bin, ptr, fixed bin (35)); /* extended open info */
1288           declare no_output_mode         bit (1) int static init ("0"b); /* on => don't return retreived values */
1289           declare tuples_retrieved       fixed bin (35);    /* number of values not seen */
1290           dcl     NA                     char (20) init ("Mode not available");
1291           dcl     release_temp_segment_  entry (char (*), ptr, fixed bin (35)); /* removes work space */
1292           dcl     temp_mode_list         (1:mrds_data_$max_dbs) char (20) based (tml_ptr); /* temp store for opening modes */
1293           dcl     tml_ptr                ptr init (null ());/* points to temp_mode_list */
1294 
1295           dcl     cu_$arg_list_ptr       entry (ptr);
1296           dcl     cu_$arg_ptr            entry (fixed bin, ptr, fixed bin, fixed bin (35));
1297           dcl     cu_$arg_ptr_rel        entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
1298           dcl     cu_$generate_call      entry (entry, ptr);
1299           dcl     expand_path_           entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
1300           dcl     hcs_$initiate_count    entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
1301           dcl     hcs_$terminate_noname  entry (ptr, fixed bin (35));
1302 
1303      end mrds_call;
1304 
1305