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 
 19 linus_retrieve:
 20      proc (lcb_ptr, ca_ptr, char_ptr, al_ptr, e_ptr, icode);
 21 
 22 
 23 /* DESCRIPTION:
 24 
 25    Data  is  retrieved  from  the  currently open data base and used by various
 26    linus  request procedures.  This procedure does the first retrieval and sets
 27    up  the  system  standard  arg  list  for  subsequent  retrievals  using the
 28    "-another"   selection   expression.   Therefore  the  "char_desc"  and  the
 29    "arg_list" structures must be released by the calling procedure.
 30 
 31 
 32 
 33    HISTORY:
 34 
 35    77-05-01 J. C. C. Jagernauth: Initially written.
 36 
 37    80-03-14  Rickie  E.   Brinegar:  Modified  to  use  a  work area defined on
 38    lcb.linus_area_ptr instead of getting system free area.
 39 
 40    81-02-02  Rickie  E.  Brinegar: The internal static debug switch declaration
 41    was moved from the db_on entry to the main entry.
 42 
 43    81-02-11  Rickie  E.   Brinegar: Modified to set the argument list only when
 44    the  al_ptr  is  null  and to do the work of preparing the argument list for
 45    another  processing  as  was advertised in the notes above (something it did
 46    not do).
 47 
 48    81-02-20  Rickie  E.   Brinegar: changed the call to mdb_display_value_ to a
 49    call to mdb_display_data_value$ptr to allow for selection expressions longer
 50    that 256 characters.
 51 
 52    81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler.
 53 
 54    81-09-17  Rickie E.  Brinegar: Removed the is_var bit array for determining
 55    if  a  descriptor  is  a  varying data type.  This use of the bit array was
 56    replaced with a call to mdbm_util_$varying_data_class with a pointer to the
 57    appropriate descriptor.
 58 
 59    81-11-12 Rickie E. Brinegar: Added timing of dsl_$retrieve call.
 60 
 61 */
 62 ^L
 63 %include linus_lcb;
 64 %page;
 65 %include linus_char_argl;
 66 %page;
 67 %include linus_arg_list;
 68 %page;
 69 %include linus_select_info;
 70 %page;
 71 %include mdbm_arg_list;
 72 ^L
 73 
 74           dcl     1 arg_len_bits         based,
 75                     2 pad                bit (12) unal,
 76                     2 length             bit (24);          /* Length of argument to be passed in arg_list */
 77 
 78           dcl     debug_switch           bit (1) int static init ("0"b);
 79 
 80           dcl     icode                  fixed bin (35);
 81 
 82           dcl     (desc, l, loop)        fixed bin;
 83 
 84           dcl     initial_vclock         float bin (63);
 85 
 86           dcl     (addr, addrel, fixed, null, rel, vclock) builtin;
 87 
 88           dcl     (
 89                   e_ptr,
 90                   env_ptr                init (null),
 91                   temp_ptr               init (null)
 92                   )                      ptr;
 93 
 94           dcl     ANOTHER                char (8) init ("-another") int static options (constant);
 95           dcl     ANOTHER_LEN            bit (24) init ("000000000000000000001000"b) int static
 96                                          options (constant);
 97           dcl     ANOTHER_PTR            ptr init (null) int static;
 98 
 99           dcl     cu_$generate_call      entry (entry, ptr);
