1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 
 10 /* DESCRIPTION:
 11 
 12    Given the identifier of a control interval (in p_element_id) or a pointer
 13    to a copy of a control interval (p_ci_buffer_ptr), re-arrange the contents
 14    of the control interval so as to maximize the amount of contiguous space in
 15    the free pool, or un-used portion, between the header and slots on one side
 16    and the used portion (where each datum is stored).  The non-buffered
 17    entries must first get the contents of the control interval in a local
 18    buffer (old_ci), compact the contents of the control interval into another
 19    local buffer (new_ci), and finally put the new contents back into the file.
 20    The buffered entries are given a pointer to a buffered control interval
 21    from which to work.  On input, this control interval buffer contains the
 22    contents of the control interval to be compacted; on output, it contains
 23    the new, compacted contents of the control interval.  Therefore, the
 24    buffered entries must first copy the contents of the control interval
 25    buffer into a local buffer (old_ci), then compact the contents back into
 26    the supplied control interval buffer.  The file is not actually updated by
 27    the buffered entries.
 28 
 29         The caller specified the number of datum slots (p_number_of_slots) the
 30    control interval is to have after the compaction.  This allows the caller
 31    to specify more slots than are in the old control interval.
 32 
 33         The replacement entries do not retain the contents of the datum
 34    specified by p_element_id, but do retain the datum's slot.  This is used
 35    when modifying a datum to a size larger than its previous size and larger
 36    than can fit in the current free pool.  One wants the contents, which will
 37    be changed, to be removed by the compaction, to be replaced later with the
 38    new contents.  The non-replacement entries retain each datum.
 39 
 40         If p_basic_control_interval_header_ptr (only in the non-buffered
 41    entries) is non-null, it points to a buffer maintained by the caller in
 42    which to but the contents of the control interval header after the
 43    compaction.  The caller may need some of the information in that header.
 44 */
 45 
 46 /* HISTORY:
 47 Written by Matthew Pierret 06/15/82.
 48      (Mostly copied from cm_compact_and_add.pl1)
 49 Modified:
 50 09/21/82 by Lindsey Spratt:  Added the replacement entry.  This entry is used
 51             to reclaim them the storage associated with the p_element_id'th
 52             slot, rather than create a new slot a p_element_id.  It is called
 53             by cm_put_element.
 54 10/20/82 by Matthew Pierret:  Converted to use file_manager_.
 55 11/03/82 by Matthew Pierret:  Converted to use the BASIC_CI_LAYOUT_1, which
 56             has flags in the datum slots.
 57 11/23/82 by Matthew Pierret:  Added initialization of new_control_interval_buffer
 58             improper initialization was allowing stack garbage to find its way
 59             into the datum slot flags.  Also fully qualified all references
 60             to basic_control_interval with one of new_ci_ptr and old_ci_ptr.
 61 01/07/83 by Matthew Pierret:  Added $buffered & $buffered_replacement entries.
 62 02/03/83 by Matthew Pierret:  Changed to check CI version for $buffered*
 63 01/13/84 by Matthew Pierret:  Added check to make sure that slots are not
 64             inserted in past the end of the new CI's datum_position_table.
 65 09/26/84 by Matthew Pierret:  Beefed up DESCRIPTION section.  Removed un-used
 66             variables. Removed BEGIN_BLOCK, instead declaring the control
 67             interval buffers in the main procedure. Changed to use
 68             file_manager_$simple_(get put), thus removing the ci_parts
 69             structure.
 70 */
 71 
 72 
 73 /****^  HISTORY COMMENTS:
 74   1) change(89-05-10,Dupuis), approve(89-06-06,MCR8112),
 75      audit(89-06-07,Farley), install(89-06-09,MR12.3-1054):
 76      Fixed a bug in the compaction algorithm where it was clobbering free
 77      slots because a loop counter wasn't being updated.
 78                                                    END HISTORY COMMENTS */
 79 
 80 ^L
 81 /* format: style2,ind3 */
 82 
 83 cm_compact:
 84    proc (p_file_opening_id, p_number_of_slots, p_element_id, p_basic_control_interval_header_ptr, p_code);
 85 
 86 /* START OF DECLARATIONS */
 87 /* Parameter */
 88 
 89       dcl     p_ci_buffer_ptr        ptr;
 90       dcl     p_file_opening_id      bit (36) aligned;
 91       dcl     p_number_of_slots      fixed bin;
 92       dcl     p_element_id           bit (36) aligned;
 93       dcl     p_basic_control_interval_header_ptr
 94                                      ptr;
 95       dcl     p_code                 fixed bin (35);
 96 
 97 /* Automatic */
 98 
 99       dcl     code                   fixed bin (35);
