1 /* BEGIN INCLUDE FILE - dm_comp_vec_str_proc.incl.pl1 */
  2 
  3 /* DESCRIPTION:
  4 
  5           This program compares the value of a simple_typed_vector and a key.
  6      It is responsible for "parsing" the key bit string into its constituent
  7      fields, using the information provided by the field_table.  Dimension I
  8      of the simple_typed_vector is assumed to be the same field as field I of
  9      the key.
 10           The comparison is done a-field-at-a-time, starting with field 1 and
 11      continuing with field 2, field 3, etc. until either an inequality is
 12      found or all of the fields have been compared.
 13 
 14           Global variables are assumed to be in the main procedure so as to
 15      simulate the calling sequence:
 16 
 17      call COMPARE_VECTOR_TO_STRING
 18         (cvs_p_field_table_ptr, cvs_p_simple_typed_vector_ptr,
 19          cvs_p_key_string_ptr, cvs_p_key_string_length,
 20          cvs_p_last_field_idx, cvs_p_first_inequal_field_id,
 21          cvs_p_vector_equal_to_key, cvs_p_vector_less_than_key, cvs_p_code);
 22 
 23      They must be declared as follows described under Parameters.
 24 */
 25 
 26 /* HISTORY:
 27 
 28 Written by Matthew Pierret, 04/19/84.
 29   (Extracted from dmu_compare_vector_to_str.pl1.)
 30 Modified:
 31 05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.
 32 12/07/84 by M. Sharpe:  to correct format and dcls.
 33 */
 34 
 35 
 36 /****^  HISTORY COMMENTS:
 37   1) change(86-12-17,Dupuis), approve(87-04-01,MCR7632), audit(87-01-13,Blair),
 38      install(87-04-02,MR12.1-1020):
 39      Corrected a bug (phx20420) where the cvs_location_of_first_varying_field
 40      was being set incorrectly when it was a bit varying or char varying field,
 41      and all of the fields weren't present.
 42                                                    END HISTORY COMMENTS */
 43 
 44 
 45 /* format: style2,ind3 */
 46 
 47 %page;
 48 
 49 COMPARE_VECTOR_TO_STRING:
 50    proc ();
 51 
 52 /* START OF DECLARATIONS */
 53 /* Parameter */
 54 
 55 /*
 56 
 57    dcl cvs_p_field_table_ptr     ptr;  /* points to a field_table
 58    dcl cvs_p_simple_typed_vector_ptr   /* points to the simple_typed_vector
 59                                  ptr;  /* to be compared with ...
 60    dcl cvs_p_key_string_ptr      ptr;  /* (points to) the string
 61    dcl cvs_p_key_string_length   fixed bin (24);
 62                                        /* length of the string in bits
 63    dcl cvs_p_last_field_idx      fixed bin (17);
 64                                        /* the index of the last field
 65                                        /* contained in the string.  This last
 66                                        /* field have a truncated value. If
 67                                        /* this is -1, all fields are present
 68                                        /* in full form.
 69    dcl cvs_p_first_inequal_field_id
 70                                  fixed bin (17);
 71                                        /* is set by this routine to be the id
 72                                        /* of the first field which did not
 73                                        /* compare equal.
 74    dcl cvs_p_vector_equal_to_key bit (1) aligned;
 75                                        /* is set by this routine to ON if the
 76                                        /* vector and string are equal.
 77    dcl cvs_p_vector_less_than_key bit (1) aligned;
 78                                        /* is set by this routine to ON if the
 79                                        /* vector is less than the key
 80    dcl cvs_p_code                fixed bin (35);
 81 */
 82 
 83 /* Automatic */
 84 
 85       dcl     cv_p_code              fixed bin (35);
 86       dcl     cv_p_descriptor_ptr    ptr;
 87       dcl     cv_p_field_value_length
 88                                      fixed bin (35);
 89       dcl     cv_p_field_value_ptr   ptr;
 90       dcl     cv_p_vector_equal_to_key
 91                                      bit (1) aligned;
 92       dcl     cv_p_vector_less_than_key
 93                                      bit (1) aligned;
 94       dcl     cv_p_vector_value_length
 95                                      fixed bin (35);
 96       dcl     cv_p_vector_value_ptr  ptr;
 97 
 98       dcl     cvs_current_field_id   fixed bin (35);
 99       dcl     cvs_field_idx          fixed bin;