100           dcl     dsl_$retrieve          entry options (variable); /* MRDS subroutine */
101           dcl     ioa_                   entry options (variable);
102           dcl     mdb_display_data_value$ptr entry (ptr, ptr);
103           dcl     mdbm_util_$varying_data_class entry (ptr) returns (bit (1) aligned);
104           dcl     sys_info$max_seg_size  fixed bin (35) ext;/* Used in linus control block */
105           dcl     work_area              area (sys_info$max_seg_size) based (lcb.linus_area_ptr);
106 ^L
107 
108 /* assure ANOTHER_PTR is not null and that the arg_list is only
109    when the al_ptr is null */
110 
111           if ANOTHER_PTR = null then
112                ANOTHER_PTR = addr (ANOTHER);
113 
114           si_ptr = lcb.si_ptr;                              /* Init */
115           desc = select_info.n_mrds_items + 3 + select_info.nsevals;
116                                                             /* Offset for descriptors */
117           if al_ptr = null then do;
118                     num_ptrs = desc * 2;                    /* Number of pointers in arg_list */
119                     allocate arg_list in (work_area);       /* System standard argument list */
120                     arg_list.arg_des_ptr (desc) = addr (icode); /* Pointer to return code */
121                     if char_ptr = null then do;
122                               n_chars_init = 1;             /* Number to allocate */
123                               allocate char_desc in (work_area); /* Character descriptors */
124                          end;
125                     arg_list.arg_des_ptr (num_ptrs) = addr (char_desc.fb_desc);
126                                                             /* Return code descriptor */
127                     arg_list.arg_des_ptr (1) = addr (lcb.db_index); /* Data base index */
128                     arg_list.arg_des_ptr (desc + 1) = addr (char_desc.fb_desc);
129                                                             /* Data base index descriptor */
130                     arg_list.arg_count, arg_list.desc_count = num_ptrs; /* Initialize argument list header */
131                     arg_list.code = 4;
132                     arg_list.pad = 0;
133 
134 /* Fill in rest of standard arg_list */
135                     char_desc.arr.var (1) =
136                          addr (select_info.se_len) -> arg_len_bits.length;
137                     arg_list.arg_des_ptr (2) = select_info.se_ptr;
138                     arg_list.arg_des_ptr (desc + 2) = addr (char_desc.arr (1));
139                     if select_info.nsevals ^= 0 then
140                          do l = 1 to select_info.nsevals;
141                               arg_list.arg_des_ptr (2 + l) = select_info.se_vals.arg_ptr (l);
142                               arg_list.arg_des_ptr (2 + desc + l) =
143                                    select_info.se_vals.desc_ptr (l);
144                          end;
145                     l = 1;
146                     do loop = 3 + select_info.nsevals
147                          to 2 + select_info.n_mrds_items + select_info.nsevals;
148                                                             /* Use pointers and descriptors from select_info structure */
149                          arg_list.arg_des_ptr (loop) = select_info.mrds_item.arg_ptr (l);
150                          arg_list.arg_des_ptr (desc + loop) =
151                               addr (select_info.mrds_item.desc (l));
152                          if mdbm_util_$varying_data_class (
153                               addr (select_info.mrds_item.desc (l))) then do;
154                                    temp_ptr = select_info.mrds_item.arg_ptr (l);
155                                    arg_list.arg_des_ptr (loop) = addrel (temp_ptr, 1);
156                               end;
157                          l = l + 1;
158                     end;
159                end;
160 
161           if debug_switch then do;
162                     call ioa_ ("Selection expression:");
163                     call
164                          mdb_display_data_value$ptr (select_info.se_ptr,
165                          addr (char_desc.arr (1)));
166                end;                                         /* if debug_switch */
167 
168           if lcb.timing_mode then
169                initial_vclock = vclock;
170 
171           call cu_$generate_call (dsl_$retrieve, al_ptr);   /* Call retrieve */
172 
173           if lcb.timing_mode then
174                lcb.mrds_time = lcb.mrds_time + vclock - initial_vclock;
175 
176 /* Insure that we are now set up for -another processing */
177 
178           if arg_list.arg_des_ptr (2) ^= ANOTHER_PTR then do;
179                     arg_list.arg_des_ptr (2) = ANOTHER_PTR;
180                     char_desc.arr (1).var = ANOTHER_LEN;
181                end;
182 
183           return;
184 ^L
185 db_on:
186      entry;
187 
188 /* Usage:
189    linus_retrieve$db_on
190 
191    Turns on a switch which causes the value of the current
192    selection expression to be displayed at the terminal.
193 */
194 
195           debug_switch = "1"b;
196           return;
197 ^K
198 db_off:
199      entry;
200 
201 /* Usage:
202    linus_retrieve$db_off
203 
204    Turns off the switch which causes the value of the current
205    selection expression to be displayed at the terminal.
206 */
207 
208           debug_switch = "0"b;
209           return;
210 
211      end linus_retrieve;