100       dcl     ci_length_in_bytes     fixed bin (21);
101       dcl     datum_length_in_bytes  fixed bin (17);
102       dcl     old_datum_offset       fixed bin;
103       dcl     new_datum_offset       fixed bin;
104       dcl     old_slot_idx           fixed bin init (-1);
105       dcl     new_slot_idx           fixed bin init (-1);
106       dcl     new_ci_ptr             ptr;
107       dcl     old_ci_ptr             ptr;
108       dcl     (is_buffered, is_replacement)
109                                      bit (1) aligned;
110 
111       dcl     new_ci                 (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES / BYTES_PER_DOUBLE_WORD) fixed
112                                      bin (71);
113       dcl     old_ci                 (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES / BYTES_PER_DOUBLE_WORD) fixed
114                                      bin (71);
115 
116 /* Based */
117 
118       dcl     based_ci               char (ci_length_in_bytes) based;
119 
120 /* Builtin */
121 
122       dcl     (addr, ceil, divide, hbound, null, string, substr, unspec)
123                                      builtin;
124 
125 /* Controlled */
126 /* Constant */
127 
128       dcl     myname                 init ("cm_compact") char (32) varying internal static options (constant);
129       dcl     BITS_PER_BYTE          fixed bin init (9) int static options (constant);
130       dcl     BYTES_PER_DOUBLE_WORD  fixed bin init (8) int static options (constant);
131       dcl     START_OF_CI_OFFSET     fixed bin (21) init (0) int static options (constant);
132 
133 /* Entry */
134 
135       dcl     file_manager_$simple_get
136                                      entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
137                                      fixed bin (35));
138       dcl     file_manager_$simple_put
139                                      entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
140                                      fixed bin (35));
141       dcl     sub_err_               entry () options (variable);
142 
143 /* External */
144 
145       dcl     dm_error_$unimplemented_ci_version
146                                      ext fixed bin (35);
147 
148 /* END OF DECLARATIONS */
149 ^L
150       is_buffered = "0"b;
151       is_replacement = "0"b;
152       go to JOIN;
153 
154 
155 replacement:
156    entry (p_file_opening_id, p_number_of_slots, p_element_id, p_basic_control_interval_header_ptr, p_code);
157 
158       is_buffered = "0"b;
159       is_replacement = "1"b;
160       go to JOIN;
161 
162 buffered:
163    entry (p_ci_buffer_ptr, p_number_of_slots, p_element_id, p_code);
164 
165       is_buffered = "1"b;
166       is_replacement = "0"b;
167       new_ci_ptr = p_ci_buffer_ptr;
168       go to JOIN;
169 
170 
171 buffered_replacement:
172    entry (p_ci_buffer_ptr, p_number_of_slots, p_element_id, p_code);
173 
174       is_buffered = "1"b;
175       is_replacement = "1"b;
176       new_ci_ptr = p_ci_buffer_ptr;
177       go to JOIN;
178 ^L
179 JOIN:
180       p_code, code = 0;
181       element_id_string = p_element_id;
182 
183       if element_id.control_interval_id = 0
184       then ci_length_in_bytes = CONTROL_INTERVAL_ZERO_ADDRESSABLE_LENGTH_IN_BYTES;
185       else ci_length_in_bytes = CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES;
186 
187       old_ci_ptr = addr (old_ci);
188 
189       if is_buffered
190       then
191          do;
192             call CHECK_CI_VERSION (new_ci_ptr -> basic_control_interval.header.layout_type);
193             unspec (old_ci_ptr -> based_ci) = unspec (new_ci_ptr -> based_ci);
194             unspec (new_ci_ptr -> based_ci) = ""b;
195          end;
196       else
197          do;
198             call file_manager_$simple_get (p_file_opening_id, (element_id.control_interval_id), START_OF_CI_OFFSET,
199                  old_ci_ptr, ci_length_in_bytes, code);
200             if code ^= 0
201             then call ERROR_RETURN (code);
202             call CHECK_CI_VERSION (old_ci_ptr -> basic_control_interval.header.layout_type);
203             new_ci_ptr = addr (new_ci);
204             unspec (new_ci_ptr -> based_ci) = "0"b;
205          end;
206 
207       basic_control_interval_ptr = null;
208 
209       new_datum_offset = ci_length_in_bytes;
210 
211       new_ci_ptr -> basic_control_interval.header = old_ci_ptr -> basic_control_interval.header;
212       new_ci_ptr -> basic_control_interval.header.scattered_free_space = 0;
213       new_ci_ptr -> basic_control_interval.header.number_of_datums = p_number_of_slots;
214 
215       new_slot_idx = 1;
216 PUT_EACH_DATUM_IN_NEW_CI_LOOP:
217       do old_slot_idx = 1 to hbound (old_ci_ptr -> basic_control_interval.datum_position_table, 1)
218            while (new_slot_idx <= hbound (new_ci_ptr -> basic_control_interval.datum_position_table, 1));
219          if new_slot_idx = element_id.index
220          then
221             do;
222                string (new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).flags) = "0"b;
223                new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes = FREE_SLOT;
224                new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).length_in_bits = 0;
225 
226                new_slot_idx = new_slot_idx + 1;
227                if ^is_replacement
228                then if old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).offset_in_bytes
229                          ^= FREE_SLOT
230                     then old_slot_idx = old_slot_idx - 1;   /* The old_slot hasn't been processed yet. old_slot_idx */
231                                                             /* will be incremented back up to the current old_slot at */
232                                                             /* the end of the loop. */
233             end;
234          else if old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).offset_in_bytes = FREE_SLOT
235          then
236 COPY_FREE_SLOT:
237             do;
238                string (new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).flags) = "0"b;
239                new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes = FREE_SLOT;
240                new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).length_in_bits = 0;
241 
242                new_slot_idx = new_slot_idx + 1;
243             end COPY_FREE_SLOT;
244          else
245 COPY_OLD_DATUM:
246             do;
247                datum_length_in_bytes =
248                     ceil (
249                     divide (old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).length_in_bits,
250                     BITS_PER_BYTE, 35, 18));
251 
252                new_datum_offset = new_datum_offset - datum_length_in_bytes;
253 
254                old_datum_offset =
255                     old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).offset_in_bytes;
256                substr (new_ci_ptr -> based_ci, new_datum_offset + 1, datum_length_in_bytes) =
257                     substr (old_ci_ptr -> based_ci, old_datum_offset + 1, datum_length_in_bytes);
258 
259                string (new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).flags) =
260                     string (old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).flags);
261                new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes =
262                     new_datum_offset;
263                new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).length_in_bits =
264                     old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).length_in_bits;
265 
266                new_slot_idx = new_slot_idx + 1;
267 
268             end COPY_OLD_DATUM;
269       end PUT_EACH_DATUM_IN_NEW_CI_LOOP;
270 
271 INIT_NEW_FREE_SLOTS:
272       do new_slot_idx = new_slot_idx to element_id.index - 1;
273 
274          string (new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).flags) = "0"b;
275          new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes = FREE_SLOT;
276          new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).length_in_bits = 0;
277 
278       end INIT_NEW_FREE_SLOTS;
279 
280       if element_id.index = new_slot_idx
281       then new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes = FREE_SLOT;
282 
283       new_ci_ptr -> basic_control_interval.header.start_of_used_space = new_datum_offset;
284 
285       if ^is_buffered
286       then
287          do;
288             call file_manager_$simple_put (p_file_opening_id, (element_id.control_interval_id), START_OF_CI_OFFSET,
289                  new_ci_ptr, ci_length_in_bytes, code);
290             if code ^= 0
291             then call ERROR_RETURN (code);
292             p_basic_control_interval_header_ptr -> basic_control_interval.header =
293                  new_ci_ptr -> basic_control_interval.header;
294          end;
295 
296 MAIN_RETURN:
297       return;
298 
299 
300 ERROR_RETURN:
301    proc (er_p_code);
302 
303       dcl     er_p_code              fixed bin (35);
304 
305       p_code = er_p_code;
306       go to MAIN_RETURN;
307 
308    end ERROR_RETURN;
309 %page;
310 CHECK_CI_VERSION:
311    proc (ccv_p_given_version);
312 
313       dcl     ccv_p_given_version    char (4) aligned;
314 
315       if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
316       then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
317                 "^/Expected version ""^4a"" control interval; received ""^4a"".", BASIC_CI_LAYOUT_1, ccv_p_given_version);
318 
319       return;
320 
321 
322    end CHECK_CI_VERSION;
323 %page;
324 %include dm_cm_basic_ci;
325 %page;
326 %include dm_cm_basic_ci_const;
327 %page;
328 %include dm_element_id;
329 %page;
330 %include dm_ci_lengths;
331 %page;
332 %include sub_err_flags;
333 
334    end cm_compact;