100       dcl     cvs_field_value_offset fixed bin (24);
101       dcl     cvs_key_string_length  fixed bin (35);
102       dcl     cvs_key_string_ptr     ptr;
103       dcl     cvs_last_field_idx     fixed bin;
104       dcl     cvs_last_field_is_truncated
105                                      bit (1) aligned init ("0"b);
106       dcl     cvs_last_field_length_in_bits
107                                      fixed bin (35);
108       dcl     cvs_last_field_length_ptr
109                                      ptr;
110       dcl     cvs_last_field_value_ptr
111                                      ptr;
112       dcl     cvs_length_field_length
113                                      fixed bin (35);
114       dcl     cvs_length_field_ptr   ptr;
115       dcl     cvs_location_of_first_varying_field
116                                      fixed bin (35);
117       dcl     cvs_maximum_field_idx  fixed bin (17);
118       dcl     1 cvs_truncated_field_descriptor
119                                      like arg_descriptor;
120       dcl     cvs_varying_field_idx  fixed bin;
121       dcl     cvs_varying_field_value_offset
122                                      fixed bin (24);
123 
124 /* Based */
125 
126       dcl     cvs_based_real_fix_bin_1u
127                                      based fixed bin (35) unaligned;
128 
129       dcl     cvs_key_string         based (cvs_key_string_ptr) bit (cvs_key_string_length);
130       dcl     cvs_length_field_string
131                                      based (cvs_length_field_ptr) bit (cvs_length_field_length);
132 
133 /* Builtin */
134 
135       dcl     (addbitno, addr, bin, hbound, min, null)
136                                      builtin;
137 
138 /* Controlled */
139 /* Constant */
140 
141       dcl     (
142               BITS_PER_WORD          init (36),
143               BITS_PER_BYTE          init (9),
144               BYTES_PER_WORD         init (4)
145               )                      internal static options (constant) fixed bin (17);
146       dcl     VECTOR_VALUE_IS_IN_VECTOR_FORMAT
147                                      init ("0"b) bit (1) aligned internal static options (constant);
148 
149 /* Entry */
150 
151       dcl     sub_err_               entry () options (variable);
152 
153 /* External */
154 
155       dcl     error_table_$unimplemented_version
156                                      fixed bin (35) ext;
157 
158 /* END OF DECLARATIONS */
159 ^L
160       cvs_key_string_ptr = cvs_p_key_string_ptr;
161       cvs_key_string_length = cvs_p_key_string_length;
162       cvs_last_field_idx = cvs_p_last_field_idx;
163 
164       simple_typed_vector_ptr = cvs_p_simple_typed_vector_ptr;
165       if simple_typed_vector.type ^= SIMPLE_TYPED_VECTOR_TYPE
166       then call
167               sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
168               "^/Expected the simple_typed_vector structure, type ^d;^/Received type ^d instead.",
169               SIMPLE_TYPED_VECTOR_TYPE, simple_typed_vector.type);
170       field_table_ptr = cvs_p_field_table_ptr;
171       if field_table.version ^= FIELD_TABLE_VERSION_3
172       then call
173               sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
174               "^/Expected version ^a of the field_table structure;^/Received ^a instead.", FIELD_TABLE_VERSION_3,
175               field_table.version);
176 
177       cv_p_code = 0;
178       cv_p_vector_equal_to_key = "1"b;
179       cv_p_vector_less_than_key = "0"b;
180 
181       if cvs_last_field_idx = -1                            /* not truncated */
182       then
183          do;
184             cvs_maximum_field_idx = min (hbound (simple_typed_vector.dimension, 1), hbound (field_table.field, 1));
185             cvs_location_of_first_varying_field = field_table.location_of_first_varying_field;
186             cvs_last_field_is_truncated = "0"b;
187          end;
188       else if cvs_last_field_idx > 0
189       then
190          do;
191             cvs_maximum_field_idx = min (cvs_last_field_idx, hbound (simple_typed_vector.dimension, 1));
192             arg_descriptor_ptr = addr (field_table.field (cvs_last_field_idx).descriptor);
193 
194             if (arg_descriptor.type = varying_char_dtype) | (arg_descriptor.type = varying_bit_dtype)
195             then cvs_last_field_is_truncated = "0"b;
196             else if arg_descriptor.type = bit_dtype
197             then
198                do;
199                   if arg_descriptor.size > BITS_PER_WORD + BITS_PER_BYTE
200                   then
201                      do;
202                         cvs_last_field_length_ptr =
203                            addbitno (cvs_key_string_ptr, field_table.field (cvs_last_field_idx).location - 1);
204                         cvs_last_field_value_ptr = addbitno (cvs_last_field_length_ptr, BITS_PER_WORD);
205 
206                         cvs_truncated_field_descriptor.packed = "1"b;
207                         cvs_truncated_field_descriptor.flag = "1"b;
208                         cvs_truncated_field_descriptor.type = bit_dtype;
209                         cvs_truncated_field_descriptor.size = cvs_last_field_length_ptr -> cvs_based_real_fix_bin_1u;
210 
211                         cvs_last_field_length_in_bits = cvs_truncated_field_descriptor.size + BITS_PER_WORD;
212                         cvs_last_field_is_truncated = "1"b;
213                      end;
214                end;
215             else if arg_descriptor.type = char_dtype
216             then
217                do;
218                   if arg_descriptor.size > BYTES_PER_WORD + 1
219                   then
220                      do;
221                         cvs_last_field_length_ptr =
222                            addbitno (cvs_key_string_ptr, field_table.field (cvs_last_field_idx).location - 1);
223                         cvs_last_field_value_ptr = addbitno (cvs_last_field_length_ptr, BITS_PER_WORD);
224 
225                         cvs_truncated_field_descriptor.packed = "1"b;
226                         cvs_truncated_field_descriptor.flag = "1"b;
227                         cvs_truncated_field_descriptor.type = char_dtype;
228                         cvs_truncated_field_descriptor.size = cvs_last_field_length_ptr -> cvs_based_real_fix_bin_1u;
229 
230                         cvs_last_field_length_in_bits =
231                            cvs_truncated_field_descriptor.size * BITS_PER_BYTE + BITS_PER_WORD;
232                         cvs_last_field_is_truncated = "1"b;
233                      end;
234                end;
235             else cvs_last_field_is_truncated = "0"b;
236 
237             if cvs_last_field_is_truncated
238             then cvs_location_of_first_varying_field =
239                     field_table.field (cvs_last_field_idx).location + cvs_last_field_length_in_bits;
240             else cvs_location_of_first_varying_field = field_table.location_of_first_varying_field;
241          end;
242 
243       cvs_varying_field_value_offset = cvs_location_of_first_varying_field - 1;
244                                                             /* 1 is subtracted because locations are */
245                                                             /* 1-based, offsets are 0-based.         */
246 
247 FIELD_LOOP:
248       do cvs_field_idx = 1 to cvs_maximum_field_idx while (cv_p_code = 0 & cv_p_vector_equal_to_key);
249          if cvs_last_field_is_truncated & cvs_field_idx = cvs_last_field_idx
250          then
251             do;
252                cv_p_field_value_ptr = cvs_last_field_value_ptr;
253                cv_p_field_value_length = -1;
254                cv_p_descriptor_ptr = addr (cvs_truncated_field_descriptor);
255             end;
256          else
257             do;
258                cv_p_descriptor_ptr = addr (field_table.field (cvs_field_idx).descriptor);
259                                                             /* Is field varying or non-varying? */
260                if ^(cv_p_descriptor_ptr -> arg_descriptor.type = varying_char_dtype
261                   | cv_p_descriptor_ptr -> arg_descriptor.type = varying_bit_dtype)
262                then
263 PREPARE_NONVARYING_FIELD:
264                   do;
265                      cv_p_field_value_length = -1;
266                      cv_p_field_value_ptr = addbitno (cvs_key_string_ptr, field_table.field (cvs_field_idx).location - 1);
267                   end PREPARE_NONVARYING_FIELD;
268                else
269 PREPARE_VARYING_FIELD:
270                   do;
271                      cvs_length_field_length = field_table.field (cvs_field_idx).length_in_bits;
272                      cvs_length_field_ptr = addbitno (cvs_key_string_ptr, field_table.field (cvs_field_idx).location - 1);
273                      cv_p_field_value_length = bin (cvs_length_field_string, 35, 0);
274 
275                      cvs_field_value_offset = cvs_varying_field_value_offset;
276 
277                      if field_table.field (cvs_field_idx).flags.length_is_in_characters
278                      then cvs_varying_field_value_offset =
279                              cvs_varying_field_value_offset + cv_p_field_value_length * BITS_PER_BYTE;
280                      else cvs_varying_field_value_offset = cvs_varying_field_value_offset + cv_p_field_value_length;
281 
282                      cv_p_field_value_ptr = addbitno (cvs_key_string_ptr, cvs_field_value_offset);
283 
284                   end PREPARE_VARYING_FIELD;
285             end;
286 
287          cv_p_vector_value_ptr = simple_typed_vector.dimension (cvs_field_idx).value_ptr;
288          cv_p_vector_value_length = -1;                     /* length is only needed if vector is in field format */
289 
290          call COMPARE_VALUES (VECTOR_VALUE_IS_IN_VECTOR_FORMAT);
291 
292 /* Actually uses global variables to simulate:
293 
294          call COMPARE_VALUES
295                (VECTOR_VALUE_IS_IN_VECTOR_FORMAT,
296                 cv_p_descriptor_ptr,
297                 cv_p_vector_value_ptr,
298                 cv_p_field_value_ptr, cv_p_field_value_length,
299                 cv_p_vector_equal_to_key, cv_p_vector_less_than_key, cv_p_code);
300 */
301 
302          if cv_p_vector_equal_to_key
303          then if cvs_last_field_is_truncated & cvs_field_idx = cvs_last_field_idx
304               then if cvs_truncated_field_descriptor.size < arg_descriptor.size
305                    then cv_p_vector_equal_to_key = "0"b;
306 
307       end FIELD_LOOP;
308 
309       cvs_p_first_inequal_field_id = cvs_field_idx - bin (^cv_p_vector_equal_to_key);
310 
311       if cvs_maximum_field_idx < hbound (simple_typed_vector.dimension, 1)
312       then cvs_p_vector_equal_to_key = "0"b;                /* The vector is longer than the key, so the */
313                                                             /* comparison cannot be equal. */
314       else cvs_p_vector_equal_to_key = cv_p_vector_equal_to_key;
315 
316       cvs_p_vector_less_than_key = cv_p_vector_less_than_key;
317       cvs_p_code = cv_p_code;
318 
319       return;
320 %page;
321 %include dm_comp_values_proc;
322 %page;
323 %include dm_field_table;
324 %page;
325 %include vu_typed_vector;
326 %page;
327 %include arg_descriptor;
328 %page;
329 %include std_descriptor_types;
330 %page;
331 %include sub_err_flags;
332    end COMPARE_VECTOR_TO_STRING;
333 
334 /* END INCLUDE FILE - dm_comp_vec_str_proc.incl.pl1 */