1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4         *                                                         *
  5         *********************************************************** */
  6 
  7 
  8 
  9 
 10 /****^  HISTORY COMMENTS:
 11   1) change(86-02-27,Pierret), approve(86-02-27,MCR7340),
 12      audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
 13      Changed GET_CONTINUATION to correctly use a continued-datum header, not a
 14      continued-continuation-datum header, to get the continuation datum id.
 15   2) change(86-04-22,Pierret), approve(86-04-22,MCR7340),
 16      audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
 17      Removed dm_cm_datum_constants.incl.pl1 as it was not used.
 18                                                    END HISTORY COMMENTS */
 19 
 20 
 21 /* DESCRIPTION
 22 
 23           This routine deletes an element specified by p_element_id.  If using
 24      the Basic Element Storage Method the return value of p_element_id is
 25      the id of the next non-free, non-continuation datum (if there is one in
 26      the collection); otherwise p_element_id is "0"b, meaning that the deleted
 27      element was the last element of the collection.
 28 
 29           Basic ESM elements are deleted by zeroing the slot in which the
 30      containing datum is stored;  Ordered ESM elements are deleted by shifting
 31      slots to the right of the containing datum one slot towards the left.
 32      If this action leaves free slots at the end of the slot table, those slots
 33      are removed and the number of slots is decremented. If there remain any
 34      free slots withinn the table, the free_slot_is_present flag is turned on.
 35 
 36           The zero-on-free option (indicated by p_zero_on_free) is not yet
 37      implemented.
 38 
 39 CONVENTIONS:
 40 
 41      Labels, internal procedure labels and constant names are all in
 42      upper-case. Parameter variables are prefixed with "p_". Variables
 43      declared in subroutine are perfixed with the lowercase initials of the
 44      subroutine name.  Subroutine parameters are prefixed with <initials>_p_.
 45 
 46      When an error is encountered, whether in the main procedure are in a
 47      subroutine, the ERROR_RETURN subroutine is invoked, which sets the
 48      output code p_code and causes a return to the caller of the main
 49      procedure.  For this reason, code checks are unnecessary after control
 50      returns from a subroutine.
 51 */
 52 
 53 /* HISTORY:
 54 Written by Matthew Pierret 04/../82.
 55 Modified:
 56 05/20/82 by Matthew Pierret: Changed to use collection_header instead of
 57             collmgr_header.collection (), and to call cm_get_collection_header.
 58             Added ability to free uninitialized trailing slots.
 59 06/15/82 by Matthew Pierret: Changed to use bci_header, dm_cm_basic_ci.incl.pl1,
 60             ci_parts offset to ignore non-addressable ci header.
 61 08/13/82 by Matthew Pierret:  Added Basic ESM.
 62 09/09/82 by Matthew Pierret:  Changed to return the element_id of the next
 63             element.  Fixed bug in calculation of offset of slots to shift.
 64             Changed datum_slots_buffer to always be based on number_of_slots,
 65             removing number_of_slots_to_shift.
 66 09/10/82 by Lindsey Spratt: Changed to call PUT_HEADER_AND_SLOTS in each of
 67             the freeing cases.  This is necessary because the data being put,
 68             in some cases, is allocated in a begin block and therefore
 69             vanishes at the end of the code for that case.
 70 10/20/82 by Matthew Pierret:  Converted to use file_manager_.
 71 11/10/82 by Matthew Pierret:  Changed to support multi-datum elements, free
 72             control interval if nothing left (BESM only).
 73 02/08/83 by Mathew Pierret:  Upgraded to CM_INFO_VERSION_2. Changed to use
 74             cm_get_bci_header$slot instead of cm_get_header_and_slot.
 75             Changed to return dm_error_$no_element if p_element_id.index = 0.
 76 04/06/83 by Lindsey L. Spratt:  Fixed to use the correct datum header size
 77             when getting the continuation of a multi-datum element.  It was
 78             using the continued-continuation datum header length when it
 79             should have been using the conintued datum header length.
 80             Fixed GET_CONTINUED_CONTINUATION to correctly interpret the datum
 81             header.
 82 07/14/83 by Matthew Pierret:  Essentially re-wrote most of the module to
 83             simplify the code and make the ordered and basic ESMs behave in a
 84             similar fashion.  Now both get the whole slot table always, modify
 85             the slots, check for free slots, decrement the number of datums
 86             and replace the bci_header and slot table.  Both also use
 87             cm_get_id to position.  Also, added an ERROR_RETURN routine which
 88             sets p_code and non-locally goes to the main return statement in
 89             the main procedure.  Internal subroutines use ERROR_RETURN, so
 90             their callers can assume that if control is returned to the
 91             caller, no errors were encountered.  Also, renamed subroutine
 92             variables to be prefixed with the initials of the subroutine.
 93 10/14/83 by Lindsey L. Spratt:  Changed to use cm_get_id$info_header instead
 94             of cm_get_id$header.
 95 02/07/84 by Matthew Pierret:  Changed to use cm_get_id$id instead of
 96             $info_header.  $info_header is now obsolete.  In the future, this
 97             routine should be changed to look at data in control intervals by
 98             getting a pointer to the addressable portion of the control
 99             interval via file_manager_$get_ci_ptr, and should use
100             cm_get_id$ptr.
101 05/21/84 by Matthew Pierret: Renamed include file dm_cm_esm_info to
102             dm_esm_info.
103 09/28/84 by Matthew Pierret: Renamed to cm_delete from cm_free_element in
104             accordance with new naming scheme for operations. Corrected a
105             situation wherein it was possible to free a control interval
106             because there was no datum left after the deletion, but then
107             write into that freed control interval by calling
108             PUT_HEADER_AND_SLOTS. Removed include files from subroutines,
109             adding explicit pointer references in those subroutines to
110             structures that are declared globally. Cleaned up incorrect
111             declarations.  Added use of file_mnager_$simple_get.
112 12/03/84 by Matthew Pierret: Changed to use my_ci_parts instead of
113             automatic_ci_parts_buffer, the former using a "like" to
114             ci_parts.part.  Fixed the improper use of the glogal
115             datum_slot instead of using an explicit pointer reference in
116             PUT_HEADER_AND_SLOTS.
117 12/11/84 by Matthew Pierret:  Initialized my_ci_parts.pad to 0.
118 05/21/85 by Matthew C. Pierret:  Changed GET_CONTINUATION to correctly assume
119             the supplied offset is to the beginning of a continued-datum, not
120             a continued-continuation-datum.  The two have different headers,
121             so incorrect an value was being returned.
122 */
123 ^L
124 /* format: style2,ind3 */
125 
126 cm_delete:
127    proc (p_file_opening_id, p_collection_id, p_element_id, p_zero_on_free, p_code);
128 
129 
130 /* START OF DECLARATIONS */
131 /* Parameter */
132 
133       dcl     p_cm_info_ptr          ptr;
134       dcl     p_file_opening_id      bit (36) aligned;
135       dcl     p_collection_id        bit (36) aligned;
136       dcl     p_element_id           bit (36) aligned;
137       dcl     p_zero_on_free         bit (1) aligned;
138       dcl     p_code                 fixed bin (35);
139 
140 /* Automatic */
141 
142       dcl     code                   fixed bin (35);
143       dcl     1 automatic_bci_header aligned like bci_header;
144       dcl     1 automatic_datum_slot aligned like datum_slot;
145       dcl     1 my_ci_parts          aligned,
146                 2 number_of_ci_parts fixed bin init (0),
147                 2 pad                fixed bin init (0),
148                 2 part               (2) like ci_parts.part;
149 
150       dcl     continuation_datum_id_string
151                                      bit (36) aligned init ("0"b);
152       dcl     next_element_id_string bit (36) aligned init ("0"b);
153 
154       dcl     is_ordered_esm         bit (1) aligned init ("0"b);
155 
156       dcl     first_free_slot_idx    fixed bin (17);
157       dcl     slot_idx               fixed bin (17);
158       dcl     st_number_of_slots     fixed bin (17);
159 
160 /* Based */
161 /* Builtin */
162 
163       dcl     (addr, divide, null, size, unspec)
164                                      builtin;
165 
166 /* Controlled */
167 /*  Constant */
168 
169       dcl     myname                 init ("cm_delete") char (32) varying int static options (constant);
170       dcl     RELATIVE               init ("0"b) bit (1) aligned int static options (constant);
171       dcl     NEXT_ELEMENT           init (1) fixed bin (17) int static options (constant);
172       dcl     BITS_PER_BYTE          init (9) fixed bin int static options (constant);
173       dcl     BYTES_PER_WORD         init (4) fixed bin int static options (constant);
174 
175 /* Entry */
176 
177       dcl     file_manager_$get      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
178       dcl     file_manager_$put      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
179       dcl     file_manager_$simple_get
180                                      entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
181                                      fixed bin (35));
182       dcl     sub_err_               entry () options (variable);
183 
184 /* External */
185 
186       dcl     (
187               dm_error_$end_of_collection,
188               dm_error_$no_element,
189               dm_error_$ci_not_in_collection
190               )                      ext fixed bin (35);
191       dcl     error_table_$unimplemented_version
192                                      ext fixed bin (35);
193 
194 /* END OF DECLARATIONS */
195 ^L
196 /* format: ^indblkcom,indcomtxt */
197 
198       code = 0;
199       call cm_opening_info$get (p_file_opening_id, p_collection_id, cm_info_ptr, code);
200       if code ^= 0
201       then call ERROR_RETURN (code);
202       else go to JOIN;
203 
204 
205 info:
206    entry (p_cm_info_ptr, p_element_id, p_zero_on_free, p_code);
207 
208       code = 0;
209       cm_info_ptr = p_cm_info_ptr;
210       go to JOIN;
211 %page;
212 JOIN:
213       p_code = 0;
214 
215       call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);
216 
217       collection_header_ptr = cm_info.header_ptr;
218       call CHECK_VERSION ("collection_header", collection_header.version, COLLECTION_HEADER_VERSION_2);
219 
220       element_id_string = p_element_id;
221       if element_id.index = 0
222       then call ERROR_RETURN (dm_error_$no_element);
223 
224       bci_header_ptr = addr (automatic_bci_header);
225       datum_slot_ptr = addr (automatic_datum_slot);
226 
227       call cm_get_bci_header$slot (cm_info.file_oid, bci_header_ptr, datum_slot_ptr, element_id_string, code);
228       if code ^= 0
229       then call ERROR_RETURN (code);
230 
231       if bci_header.collection_id ^= cm_info.collection_id
232       then call ERROR_RETURN (dm_error_$ci_not_in_collection);
233 
234       if datum_slot.offset_in_bytes = FREE_SLOT | datum_slot.flags.is_continuation
235       then call ERROR_RETURN (dm_error_$no_element);
236 
237 
238       if collection_header.element_storage_method = ORDERED_ELEMENT_STORAGE_METHOD
239       then is_ordered_esm = "1"b;
240       else is_ordered_esm = "0"b;
241 
242       if datum_slot.is_continued
243       then
244          do;
245 
246          /*** The element is a multi-datum element. Free the trailing
247               datums first. It is necessary to get the id of the first continuation
248               datum out of this initial datum.  The routine cm_delete_cn_datum will
249               return subsequent continuation ids. */
250 
251             continuation_datum_id_string =
252                  GET_CONTINUATION ((element_id.control_interval_id), (datum_slot.offset_in_bytes));
253 
254             do while (continuation_datum_id_string ^= "0"b);
255 
256                call cm_delete_cn_datum (cm_info_ptr, p_zero_on_free, continuation_datum_id_string, code);
257                if code ^= 0
258                then call ERROR_RETURN (code);
259             end;
260 
261          end;
262 
263       st_number_of_slots = bci_header.number_of_datums;
264 
265 BEGIN_BLOCK:
266       begin;
267 
268          dcl     1 slot_table           aligned,
269                    2 slot               (st_number_of_slots) like datum_slot;
270 
271          ci_parts_ptr = addr (my_ci_parts);
272          ci_parts.number_of_parts = 1;
273          call GET_SLOT_TABLE (cm_info.file_oid, (element_id.control_interval_id), addr (slot_table), st_number_of_slots,
274               ci_parts_ptr);
275 
276          if ^is_ordered_esm
277          then
278             do;
279 
280             /*** This is a basic collection. Find the id of the next element, to be returned
281                  to the caller. This must be done before deleteing the specified element. */
282 
283                call cm_get_id$id (cm_info.file_oid, cm_info.collection_id, element_id_string, NEXT_ELEMENT, RELATIVE,
284                     next_element_id_string, code);
285                if code ^= 0
286                then if code = dm_error_$end_of_collection
287                     then code = 0;
288                     else call ERROR_RETURN (code);
289             end;
290 
291          if is_ordered_esm
292          then
293             do;
294 
295             /*** This is an ordered collection. Shift slots one to left and
296                  decrement the number of datums in the control interval. */
297 
298                do slot_idx = element_id.index to bci_header.number_of_datums - 1;
299                   slot_table.slot (slot_idx) = slot_table.slot (slot_idx + 1);
300                end;
301                unspec (slot_table.slot (slot_idx)) = "0"b;
302                bci_header.number_of_datums = bci_header.number_of_datums - 1;
303 
304             end;
305          else /* Simply free the specified slot */
306               unspec (slot_table.slot (element_id.index)) = "0"b;
307 
308 
309          do slot_idx = bci_header.number_of_datums to 1 by -1 while (unspec (slot_table.slot (slot_idx)) = "0"b);
310          end;
311 
312 
313          if ^is_ordered_esm & slot_idx <= 0
314          then
315 FREE_ENTIRE_CI:
316             do;
317 
318             /*** The control interval is empty.  Free it */
319 
320                call cm_free_ci$info (cm_info_ptr, (element_id.control_interval_id), p_zero_on_free, code);
321                if code ^= 0
322                then call ERROR_RETURN (code);
323             end FREE_ENTIRE_CI;
324          else
325 UPDATE_CI:
326             do;
327 
328             /*** There remains at least one datum in the control interval.
329                  Update the number of datums in the bci_header, and the
330                  free_slot_is_resent flag if there remain any free slots.
331                  Then put the modified bci_header and datum_slot_table back
332                  in the control interval. */
333 
334                bci_header.number_of_datums = slot_idx;
335 
336                do first_free_slot_idx = 1 to bci_header.number_of_datums
337                     while (unspec (slot_table.slot (first_free_slot_idx)) ^= ""b);
338                end;
339                if first_free_slot_idx < bci_header.number_of_datums
340                then bci_header.flags.free_slot_is_present = "1"b;
341                else bci_header.flags.free_slot_is_present = "0"b;
342 
343                call PUT_HEADER_AND_SLOTS (cm_info.file_oid, bci_header_ptr, datum_slot_ptr,
344                     (element_id.control_interval_id), ci_parts_ptr);
345 
346             end UPDATE_CI;
347       end BEGIN_BLOCK;
348 
349       if ^is_ordered_esm
350       then p_element_id = next_element_id_string;
351 
352 MAIN_RETURN:
353       return;
354 %page;
355 ERROR_RETURN:
356    proc (er_p_code);
357 
358       dcl     er_p_code              fixed bin (35);
359 
360       p_code = er_p_code;
361       go to MAIN_RETURN;
362 
363    end ERROR_RETURN;
364 %page;
365 CHECK_VERSION:
366    proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);
367 
368       dcl     cv_p_structure_name    char (*);
369       dcl     cv_p_given_version     char (8) aligned;
370       dcl     cv_p_correct_version   char (8) aligned;
371 
372       if cv_p_given_version ^= cv_p_correct_version
373       then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
374                 "^/Expected version ^8a of ^a structure; received ^8a.", cv_p_correct_version, cv_p_structure_name,
375                 cv_p_given_version);
376       else return;
377 
378    end CHECK_VERSION;
379 %page;
380 PUT_HEADER_AND_SLOTS:
381    proc (phas_p_file_opening_id, phas_p_bci_header_ptr, phas_p_datum_slot_ptr, phas_p_control_interval_id,
382         phas_p_ci_parts_ptr);
383 
384       dcl     phas_p_file_opening_id bit (36) aligned;
385       dcl     phas_p_bci_header_ptr  ptr;
386       dcl     phas_p_datum_slot_ptr  ptr;
387       dcl     phas_p_control_interval_id
388                                      fixed bin (27);
389       dcl     phas_p_ci_parts_ptr    ptr;
390       dcl     phas_code              fixed bin (35);
391 
392       phas_code = 0;
393 
394       if phas_p_datum_slot_ptr -> datum_slot.offset_in_bytes = phas_p_bci_header_ptr -> bci_header.start_of_used_space
395       then phas_p_bci_header_ptr -> bci_header.start_of_used_space =
396                 phas_p_bci_header_ptr -> bci_header.start_of_used_space
397                 + BITS_TO_BYTES ((phas_p_datum_slot_ptr -> datum_slot.length_in_bits));
398       else phas_p_bci_header_ptr -> bci_header.scattered_free_space =
399                 phas_p_bci_header_ptr -> bci_header.scattered_free_space
400                 + BITS_TO_BYTES ((phas_p_datum_slot_ptr -> datum_slot.length_in_bits));
401 
402 
403       phas_p_ci_parts_ptr -> ci_parts.number_of_parts = 2;
404       phas_p_ci_parts_ptr -> ci_parts.part (2).offset_in_bytes = 0;
405       phas_p_ci_parts_ptr -> ci_parts.part (2).length_in_bytes = size (bci_header) * BYTES_PER_WORD;
406       phas_p_ci_parts_ptr -> ci_parts.part (2).local_ptr = phas_p_bci_header_ptr;
407 
408       call file_manager_$put (phas_p_file_opening_id, phas_p_control_interval_id, phas_p_ci_parts_ptr, phas_code);
409       if phas_code ^= 0
410       then call ERROR_RETURN (phas_code);
411       else return;
412 
413    end PUT_HEADER_AND_SLOTS;
414 %page;
415 BITS_TO_BYTES:
416    proc (btb_p_bits) returns (fixed bin (17));
417 
418       dcl     btb_p_bits             fixed bin (35);
419 
420       return (divide (btb_p_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0));
421 
422    end BITS_TO_BYTES;
423 %page;
424 GET_CONTINUATION:
425    proc (gc_p_ci, gc_p_offset) returns (bit (36) aligned);
426 
427 /* Given the CI and the offset in bytes within the CI of a continued_datum
428    (i.e., the first datum of a multi-datum element), this routine returns
429    the continuation id in the continued_datum's header. This is the id of
430    the second datum of the multi-datum element. */
431 
432       dcl     gc_p_ci                fixed bin (27);
433       dcl     gc_p_offset            fixed bin (21);
434       dcl     1 gc_continued_datum_header
435                                      aligned like continued_datum.header;
436       dcl     gc_code                fixed bin (35);
437 
438       call file_manager_$simple_get (cm_info.file_oid, gc_p_ci, gc_p_offset, addr (gc_continued_datum_header),
439            (size (gc_continued_datum_header) * BYTES_PER_WORD), gc_code);
440       if gc_code ^= 0
441       then call ERROR_RETURN (gc_code);
442       else return (unspec (gc_continued_datum_header.continuation));
443 
444 
445    end GET_CONTINUATION;
446 %page;
447 GET_SLOT_TABLE:
448    proc (gst_p_file_oid, gst_p_control_interval_id, gst_p_slot_table_ptr, gst_p_slot_table_length_in_words,
449         gst_p_ci_parts_ptr);
450 
451       dcl     gst_p_file_oid         bit (36) aligned;
452       dcl     gst_p_control_interval_id
453                                      fixed bin (27);
454       dcl     gst_p_slot_table_ptr   ptr;
455       dcl     gst_p_slot_table_length_in_words
456                                      fixed bin (17);
457       dcl     gst_p_ci_parts_ptr     ptr;
458 
459       dcl     gst_code               fixed bin (35);
460 
461       gst_p_ci_parts_ptr -> ci_parts.number_of_parts = 1;
462       gst_p_ci_parts_ptr -> ci_parts.part (1).offset_in_bytes = size (bci_header) * BYTES_PER_WORD;
463       gst_p_ci_parts_ptr -> ci_parts.part (1).length_in_bytes = gst_p_slot_table_length_in_words * BYTES_PER_WORD;
464       gst_p_ci_parts_ptr -> ci_parts.part (1).local_ptr = gst_p_slot_table_ptr;
465 
466       call file_manager_$get (gst_p_file_oid, gst_p_control_interval_id, gst_p_ci_parts_ptr, gst_code);
467       if gst_code ^= 0
468       then call ERROR_RETURN (gst_code);
469       else return;
470 
471 
472    end GET_SLOT_TABLE;
473 %page;
474 %include dm_cm_datum;
475 %page;
476 %include dm_cm_info;
477 %page;
478 %include dm_cm_basic_ci;
479 %page;
480 %include dm_cm_basic_ci_const;
481 %page;
482 %include dm_cm_collection_header;
483 %page;
484 %include dm_element_id;
485 %page;
486 %include dm_esm_info;
487 %page;
488 %include dm_ci_parts;
489 %page;
490 %include dm_cm_entry_dcls;
491 %page;
492 %include sub_err_flags;
493 
494    end cm_delete;