



		    cm_allocate_ci.pl1              04/02/87  1313.6rew 04/02/87  1300.0      273294



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */

/* DESCRIPTION:

         This module implements collection_manager_$allocate_control_interval.

         This  routine  allocates  a  control  interval  in a page file using
     either the Unblocked or Blocked Control Interval Storage Method.

          Currently only the Unblocked CISM is supported. Allocating a control
     interval requires finding a free control interval in the allocation map,
     assigning a disk address to a new control interval, initializing that
     control interval, updating the map, updating the collection_header to show
     that the new control interval is the last control interval of the
     collection, and updating the former last control interval's header to
     thread it with the new one. Non-harmful inconsistencies can develop if a
     failure occurs in the middle of this routine, but they are not rolled back
     because future allocations will fix the inconsistency. 
          One non-pasive inconsistency can arise if every step is completed
     except for threading the previous control interval.

     **** This module should be changed to not abort if a deadlock ****
     occurs while attempting to access a file_reservation_map fragment.
     It was set up to skip a fragment if a deadlock or timeout occured,
     but assumed that dm_error_$lock_deadlock and dm_error_$lock_timeout
     would be returned.  Actually, deadlocks are signalled, and file_manager_
    wwaits for a very long time.  This module really needs an interface to
     file_manager_ which does not wait at all.  That is the only way in which 
     it would be practical to implement the skipping of fragments which are
     already locked.
*/

/* HISTORY:

Written by Matthew Pierret, 07/21/82.
Modified:
09/27/82 by Matthew Pierret:  Fixed bug that accidentally set first_control_interval
            equal to last_control_interval.
10/20/82 by Matthew Pierret:  Converted to use file_manager_.  Removed attempts
            to explicitly assign disk addresses to control intervals - this is
            done automatically by fm_$put.
11/23/82 by Lindsey Spratt:  Fixed to set the storage_record_ptr to null in
	  the finish procedure if the storage_record is freed.  Added
	  putting of the storage_record back into the header collection when
	  modified.  Also, added setting of the first_control_interval.
01/03/83 by Lindsey Spratt:  Fixed to call cm_get_info$full_get using
	  cm_info.file_oid and cm_info.collection_id instead of
	  p_file_opening_id and p_collection_id.  Added the info_header
	  entry point.  This entry takes a pointer to an (empty) bci_header
	  and fills in the bci_header for its caller.
	  cm_allocate_overlength_tail needs this.
02/01/83 by Matthew Pierret: Upgraded to support CM_INFO_VERSION_2.
            Changed to report internal inconsistencies via sub_err_.
            Changed to use cm_get_bci_header. Removed allocate_control_interval
            label.
02/23/83 by Matthew Pierret: Changed to use file_reservation_map instead of
            block_map_array.
03/31/83 by Lindsey L. Spratt:  Fixed to initialize the new
            file_reservation_map.element_id to "0"b.
03/31/83 by Lindsey L.  Spratt:  Added distinct setup of the CI which holds
            the new allocation map fragment.  This CI is in the header
            collection, but is not threaded into any list of CI's (e.g., those
            in the header collection).
04/01/83 by Lindsey L. Spratt:  Fixed to set the lowest_ci_number of the new
            map fragment to 1 greater than the ci number of the ci which
	  contains the new map fragment.  The new map fragment CI being the
	  CI which immediately follows the last CI of the previous map
	  fragment.
	  Fixed to fully initialize the fragment_bci_header.  Fixed to set
	  the cm_file_header.number_of_blocks when extending the
            file_reservation_map.  Fixed to leave space in the map_buffer for
            the extension (by 1).  Changed to use the ERROR_RETURN procedure.
04/03/83 by Lindsey L. Spratt:  Fixed to replace the file_reservation_map in
            the file after extending it.
04/29/83 by Matthew Pierret:  Changed to check for
            dm_error_$long_return_element in addition to $long_element, as the
            "get" modules now return the former and the "put" modules return
            the latter.
            Changed to check to see if this is the first control interval of a
            collection (storage_record.first_control_interval is 0), and to not
            attempt to thread the non-existent previous ci in this case.
08/09/83 by Matthew Pierret:  Removed uses of the obsolete dm_data_$area_ptr.
01/24/84 by Matthew Pierret:  Added debugging entriesto trace control interval
            thread modificaitons.
05/21/84 by Matthew Pierret:  Renamed include file dm_cm_cism_info to 
            dm_cism_info.
06/12/84 by Matthew Pierret:  Renamed cm_allocate_element to cm_put,
            cm_put_element to cm_modify.
10/09/84 by Matthew Pierret:  Changed file_manager_$get declaration to take
            a fixed bin (27) control interval number.  Changed ERROR_RETURN
            to accept as input an error code, and changed the module to use
            a local code variable instead of the p_code parameter.
            Changed value of myname to from "cm_allocate_control_interval".
            Added a call to sub_err_ if the CISM is not supported.
            Removed the FINISH procedure - the work it did was unnecessary
            and wrong. Re-hashed the technology for determining
            inconsistencies.
*/


/****^  HISTORY COMMENTS:
  1) change(87-01-15,Hergert), approve(87-04-01,MCR7632),
     audit(87-02-02,Dupuis), install(87-04-02,MR12.1-1020):
     For TR phx20754, changed initialization of bci_header.start_of_used_space
     to be just CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES. It was CIALIB -1
     which caused assumptions of the free space available being on a word
     boundary to be wrong. This caused alignment problems with internal data
     structures depending on this word alignment.
                                                   END HISTORY COMMENTS */



/* format: style2,^indnoniterdo,^indprocbody,ind3,ll79 */
cm_allocate_ci:
   proc (p_file_opening_id, p_collection_id, p_control_interval_number, p_code)
        ;

/* START OF DECLARATIONS */

/* Parameter */

   dcl	 p_file_opening_id	    bit (36) aligned parameter;
   dcl	 p_collection_id	    bit (36) aligned parameter;
   dcl	 p_control_interval_number
			    fixed bin (24) unsigned parameter;
   dcl	 p_bci_header_ptr	    ptr parameter;
   dcl	 p_cm_info_ptr	    ptr parameter;
   dcl	 p_code		    fixed bin (35) parameter;

/* Automatic */

   dcl	 1 automatic_bci_header aligned like bci_header;
   dcl	 1 fragment_bci_header  aligned like bci_header;
   dcl	 automatic_ci_parts_buffer
			    (6) fixed bin (71);	/* Max of 1 part */
   dcl	 1 automatic_cm_file_header
			    aligned like cm_file_header;
   dcl	 map_idx		    fixed bin (17);
   dcl	 code		    fixed bin (35);
   dcl	 control_interval_number
			    fixed bin (27);
   dcl	 free_control_interval_idx
			    fixed bin (17);
   dcl	 number_of_fragments_with_vacancies
			    fixed bin (17);
   dcl	 1 previous_bci_header  aligned like bci_header;
   dcl	 previous_control_interval_number
			    fixed bin (27);

   dcl	 allocated	    bit (1) aligned;
   dcl	 replace_map	    bit (1) aligned;

/* Based */
/* Builtin */

   dcl	 (addr, divide, string, index, length, null, size, substr, unspec)
			    builtin;

/* Constant */

   dcl	 myname		    init ("cm_allocate_ci") char (32) varying
			    int static options (constant);
   dcl	 BYTES_PER_WORD	    init (4) fixed bin (17) int static
			    options (constant);
   dcl	 BITS_PER_WORD	    init (36) fixed bin (17) int static
			    options (constant);
   dcl	 (
	 ATTEMPTING_TO_GET	    init ("1"b),
	 ATTEMPTING_TO_PUT	    init ("0"b)
	 )		    bit (1) aligned int static
			    options (constant);

/* Entry */

   dcl	 sub_err_		    entry () options (variable);
   dcl	 file_manager_$put	    entry (bit (36) aligned, fixed bin (27), ptr,
			    fixed bin (35));
   dcl	 ioa_		    entry () options (variable);

/* Static */

   dcl	 static_trace_thread_switch
			    init ("0"b) bit (1) aligned internal static;

/* External */

   dcl	 (
	 dm_error_$long_element,
	 dm_error_$long_return_element,
	 dm_error_$ci_not_allocated,
	 dm_error_$no_element,
	 dm_error_$misformatted_ci,
	 dm_error_$ci_not_in_collection,
	 dm_error_$unimplemented_cism,
	 error_table_$unimplemented_version
	 )		    ext fixed bin (35);

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */

   p_code, code = 0;
   call cm_opening_info$full_get (p_file_opening_id, p_collection_id,
        cm_info_ptr, code);
   if code ^= 0
   then call ERROR_RETURN (code);
   bci_header_ptr = addr (automatic_bci_header);

   go to JOIN;


info:
   entry (p_cm_info_ptr, p_control_interval_number, p_code);

   p_code, code = 0;
   cm_info_ptr = p_cm_info_ptr;
   bci_header_ptr = addr (automatic_bci_header);

   go to JOIN;

info_header:
   entry (p_cm_info_ptr, p_control_interval_number, p_bci_header_ptr, p_code);

   p_code, code = 0;
   cm_info_ptr = p_cm_info_ptr;
   bci_header_ptr = p_bci_header_ptr;

   go to JOIN;

%page;
JOIN:
   call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);
   collection_header_ptr = cm_info.header_ptr;
   call CHECK_VERSION ("collection_header", collection_header.version,
        COLLECTION_HEADER_VERSION_2);

   p_control_interval_number = 0;

   blocked_storage_record_ptr, unblocked_storage_record_ptr = null;
   if cm_info.storage_record_ptr = null
   then
      do;
      call cm_opening_info$get_storage_record (cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);
   end;

/**** Setup the ci_parts structure for later use in writing bci_header */

   automatic_ci_parts_buffer = 0;
   ci_parts_ptr = addr (automatic_ci_parts_buffer);
   ci_parts.number_of_parts = 1;
   ci_parts.part (1).offset_in_bytes = 0;
   ci_parts.part (1).length_in_bytes = size (bci_header) * BYTES_PER_WORD;


   if collection_header.control_interval_storage_method
        ^= UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
   then call sub_err_ (dm_error_$unimplemented_cism, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/This operation only supports control interval storage method ^d;^/received method ^d."
	   , UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD,
	   collection_header.control_interval_storage_method);
   else
UNBLOCKED:
      do;
      unblocked_storage_record_ptr = cm_info.storage_record_ptr;

   /*** Get the header of the last control interval of the collection exclusively.
        If an exclusive lock cannot be obtained on this control interval, the
        allocation cannot take place, as it must be threaded to the new control
        interval. */

      previous_control_interval_number =
	 unblocked_storage_record.last_control_interval;

      if previous_control_interval_number ^= 0
	 | cm_info.collection_id = HEADER_COLLECTION_ID
      then
         do;
         call cm_get_bci_header (cm_info.file_oid,
	    (previous_control_interval_number), addr (previous_bci_header),
	    code);
         if code ^= 0
         then call ERROR_RETURN (code);
      end;

   /*** Get the allocation map by getting cm_file_header, file_reservation_map and
        then a suitable fragment of the reservation map. */

      call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID,
	 CM_FILE_HEADER_ELEMENT_ID, 0, addr (automatic_cm_file_header),
	 length (unspec (automatic_cm_file_header)), null, ("0"b),
	 cm_file_header_ptr, (0), code);
      if code ^= 0
      then call GET_ERROR_RETURN (code, "cm_file_header",
	      CM_FILE_HEADER_ELEMENT_ID,
	      length (unspec (automatic_cm_file_header)));

      call CHECK_VERSION ("cm_file_header", cm_file_header.version,
	 CM_FILE_HEADER_VERSION_1);

   /*** Before proceeding, initialize the header of the new control interval
        (bci_header), and set up buffers for the file_reservation_map and for one
        fragment. Note that the buffer for file_reservation_map is slightly
        larger than is needed; this is in case the array needs to be extended
        (i.e., there are no available control intervals).
   */

      unspec (bci_header) = "0"b;
      bci_header.layout_type = BASIC_CI_LAYOUT_1;
      bci_header.collection_id = cm_info.collection_id;
      bci_header.start_of_used_space =
	 CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES;
      bci_header.previous_control_interval =
	 unblocked_storage_record.last_control_interval;


      frmf_number_of_control_intervals =
	 cm_file_header.number_of_control_intervals_per_block;
      frm_number_of_fragments = cm_file_header.number_of_blocks;

BEGIN_BLOCK:
      begin;
         dcl     fragment_buffer	(
				divide (
				frmf_number_of_control_intervals,
				BITS_PER_WORD * 2, 17, 0) + 1)
				fixed bin (71);
         dcl     map_buffer		(frm_number_of_fragments + 1) fixed
				bin (71);

      /*** Get file_reservation_map, which contains the element ids of the fragments of
	 the reservation map. The array also contains a flag associated with each
	 entry (no_control_intervals_are_available) which tells if the fragment is
	 full. If the file_reservation_map cannot be gotten, the allocation cannot continue
      */

         call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID,
	    cm_file_header.allocation_map_element_id, 0, addr (map_buffer),
	    length (unspec (map_buffer)), null, ("0"b),
	    file_reservation_map_ptr, (0), code);
         if code ^= 0
         then call GET_ERROR_RETURN (code, "file reservation map",
	         cm_file_header.allocation_map_element_id,
	         length (unspec (map_buffer)));

         allocated, replace_map = "0"b;
         number_of_fragments_with_vacancies = 0;

TRY_EACH_ALLOCATION_FRAGMENT_LOOP:
         do map_idx = 1 to frm_number_of_fragments while (^allocated);

	  if ^file_reservation_map (map_idx).flags
	       .no_control_intervals_are_available
	  then
TRY_THIS_ALLOCATION_FRAGMENT:
	     do;
	     number_of_fragments_with_vacancies =
		number_of_fragments_with_vacancies + 1;

	  /*** Get this fragment. If unavailable because of locking conflict,
	       try the next fragment. If unavailable for any other reason, it can be assumed
	       the problem is not local to the fragment, so give up the allocation.
	  */

	     call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID,
		file_reservation_map (map_idx).element_id, 0,
		addr (fragment_buffer), length (unspec (fragment_buffer)),
		null, "0"b, file_reservation_map_fragment_ptr, (0), code);
	     if code ^= 0
	     then call FILE_MAP_ERROR_RETURN (code, map_idx,
		     file_reservation_map (map_idx).element_id,
		     length (unspec (fragment_buffer)));
	     else
	        do;

	        free_control_interval_idx =
		   index (file_reservation_map_fragment, "0"b);

	        if free_control_interval_idx = 0
	        then
		 do;
		 number_of_fragments_with_vacancies =
		      number_of_fragments_with_vacancies - 1;
		 file_reservation_map (map_idx).flags
		      .no_control_intervals_are_available = "1"b;
		 replace_map = "1"b;
	        end;
	        else
TRY_THIS_CI:
		 do;

		 control_interval_number =
		      file_reservation_map (map_idx)
		      .lowest_numbered_control_interval
		      + free_control_interval_idx - 1;
		 substr (file_reservation_map_fragment,
		      free_control_interval_idx, 1) = "1"b;

	        /*** Try to assign a disk address to the new control interval by writing into
		   it.  If a locking conflict exists, someone else is trying to allocate
		   into this fragment, so give up on the entire fragment. */

		 ci_parts.part (1).local_ptr = bci_header_ptr;

		 call file_manager_$put (cm_info.file_oid,
		      control_interval_number, ci_parts_ptr, code);
		 if code ^= 0
		 then call ERROR_RETURN (code);

	        /*** Put the updated file_reservation_map_fragment. If unsuccessful due to locking conflict,
		   try another fragment. Otherwise it is assumed that the same error will occur
		   no matter what fragment is tried.  */

		 call cm_modify (cm_info.file_oid, HEADER_COLLECTION_ID,
		      file_reservation_map_fragment_ptr, -1,
		      file_reservation_map (map_idx).element_id, (0), code)
		      ;
		 if code ^= 0
		 then call MODIFY_ERROR_RETURN (code,
			 "file reservation map fragment",
			 file_reservation_map (map_idx).element_id);
		 else
		    do;

		 /*** Put the updated collection_header. If unsuccessful, return. The collection
		      will be inconsistent in a non-harmful way, only causing the loss of a
		      control interval, but no data. */

		    if unblocked_storage_record.first_control_interval = 0
		         & cm_info.collection_id ^= HEADER_COLLECTION_ID
		    then unblocked_storage_record.first_control_interval =
			    control_interval_number;

		    unblocked_storage_record.last_control_interval =
		         control_interval_number;

		    call cm_modify (cm_info.file_oid, HEADER_COLLECTION_ID,
		         cm_info.storage_record_ptr, -1,
		         collection_header.storage_record_element_id, (0),
		         code);
		    if code ^= 0
		    then call MODIFY_ERROR_RETURN (code, "storage record",
			    collection_header.storage_record_element_id);

		    call cm_modify (cm_info.file_oid, HEADER_COLLECTION_ID,
		         collection_header_ptr, -1, cm_info.collection_id,
		         (0), code);
		    if code ^= 0
		    then call MODIFY_ERROR_RETURN (code,
			    "collection header", cm_info.collection_id);


		    if previous_control_interval_number ^= 0
		         | cm_info.collection_id = HEADER_COLLECTION_ID
		    then
		       do;

		    /*** Thread in the previous control interval.  This control interval has already
		         been locked exclusively, so a non-zero error code indicates a fatal problem.
		         If such is the case, the colleciton is left inconsistent, since the
		         collection_header thinks that the last control interval is one that is not
		         addressable. */

		       previous_bci_header.next_control_interval =
			  control_interval_number;
		       ci_parts.part (1).local_ptr =
			  addr (previous_bci_header);

		       call file_manager_$put (cm_info.file_oid,
			  previous_control_interval_number, ci_parts_ptr,
			  code);
		       if code ^= 0
		       then call ERROR_RETURN (code);
		    end;

		    allocated = "1"b;

		 end;

	        end TRY_THIS_CI;
	     end;
	  end TRY_THIS_ALLOCATION_FRAGMENT;
         end TRY_EACH_ALLOCATION_FRAGMENT_LOOP;

         if number_of_fragments_with_vacancies > 0
         then
	  do;

	  if replace_map
	  then call cm_modify (cm_info.file_oid, HEADER_COLLECTION_ID,
		  file_reservation_map_ptr, -1,
		  cm_file_header.allocation_map_element_id, (0), (0));
         end;
         else
EXTEND_MAP_AND_ALLOCATE_IN_NEW_FRAGMENT:
	  do;

         /*** This do-group does almost the identical thing as TRY_THIS_ALLOCATION_FRAGMENT,
	    with a few exceptions: Since this is the last attempt, an error at any point
	    aborts the allocation; the file_reservation_map is extended one entry and
	    put back; the control_interval_number is determined by figuring out
	    the highest possible control interval number + 1; and the file_reservation_map_fragment
	    is allocated instead of put because it does not exist yet. */

	  frm_number_of_fragments = frm_number_of_fragments + 1;
	  cm_file_header.number_of_blocks = frm_number_of_fragments;
	  map_idx = frm_number_of_fragments;
	  control_interval_number =
	       file_reservation_map (map_idx - 1)
	       .lowest_numbered_control_interval
	       + frmf_number_of_control_intervals;
	  file_reservation_map (map_idx).lowest_numbered_control_interval =
	       control_interval_number + 1;
	  string (file_reservation_map (map_idx).flags) = "0"b;
	  addr (file_reservation_map (map_idx).element_id)
	       -> element_id.control_interval_id = control_interval_number;
	  addr (file_reservation_map (map_idx).element_id)
	       -> element_id.index = 0;
	  file_reservation_map_fragment = "0"b;
	  substr (file_reservation_map_fragment, 1, 1) = "1"b;
	  control_interval_number = control_interval_number + 1;

         /*** Assign a disk address for the new control interval by writing into the new
	    control interval.  Put the bci_header initialized earlier. */

	  ci_parts.part (1).local_ptr = bci_header_ptr;

	  call file_manager_$put (cm_info.file_oid, control_interval_number,
	       ci_parts_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

         /*** Set up the CI for the new fragment. */

	  unspec (fragment_bci_header) = "0"b;
	  fragment_bci_header.layout_type = BASIC_CI_LAYOUT_1;
	  fragment_bci_header.collection_id = HEADER_COLLECTION_ID;
	  fragment_bci_header.start_of_used_space =
	       CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES;

	  ci_parts.part (1).local_ptr = addr (fragment_bci_header);
	  call file_manager_$put (cm_info.file_oid,
	       (addr (file_reservation_map (map_idx).element_id)
	       -> element_id.control_interval_id), ci_parts_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

         /*** Allocate a new file_reservation_map_fragment. */

	  call cm_put (cm_info.file_oid, HEADER_COLLECTION_ID,
	       file_reservation_map_fragment_ptr,
	       (frmf_number_of_control_intervals),
	       file_reservation_map (map_idx).element_id, (0), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

         /*** Put the updated cm_file_header. */

	  call cm_modify (cm_info.file_oid, HEADER_COLLECTION_ID,
	       cm_file_header_ptr, -1, CM_FILE_HEADER_ELEMENT_ID, (0), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

         /*** Put the revised file_reservation_map. */

	  call cm_modify (cm_info.file_oid, HEADER_COLLECTION_ID,
	       file_reservation_map_ptr,
	       length (unspec (file_reservation_map)),
	       cm_file_header.allocation_map_element_id, (0), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

         /*** Put updated collection_header. */

	  unblocked_storage_record.last_control_interval =
	       control_interval_number;

	  if unblocked_storage_record.first_control_interval = 0
	       & cm_info.collection_id ^= HEADER_COLLECTION_ID
	  then unblocked_storage_record.first_control_interval =
		  control_interval_number;

	  call cm_modify (cm_info.file_oid, HEADER_COLLECTION_ID,
	       cm_info.storage_record_ptr, -1,
	       collection_header.storage_record_element_id, (0), code);
	  if code ^= 0
	  then call MODIFY_ERROR_RETURN (code, "storage record",
		  collection_header.storage_record_element_id);

	  call cm_modify (cm_info.file_oid, HEADER_COLLECTION_ID,
	       cm_info.header_ptr, -1, cm_info.collection_id, (0), code);
	  if code ^= 0
	  then call MODIFY_ERROR_RETURN (code, "collection header",
		  cm_info.collection_id);

	  if previous_control_interval_number ^= 0
	       | cm_info.collection_id = HEADER_COLLECTION_ID
	  then
	     do;

	  /*** Thread in the previous control interval.  This control interval has
	       already been locked exclusively, so a non-zero error code indicates a
	       fatal problem. */

	     previous_bci_header.next_control_interval =
		control_interval_number;
	     ci_parts.part (1).local_ptr = addr (previous_bci_header);

	     call file_manager_$put (cm_info.file_oid,
		previous_control_interval_number, ci_parts_ptr, code);
	     if code ^= 0
	     then call ERROR_RETURN (code);
	  end;

         end EXTEND_MAP_AND_ALLOCATE_IN_NEW_FRAGMENT;
      end BEGIN_BLOCK;
   end UNBLOCKED;

   if static_trace_thread_switch
   then call ioa_ (
	   "Control interval ^d allocated with previous of ^d.^/^8xControl interval ^d changed to have next of ^d."
	   , control_interval_number, bci_header.previous_control_interval,
	   previous_bci_header.next_control_interval);

   p_control_interval_number = control_interval_number;

MAIN_RETURN:
   return;


trace_thread_modifications_on:
   entry ();

   static_trace_thread_switch = "1"b;
   call cm_free_ci$trace_thread_modifications_on ();
   call cm_replace_buffered_ci$trace_thread_modifications_on ();
   return;

trace_thread_modifications_off:
   entry ();

   static_trace_thread_switch = "0"b;
   call cm_free_ci$trace_thread_modifications_off ();
   call cm_replace_buffered_ci$trace_thread_modifications_off ();
   return;

%page;
ERROR_RETURN:
   proc (er_p_code);

   dcl	 er_p_code	    fixed bin (35);

   p_code = er_p_code;
   go to MAIN_RETURN;

   end ERROR_RETURN;


CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

   dcl	 cv_p_structure_name    char (*);
   dcl	 cv_p_given_version	    char (8) aligned;
   dcl	 cv_p_correct_version   char (8) aligned;

   if cv_p_given_version ^= cv_p_correct_version
   then call sub_err_ (error_table_$unimplemented_version, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected version ^8a of ^a structure; received ^8a.",
	   cv_p_correct_version, cv_p_structure_name, cv_p_given_version);
   else return;

   end CHECK_VERSION;
%page;
GET_ERROR_RETURN:
   proc (ger_p_code, ger_p_element_name, ger_p_element_id,
        ger_p_expected_length);

   dcl	 ger_p_code	    fixed bin (35);
   dcl	 ger_p_element_name	    char (*);
   dcl	 ger_p_element_id	    bit (36) aligned;
   dcl	 ger_p_expected_length  fixed bin (35);

   if ger_p_code = dm_error_$long_return_element
   then call sub_err_ (ger_p_code, myname, ACTION_CANT_RESTART, null, 0,
	   "The ^a at CI ^d, slot ^d, is longer than the ^d bits expected.",
	   ger_p_element_name,
	   addr (ger_p_element_id) -> element_id.control_interval_id,
	   addr (ger_p_element_id) -> element_id.index,
	   ger_p_expected_length);
   else if ger_p_code = dm_error_$no_element
   then call sub_err_ (ger_p_code, myname, ACTION_CANT_RESTART, null, 0,
	   "^/The ^a expected at CI ^d, slot ^d, is not there.",
	   ger_p_element_name,
	   addr (ger_p_element_id) -> element_id.control_interval_id,
	   addr (ger_p_element_id) -> element_id.index);
   else if ger_p_code = dm_error_$ci_not_allocated
	   | ger_p_code = dm_error_$ci_not_in_collection
	   | ger_p_code = dm_error_$misformatted_ci
   then call sub_err_ (ger_p_code, myname, ACTION_CANT_RESTART, null, 0,
	   "^/CI ^d is expected to have the ^a at slot ^d.",
	   addr (ger_p_element_id) -> element_id.control_interval_id,
	   ger_p_element_name, addr (ger_p_element_id) -> element_id.index);
   else call ERROR_RETURN (ger_p_code);

   end GET_ERROR_RETURN;
%page;
MODIFY_ERROR_RETURN:
   proc (mer_p_code, mer_p_element_name, mer_p_element_id);

   dcl	 mer_p_code	    fixed bin (35);
   dcl	 mer_p_element_name	    char (*);
   dcl	 mer_p_element_id	    bit (36) aligned;

   if mer_p_code = dm_error_$long_element
   then call sub_err_ (mer_p_code, myname, ACTION_CANT_RESTART, null, 0,
	   "The ^a at CI ^d, slot ^d, did not fit, even though it did not change in size."
	   , mer_p_element_name,
	   addr (mer_p_element_id) -> element_id.control_interval_id,
	   addr (mer_p_element_id) -> element_id.index);
   else if mer_p_code = dm_error_$no_element
   then call sub_err_ (mer_p_code, myname, ACTION_CANT_RESTART, null, 0,
	   "^/The ^a expected at CI ^d, slot ^d, is not there.",
	   mer_p_element_name,
	   addr (mer_p_element_id) -> element_id.control_interval_id,
	   addr (mer_p_element_id) -> element_id.index);
   else if mer_p_code = dm_error_$ci_not_allocated
	   | mer_p_code = dm_error_$ci_not_in_collection
	   | mer_p_code = dm_error_$misformatted_ci
   then call sub_err_ (mer_p_code, myname, ACTION_CANT_RESTART, null, 0,
	   "^/CI ^d is expected to have the ^a at slot ^d.",
	   addr (mer_p_element_id) -> element_id.control_interval_id,
	   mer_p_element_name, addr (mer_p_element_id) -> element_id.index);
   else call ERROR_RETURN (mer_p_code);

   end MODIFY_ERROR_RETURN;

%page;
FILE_MAP_ERROR_RETURN:
   proc (fmer_p_code, fmer_p_fragment_number, fmer_p_element_id,
        fmer_p_expected_length);

   dcl	 fmer_p_code	    fixed bin (35);
   dcl	 fmer_p_fragment_number fixed bin (17);
   dcl	 fmer_p_element_id	    bit (36) aligned;
   dcl	 fmer_p_expected_length fixed bin (35);

   if fmer_p_code = dm_error_$long_return_element
   then call sub_err_ (fmer_p_code, myname, ACTION_CANT_RESTART, null, 0,
	   "File reservation map fragment ^d at CI ^d, slot ^d, is longer than^/the ^d bits expected."
	   , fmer_p_fragment_number,
	   addr (fmer_p_element_id) -> element_id.control_interval_id,
	   addr (fmer_p_element_id) -> element_id.index,
	   fmer_p_expected_length);
   else if fmer_p_code = dm_error_$no_element
   then call sub_err_ (fmer_p_code, myname, ACTION_CANT_RESTART, null, 0,
	   "^/File reservation map fragment ^d is not at the expected location, CI ^d, slot ^d."
	   , fmer_p_fragment_number,
	   addr (fmer_p_element_id) -> element_id.control_interval_id,
	   addr (fmer_p_element_id) -> element_id.index);
   else if fmer_p_code = dm_error_$ci_not_allocated
	   | fmer_p_code = dm_error_$ci_not_in_collection
	   | fmer_p_code = dm_error_$misformatted_ci
   then call sub_err_ (fmer_p_code, myname, ACTION_CANT_RESTART, null, 0,
	   "^/CI ^d is expected to have file reservation map fragment ^d at slot ^d."
	   , addr (fmer_p_element_id) -> element_id.control_interval_id,
	   fmer_p_fragment_number,
	   addr (fmer_p_element_id) -> element_id.index);
   else call ERROR_RETURN (fmer_p_code);

   end FILE_MAP_ERROR_RETURN;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_cm_hdr_col_ids;
%page;
%include dm_cm_info;
%page;
%include dm_cm_file_header;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_storage_record;
%page;
%include dm_cm_reservation_map;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cism_info;
%page;
%include dm_ci_header;
%page;
%include dm_ci_parts;
%page;
%include dm_ci_lengths;
%page;
%include dm_element_id;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;
   end cm_allocate_ci;




		    cm_compact.pl1                  06/09/89  0752.4rew 06/09/89  0747.5      120141



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/* DESCRIPTION:

   Given the identifier of a control interval (in p_element_id) or a pointer
   to a copy of a control interval (p_ci_buffer_ptr), re-arrange the contents
   of the control interval so as to maximize the amount of contiguous space in
   the free pool, or un-used portion, between the header and slots on one side
   and the used portion (where each datum is stored).  The non-buffered
   entries must first get the contents of the control interval in a local
   buffer (old_ci), compact the contents of the control interval into another
   local buffer (new_ci), and finally put the new contents back into the file.
   The buffered entries are given a pointer to a buffered control interval
   from which to work.  On input, this control interval buffer contains the
   contents of the control interval to be compacted; on output, it contains
   the new, compacted contents of the control interval.  Therefore, the
   buffered entries must first copy the contents of the control interval
   buffer into a local buffer (old_ci), then compact the contents back into
   the supplied control interval buffer.  The file is not actually updated by
   the buffered entries.
   
        The caller specified the number of datum slots (p_number_of_slots) the
   control interval is to have after the compaction.  This allows the caller
   to specify more slots than are in the old control interval.
   
        The replacement entries do not retain the contents of the datum
   specified by p_element_id, but do retain the datum's slot.  This is used
   when modifying a datum to a size larger than its previous size and larger
   than can fit in the current free pool.  One wants the contents, which will
   be changed, to be removed by the compaction, to be replaced later with the
   new contents.  The non-replacement entries retain each datum.
   
        If p_basic_control_interval_header_ptr (only in the non-buffered
   entries) is non-null, it points to a buffer maintained by the caller in
   which to but the contents of the control interval header after the
   compaction.  The caller may need some of the information in that header.
*/

/* HISTORY:
Written by Matthew Pierret 06/15/82.
     (Mostly copied from cm_compact_and_add.pl1)
Modified:
09/21/82 by Lindsey Spratt:  Added the replacement entry.  This entry is used
	  to reclaim them the storage associated with the p_element_id'th
	  slot, rather than create a new slot a p_element_id.  It is called
	  by cm_put_element.
10/20/82 by Matthew Pierret:  Converted to use file_manager_.
11/03/82 by Matthew Pierret:  Converted to use the BASIC_CI_LAYOUT_1, which
            has flags in the datum slots.
11/23/82 by Matthew Pierret:  Added initialization of new_control_interval_buffer
            improper initialization was allowing stack garbage to find its way
            into the datum slot flags.  Also fully qualified all references
            to basic_control_interval with one of new_ci_ptr and old_ci_ptr.
01/07/83 by Matthew Pierret:  Added $buffered & $buffered_replacement entries.
02/03/83 by Matthew Pierret:  Changed to check CI version for $buffered*
01/13/84 by Matthew Pierret:  Added check to make sure that slots are not
            inserted in past the end of the new CI's datum_position_table.
09/26/84 by Matthew Pierret:  Beefed up DESCRIPTION section.  Removed un-used
            variables. Removed BEGIN_BLOCK, instead declaring the control
            interval buffers in the main procedure. Changed to use 
            file_manager_$simple_(get put), thus removing the ci_parts
            structure.
*/


/****^  HISTORY COMMENTS:
  1) change(89-05-10,Dupuis), approve(89-06-06,MCR8112),
     audit(89-06-07,Farley), install(89-06-09,MR12.3-1054):
     Fixed a bug in the compaction algorithm where it was clobbering free
     slots because a loop counter wasn't being updated.
                                                   END HISTORY COMMENTS */


/* format: style2,ind3 */

cm_compact:
   proc (p_file_opening_id, p_number_of_slots, p_element_id, p_basic_control_interval_header_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_ci_buffer_ptr	       ptr;
      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_number_of_slots      fixed bin;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_basic_control_interval_header_ptr
			       ptr;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    ci_length_in_bytes     fixed bin (21);
      dcl	    datum_length_in_bytes  fixed bin (17);
      dcl	    old_datum_offset       fixed bin;
      dcl	    new_datum_offset       fixed bin;
      dcl	    old_slot_idx	       fixed bin init (-1);
      dcl	    new_slot_idx	       fixed bin init (-1);
      dcl	    new_ci_ptr	       ptr;
      dcl	    old_ci_ptr	       ptr;
      dcl	    (is_buffered, is_replacement)
			       bit (1) aligned;

      dcl	    new_ci	       (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES / BYTES_PER_DOUBLE_WORD) fixed
			       bin (71);
      dcl	    old_ci	       (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES / BYTES_PER_DOUBLE_WORD) fixed
			       bin (71);

/* Based */

      dcl	    based_ci	       char (ci_length_in_bytes) based;

/* Builtin */

      dcl	    (addr, ceil, divide, hbound, null, string, substr, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("cm_compact") char (32) varying internal static options (constant);
      dcl	    BITS_PER_BYTE	       fixed bin init (9) int static options (constant);
      dcl	    BYTES_PER_DOUBLE_WORD  fixed bin init (8) int static options (constant);
      dcl	    START_OF_CI_OFFSET     fixed bin (21) init (0) int static options (constant);

/* Entry */

      dcl	    file_manager_$simple_get
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    file_manager_$simple_put
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$unimplemented_ci_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

      is_buffered = "0"b;
      is_replacement = "0"b;
      go to JOIN;


replacement:
   entry (p_file_opening_id, p_number_of_slots, p_element_id, p_basic_control_interval_header_ptr, p_code);

      is_buffered = "0"b;
      is_replacement = "1"b;
      go to JOIN;

buffered:
   entry (p_ci_buffer_ptr, p_number_of_slots, p_element_id, p_code);

      is_buffered = "1"b;
      is_replacement = "0"b;
      new_ci_ptr = p_ci_buffer_ptr;
      go to JOIN;


buffered_replacement:
   entry (p_ci_buffer_ptr, p_number_of_slots, p_element_id, p_code);

      is_buffered = "1"b;
      is_replacement = "1"b;
      new_ci_ptr = p_ci_buffer_ptr;
      go to JOIN;

JOIN:
      p_code, code = 0;
      element_id_string = p_element_id;

      if element_id.control_interval_id = 0
      then ci_length_in_bytes = CONTROL_INTERVAL_ZERO_ADDRESSABLE_LENGTH_IN_BYTES;
      else ci_length_in_bytes = CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES;

      old_ci_ptr = addr (old_ci);

      if is_buffered
      then
         do;
	  call CHECK_CI_VERSION (new_ci_ptr -> basic_control_interval.header.layout_type);
	  unspec (old_ci_ptr -> based_ci) = unspec (new_ci_ptr -> based_ci);
	  unspec (new_ci_ptr -> based_ci) = ""b;
         end;
      else
         do;
	  call file_manager_$simple_get (p_file_opening_id, (element_id.control_interval_id), START_OF_CI_OFFSET,
	       old_ci_ptr, ci_length_in_bytes, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  call CHECK_CI_VERSION (old_ci_ptr -> basic_control_interval.header.layout_type);
	  new_ci_ptr = addr (new_ci);
	  unspec (new_ci_ptr -> based_ci) = "0"b;
         end;

      basic_control_interval_ptr = null;

      new_datum_offset = ci_length_in_bytes;

      new_ci_ptr -> basic_control_interval.header = old_ci_ptr -> basic_control_interval.header;
      new_ci_ptr -> basic_control_interval.header.scattered_free_space = 0;
      new_ci_ptr -> basic_control_interval.header.number_of_datums = p_number_of_slots;

      new_slot_idx = 1;
PUT_EACH_DATUM_IN_NEW_CI_LOOP:
      do old_slot_idx = 1 to hbound (old_ci_ptr -> basic_control_interval.datum_position_table, 1)
	 while (new_slot_idx <= hbound (new_ci_ptr -> basic_control_interval.datum_position_table, 1));
         if new_slot_idx = element_id.index
         then
	  do;
	     string (new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).flags) = "0"b;
	     new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes = FREE_SLOT;
	     new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).length_in_bits = 0;

	     new_slot_idx = new_slot_idx + 1;
	     if ^is_replacement
	     then if old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).offset_in_bytes
		     ^= FREE_SLOT
		then old_slot_idx = old_slot_idx - 1;	/* The old_slot hasn't been processed yet. old_slot_idx */
						/* will be incremented back up to the current old_slot at */
						/* the end of the loop. */
	  end;
         else if old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).offset_in_bytes = FREE_SLOT
         then
COPY_FREE_SLOT:
	  do;
	     string (new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).flags) = "0"b;
	     new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes = FREE_SLOT;
	     new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).length_in_bits = 0;

	     new_slot_idx = new_slot_idx + 1;
	  end COPY_FREE_SLOT;
         else
COPY_OLD_DATUM:
	  do;
	     datum_length_in_bytes =
		ceil (
		divide (old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).length_in_bits,
		BITS_PER_BYTE, 35, 18));

	     new_datum_offset = new_datum_offset - datum_length_in_bytes;

	     old_datum_offset =
		old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).offset_in_bytes;
	     substr (new_ci_ptr -> based_ci, new_datum_offset + 1, datum_length_in_bytes) =
		substr (old_ci_ptr -> based_ci, old_datum_offset + 1, datum_length_in_bytes);

	     string (new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).flags) =
		string (old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).flags);
	     new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes =
		new_datum_offset;
	     new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).length_in_bits =
		old_ci_ptr -> basic_control_interval.datum_position_table (old_slot_idx).length_in_bits;

	     new_slot_idx = new_slot_idx + 1;

	  end COPY_OLD_DATUM;
      end PUT_EACH_DATUM_IN_NEW_CI_LOOP;

INIT_NEW_FREE_SLOTS:
      do new_slot_idx = new_slot_idx to element_id.index - 1;

         string (new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).flags) = "0"b;
         new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes = FREE_SLOT;
         new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).length_in_bits = 0;

      end INIT_NEW_FREE_SLOTS;

      if element_id.index = new_slot_idx
      then new_ci_ptr -> basic_control_interval.datum_position_table (new_slot_idx).offset_in_bytes = FREE_SLOT;

      new_ci_ptr -> basic_control_interval.header.start_of_used_space = new_datum_offset;

      if ^is_buffered
      then
         do;
	  call file_manager_$simple_put (p_file_opening_id, (element_id.control_interval_id), START_OF_CI_OFFSET,
	       new_ci_ptr, ci_length_in_bytes, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  p_basic_control_interval_header_ptr -> basic_control_interval.header =
	       new_ci_ptr -> basic_control_interval.header;
         end;

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^4a"" control interval; received ""^4a"".", BASIC_CI_LAYOUT_1, ccv_p_given_version);

      return;


   end CHECK_CI_VERSION;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_element_id;
%page;
%include dm_ci_lengths;
%page;
%include sub_err_flags;

   end cm_compact;




		    cm_compact_ci.pl1               01/04/85  0947.4re  01/03/85  1148.2       58509



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

         This module implements collection_manager_$compact_control_interval.

         Given an identifier of  a  control interval in a file, re-arrange the
     contents of the control interval so as to concentrate  all  of  the  free
     space  in one contiguous area of the control interval.  This is necessary
     at times to recover scattered free space and is known as  compacting  the
     control  interval.    In normal use of collection_manager_, this entry is
     never needed.  It is only used by applications which attempt at their own
     risk to make simple modifications  to  control  intervals  without  going
     through collection_manager_.
*/

/* HISTORY:

Written by Matthew Pierret, 04/03/84.
Modified:
09/26/84 by Matthew Pierret:  Changed to use file_manager_$simple_put, thus
            removing the need for the ci_parts structure.  Added
            CHECK_CI_VERSION to verify the correctness of the control interval
            layout type.
*/

/* format: style2,ind3 */

cm_compact_ci:
   proc (p_file_opening_id, p_control_interval_id, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned;	/*is the opening identifier of the file.*/
      dcl	    p_control_interval_id  fixed bin (24) uns;	/* identifies a control interval to be compacted. */
      dcl	    p_code	       fixed bin (35);	/*is a standard system error code.*/

/* Automatic */

      dcl	    ci_id		       fixed bin (24) uns;
      dcl	    ci_length_in_bytes     fixed bin (21) init (-1);
      dcl	    code		       fixed bin (35) init (0);
      dcl	    datum_length_in_bytes  fixed bin (35) init (-1);
      dcl	    file_opening_id	       bit (36) aligned;
      dcl	    local_ci_buffer	       (512) fixed bin (71) init ((512) 0);
      dcl	    new_datum_offset_in_bytes
			       fixed bin (35);
      dcl	    new_ci_ptr	       ptr init (null);
      dcl	    new_datum_ptr	       ptr init (null);
      dcl	    new_slot_ptr	       ptr init (null);
      dcl	    old_ci_ptr	       ptr init (null);
      dcl	    old_datum_ptr	       ptr init (null);
      dcl	    old_slot_ptr	       ptr init (null);
      dcl	    slot_idx	       fixed bin;
      dcl	    slot_offset_in_bytes   fixed bin init (-1);

/* Based */

      dcl	    datum_string	       char (datum_length_in_bytes) unal based;
      dcl	    1 new_slot	       aligned like datum_slot based (new_slot_ptr);
      dcl	    1 old_slot	       aligned like datum_slot based (old_slot_ptr);

/* Builtin */

      dcl	    (addcharno, addr, ceil, divide, null)
			       builtin;

/* Constant */

      dcl	    myname	       init ("cm_compact_ci") char (32) varying internal static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin internal static options (constant);
      dcl	    BYTES_PER_WORD	       init (4) fixed bin internal static options (constant);
      dcl	    START_OF_CI_OFFSET     init (0) fixed bin (21) internal static options (constant);

/* Entry */

      dcl	    file_manager_$get_ci_ptr
			       entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    file_manager_$simple_put
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$unimplemented_ci_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      file_opening_id = p_file_opening_id;

      ci_id = p_control_interval_id;

      call file_manager_$get_ci_ptr (file_opening_id, (ci_id), old_ci_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);
      else call CHECK_CI_VERSION (old_ci_ptr -> bci_header.layout_type);

      new_ci_ptr = addr (local_ci_buffer);
      new_ci_ptr -> bci_header = old_ci_ptr -> bci_header;

      if ci_id = 0
      then ci_length_in_bytes = CONTROL_INTERVAL_ZERO_ADDRESSABLE_LENGTH_IN_BYTES;
      else ci_length_in_bytes = CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES;

      new_datum_offset_in_bytes = ci_length_in_bytes;

      slot_offset_in_bytes = DATUM_POSITION_TABLE_OFFSET_IN_BYTES;

      do slot_idx = 1 to old_ci_ptr -> bci_header.number_of_datums;

         old_slot_ptr = addcharno (old_ci_ptr, slot_offset_in_bytes);
         new_slot_ptr = addcharno (new_ci_ptr, slot_offset_in_bytes);

         new_slot = old_slot;

         if old_slot.offset_in_bytes ^= FREE_SLOT
         then
	  do;
	     datum_length_in_bytes = ceil (divide (old_slot.length_in_bits, BITS_PER_BYTE, 35, 18));

	     new_datum_offset_in_bytes = new_datum_offset_in_bytes - datum_length_in_bytes;
	     new_slot.offset_in_bytes = new_datum_offset_in_bytes;

	     new_datum_ptr = addcharno (new_ci_ptr, new_slot.offset_in_bytes);
	     old_datum_ptr = addcharno (old_ci_ptr, old_slot.offset_in_bytes);

	     new_datum_ptr -> datum_string = old_datum_ptr -> datum_string;

	  end;

         slot_offset_in_bytes = slot_offset_in_bytes + BYTES_PER_WORD;

      end;

      new_ci_ptr -> bci_header.start_of_used_space = new_datum_offset_in_bytes;
      new_ci_ptr -> bci_header.scattered_free_space = 0;

      call file_manager_$simple_put (file_opening_id, (ci_id), START_OF_CI_OFFSET, new_ci_ptr, ci_length_in_bytes, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      p_code = 0;
MAIN_RETURN:
      return;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH ();
      go to MAIN_RETURN;

   end ERROR_RETURN;

FINISH:
   proc ();

   end FINISH;



CHECK_CI_VERSION:
   proc (ccv_p_version_received);

      dcl	    ccv_p_version_received char (4) aligned;

      if ccv_p_version_received ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null (), 0,
	      "^/Expected version ^4a; received version ^4a.", BASIC_CI_LAYOUT_1, ccv_p_version_received);
      else return;

   end CHECK_CI_VERSION;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_ci_lengths;
%page;
%include sub_err_flags;
   end cm_compact_ci;




		    cm_create_collection.pl1        04/04/85  1112.8r w 04/04/85  0912.4      116676



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

          This routine creates a collection. Basically this consists of the
     following steps:
     1) initialize and store a collection_header structure as a regular
     element in the header collection.  The element id of this element is
     the collection's id.
     2) initialize and store a storage record.  Depending on the requested
     control interval storage method, this will either be an
     unblocked_storage_record structure or a blocked_storage_record structure.
     3) Add the new collection id to the collection_id_table structure and
     put it back in the header collection. The CIT is infinitely (nearly)
     extendable.
     4) Update the number of collections in the cm_file_header structure and
     put it back in the header collection.
*/

/* HISTORY:
Written by Matthew Pierret.
Modified:
03/26/82 by Matthew Pierret: Fixed a bug which used wrong value to signify
            beginning-of-element to put_element.
            Also fixed bug that tried to put, instead of allocate, the 
            collmgr_header the first time around.
            Extended collmgr_header to contain an entry for the header 
            collection, initialized the first tiem this module is called.
04/16/82 by Matthew Pierret: Made to set the thread_control_intervals flag.
04/21/82 by Matthew Pierret: Removed code to create collmgr_header if not found.
            This function has been moved to cm_init_ci_0, which is called by
            page_file_manager_$create.
05/19/82 by Matthew Pierret: Changed collmgr_header to contain an array of
            element ids "pointing" to collection_header's, each stored as an
            element in the header collection.
06/15/82 by Matthew Pierret: Changed to use bci_header, dm_cm_basic_ci.incl,
            new calling sequence to cm_put_element.
07/28/82 by Matthew Pierret: Adjusted for extensibility of collmgr_header.
10/12/82 by Matthew Pierret:  Fixed bug that truncated collection_id_table.
11/03/82 by Matthew Pierret:  Changed to use version 2 of collection_header,
            separate element for storage element, cm_file_header instead of
            collmgr_header, opening info (cm_info).
12/03/82 by Lindsey Spratt:  Changed to set the collection_id_table_ptr when
            there are no collections.  It was just being used uninitialized.
04/29/83 by Matthew Pierret: Removed some unused variables.
05/21/84 by Matthew Pierret: Renamed include files dm_cm_(esm csim)_info
            to dm_(esm cism)_info. Added ERROR_RETURN procedure. Added version
            checks for the *esm_info and *cism_info structures.
06/12/84 by Matthew Pierret: Re-named cm_put_element to cm_modify,
            cm_allocate_element to cm_put.
09/26/84 by Matthew Pierret: Moved declaration of et_$unimplemented_version
            to the main procedure.
*/


/* format: style2,ind3 */

cm_create_collection:
   proc (p_file_opening_id, p_cism_info_ptr, p_esm_info_ptr, p_collection_id, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_cism_info_ptr	       ptr;
      dcl	    p_esm_info_ptr	       ptr;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    1 automatic_collection_header
			       aligned like collection_header;
      dcl	    1 automatic_cm_file_header
			       aligned like cm_file_header;
      dcl	    automatic_storage_record_buffer
			       (6) fixed bin (71) init (0, 0, 0, 0, 0, 0);
      dcl	    code		       fixed bin (35);
      dcl	    collection_id	       bit (36) aligned;
      dcl	    collection_entry_idx   fixed bin;
      dcl	    collection_id_table_length_in_dwords
			       fixed bin (17);
      dcl	    collection_id_table_length_in_bits
			       fixed bin (35);

/* Based */
/* Builtin */

      dcl	    (length, unspec, null, addr, divide)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    FULL_LENGTH_OF_ELEMENT fixed bin (35) init (-1);
      dcl	    BITS_PER_BYTE	       fixed bin init (4);
      dcl	    BITS_PER_WORD	       fixed bin init (36);
      dcl	    NO_HEADER_RECORD       bit (36) aligned init ("0"b);
      dcl	    myname	       init ("cm_create_collection") char (20);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$unimplemented_cism
			       ext fixed bin (35);
      dcl	    dm_error_$unimplemented_esm
			       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code, code = 0;

      call cm_opening_info$get (p_file_opening_id, HEADER_COLLECTION_ID, cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      unblocked_cism_info_ptr = p_cism_info_ptr;
      call CHECK_VERSION ("cism_info", unblocked_cism_info.version, CISM_INFO_VERSION_1);
      basic_esm_info_ptr = p_esm_info_ptr;
      call CHECK_VERSION ("cism_info", basic_esm_info.version, ESM_INFO_VERSION_1);

      collection_id = "0"b;

      unspec (automatic_cm_file_header) = "0"b;
      unspec (automatic_collection_header) = "0"b;

/*
     Get the cm_file_header.  
*/

      call cm_get_element (cm_info.file_oid, cm_info.collection_id, CM_FILE_HEADER_ELEMENT_ID, 0,
	 addr (automatic_cm_file_header), length (unspec (automatic_cm_file_header)), null, ("0"b), cm_file_header_ptr,
	 (0), code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call CHECK_VERSION ("cm_file_header", cm_file_header.version, CM_FILE_HEADER_VERSION_1);

/*
     Set up space for the collection_id_table. Each collection id takes up one
     word in the collection_id_table and one may be added for the new
     collection.
*/

      collection_id_table_length_in_dwords = divide (cm_file_header.number_of_collections, 2, 17, 0) + 1;
      collection_id_table_length_in_bits = cm_file_header.number_of_collections * BITS_PER_WORD;

BEGIN_BLOCK:
      begin;

         dcl     automatic_cit_buffer	(collection_id_table_length_in_dwords) fixed bin (71);

         automatic_cit_buffer = 0;
         cit_number_of_collections = cm_file_header.number_of_collections;

         if cm_file_header.number_of_collections > 0
         then call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID, cm_file_header.collection_id_table_element_id,
	         0, addr (automatic_cit_buffer), collection_id_table_length_in_bits, null, ("0"b),
	         collection_id_table_ptr, (0), code);
         else collection_id_table_ptr = addr (automatic_cit_buffer);
         if code ^= 0
         then call ERROR_RETURN (code);

/*
    Find a free slot in the collection_id_table, extending the table by one if
    necessary.
*/

         do collection_entry_idx = 1 to cm_file_header.number_of_collections
	    while (collection_id_table (collection_entry_idx) ^= "0"b);
         end;

         if collection_entry_idx > cm_file_header.number_of_collections
         then
	  do;
	     collection_id_table_length_in_bits = collection_id_table_length_in_bits + BITS_PER_WORD;
	     cit_number_of_collections = cm_file_header.number_of_collections + 1;
	     cm_file_header.number_of_collections = cit_number_of_collections;

	  end;

/* 
     Initialize the collection_header for the new collection from the supplied
     information.
*/

         collection_header_ptr = addr (automatic_collection_header);
         collection_header.version = COLLECTION_HEADER_VERSION_2;
         collection_header.control_interval_storage_method = unblocked_cism_info.type;
         collection_header.element_storage_method = basic_esm_info.type;

         if basic_esm_info.type = BASIC_ELEMENT_STORAGE_METHOD
         then
BASIC_ESM:
	  do;
	     collection_header.flags.fixed_size_elements = basic_esm_info.flags.fixed_length;
	     collection_header.flags.thread_elements = basic_esm_info.flags.threaded;
	     collection_header.flags.must_be_zero1 = "0"b;
	     collection_header.maximum_element_size = basic_esm_info.maximum_element_length;

	  end BASIC_ESM;

         else if basic_esm_info.type = ORDERED_ELEMENT_STORAGE_METHOD
         then
ORDERED_ESM:
	  do;
	     ordered_esm_info_ptr = p_esm_info_ptr;
	     collection_header.flags.fixed_size_elements = ordered_esm_info.flags.fixed_length;
	     collection_header.flags.thread_elements = "0"b;
	     collection_header.flags.must_be_zero1 = "0"b;
	     collection_header.maximum_element_size = ordered_esm_info.maximum_element_length;

	  end ORDERED_ESM;

         else call sub_err_ (dm_error_$unimplemented_esm, myname, ACTION_CANT_RESTART, null, 0,
	         "^/This routine does not implement element storage method ^d.", basic_esm_info.type);


         if unblocked_cism_info.type = UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
         then
UNBLOCKED:
	  do;
	     unblocked_storage_record_ptr = addr (automatic_storage_record_buffer);

	     unblocked_storage_record.first_control_interval = 0;
	     unblocked_storage_record.last_control_interval = 0;

	     collection_header.flags.thread_control_intervals = "1"b;

	     call cm_put$info (cm_info_ptr, unblocked_storage_record_ptr, length (unspec (unblocked_storage_record)),
		collection_header.storage_record_element_id, (0), code);
	     if code ^= 0
	     then call ERROR_RETURN (code);

	  end UNBLOCKED;

         else if unblocked_cism_info.type = BLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
         then
BLOCKED:
	  do;
	     call sub_err_ (dm_error_$unimplemented_cism, myname, ACTION_CANT_RESTART, null, 0,
		"^/This routine does not implement control interval storage method ^d.", unblocked_cism_info.type);
						/* Not yet anyway */

	     blocked_cism_info_ptr = p_cism_info_ptr;
	     blocked_storage_record_ptr = addr (automatic_storage_record_buffer);

	     blocked_storage_record.last_control_interval = 0;
	     blocked_storage_record.number_of_blocks = 1;
	     blocked_storage_record.number_of_control_intervals_per_block =
		blocked_cism_info.number_of_control_intervals_per_block;

	     call cm_put$info (cm_info_ptr, unblocked_storage_record_ptr, length (unspec (blocked_storage_record)),
		collection_header.storage_record_element_id, (0), code);
	     if code ^= 0
	     then call ERROR_RETURN (code);

	  end BLOCKED;

         else call sub_err_ (dm_error_$unimplemented_cism, myname, ACTION_CANT_RESTART, null, 0,
	         "^/This routine does not implement control interval storage method ^d.", unblocked_cism_info.type);

/* Allocate a new element and put the new collection_header in it. */

         call cm_put$info (cm_info_ptr, collection_header_ptr, length (unspec (collection_header)), collection_id, (0),
	    code);
         if code ^= 0
         then call ERROR_RETURN (code);

/* Put back the table of collection_header element_ids, with the new id */

         collection_id_table (collection_entry_idx) = collection_id;

         call cm_modify$info (cm_info_ptr, collection_id_table_ptr, collection_id_table_length_in_bits,
	    cm_file_header.collection_id_table_element_id, (0), code);
         if code ^= 0
         then call ERROR_RETURN (code);

/* Put the cm_file_header. */

         call cm_modify$info (cm_info_ptr, cm_file_header_ptr, FULL_LENGTH_OF_ELEMENT, CM_FILE_HEADER_ELEMENT_ID, (0),
	    code);
         if code ^= 0
         then call ERROR_RETURN (code);


      end BEGIN_BLOCK;

      p_collection_id = collection_id;
      p_code = code;

MAIN_RETURN:
      return;
%page;
ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;

%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", cv_p_correct_version,
	      cv_p_structure_name, cv_p_given_version);
      else return;

   end CHECK_VERSION;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_cm_hdr_col_ids;
%page;
%include dm_cm_info;
%page;
%include dm_cm_file_header;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_storage_record;
%page;
%include dm_cism_info;
%page;
%include dm_esm_info;
%page;
%include dm_element_id;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_create_collection;




		    cm_create_file.pl1              01/04/85  0947.4re  01/03/85  1148.3      116487



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

          This routine creates a file and formats control interval zero
     for maintenance by collection_manager_. Creating the file consists
     solely of calling file_manager_$create_open. The format of control
     interval zero is a basic_control_interval (see dm_cm_basic_ci.incl.pl1)
     with the collection_header of collection zero (the header collection)
     taking up slot one, and the header for all collections, collmgr_header,
     taking up slot two.
     */

/* HISTORY:

Written by Matthew Pierret 08/04/82.
Modified:
11/03/82 by Matthew Pierret:  Changed to use cm_file_header (instead of 
            collmgr_header), new format CI (BASIC_CI_LAYOUT_1) which does
            not use datum headers.
12/01/82 by Lindsey Spratt:  Changed to set the storage_record_element_id in
	  the collection_header.
02/23/83 by Matthew Pierret: Changed to use file_reservation_map instead of
            block_map_array.
05/21/84 by Matthew Pierret: Renamed include files dm_cm_(esm cism)_info to
            dm_(esm cism)_info.  Added ERROR_RETURN procedure.
09/26/84 by Matthew Pierret: Changed to use file_manger_$simple_put.
            Removed unused variable declarations.  Changed to use addcharno
            instead of addr(substr()).
*/


/* format: style2,ind3 */

cm_create_file:
   proc (p_file_dir, p_file_name, p_file_create_info_ptr, p_file_opening_id, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_dir	       char (*);
      dcl	    p_file_name	       char (*);
      dcl	    p_file_create_info_ptr ptr;
      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    code		       fixed bin (35) init (0);
      dcl	    file_opening_id	       bit (36) aligned init ("0"b);
      dcl	    control_interval_zero  char (CONTROL_INTERVAL_ZERO_ADDRESSABLE_LENGTH_IN_BYTES) aligned;
      dcl	    control_interval_one   char (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES) aligned;
      dcl	    collection_header_length_in_bytes
			       fixed bin (17);
      dcl	    cm_file_header_length_in_bytes
			       fixed bin (17);
      dcl	    based_byte_string_ptr  ptr;
      dcl	    bbs_length	       fixed bin (17);

      dcl	    1 initial_file_reservation_map
			       aligned like file_reservation_map;

/* Based */

      dcl	    datum_header_string    bit (9) unaligned based;
      dcl	    based_byte_string      char (bbs_length) unaligned based (based_byte_string_ptr);

/* Builtin */

      dcl	    (addcharno, addr, size, substr, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    BYTES_PER_WORD	       fixed bin init (4) int static options (constant);
      dcl	    BITS_PER_BYTE	       fixed bin init (9) int static options (constant);
      dcl	    BITS_PER_WORD	       fixed bin init (36) int static options (constant);
      dcl	    myname	       init ("cm_create_file") char (32) varying int static options (constant);
      dcl	    MAX_ELEMENT_SIZE       fixed bin (35) init (999999) int static options (constant);
      dcl	    ALLOCATION_MAP_ELEMENT_ID
			       bit (36) aligned init ("000000010001"b3) int static options (constant);
      dcl	    COLLECTION_ID_TABLE_ELEMENT_ID
			       bit (36) aligned init ("000000000004"b3) int static options (constant);
      dcl	    BLOCK_MAP_ARRAY_ELEMENT_ID
			       bit (36) aligned init ("000000000005"b3) int static options (constant);

      dcl	    INITIAL_ALLOCATION_MAP_LENGTH_IN_BYTES
			       fixed bin (17) init (116) int static options (constant);
      dcl	    DEFAULT_NUMBER_OF_CONTROL_INTERVALS_PER_BLOCK
			       fixed bin (17) init (1024) int static options (constant);
      dcl	    DEFAULT_STORAGE_RECORD_ELEMENT_ID
			       init ("000000000006"b3) bit (36) aligned internal static options (constant);
      dcl	    START_OF_CI_OFFSET     init (0) fixed bin (21) internal static options (constant);

/* Entry */

      dcl	    file_manager_$create_open
			       entry (char (*), char (*), ptr, bit (36) aligned, fixed bin (35));
      dcl	    file_manager_$delete_close
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    file_manager_$simple_put
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));

/* External */

      dcl	    (
	    dm_error_$file_already_exists,
	    dm_error_$file_already_open
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code, code = 0;
      p_file_opening_id = "0"b;
      frm_number_of_fragments = 0;			/* To silence the compiler */

      call file_manager_$create_open (p_file_dir, p_file_name, p_file_create_info_ptr, file_opening_id, code);
      if code ^= 0
      then
         do;
	  if code = dm_error_$file_already_exists | code = dm_error_$file_already_open
	  then p_file_opening_id = file_opening_id;
	  call ERROR_RETURN (code);
         end;

      collection_header_length_in_bytes = size (collection_header) * BYTES_PER_WORD;
      cm_file_header_length_in_bytes = size (cm_file_header) * BYTES_PER_WORD;

/* Initialize the first control interval - control interval 0. */

      unspec (control_interval_zero) = "0"b;
      basic_control_interval_ptr = addr (control_interval_zero);

      basic_control_interval.header.layout_type = BASIC_CI_LAYOUT_1;
      basic_control_interval.header.collection_id = HEADER_COLLECTION_ID;
      basic_control_interval.header.number_of_datums = 6;

/*
    Initialize the datum slots of the following elements:
     Slot 1 - collection_header of the "header collection"
     Slot 2 - cm_file_header (collection_manager_ info about entire file)
     Slot 3 - Reserved for user
     Slot 4 - collection_id_table (containing no collection ids)
     Slot 5 - file_reservation_map (containing one fragment)
     Slot 6 - storage record for header collection (unblocked_storage_record)
*/

      basic_control_interval.datum_position_table (1).offset_in_bytes =
	 CONTROL_INTERVAL_ZERO_ADDRESSABLE_LENGTH_IN_BYTES - collection_header_length_in_bytes;
      basic_control_interval.datum_position_table (1).length_in_bits = collection_header_length_in_bytes * BITS_PER_BYTE;

      basic_control_interval.datum_position_table (2).offset_in_bytes =
	 basic_control_interval.datum_position_table (1).offset_in_bytes - cm_file_header_length_in_bytes;
      basic_control_interval.datum_position_table (2).length_in_bits = cm_file_header_length_in_bytes * BITS_PER_BYTE;

      basic_control_interval.datum_position_table (3).offset_in_bytes =
	 basic_control_interval.datum_position_table (2).offset_in_bytes;
      basic_control_interval.datum_position_table (3).length_in_bits = 0;

      basic_control_interval.datum_position_table (4).offset_in_bytes =
	 basic_control_interval.datum_position_table (2).offset_in_bytes - BYTES_PER_WORD;
      basic_control_interval.datum_position_table (4).length_in_bits = BITS_PER_WORD;

      basic_control_interval.datum_position_table (5).offset_in_bytes =
	 basic_control_interval.datum_position_table (4).offset_in_bytes
	 - size (initial_file_reservation_map) * BYTES_PER_WORD;
      basic_control_interval.datum_position_table (5).length_in_bits =
	 size (initial_file_reservation_map) * BITS_PER_WORD;

      basic_control_interval.datum_position_table (6).offset_in_bytes =
	 basic_control_interval.datum_position_table (5).offset_in_bytes
	 - size (unblocked_storage_record) * BYTES_PER_WORD;
      basic_control_interval.datum_position_table (6).length_in_bits = size (unblocked_storage_record) * BITS_PER_WORD;

      basic_control_interval.header.start_of_used_space = basic_control_interval.datum_position_table (6).offset_in_bytes;

/* 
     Directly insert the values of the six elements by overlaying based
     structures on control_interval_zero.  Each element is on a word boundary,
     so there are no alignment problems.

     Set value of collection zero's collection_header 
*/

      collection_header_ptr =
	 addcharno (basic_control_interval_ptr, basic_control_interval.datum_position_table (1).offset_in_bytes);

      collection_header.version = COLLECTION_HEADER_VERSION_2;
      collection_header.flags.thread_control_intervals = "1"b;
      collection_header.maximum_element_size = MAX_ELEMENT_SIZE;
      collection_header.control_interval_storage_method = UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD;
      collection_header.element_storage_method = BASIC_ELEMENT_STORAGE_METHOD;
      collection_header.storage_record_element_id = DEFAULT_STORAGE_RECORD_ELEMENT_ID;

/* Set value for collection_manager_'s file header (cm_file_header) */

      cm_file_header_ptr =
	 addcharno (basic_control_interval_ptr, basic_control_interval.datum_position_table (2).offset_in_bytes);

      cm_file_header.version = CM_FILE_HEADER_VERSION_1;
      cm_file_header.allocation_map_element_id = BLOCK_MAP_ARRAY_ELEMENT_ID;
      cm_file_header.collection_id_table_element_id = COLLECTION_ID_TABLE_ELEMENT_ID;
      cm_file_header.number_of_control_intervals_per_block = DEFAULT_NUMBER_OF_CONTROL_INTERVALS_PER_BLOCK;
      cm_file_header.number_of_blocks = 1;

/*
    Since the initial value for the collection_id_table is "0"b,
    it need not be inserted.

    Insert the file_reservation_map, which at this time consists of one entry. 
*/

      based_byte_string_ptr =
	 addcharno (basic_control_interval_ptr, basic_control_interval.datum_position_table (5).offset_in_bytes);
      bbs_length = size (initial_file_reservation_map) * BYTES_PER_WORD;

      unspec (initial_file_reservation_map) = "0"b;
      initial_file_reservation_map.lowest_numbered_control_interval = 1;
      initial_file_reservation_map.element_id = ALLOCATION_MAP_ELEMENT_ID;

      based_byte_string = addr (initial_file_reservation_map) -> based_byte_string;

/*
     Set the value of the unblocked_storage_record. 
*/

      unblocked_storage_record_ptr =
	 addcharno (basic_control_interval_ptr, basic_control_interval.datum_position_table (6).offset_in_bytes);

      unblocked_storage_record.first_control_interval = 0;
      unblocked_storage_record.last_control_interval = 1;

/*
     Put the whole control interval into the file.
*/

      call file_manager_$simple_put (file_opening_id, 0, START_OF_CI_OFFSET, basic_control_interval_ptr,
	 (CONTROL_INTERVAL_ZERO_ADDRESSABLE_LENGTH_IN_BYTES), code);
      if code ^= 0
      then call ERROR_RETURN (code);

/*
     Insert the reservation map.  It consists of a single fragment in control
     interval one, which is also part of the header collection (collection
     zero).
*/

      unspec (control_interval_one) = "0"b;
      basic_control_interval_ptr = addr (control_interval_one);

      basic_control_interval.layout_type = BASIC_CI_LAYOUT_1;
      basic_control_interval.header.collection_id = HEADER_COLLECTION_ID;
      basic_control_interval.number_of_datums = 1;

      frmf_number_of_control_intervals = DEFAULT_NUMBER_OF_CONTROL_INTERVALS_PER_BLOCK;

      basic_control_interval.datum_position_table (1).offset_in_bytes =
	 CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES - INITIAL_ALLOCATION_MAP_LENGTH_IN_BYTES;
      basic_control_interval.datum_position_table (1).length_in_bits = frmf_number_of_control_intervals;

      file_reservation_map_fragment_ptr =
	 addcharno (basic_control_interval_ptr, basic_control_interval.datum_position_table (1).offset_in_bytes);

      substr (file_reservation_map_fragment, 1, 1) = "1"b;	/* To mark that control interval one has been allocated */

      call file_manager_$simple_put (file_opening_id, 1, START_OF_CI_OFFSET, basic_control_interval_ptr,
	 (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES), code);
      if code ^= 0
      then call ERROR_RETURN (code);


      p_file_opening_id = file_opening_id;
MAIN_RETURN:
      return;
%page;
ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH ();
      go to MAIN_RETURN;

   end ERROR_RETURN;


FINISH:
   proc ();

/* This can go when protected file creation is implemented */
      if p_file_opening_id = "0"b & file_opening_id ^= "0"b
      then call file_manager_$delete_close (file_opening_id, (0));

   end FINISH;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_cm_hdr_col_ids;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_file_header;
%page;
%include dm_cm_collection_header;
%page;
%include dm_esm_info;
%page;
%include dm_cism_info;
%page;
%include dm_cm_reservation_map;
%page;
%include dm_cm_storage_record;
%page;
%include dm_ci_header;
%page;
%include dm_ci_lengths;

   end cm_create_file;




		    cm_delete.pl1                   05/06/86  1320.4rew 05/06/86  1259.1      174285



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(86-02-27,Pierret), approve(86-02-27,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Changed GET_CONTINUATION to correctly use a continued-datum header, not a
     continued-continuation-datum header, to get the continuation datum id.
  2) change(86-04-22,Pierret), approve(86-04-22,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Removed dm_cm_datum_constants.incl.pl1 as it was not used.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION

          This routine deletes an element specified by p_element_id.  If using
     the Basic Element Storage Method the return value of p_element_id is
     the id of the next non-free, non-continuation datum (if there is one in
     the collection); otherwise p_element_id is "0"b, meaning that the deleted
     element was the last element of the collection.
     
          Basic ESM elements are deleted by zeroing the slot in which the 
     containing datum is stored;  Ordered ESM elements are deleted by shifting
     slots to the right of the containing datum one slot towards the left.
     If this action leaves free slots at the end of the slot table, those slots
     are removed and the number of slots is decremented. If there remain any 
     free slots withinn the table, the free_slot_is_present flag is turned on.
     
          The zero-on-free option (indicated by p_zero_on_free) is not yet
     implemented.

CONVENTIONS:
     
     Labels, internal procedure labels and constant names are all in
     upper-case. Parameter variables are prefixed with "p_". Variables
     declared in subroutine are perfixed with the lowercase initials of the
     subroutine name.  Subroutine parameters are prefixed with <initials>_p_.
     
     When an error is encountered, whether in the main procedure are in a
     subroutine, the ERROR_RETURN subroutine is invoked, which sets the 
     output code p_code and causes a return to the caller of the main 
     procedure.  For this reason, code checks are unnecessary after control
     returns from a subroutine.
*/

/* HISTORY:
Written by Matthew Pierret 04/../82.
Modified:
05/20/82 by Matthew Pierret: Changed to use collection_header instead of
            collmgr_header.collection (), and to call cm_get_collection_header.
            Added ability to free uninitialized trailing slots.
06/15/82 by Matthew Pierret: Changed to use bci_header, dm_cm_basic_ci.incl.pl1,
            ci_parts offset to ignore non-addressable ci header.
08/13/82 by Matthew Pierret:  Added Basic ESM.
09/09/82 by Matthew Pierret:  Changed to return the element_id of the next
            element.  Fixed bug in calculation of offset of slots to shift.
            Changed datum_slots_buffer to always be based on number_of_slots,
            removing number_of_slots_to_shift.
09/10/82 by Lindsey Spratt: Changed to call PUT_HEADER_AND_SLOTS in each of
	  the freeing cases.  This is necessary because the data being put,
	  in some cases, is allocated in a begin block and therefore
	  vanishes at the end of the code for that case.
10/20/82 by Matthew Pierret:  Converted to use file_manager_.
11/10/82 by Matthew Pierret:  Changed to support multi-datum elements, free
            control interval if nothing left (BESM only).
02/08/83 by Mathew Pierret:  Upgraded to CM_INFO_VERSION_2. Changed to use
            cm_get_bci_header$slot instead of cm_get_header_and_slot.
            Changed to return dm_error_$no_element if p_element_id.index = 0.
04/06/83 by Lindsey L. Spratt:  Fixed to use the correct datum header size
            when getting the continuation of a multi-datum element.  It was
            using the continued-continuation datum header length when it
            should have been using the conintued datum header length.
            Fixed GET_CONTINUED_CONTINUATION to correctly interpret the datum
            header.
07/14/83 by Matthew Pierret:  Essentially re-wrote most of the module to
            simplify the code and make the ordered and basic ESMs behave in a
            similar fashion.  Now both get the whole slot table always, modify
            the slots, check for free slots, decrement the number of datums
            and replace the bci_header and slot table.  Both also use
            cm_get_id to position.  Also, added an ERROR_RETURN routine which
            sets p_code and non-locally goes to the main return statement in
            the main procedure.  Internal subroutines use ERROR_RETURN, so
            their callers can assume that if control is returned to the
            caller, no errors were encountered.  Also, renamed subroutine
            variables to be prefixed with the initials of the subroutine.
10/14/83 by Lindsey L. Spratt:  Changed to use cm_get_id$info_header instead
            of cm_get_id$header.
02/07/84 by Matthew Pierret:  Changed to use cm_get_id$id instead of
            $info_header.  $info_header is now obsolete.  In the future, this
            routine should be changed to look at data in control intervals by
            getting a pointer to the addressable portion of the control
            interval via file_manager_$get_ci_ptr, and should use
            cm_get_id$ptr.
05/21/84 by Matthew Pierret: Renamed include file dm_cm_esm_info to
            dm_esm_info.
09/28/84 by Matthew Pierret: Renamed to cm_delete from cm_free_element in
            accordance with new naming scheme for operations. Corrected a
            situation wherein it was possible to free a control interval 
            because there was no datum left after the deletion, but then
            write into that freed control interval by calling
            PUT_HEADER_AND_SLOTS. Removed include files from subroutines,
            adding explicit pointer references in those subroutines to
            structures that are declared globally. Cleaned up incorrect
            declarations.  Added use of file_mnager_$simple_get.
12/03/84 by Matthew Pierret: Changed to use my_ci_parts instead of
            automatic_ci_parts_buffer, the former using a "like" to
            ci_parts.part.  Fixed the improper use of the glogal
            datum_slot instead of using an explicit pointer reference in
            PUT_HEADER_AND_SLOTS.
12/11/84 by Matthew Pierret:  Initialized my_ci_parts.pad to 0.
05/21/85 by Matthew C. Pierret:  Changed GET_CONTINUATION to correctly assume
            the supplied offset is to the beginning of a continued-datum, not
            a continued-continuation-datum.  The two have different headers,
            so incorrect an value was being returned.
*/

/* format: style2,ind3 */

cm_delete:
   proc (p_file_opening_id, p_collection_id, p_element_id, p_zero_on_free, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr;
      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_zero_on_free	       bit (1) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    1 automatic_bci_header aligned like bci_header;
      dcl	    1 automatic_datum_slot aligned like datum_slot;
      dcl	    1 my_ci_parts	       aligned,
	      2 number_of_ci_parts fixed bin init (0),
	      2 pad	       fixed bin init (0),
	      2 part	       (2) like ci_parts.part;

      dcl	    continuation_datum_id_string
			       bit (36) aligned init ("0"b);
      dcl	    next_element_id_string bit (36) aligned init ("0"b);

      dcl	    is_ordered_esm	       bit (1) aligned init ("0"b);

      dcl	    first_free_slot_idx    fixed bin (17);
      dcl	    slot_idx	       fixed bin (17);
      dcl	    st_number_of_slots     fixed bin (17);

/* Based */
/* Builtin */

      dcl	    (addr, divide, null, size, unspec)
			       builtin;

/* Controlled */
/*  Constant */

      dcl	    myname	       init ("cm_delete") char (32) varying int static options (constant);
      dcl	    RELATIVE	       init ("0"b) bit (1) aligned int static options (constant);
      dcl	    NEXT_ELEMENT	       init (1) fixed bin (17) int static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin int static options (constant);
      dcl	    BYTES_PER_WORD	       init (4) fixed bin int static options (constant);

/* Entry */

      dcl	    file_manager_$get      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    file_manager_$put      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    file_manager_$simple_get
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$end_of_collection,
	    dm_error_$no_element,
	    dm_error_$ci_not_in_collection
	    )		       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */

      code = 0;
      call cm_opening_info$get (p_file_opening_id, p_collection_id, cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);
      else go to JOIN;


info:
   entry (p_cm_info_ptr, p_element_id, p_zero_on_free, p_code);

      code = 0;
      cm_info_ptr = p_cm_info_ptr;
      go to JOIN;
%page;
JOIN:
      p_code = 0;

      call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);

      collection_header_ptr = cm_info.header_ptr;
      call CHECK_VERSION ("collection_header", collection_header.version, COLLECTION_HEADER_VERSION_2);

      element_id_string = p_element_id;
      if element_id.index = 0
      then call ERROR_RETURN (dm_error_$no_element);

      bci_header_ptr = addr (automatic_bci_header);
      datum_slot_ptr = addr (automatic_datum_slot);

      call cm_get_bci_header$slot (cm_info.file_oid, bci_header_ptr, datum_slot_ptr, element_id_string, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      if bci_header.collection_id ^= cm_info.collection_id
      then call ERROR_RETURN (dm_error_$ci_not_in_collection);

      if datum_slot.offset_in_bytes = FREE_SLOT | datum_slot.flags.is_continuation
      then call ERROR_RETURN (dm_error_$no_element);


      if collection_header.element_storage_method = ORDERED_ELEMENT_STORAGE_METHOD
      then is_ordered_esm = "1"b;
      else is_ordered_esm = "0"b;

      if datum_slot.is_continued
      then
         do;

         /*** The element is a multi-datum element. Free the trailing
	    datums first. It is necessary to get the id of the first continuation
	    datum out of this initial datum.  The routine cm_delete_cn_datum will
	    return subsequent continuation ids. */

	  continuation_datum_id_string =
	       GET_CONTINUATION ((element_id.control_interval_id), (datum_slot.offset_in_bytes));

	  do while (continuation_datum_id_string ^= "0"b);

	     call cm_delete_cn_datum (cm_info_ptr, p_zero_on_free, continuation_datum_id_string, code);
	     if code ^= 0
	     then call ERROR_RETURN (code);
	  end;

         end;

      st_number_of_slots = bci_header.number_of_datums;

BEGIN_BLOCK:
      begin;

         dcl     1 slot_table		aligned,
	         2 slot		(st_number_of_slots) like datum_slot;

         ci_parts_ptr = addr (my_ci_parts);
         ci_parts.number_of_parts = 1;
         call GET_SLOT_TABLE (cm_info.file_oid, (element_id.control_interval_id), addr (slot_table), st_number_of_slots,
	    ci_parts_ptr);

         if ^is_ordered_esm
         then
	  do;

	  /*** This is a basic collection. Find the id of the next element, to be returned
	       to the caller. This must be done before deleteing the specified element. */

	     call cm_get_id$id (cm_info.file_oid, cm_info.collection_id, element_id_string, NEXT_ELEMENT, RELATIVE,
		next_element_id_string, code);
	     if code ^= 0
	     then if code = dm_error_$end_of_collection
		then code = 0;
		else call ERROR_RETURN (code);
	  end;

         if is_ordered_esm
         then
	  do;

	  /*** This is an ordered collection. Shift slots one to left and
	       decrement the number of datums in the control interval. */

	     do slot_idx = element_id.index to bci_header.number_of_datums - 1;
	        slot_table.slot (slot_idx) = slot_table.slot (slot_idx + 1);
	     end;
	     unspec (slot_table.slot (slot_idx)) = "0"b;
	     bci_header.number_of_datums = bci_header.number_of_datums - 1;

	  end;
         else /* Simply free the specified slot */
	    unspec (slot_table.slot (element_id.index)) = "0"b;


         do slot_idx = bci_header.number_of_datums to 1 by -1 while (unspec (slot_table.slot (slot_idx)) = "0"b);
         end;


         if ^is_ordered_esm & slot_idx <= 0
         then
FREE_ENTIRE_CI:
	  do;

	  /*** The control interval is empty.  Free it */

	     call cm_free_ci$info (cm_info_ptr, (element_id.control_interval_id), p_zero_on_free, code);
	     if code ^= 0
	     then call ERROR_RETURN (code);
	  end FREE_ENTIRE_CI;
         else
UPDATE_CI:
	  do;

	  /*** There remains at least one datum in the control interval.
	       Update the number of datums in the bci_header, and the
	       free_slot_is_resent flag if there remain any free slots.
	       Then put the modified bci_header and datum_slot_table back
	       in the control interval. */

	     bci_header.number_of_datums = slot_idx;

	     do first_free_slot_idx = 1 to bci_header.number_of_datums
		while (unspec (slot_table.slot (first_free_slot_idx)) ^= ""b);
	     end;
	     if first_free_slot_idx < bci_header.number_of_datums
	     then bci_header.flags.free_slot_is_present = "1"b;
	     else bci_header.flags.free_slot_is_present = "0"b;

	     call PUT_HEADER_AND_SLOTS (cm_info.file_oid, bci_header_ptr, datum_slot_ptr,
		(element_id.control_interval_id), ci_parts_ptr);

	  end UPDATE_CI;
      end BEGIN_BLOCK;

      if ^is_ordered_esm
      then p_element_id = next_element_id_string;

MAIN_RETURN:
      return;
%page;
ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of ^a structure; received ^8a.", cv_p_correct_version, cv_p_structure_name,
	      cv_p_given_version);
      else return;

   end CHECK_VERSION;
%page;
PUT_HEADER_AND_SLOTS:
   proc (phas_p_file_opening_id, phas_p_bci_header_ptr, phas_p_datum_slot_ptr, phas_p_control_interval_id,
        phas_p_ci_parts_ptr);

      dcl	    phas_p_file_opening_id bit (36) aligned;
      dcl	    phas_p_bci_header_ptr  ptr;
      dcl	    phas_p_datum_slot_ptr  ptr;
      dcl	    phas_p_control_interval_id
			       fixed bin (27);
      dcl	    phas_p_ci_parts_ptr    ptr;
      dcl	    phas_code	       fixed bin (35);

      phas_code = 0;

      if phas_p_datum_slot_ptr -> datum_slot.offset_in_bytes = phas_p_bci_header_ptr -> bci_header.start_of_used_space
      then phas_p_bci_header_ptr -> bci_header.start_of_used_space =
	      phas_p_bci_header_ptr -> bci_header.start_of_used_space
	      + BITS_TO_BYTES ((phas_p_datum_slot_ptr -> datum_slot.length_in_bits));
      else phas_p_bci_header_ptr -> bci_header.scattered_free_space =
	      phas_p_bci_header_ptr -> bci_header.scattered_free_space
	      + BITS_TO_BYTES ((phas_p_datum_slot_ptr -> datum_slot.length_in_bits));


      phas_p_ci_parts_ptr -> ci_parts.number_of_parts = 2;
      phas_p_ci_parts_ptr -> ci_parts.part (2).offset_in_bytes = 0;
      phas_p_ci_parts_ptr -> ci_parts.part (2).length_in_bytes = size (bci_header) * BYTES_PER_WORD;
      phas_p_ci_parts_ptr -> ci_parts.part (2).local_ptr = phas_p_bci_header_ptr;

      call file_manager_$put (phas_p_file_opening_id, phas_p_control_interval_id, phas_p_ci_parts_ptr, phas_code);
      if phas_code ^= 0
      then call ERROR_RETURN (phas_code);
      else return;

   end PUT_HEADER_AND_SLOTS;
%page;
BITS_TO_BYTES:
   proc (btb_p_bits) returns (fixed bin (17));

      dcl	    btb_p_bits	       fixed bin (35);

      return (divide (btb_p_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0));

   end BITS_TO_BYTES;
%page;
GET_CONTINUATION:
   proc (gc_p_ci, gc_p_offset) returns (bit (36) aligned);

/* Given the CI and the offset in bytes within the CI of a continued_datum
   (i.e., the first datum of a multi-datum element), this routine returns
   the continuation id in the continued_datum's header. This is the id of
   the second datum of the multi-datum element. */

      dcl	    gc_p_ci	       fixed bin (27);
      dcl	    gc_p_offset	       fixed bin (21);
      dcl	    1 gc_continued_datum_header
			       aligned like continued_datum.header;
      dcl	    gc_code	       fixed bin (35);

      call file_manager_$simple_get (cm_info.file_oid, gc_p_ci, gc_p_offset, addr (gc_continued_datum_header),
	 (size (gc_continued_datum_header) * BYTES_PER_WORD), gc_code);
      if gc_code ^= 0
      then call ERROR_RETURN (gc_code);
      else return (unspec (gc_continued_datum_header.continuation));


   end GET_CONTINUATION;
%page;
GET_SLOT_TABLE:
   proc (gst_p_file_oid, gst_p_control_interval_id, gst_p_slot_table_ptr, gst_p_slot_table_length_in_words,
        gst_p_ci_parts_ptr);

      dcl	    gst_p_file_oid	       bit (36) aligned;
      dcl	    gst_p_control_interval_id
			       fixed bin (27);
      dcl	    gst_p_slot_table_ptr   ptr;
      dcl	    gst_p_slot_table_length_in_words
			       fixed bin (17);
      dcl	    gst_p_ci_parts_ptr     ptr;

      dcl	    gst_code	       fixed bin (35);

      gst_p_ci_parts_ptr -> ci_parts.number_of_parts = 1;
      gst_p_ci_parts_ptr -> ci_parts.part (1).offset_in_bytes = size (bci_header) * BYTES_PER_WORD;
      gst_p_ci_parts_ptr -> ci_parts.part (1).length_in_bytes = gst_p_slot_table_length_in_words * BYTES_PER_WORD;
      gst_p_ci_parts_ptr -> ci_parts.part (1).local_ptr = gst_p_slot_table_ptr;

      call file_manager_$get (gst_p_file_oid, gst_p_control_interval_id, gst_p_ci_parts_ptr, gst_code);
      if gst_code ^= 0
      then call ERROR_RETURN (gst_code);
      else return;


   end GET_SLOT_TABLE;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_cm_collection_header;
%page;
%include dm_element_id;
%page;
%include dm_esm_info;
%page;
%include dm_ci_parts;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_delete;




		    cm_delete_buffered.pl1          04/04/85  1112.8r w 04/04/85  0912.5       88794



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION

   This routine frees an element specified by p_element_id.  If using
   the Basic Element Storage Method the return value of p_element_id is
   either id of the next non-free, non-continuation datum (if there is one in
   this control interval), the control interval id of the next control
   interval and a slot index of 0 (if there is another control interval),
   or "0"b.  The caller can assume that a value of "0"b means that the freed
   element was the last element of the collection.

   Using Basic ESM if the element to be freed is stored in a datum
   slot other than the last slot of the slot table (datum_position_table)
   that slot is marked free by zeroing it and bci_header.free_slot_is_present
   is turned on to note the existence of the free slot.  If the last slot
   is being freed, the table is truncated. If there exists a contiguous
   block of free slots adjacent to the last slot, these slots are truncated
   also, and the whole slot table is searched to see if all of the free slots
   have been truncated.  If so, turn bci_header.free_slot_is_present off;
   otherwise leave it on.

   The zero-on-free option (indicated by p_zero_on_free) is not yet
   implemented.
*/

/* HISTORY:

Written by Matthew Pierret 01/10/83.
Modified:
02/04/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2. Changed to
            check control interval layout type.
05/21/84 by Matthew Pierret: Renamed include file dm_cm_cism_info to
            dm_cism_info. Added ERROR_RETURN procedure. Changed to not get
            opening info unless a multi-datum element is to be deleted.
09/28/84 by Matthew Pierret: Fixed HISTORY section. Changed comments to be
            indented properly. Corrected mis-statement in DESCRIPTION
            which claimed that element_id.index could be 0 on inpput.
            Improved expression for converting bits to bytes.
12/03/84 by Matthew Pierret:  Fixed HISTORY section and removed indcomtxt
            from the main format statement as that mode causes the HISTORY
            section to be formatted in a non-standard fashion.  Removed the
            un-used sys_info$max_seg_size, BYTES_PER_WORD, next_element_id
            dm_esm_info.incl.pl1.
*/

/* format: style2,ind3 */
/* format: indcomtxt   */

cm_delete_buffered:
   proc (p_ci_buffer_ptr, p_file_opening_id, p_collection_id, p_element_id, p_zero_on_free, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr;
      dcl	    p_ci_buffer_ptr	       ptr;
      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_zero_on_free	       bit (1) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    (file_opening_id, collection_id)
			       bit (36) aligned;
      dcl	    continuation_datum_id_string
			       bit (36) aligned init ("0"b);
      dcl	    1 local_datum_slot     aligned like datum_slot;
      dcl	    next_element_id_string bit (36) aligned init ("0"b);
      dcl	    (new_number_of_datums, new_start_of_used_space, new_scattered_free_space)
			       fixed bin (17);
      dcl	    slot_idx	       fixed bin;

      dcl	    slot_not_specified     bit (1) aligned init ("0"b);
      dcl	    found		       bit (1) aligned init ("0"b);


/* Based */

      dcl	    1 continuation_datum_id
			       aligned like datum_id based (addr (continuation_datum_id_string));

/* Builtin */

      dcl	    (addcharno, addr, divide, null, unspec)
			       builtin;

/* Controlled */
/*  Constant */

      dcl	    myname	       init ("cm_delete_buffered") char (32) varying int static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin int static options (constant);
      dcl	    ZEROED_DATUM_SLOT      init (0) fixed bin (35) int static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$no_element,
	    dm_error_$ci_not_in_collection,
	    dm_error_$unimplemented_ci_version,
	    error_table_$unimplemented_version
	    )		       ext fixed bin (35);

/* END OF DECLARATIONS */

      cm_info_ptr = null;
      file_opening_id = p_file_opening_id;
      collection_id = p_collection_id;

      go to JOIN;


info:
   entry (p_cm_info_ptr, p_ci_buffer_ptr, p_element_id, p_zero_on_free, p_code);

      cm_info_ptr = p_cm_info_ptr;

      call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);

      file_opening_id = cm_info.file_oid;
      collection_id = cm_info.collection_id;

      go to JOIN;
%page;
JOIN:
      p_code, code = 0;

      element_id_string = p_element_id;

      basic_control_interval_ptr, bci_header_ptr = p_ci_buffer_ptr;

      call CHECK_CI_VERSION (bci_header.layout_type);

      if bci_header.collection_id ^= collection_id
      then call ERROR_RETURN (dm_error_$ci_not_in_collection);

/* Verify supplied element id. */

      if element_id.index > bci_header.number_of_datums | element_id.index <= 0
      then call ERROR_RETURN (dm_error_$no_element);

/* Verify the datum slot. The slot must correspond with an allocated, non-continuation datum. */

      local_datum_slot = basic_control_interval.datum_position_table (element_id.index);

      if local_datum_slot.offset_in_bytes = FREE_SLOT | local_datum_slot.flags.is_continuation
      then call ERROR_RETURN (dm_error_$no_element);


/**** Calculate new values for scattered free space and start of used space
      and the number of datums for the control interval. */

      new_number_of_datums = bci_header.number_of_datums - 1;
      new_start_of_used_space = bci_header.start_of_used_space;
      new_scattered_free_space = bci_header.scattered_free_space;

      if local_datum_slot.offset_in_bytes = bci_header.start_of_used_space
      then new_start_of_used_space =
	      new_start_of_used_space
	      + divide (local_datum_slot.length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);
      else new_scattered_free_space =
	      new_scattered_free_space
	      + divide (local_datum_slot.length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);

      if local_datum_slot.is_continued
      then
         do;

	  /*** The element is a multi-datum element. Free the trailing datums first.
	       It is necessary to get the id of the first continuation datum out of
	       this initial datum.  The routine cm_delete_cn_datum will return subsequent
	       continuation ids. It may also be necessary to get the opening info for the
	       collection (cm_info) it it has not geen goten already (cm_info_ptr=null). */

	  if cm_info_ptr = null
	  then
	     do;
	        call cm_opening_info$get (file_opening_id, collection_id, cm_info_ptr, code);
	        if code ^= 0
	        then call ERROR_RETURN (code);
	        call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);
	     end;

	  datum_ptr = addcharno (bci_header_ptr, local_datum_slot.offset_in_bytes);
						/* continued_datum is based on datum_ptr */
	  continuation_datum_id = continued_datum.continuation;
						/* This sets continuation_datum_id_string */

	  do while (continuation_datum_id_string ^= "0"b & code = 0);

	     call cm_delete_cn_datum (cm_info_ptr, p_zero_on_free, continuation_datum_id_string, code);

	  end;

	  if code ^= 0
	  then call ERROR_RETURN (code);

         end;

/**** Shift trailing slots one slot to the left to recover the recently
      freed slot, zero-ing out the rightmost slot. */

      do slot_idx = element_id.index to new_number_of_datums;
         basic_control_interval.datum_position_table (slot_idx) =
	    basic_control_interval.datum_position_table (slot_idx + 1);
      end;

      unspec (basic_control_interval.datum_position_table (new_number_of_datums + 1)) = unspec (ZEROED_DATUM_SLOT);

      bci_header.scattered_free_space = new_scattered_free_space;
      bci_header.start_of_used_space = new_start_of_used_space;
      bci_header.number_of_datums = new_number_of_datums;

MAIN_RETURN:
      return;
%page;
ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of ^a structure; received ^8a.", cv_p_correct_version, cv_p_structure_name,
	      cv_p_given_version);

      return;

   end CHECK_VERSION;


CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^4a control interval; received ^4a.", BASIC_CI_LAYOUT_1, ccv_p_given_version);

      return;

   end CHECK_CI_VERSION;
%page;
%include dm_cm_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_cm_datum;
%page;
%include dm_element_id;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_delete_buffered;




		    cm_delete_cn_datum.pl1          04/04/85  1112.8r w 04/04/85  0912.5      139986



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION

   This routine frees a datum specified by p_datum_id. The datum
   must be a continuation datum or a continued continuation datum.
   If the latter, the datum id of this datum's continuation is returned
   in p_datum_id.  Otherwise the return value of p_datum_id is "0"b;
   The Ordered Element Storage Method requires that CdCn and Cn datums
   be maximum-sized datums stored alone in a control interval.  For this
   reason, if the OESM is in effect, the entire control interval in which
   this datum resides is freed.  If the Basic ESM is in effect, the
   control interval is freed if this datum is sole remaining datum in the
   control interval.  If the datum slot is anywhere but at the rightmost
   end of the slot table, the slot is simply marked free.  Otherwise the
   last datum slot and any adjacent free slots are truncated.

   The zero-on-free option (dictated by p_zero_on_free) is not
   implemented yet.  Datum contents are not zeroed unless the entire
   control interval is freed.
*/

/* HISTORY:

Written by Matthew Pierret 11/10/82.
Modified:
02/04/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2.  Changed to use
            cm_get_bci_header$slot instead of cm_get_header_and_slot.
04/05/83 by Lindsey L. Spratt:  Changed to not test the datum_slot
            is_continued flag until the datum_slot has been gottn in the
            must_get_header case.
04/06/83 by Lindsey L. Spratt:  Moved the getting of the header and the
            getting of the continuation id out of the BASIC_ESM block, so that
            the continuation id is alos gotten in the ORDERED_ESM case.
05/21/84 by Matthew Pierret:  Renamed include file dm_cm_cism_info to
            dm_cism_info. Removed un-used error codes.
09/28/84 by Matthew Pierret:  Re-named CHECK_VERSION_CHAR_4 to CHEK_CI_VERSION.
            Added subroutine prefix to variables local to subroutines and
            explicit pointer reference to structures in subroutines. Added
            BITS_TO_BYTES function to replace the old ceil(divide(...)).
12/03/84 by Matthew Pierret:  Fixed HISTORY section to conform to standards.
            Made to pass on p_zero_on_free to cm_free_ci.  Removed
            automatic_collection_header (not used) and changed 
            automatic_ci_parts_buffer to my_ci_parts, which has a component
            which is liked to ci_parts.part.  Upgraded to modern sub_err_
            calling sequence.
*/

/* format: style2,ind3 */
/* format: indcomtxt   */

cm_delete_cn_datum:
   proc (p_cm_info_ptr, p_zero_on_free, p_datum_id, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr;
      dcl	    p_bci_header_ptr       ptr;
      dcl	    p_datum_slot_ptr       ptr;
      dcl	    p_datum_id	       bit (36) aligned;
      dcl	    p_zero_on_free	       bit (1) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    1 my_bci_header	       aligned like bci_header;
      dcl	    1 my_datum_slot	       aligned like datum_slot;
      dcl	    1 my_ci_parts	       aligned,
	      2 number_of_parts    fixed bin (17) init (0),
	      2 mbz	       fixed bin (17) init (0),
	      2 part	       (2) like ci_parts.part;

      dcl	    continuation	       bit (36) aligned init ("0"b);
      dcl	    datum_id_string	       bit (36) aligned init ("0"b);
      dcl	    number_of_slots	       fixed bin (17);
      dcl	    rightmost_non_free_slot
			       fixed bin (17);
      dcl	    slot_idx	       fixed bin (17);
      dcl	    datum_slot_table_ptr   ptr;
      dcl	    found		       bit (1) aligned init ("0"b);
      dcl	    must_get_header	       bit (1) aligned init ("0"b);

/* Based */

      dcl	    1 datum_slot_table     (number_of_slots) aligned based (datum_slot_table_ptr) like datum_slot;

/* Builtin */

      dcl	    (addr, divide, null, size)
			       builtin;

/* Controlled */
/*  Constant */

      dcl	    myname	       init ("cm_delete_cn_datum") char (32) varying int static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin int static options (constant);
      dcl	    BYTES_PER_WORD	       init (4) fixed bin int static options (constant);
      dcl	    ZEROED_DATUM_SLOT      init (0) fixed bin (35) int static options (constant);

/* Entry */

      dcl	    file_manager_$get      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    file_manager_$put      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    file_manager_$simple_get
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$no_datum     ext fixed bin (35);
      dcl	    dm_error_$unimplemented_ci_version
			       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

      must_get_header = "1"b;

      goto JOIN;


header:
   entry (p_cm_info_ptr, p_bci_header_ptr, p_datum_slot_ptr, p_zero_on_free, p_datum_id, p_code);

      must_get_header = "0"b;
      datum_slot_ptr = p_datum_slot_ptr;
      bci_header_ptr = p_bci_header_ptr;
      call CHECK_CI_VERSION (bci_header.layout_type);

      goto JOIN;
%page;
JOIN:
      p_code, code = 0;
      cm_info_ptr = p_cm_info_ptr;
      call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);

      collection_header_ptr = cm_info.header_ptr;
      call CHECK_VERSION ("collection_header", collection_header.version, COLLECTION_HEADER_VERSION_2);

      datum_id_string = p_datum_id;
      datum_id_ptr = addr (datum_id_string);

      if datum_id.index = 0
      then call ERROR_RETURN (dm_error_$no_datum);

      if must_get_header
      then
         do;

	  bci_header_ptr = addr (my_bci_header);
	  datum_slot_ptr = addr (my_datum_slot);

	  call cm_get_bci_header$slot (cm_info.file_oid, bci_header_ptr, datum_slot_ptr, p_datum_id, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  else call CHECK_CI_VERSION (bci_header.layout_type);
         end;

      if ^datum_slot.flags.is_continuation
      then call ERROR_RETURN (dm_error_$no_datum);

      if datum_slot.is_continued
      then
         do;

	  /*** The datum is a continued continuation datum. Before freeing this datum
	       get the id of its continuation to be passed back to the caller. */

	  continuation = GET_CONTINUATION ((datum_id.control_interval_id), (datum_slot.offset_in_bytes));
         end;

      ci_parts_ptr = addr (my_ci_parts);
      ci_parts.number_of_parts = 1;

      if collection_header.element_storage_method = ORDERED_ELEMENT_STORAGE_METHOD
      then
ORDERED_ESM:
         do;

	  /*** The Ordered Element Storage Method requires continuation datums be
	       maximum-sized datums residing alone in a control interval.  To free
	       such a datum, simply free the entire control interval. */

	  call cm_free_ci$info (cm_info_ptr, (datum_id.control_interval_id), p_zero_on_free, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end ORDERED_ESM;
      else
BASIC_ESM:
         do;

	  /*** Delete the basic datum. The following cases are possible:
	       (1) The datum is the only one in the control interval: free the control interval;
	       (2) The datum uses the last slot: truncate the slot
	       (3) The datum uses the last slot and the adjacent slot to the left is
	       a free slot: truncate all trailing free slots.
	       (4) The datum uses a slot other than the last slot: zero that slot
	       and note that there exists a free slot in the bci_header.
	  */

	  if datum_id.index = bci_header.number_of_datums
	  then if bci_header.number_of_datums = 1
	       then
BESM_1_FREE_CI:
		do;
		   call cm_free_ci$info (cm_info_ptr, (datum_id.control_interval_id), p_zero_on_free, code);
		   if code ^= 0
		   then call ERROR_RETURN (code);
		end BESM_1_FREE_CI;
	       else
		do;

		   if ^bci_header.flags.free_slot_is_present
		   then
BESM_2_TRUNCATE_LAST_SLOT:
		      do;

		         ci_parts.part (1).offset_in_bytes =
			    (size (bci_header) + datum_id.index - 1) * BYTES_PER_WORD;
		         ci_parts.part (1).length_in_bytes = BYTES_PER_WORD;
		         ci_parts.part (1).local_ptr = addr (ZEROED_DATUM_SLOT);

		         bci_header.number_of_datums = bci_header.number_of_datums - 1;
		         call PUT_HEADER_AND_SLOTS (cm_info.file_oid, bci_header_ptr, datum_slot_ptr,
			    (datum_id.control_interval_id), ci_parts_ptr);

		      end BESM_2_TRUNCATE_LAST_SLOT;
		   else
BESM_3_TRUNCATE_TRAILING_FREE_SLOTS:
		      do;

		         number_of_slots = bci_header.number_of_datums;
B3_BEGIN_BLOCK:
		         begin;

			  /*** Since there is at least one free slot in this control interval, check
			       to see if it and any others are adjacent to the last slot (which is being
			       freed).  A begin block is used to allocate a datum slot array of the
			       proper size. */

			  dcl	datum_slots_buffer	   (number_of_slots) fixed bin (35);

			  datum_slots_buffer = 0;
			  datum_slot_table_ptr = addr (datum_slots_buffer);

			  ci_parts.part (1).offset_in_bytes = size (bci_header) * BYTES_PER_WORD;
			  ci_parts.part (1).length_in_bytes = number_of_slots * BYTES_PER_WORD;
			  ci_parts.part (1).local_ptr = datum_slot_table_ptr;

			  call file_manager_$get (cm_info.file_oid, (datum_id.control_interval_id), ci_parts_ptr,
			       code);
			  if code ^= 0
			  then call ERROR_RETURN (code);

			  datum_slots_buffer (number_of_slots) = 0;

			  do rightmost_non_free_slot = number_of_slots - 1 to 1 by -1
			       while (datum_slot_table (rightmost_non_free_slot).offset_in_bytes = FREE_SLOT);
			     datum_slots_buffer (rightmost_non_free_slot) = 0;
			  end;

			  do slot_idx = 1 to rightmost_non_free_slot - 1
			       while (datum_slot_table (slot_idx).offset_in_bytes ^= FREE_SLOT);
			  end;

			  if slot_idx >= rightmost_non_free_slot
			  then bci_header.flags.free_slot_is_present = "0"b;

			  bci_header.number_of_datums = rightmost_non_free_slot;

			  if bci_header.number_of_datums = 0
			  then
			     do;
			        call cm_free_ci$info (cm_info_ptr, (datum_id.control_interval_id), p_zero_on_free,
				   code);
			        if code ^= 0
			        then call ERROR_RETURN (code);
			     end;

			  else call PUT_HEADER_AND_SLOTS (cm_info.file_oid, bci_header_ptr, datum_slot_ptr,
				  (datum_id.control_interval_id), ci_parts_ptr);

		         end B3_BEGIN_BLOCK;
		      end BESM_3_TRUNCATE_TRAILING_FREE_SLOTS;
		end;
	  else
BESM_4_DELETE_SLOT_IN_THE_MIDDLE_OF_TABLE:
	     do;

	        /*** The slot is in the middle of the slot table. Zero out that slot and note
		   that there now exists a free slot in the table. */

	        ci_parts.part (1).offset_in_bytes = (size (bci_header) + datum_id.index - 1) * BYTES_PER_WORD;
	        ci_parts.part (1).length_in_bytes = BYTES_PER_WORD;
	        ci_parts.part (1).local_ptr = addr (ZEROED_DATUM_SLOT);

	        bci_header.flags.free_slot_is_present = "1"b;

	        call PUT_HEADER_AND_SLOTS (cm_info.file_oid, bci_header_ptr, datum_slot_ptr,
		   (datum_id.control_interval_id), ci_parts_ptr);

	     end BESM_4_DELETE_SLOT_IN_THE_MIDDLE_OF_TABLE;

	  p_datum_id = continuation;

         end BASIC_ESM;

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", cv_p_correct_version,
	      cv_p_structure_name, cv_p_given_version);

      return;

   end CHECK_VERSION;


CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a control interval; received ^a.", BASIC_CI_LAYOUT_1, ccv_p_given_version);
      else return;

   end CHECK_CI_VERSION;
%page;
PUT_HEADER_AND_SLOTS:
   proc (phas_p_file_opening_id, phas_p_bci_header_ptr, phas_p_datum_slot_ptr, phas_p_control_interval_id,
        phas_p_ci_parts_ptr);

      dcl	    phas_p_file_opening_id bit (36) aligned;
      dcl	    phas_p_bci_header_ptr  ptr;
      dcl	    phas_p_datum_slot_ptr  ptr;
      dcl	    phas_p_control_interval_id
			       fixed bin (27);
      dcl	    phas_p_ci_parts_ptr    ptr;
      dcl	    phas_code	       fixed bin (35);

      phas_code = 0;

      if phas_p_datum_slot_ptr -> datum_slot.offset_in_bytes = phas_p_bci_header_ptr -> bci_header.start_of_used_space
      then phas_p_bci_header_ptr -> bci_header.start_of_used_space =
	      phas_p_bci_header_ptr -> bci_header.start_of_used_space + BITS_TO_BYTES ((datum_slot.length_in_bits));
      else phas_p_bci_header_ptr -> bci_header.scattered_free_space =
	      phas_p_bci_header_ptr -> bci_header.scattered_free_space + BITS_TO_BYTES ((datum_slot.length_in_bits));


      phas_p_ci_parts_ptr -> ci_parts.number_of_parts = 2;
      phas_p_ci_parts_ptr -> ci_parts.part (2).offset_in_bytes = 0;
      phas_p_ci_parts_ptr -> ci_parts.part (2).length_in_bytes = size (bci_header) * BYTES_PER_WORD;
      phas_p_ci_parts_ptr -> ci_parts.part (2).local_ptr = phas_p_bci_header_ptr;

      call file_manager_$put (phas_p_file_opening_id, phas_p_control_interval_id, phas_p_ci_parts_ptr, phas_code);
      if phas_code ^= 0
      then call ERROR_RETURN (phas_code);
      else return;

   end PUT_HEADER_AND_SLOTS;
%page;
BITS_TO_BYTES:
   proc (btb_p_bits) returns (fixed bin (17));

      dcl	    btb_p_bits	       fixed bin (35);

      return (divide (btb_p_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0));

   end BITS_TO_BYTES;
%page;
GET_CONTINUATION:
   proc (gc_p_ci, gc_p_offset) returns (bit (36) aligned);

      dcl	    gc_p_ci	       fixed bin (27);
      dcl	    gc_p_offset	       fixed bin (21);
      dcl	    gc_continuation_datum_id
			       bit (36) aligned;
      dcl	    gc_code	       fixed bin (35);

      call file_manager_$simple_get (cm_info.file_oid, gc_p_ci, gc_p_offset, addr (gc_continuation_datum_id),
	 (CDCN_DATUM_HEADER_LENGTH_IN_BYTES), gc_code);
      if gc_code ^= 0
      then call ERROR_RETURN (gc_code);
      else return (gc_continuation_datum_id);


   end GET_CONTINUATION;
%page;
%include dm_cm_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_esm_info;
%page;
%include dm_ci_parts;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_delete_cn_datum;




		    cm_destroy_collection.pl1       04/04/85  1112.8r w 04/04/85  0912.5      106173



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         This  routine  destroys  a collection in a DM file.  Currently, only
     collections which employ the Unblocked Control  Interval  Storage  Method
     can  be  destroyed.  Each control interval of the collection is freed, as
     well  as  all  associated  header   information,   which   includes   the
     collection_header,    the   storage_record   and   the   entry   in   the
     collection_id_table.

          In the future (post MR11) when creation of Blocked collections is
     supported, this module will also support the deletion of Blocked
     collections.  Deleting Blocked collections requires following an
     allocation map, rather than a control interval thread.
*/

/* HISTORY:
Written by Matthew Pierret, 03/21/83.
Modified:
02/07/84 by Matthew Pierret:  Changed to use cm_get_element instead of
            cm_get_element$info.  The latter entry is now obsolete.
05/21/84 by Matthew Pierret:  Renamed include file dm_cm_cism_info to
            dm_cism_info.  Added er_p_code parameter to ERROR_RETURN.
            Changed to use local variable code instead of parameter p_code.
06/12/84 by Matthew Pierret:  Re-named cm_put_element to cm_modify.
07/24/84 by Matthew Pierret:  Changed to use cm_free_ci$raw_return_prev_next
            instead of using cm_free_ci$info then relying on it to have updated
            unblocked_storage_record.first_control_interval.  The new entry
            frees the control itnerval without bothering to update headers
            and re-thread threads, and returns the value of the next ci id.
09/26/84 by Matthew Pierret: Added comment indicating that Blocked collections
            are not supported but will be in the future.
*/

/* format: style2,ind3 */

cm_destroy_collection:
   proc (p_file_opening_id, p_collection_id, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    1 local_cm_file_header aligned like cm_file_header;
      dcl	    hc_cm_info_ptr	       ptr init (null);
      dcl	    is_unblocked	       bit (1) aligned init ("1"b);
      dcl	    (header_record_element_id, collection_header_element_id, collection_id, file_opening_id,
	    storage_record_element_id)
			       bit (36) aligned init ("0"b);
      dcl	    ci_count	       fixed bin (24);
      dcl	    collection_idx	       fixed bin;
      dcl	    code		       fixed bin (35);
      dcl	    collection_id_table_length
			       fixed bin (35) init (0);
      dcl	    (current_ci_id, first_ci_id, last_ci_id, next_ci_id)
			       fixed bin (24) unsigned;

/* Based */

      dcl	    dm_work_area	       area (sys_info$max_seg_size) based (dm_work_area_ptr);
      dcl	    collection_id_table_buffer
			       aligned bit (collection_id_table_length) based (collection_id_table_ptr);

/* Builtin */

      dcl	    (addr, ceil, divide, length, null, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("cm_destroy_collection") char (32) varying internal static options (constant);
      dcl	    (
	    BITS_PER_WORD	       init (36),
	    DEFAULT_POSITION       init (0)
	    )		       fixed bin internal static options (constant);
      dcl	    LIMIT_TO_STOP_INFINITE_LOOPING
			       init (1e6) fixed bin (35) internal static options (constant);
      dcl	    DONT_ZERO_ON_FREE      init ("0"b) bit (1) aligned internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);
      dcl	    get_dm_free_area_      entry () returns (ptr);

/* External */

      dcl	    (
	    error_table_$unimplemented_version,
	    sys_info$max_seg_size,
	    dm_error_$programming_error,
	    dm_error_$unimplemented_cism
	    )		       fixed bin (35) ext;

/* Static */

      dcl	    dm_work_area_ptr       ptr init (null) internal static;

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */

      p_code, code = 0;

      file_opening_id = p_file_opening_id;
      collection_id = p_collection_id;

      collection_id_table_ptr = null;

   /*** Get opening info for the header collection (hc_cm_info_ptr). ***/

      call cm_opening_info$full_get (file_opening_id, HEADER_COLLECTION_ID, hc_cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

   /*** Get the opening info (cm_info) for this collection. ***/

      call cm_opening_info$full_get (file_opening_id, collection_id, cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call CHECK_VERSION (cm_info.version, CM_INFO_VERSION_2, "cm_info");

      collection_header_ptr = cm_info.header_ptr;
      call CHECK_VERSION (collection_header.version, COLLECTION_HEADER_VERSION_2, "collection_header");

      if collection_header.control_interval_storage_method ^= UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
      then call sub_err_ (dm_error_$unimplemented_cism, myname, ACTION_CANT_RESTART, null, 0,
	      "^/This operation only supports control interval storage method ^d;^/^10xreceived method ^d.",
	      UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD, collection_header.control_interval_storage_method);
						/* In the future (post MR11) deletion of */
						/* Blocked collections will be supported. */
      else
         do;

         /*** This is an Unblocked collection. Set up the unblocked_storage_record,
	    and  get the ids of the first and last control intervals of the collection. ***/

	  unblocked_storage_record_ptr = cm_info.storage_record_ptr;

	  first_ci_id = unblocked_storage_record.first_control_interval;
	  last_ci_id = unblocked_storage_record.last_control_interval;

         end;

   /*** Save the element ids of elements related to this element which are
        stored in the Header Collection. ***/

      collection_header_element_id = collection_id;
      header_record_element_id = collection_header.header_record_element_id;
      storage_record_element_id = collection_header.storage_record_element_id;

/**** Prepare to begin destruction. ***/

      collection_id_table_ptr = null;
      if dm_work_area_ptr = null
      then dm_work_area_ptr = get_dm_free_area_ ();
      on cleanup call FINISH ();

/**** Free all of the control intervals in the collection. ***/

      current_ci_id = first_ci_id;

      do ci_count = 1 to LIMIT_TO_STOP_INFINITE_LOOPING while (current_ci_id > 0);

         call cm_free_ci$raw_return_prev_next (cm_info_ptr, current_ci_id, "1"b, (0), next_ci_id, code);
         if code ^= 0
         then call ERROR_RETURN (code);

         current_ci_id = next_ci_id;
      end;

/**** Free the opening info for his collection. ***/

      call cm_free_opening_info (file_opening_id, collection_id, code);
      if code ^= 0
      then call ERROR_RETURN (code);
      cm_info_ptr = null;

/**** Remove the collection_id from the collection_id_table. ***/

   /*** Get the cm_file_header, to find the location of the collection_id_table. ***/

      call cm_get_element (file_opening_id, HEADER_COLLECTION_ID, CM_FILE_HEADER_ELEMENT_ID, DEFAULT_POSITION,
	 addr (local_cm_file_header), length (unspec (local_cm_file_header)), null, ("0"b), cm_file_header_ptr, (0),
	 code);
      if code ^= 0
      then call ERROR_RETURN (code);
      call CHECK_VERSION (cm_file_header.version, CM_FILE_HEADER_VERSION_1, "cm_file_header");

   /*** Get the collection_id_table. ***/

      cit_number_of_collections = cm_file_header.number_of_collections;

      call cm_get_element (file_opening_id, HEADER_COLLECTION_ID, cm_file_header.collection_id_table_element_id,
	 DEFAULT_POSITION, null, (0), dm_work_area_ptr, ("1"b), collection_id_table_ptr, collection_id_table_length,
	 code);
      if code ^= 0
      then call ERROR_RETURN (code);

      if ceil (divide (collection_id_table_length, BITS_PER_WORD, 35, 18)) ^= cit_number_of_collections
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CAN_RESTART, null, 0,
	      "^/The actual size of the collection_id_table, ^d entries, differs from the^/number of collections, ^d.",
	      ceil (divide (collection_id_table_length, BITS_PER_WORD, 35, 18)), cit_number_of_collections);

   /*** Find the entry in the collection_id_table which holds this collection_id. ***/

      do collection_idx = 1 to cit_number_of_collections while (collection_id_table (collection_idx) ^= collection_id);
      end;

      if collection_idx <= cit_number_of_collections
      then
         do;

         /*** The collection id is in collection_id_table (collection_idx). Remove it,
	    recover the entry and replace the collection_id_table in the file. ***/

	  if collection_idx ^= cit_number_of_collections
	  then collection_id_table (collection_idx) = collection_id_table (cit_number_of_collections);
	  cit_number_of_collections = cit_number_of_collections - 1;

	  call cm_modify$info (hc_cm_info_ptr, collection_id_table_ptr, length (unspec (collection_id_table)),
	       cm_file_header.collection_id_table_element_id, (0), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  cm_file_header.number_of_collections = cit_number_of_collections;

	  call cm_modify$info (hc_cm_info_ptr, cm_file_header_ptr, length (unspec (cm_file_header)),
	       CM_FILE_HEADER_ELEMENT_ID, (0), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

         end;

/**** Free all per-collection header information in the file: the collection_header,
      storage_record and caller header. ***/

      call cm_delete$info (hc_cm_info_ptr, collection_header_element_id, DONT_ZERO_ON_FREE, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call cm_delete$info (hc_cm_info_ptr, storage_record_element_id, DONT_ZERO_ON_FREE, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call cm_delete$info (hc_cm_info_ptr, header_record_element_id, DONT_ZERO_ON_FREE, code);
      if code ^= 0
      then call ERROR_RETURN (code);

/**** Finished ****/

      call FINISH ();
MAIN_RETURN:
      return;					/* Effective end of cm_destroy_collection */
%page;
ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH ();
      goto MAIN_RETURN;

   end ERROR_RETURN;



FINISH:
   proc ();

      if collection_id_table_ptr ^= null
      then free collection_id_table_buffer in (dm_work_area);

   end FINISH;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  char (8) aligned;
      dcl	    cv_p_expected_version  char (8) aligned;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of the ^a structure.
Received version ^8a instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_cm_hdr_col_ids;
%page;
%include dm_cm_info;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_file_header;
%page;
%include dm_cm_storage_record;
%page;
%include dm_cism_info;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;
   end cm_destroy_collection;




		    cm_determine_free_space.pl1     01/04/85  0947.4re  01/03/85  1148.4       85293



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         This  routine determines the number of bytes in a control interval
     available for use (free).  Contral intervals are laid out conceptually
     from left to right as follow: fixed size bci_header, an array of datum
     slots, a pool of free space, and the used portion, which may contain
     scattered bytes of free storage.

       ------------------------------------------------------------
       |        | | |   | |            |      |//|       |////|   |
       | Header |1|2|...|N|   Pool     |      |//|       |////|   |
       |        | | |   | |            |      |//|       |////|   |
       ------------------------------------------------------------
                ^         ^            ^       ^           ^
                |         |            |       |           |
                start     start        |       scattered_free_space
                of slots  of pool      start 
                                       of used space
     The four entries work as follows:
     
       $all - returns the number of bytes in the pool (p_free_bytes_in_pool)
     and the number of free bytes in the control (p_free_bytes_in_ci), which
     includes the bytes in the pool and the scattered free bytes and a caller
     suppied number of bytes currently in use but to be reclaimed
     (p_old_datum_length).
     
       $effective - returns the same information as $all including space
     required for a datum header, i.e., space required for the datum header is
     not considered free. There are three possible datum_header sizes, the
     proper type of datum_header is determined by the p_is_continued and
     p_is_continuation flags input by the caller.
     
       $does_new_datum_fit - returns two flags indicating whether a new datum
     of the size p_new_datum_contents_length will fit in the control interval
     (p_fits_in_ci) or in the pool (p_fits_in_pool).  This entry takes header
     space into consideration, as in $effective, and the amount of space
     necessary for the new datum slot.  The datum slot of the new datum is
     supplied (p_new_datum_slot_idx) by Ordered ESM callers; this is because
     the new slot can be beyond the end of the old datum slot table, requiring
     more than one new slot. Basic ESM callers supply a value of 0; if there
     is a free slot then no extra space is used, else space for one extra slot
     must be accounted.
       This routine returns the amount of free space left in the control
     interval after accounting for the new datum (p_free_bytes_in_ci), if the
     datum fits.  If the datum does not fit, p_free_bytes_in_ci is a 
     non-positive interger with absolute value of the number of bytes in the 
     datum over what would fit.
     
       ** Not yet used **
       $does_replacement_fit - returns two flags indicating whether a
     replacement for a datum will fit in the control interval (p_fits_in_ci)
     or in the pool (p_fits_in_pool).  The size of the old datum (including
     header) (p_old_datum_length) and the length of the new datum contents
     (p_new_datum_contents_length).  Header space for the value of the datum
     is taken into consideration as in $effective.  The caller also supplies
     the offset of the old datum (p_old_datum_offset), and that offset
     indicates that the datum is the first datum in the used space, the pool
     is extended to include the old datum.
       This routine returns the amount of free space left in the control
     interval after accounting for the new datum (p_free_bytes_in_ci), if the
     datum fits.  If the datum does not fit, p_free_bytes_in_ci is a 
     non-positive interger with absolute value of the number of bytes in the 
     datum over what would fit.
*/

/* HISTORY:

Written by Matthew Pierret, 10/27/82.
Modified:
02/03/83 by Matthew Pierret: Fixed bug which subtracted header_space_required
            twice. Changed to check bci_header version.
08/08/83 by Matthew Pierret: Added the $does_new_datum_fit and
            $does_replacement_fit entries.
09/26/84 by Matthew Pierret: Added declaration of max and size.  Changed
            CHECK_VERSION_CHAR_4 to CHECK_CI_VERSION.  Moved procedure and
            format statements to standard location.
*/

/* format: style2,ind3 */

cm_determine_free_space:
   proc ();

      return;

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_bci_header_ptr       ptr parameter;
      dcl	    p_is_continued	       bit (1) aligned parameter;
      dcl	    p_is_continuation      bit (1) aligned parameter;
      dcl	    p_old_datum_offset     fixed bin (35) parameter;
      dcl	    p_old_datum_length     fixed bin (35) parameter;
      dcl	    p_new_datum_contents_length
			       fixed bin (35) parameter;
      dcl	    p_free_bytes_in_ci     fixed bin (35) parameter;
      dcl	    p_free_bytes_in_pool   fixed bin (35) parameter;
      dcl	    p_new_datum_slot_idx   fixed bin (35) parameter;
      dcl	    p_fits_in_pool	       bit (1) aligned;
      dcl	    p_fits_in_ci	       bit (1) aligned;

/* Automatic */

      dcl	    (first_byte_in_pool, free_bytes_in_pool, free_bytes_in_ci, number_of_slots, required_header_space)
			       fixed bin (35) init (0);
      dcl	    (determine_if_datum_fits, for_new_datum, for_replacement)
			       bit (1) aligned init ("0"b);

/* Based */
/* Builtin */

      dcl	    (max, null, size)      builtin;

/* Constant */

      dcl	    myname	       init ("cm_determine_free_space") char (32) varying internal static
			       options (constant);
      dcl	    BYTES_PER_WORD	       init (4) fixed bin internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$unimplemented_ci_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

effective:
   entry (p_bci_header_ptr, p_old_datum_length, p_is_continued, p_is_continuation, p_free_bytes_in_ci,
        p_free_bytes_in_pool);

      goto INCLUDE_DATUM_HEADER;

does_replacement_fit:
   entry (p_bci_header_ptr, p_old_datum_offset, p_old_datum_length, p_new_datum_contents_length, p_is_continued,
        p_is_continuation, p_fits_in_ci, p_fits_in_pool, p_free_bytes_in_ci);

      determine_if_datum_fits = "1"b;
      for_replacement = "1"b;
      goto INCLUDE_DATUM_HEADER;

does_new_datum_fit:
   entry (p_bci_header_ptr, p_new_datum_contents_length, p_new_datum_slot_idx, p_is_continued, p_is_continuation,
        p_fits_in_ci, p_fits_in_pool, p_free_bytes_in_ci);

      determine_if_datum_fits = "1"b;
      for_new_datum = "1"b;
      goto INCLUDE_DATUM_HEADER;

INCLUDE_DATUM_HEADER:
      if p_is_continued & p_is_continuation
      then required_header_space = CDCN_DATUM_HEADER_LENGTH_IN_BYTES;
      else if p_is_continued
      then required_header_space = CD_DATUM_HEADER_LENGTH_IN_BYTES;
      else required_header_space = 0;

      goto JOIN;


all:
   entry (p_bci_header_ptr, p_old_datum_length, p_free_bytes_in_ci, p_free_bytes_in_pool);

      goto JOIN;

JOIN:
      bci_header_ptr = p_bci_header_ptr;

      call CHECK_CI_VERSION (bci_header.layout_type);

      if for_new_datum
      then if p_new_datum_slot_idx > 0
	 then number_of_slots = max (bci_header.number_of_datums + 1, p_new_datum_slot_idx);
	 else if bci_header.flags.free_slot_is_present
	 then number_of_slots = bci_header.number_of_datums;
	 else number_of_slots = bci_header.number_of_datums + 1;
      else number_of_slots = bci_header.number_of_datums;

      first_byte_in_pool = BYTES_PER_WORD * (size (bci_header) + number_of_slots + 1);

      free_bytes_in_pool = bci_header.start_of_used_space - first_byte_in_pool - required_header_space;
      free_bytes_in_ci = free_bytes_in_pool + bci_header.scattered_free_space;

      if for_replacement
      then if p_old_datum_offset = bci_header.start_of_used_space
	 then free_bytes_in_pool = free_bytes_in_pool + p_old_datum_length;

      if ^for_new_datum
      then free_bytes_in_ci = free_bytes_in_ci + p_old_datum_length;

      if determine_if_datum_fits
      then
         do;
	  p_fits_in_ci = (p_new_datum_contents_length <= free_bytes_in_ci);
	  p_fits_in_pool = (p_new_datum_contents_length <= free_bytes_in_pool);
	  p_free_bytes_in_ci = free_bytes_in_ci - p_new_datum_contents_length;
						/* If ^p_fits_in_ci, this will be non-positive, */
						/* indicating how much smaller the datum must be to fit. */
         end;
      else
         do;
	  p_free_bytes_in_ci = free_bytes_in_ci;
	  p_free_bytes_in_pool = free_bytes_in_pool;
         end;

      return;
%page;
CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a control interval; received ^a.", BASIC_CI_LAYOUT_1, ccv_p_given_version);
      else return;

   end CHECK_CI_VERSION;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_datum_constants;
%page;
%include sub_err_flags;

   end cm_determine_free_space;




		    cm_find_ci_to_alloc_datum.pl1   04/04/85  1112.8r w 04/04/85  0912.6       82197



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         This  routine  examines  a number of control intervals attempting to
     find one which has enough free space in which to allocate a  datum  of  a
     given  size.   If no control interval is found, one is allocated and that
     control interval becomes the one inwhich to allocate the datum.

          The caller supplies  the  number  of  bytes  required  to  hold  the
     contents  of  the  datum  and  flags indicating whether a continued_datum
     header, a coninued_continuation_datum header or no header is required.  A
     starting point may be supplied (p_input_ci).  The routine  returns  the
     control  interval found (p_return_ci) and a pointer to the bci_header of
     the control interval (p_bci_header).
*/

/* HISTORY:

Written by Matthew Pierret, 10/27/82.
Modified:
11/19/82 by Lindsey Spratt:  Changed to get the bci_header after allocating a
	  new control interval.
02/02/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2. Added sub_err_
            call to report problems getting the last CI. Changed to use
            cm_opening_info$get_storage_record instead of getting the storage
            record directly.
07/19/83 by Matthew Pierret: Changed to allow for the space taken up by the
            new datum slot in calculating the available free space.
08/05/83 by Matthew Pierret: Changed to use
            cm_determine_free_space$does_new_datum_fit, which returns a flag
            indicating whether there is enough free space in which to fit the
            new datum, accounting for a possible new slot and datum header.
            Removed the obsolete dm_data_$area_ptr.
05/21/84 by Matthew Pierret: Renamed include file dm_cm_cism_info to
            dm_cism_info.  Added RETURN and ERROR_RETURN procedures. Changed
            to use automatic code variable instead of p_code parameter.
09/26/84 by Matthew Pierret: Renamed RETURN to RETURN_CI.  Changed GET_LAST_CI
            to a function.  Changed CHECK_VERSION_CHAR_4 to CHECK_CI_VERSION.
            Moved all includes out of internal subroutines, making references
            to structures in those subroutines be by explicit pointer
            reference.
*/

/* format: style2,ind3 */

cm_find_ci_to_alloc_datum:
   proc (p_cm_info_ptr, p_datum_contents_length_in_bytes, p_input_ci, p_is_continued, p_is_continuation, p_bci_header_ptr,
        p_return_ci, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr parameter;
      dcl	    p_datum_contents_length_in_bytes
			       fixed bin (35) parameter;
      dcl	    p_input_ci	       fixed bin (24) uns parameter;
      dcl	    p_is_continued	       bit (1) aligned parameter;
      dcl	    p_is_continuation      bit (1) aligned parameter;
      dcl	    p_bci_header_ptr       ptr;
      dcl	    p_return_ci	       fixed bin (24) uns parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    (input_ci, last_ci, new_ci)
			       fixed bin (24) uns init (0);
      dcl	    total_free_bytes       fixed bin (35) init (0);
      dcl	    fits_in_ci	       bit (1) aligned init ("0"b);

/* Based */
/* Builtin */

      dcl	    (null, unspec)	       builtin;

/* Constant */

      dcl	    myname	       init ("cm_find_ci_to_alloc_datum") char (32) varying internal static
			       options (constant);
      dcl	    BYTES_PER_WORD	       init (4) fixed bin internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$misformatted_ci,
	    dm_error_$unimplemented_ci_version,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code, code = 0;
      input_ci = p_input_ci;
      cm_info_ptr = p_cm_info_ptr;
      call CHECK_VERSION ((cm_info.version), (CM_INFO_VERSION_2), "cm_info");

      bci_header_ptr = p_bci_header_ptr;
      if unspec (bci_header) ^= "0"b
      then call CHECK_CI_VERSION (bci_header.layout_type);

      if input_ci ^= 0 | (input_ci = 0 & cm_info.collection_id = HEADER_COLLECTION_ID)
      then
         do;
	  if unspec (bci_header) = "0"b
	  then
	     do;
	        call cm_get_bci_header (cm_info.file_oid, input_ci, bci_header_ptr, code);
	        if code ^= 0
	        then call ERROR_RETURN (code);
	     end;

	  call cm_determine_free_space$does_new_datum_fit (bci_header_ptr, p_datum_contents_length_in_bytes, (0),
	       p_is_continued, p_is_continuation, fits_in_ci, ("0"b), total_free_bytes);

	  if fits_in_ci
	  then call RETURN_CI (input_ci);
         end;

      last_ci = GET_LAST_CI (cm_info_ptr);

      if input_ci ^= last_ci
      then
         do;
	  call cm_get_bci_header (cm_info.file_oid, last_ci, bci_header_ptr, code);
	  if code ^= 0
	  then
	     do;
	        if code = dm_error_$ci_not_allocated | code = dm_error_$misformatted_ci
	        then call sub_err_ (code, myname, ACTION_CANT_RESTART, null, 0,
		        "^/This internal inconsistency was encountered attempting to get control^/interval ^d. The storage record for collection ^3bo claims this control^/interval is the last control interval in the collection."
		        , last_ci, cm_info.collection_id);

	        else call ERROR_RETURN (code);
	     end;

	  call cm_determine_free_space$does_new_datum_fit (bci_header_ptr, p_datum_contents_length_in_bytes, (0),
	       p_is_continued, p_is_continuation, fits_in_ci, ("0"b), total_free_bytes);

	  if fits_in_ci
	  then call RETURN_CI (last_ci);
         end;

/***** Still have not found a suitable control interval.  Allocate a new one. */

      call cm_allocate_ci$info (cm_info_ptr, new_ci, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call cm_get_bci_header (cm_info.file_oid, new_ci, bci_header_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);
      else call RETURN_CI (new_ci);

MAIN_RETURN:
      return;


RETURN_CI:
   proc (rc_p_return_ci);

      dcl	    rc_p_return_ci	       fixed bin (24) uns;

      p_return_ci = rc_p_return_ci;
      go to MAIN_RETURN;

   end RETURN_CI;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (cv_p_given_version, cv_p_correct_version, cv_p_structure_name);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of ^a structure; received ^8a.", cv_p_correct_version, cv_p_structure_name,
	      cv_p_given_version);

      return;

   end CHECK_VERSION;


CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a control interval; received ^a.", BASIC_CI_LAYOUT_1, ccv_p_given_version);
      else return;

   end CHECK_CI_VERSION;
%page;
GET_LAST_CI:
   proc (glc_p_cm_info_ptr) returns (fixed bin (24) uns);

      dcl	    glc_p_cm_info_ptr      ptr;
      dcl	    glc_collection_header_ptr
			       ptr;
      dcl	    glc_code	       fixed bin (35);

      glc_collection_header_ptr = glc_p_cm_info_ptr -> cm_info.header_ptr;
      call CHECK_VERSION (glc_collection_header_ptr -> collection_header.version, COLLECTION_HEADER_VERSION_2,
	 "collection_header");

      if glc_p_cm_info_ptr -> cm_info.storage_record_ptr = null ()
      then
         do;
	  glc_code = 0;
	  call cm_opening_info$get_storage_record (glc_p_cm_info_ptr, glc_code);
	  if glc_code ^= 0
	  then call ERROR_RETURN (glc_code);
         end;

      if glc_collection_header_ptr -> collection_header.control_interval_storage_method
	 = UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
      then return (glc_p_cm_info_ptr -> cm_info.storage_record_ptr -> unblocked_storage_record.last_control_interval);
      else return (glc_p_cm_info_ptr -> cm_info.storage_record_ptr -> blocked_storage_record.last_control_interval);

   end GET_LAST_CI;
%page;
%include dm_cm_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_storage_record;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_cism_info;
%page;
%include dm_hdr_collection_id;
%page;
%include sub_err_flags;
%page;
%include dm_cm_entry_dcls;

   end cm_find_ci_to_alloc_datum;




		    cm_find_free_slot.pl1           01/04/85  0947.4re  01/03/85  1148.4       53307



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         Given  a  control  interval,  find  an available slot for allocation
     according to the basic element storage method. There are four return 
     arguments, defined as follows:

       p_free_slot_idx - is the index of a slot that can be used for
     a new datum.  This is either a free slot in the datum_position_table
     or one slot past the current end of the table.     
       p_number_of_slots - the number of slots that will remain in 
     the datum_position_table after allocation of the datum.  The possible
     values are (bci_header.number_of_datums) if a free slot is found in the
     existing slot table or (bci_header.number_of_datums + 1) if there are no
     free slots in the existing table.  bci_header.number_of_datums is *not*
     updated to reflect the new slot.
       p_extra_free_slot_remains - is on if there are free slots in the
     datum_position_table other than the one at p_free_slot_idx.
     bci_header.flags.free_slot_is_present is not updated.
       p_code - a standard error code returned from file_manager_$get.
*/

/* HISTORY:

Written by Matthew Pierret, 10/28/82.
Modified:
02/03/83 by Matthew Pierret: Added p_number_of_slots parameter in which is
            returned the new number of slots rather than updaing 
            bci_header.number_of_datums directly.
08/09/83 by Matthew Pierret: Added p_extra_free_slot_remains parameter in
            which is the new value of bci_header.flags.free_slot_is_present
            after allocation of the new datum.  bci_header is not updated
            for any reason by this module.
09/27/84 by Matthew Pierret:  Changed to use ERROR_RETURN and local code
            variable instead of p_code parameter.  Changed CHECK_VERSION
            to CHECK_CI_VERSION.  Changed to use file_manager_$simple_get,
            thus removing the ci_parts structure.
*/

/* format: style2,ind3 */

cm_find_free_slot:
   proc (p_file_oid, p_control_interval_id, p_bci_header_ptr, p_free_slot_idx, p_number_of_slots,
        p_extra_free_slot_remains, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_oid	       bit (36) aligned parameter;
      dcl	    p_control_interval_id  fixed bin (24) uns parameter;
      dcl	    p_bci_header_ptr       ptr parameter;
      dcl	    p_free_slot_idx	       fixed bin (17) parameter;
      dcl	    p_number_of_slots      fixed bin (17) parameter;
      dcl	    p_extra_free_slot_remains
			       bit (1) aligned;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    1 datum_slot_table     (1024) like datum_slot aligned;
      dcl	    extra_free_slot_found  bit (1) aligned;
      dcl	    free_slot_found	       bit (1) aligned;
      dcl	    slot_idx	       fixed bin (17);

/* Based */
/* Builtin */

      dcl	    (addr, max, null, size)
			       builtin;

/* Constant */

      dcl	    myname	       init ("cm_find_free_slot") char (32) varying int static options (constant);
      dcl	    BYTES_PER_WORD	       init (4) fixed bin (17) int static options (constant);

/* Entry */

      dcl	    file_manager_$simple_get
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$unimplemented_ci_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code, code = 0;
      p_number_of_slots = 0;
      extra_free_slot_found = "0"b;
      free_slot_found = "0"b;
      bci_header_ptr = p_bci_header_ptr;
      call CHECK_CI_VERSION (bci_header.layout_type);

      if ^bci_header.flags.free_slot_is_present
      then
NO_FREE_SLOT:
         p_free_slot_idx = bci_header.number_of_datums + 1;
      else
SEARCH_FOR_FREE_SLOT:
         do;
	  call file_manager_$simple_get (p_file_oid, (p_control_interval_id), size (bci_header) * BYTES_PER_WORD,
	       addr (datum_slot_table), bci_header.number_of_datums * BYTES_PER_WORD, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  /*** Search the slot table for two free slots, the first to return to the
caller, the second to determine if any free slots exist other than the one
being returned to the caller. */

	  do slot_idx = 1 to bci_header.number_of_datums while (^extra_free_slot_found);

	     if datum_slot_table (slot_idx).offset_in_bytes = FREE_SLOT
	     then if free_slot_found
		then extra_free_slot_found = "1"b;
		else
		   do;
		      free_slot_found = "1"b;
		      p_free_slot_idx = slot_idx;
		   end;

	  end;

	  if ^free_slot_found
	  then p_free_slot_idx = bci_header.number_of_datums + 1;

         end SEARCH_FOR_FREE_SLOT;


      p_extra_free_slot_remains = extra_free_slot_found;
      p_number_of_slots = max (bci_header.number_of_datums, p_free_slot_idx);
MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a control interval; received ^a.", BASIC_CI_LAYOUT_1, ccv_p_given_version);
      else return;

   end CHECK_CI_VERSION;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include sub_err_flags;

   end cm_find_free_slot;




		    cm_free_ci.pl1                  04/04/85  1112.8r w 04/04/85  0912.6      206505



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

   This  module  frees  a control interval.  If the collection uses the
   Unblocked CISM, the specified control interval is  returned  directly  to
   the  page  file free pool, i.e., the allocation map is updated to reflect
   that control interval's availability.  If the collection uses the Blocked
   CISM, the map for the block in which the control interval belongs is made
   available.  If the whole block is available,  then  all  of  the  control
   intervals of the block are freed.

   There are three entries into this module, described as follows:

   cm_free_ci$cm_free_ci
   This entry is the entry used by callers through the
   collection_manager_ transfer vector.  It frees the control interval,
   updates threads for the previous and next control intervals, and,
   if the control interval is the first or last of the collection,
   updates the collection's storage record to show a new first or last
   control interval.

   cm_free_ci$info
   This entry is used by collection_manager_ modules.  It behaves
   exactly as cm_free_ci$cm_free_ci, execpt that a pointer to the
   cm_info structure is passed in.  This is because the calling
   collection_manager_ module has already gotten the structure.

   cm_free_ci$raw_return_prev_next
   This entry is used by cm_destroy_collection.  It does not bother to
   maintain the control interval threads or the storage record
   information.  Instead it just blows away the specified control
   interval.  The fact that this leaves the collection in an
   inconsistent state is all right, as cm_destroy_collection is going
   to free everything anyway.  This entry also returns the values of
   the previous and next control intervals, as stored in the specified
   control interval's header, to assist cm_destroy_collection in
   following the control interval thread.

   cm_free_ci$trace_thread_modifications_(on off)
   These entries set a static switch, static_trace_thread_switch, to
   on and off, respectively.  When the switch is on, debugging
   information is printed whenever the control interval thread may have
   been modified by freeing a control interval.


   The zero-on-free capability is not currently supported.

*/

/* HISTORY:

Written by Matthew Pierret, 07/06/82.
Modified:
10/20/82 by Matthew Pierret:  Converted to use file_manager_.
11/03/82 by Matthew Pierret:  Changed to use opening info for both the header
            and specified collections; to use cm_file_header instead of
            collmgr_header; to use BASIC_CI_LAYOUT_1 (datum header-less)
12/10/82 by Lindsey Spratt:  Fixed to get the storage record from the header
            collection.
02/04/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2. Changed to get
            blocked storage record.
02/09/83 by Lindsey Spratt:  Fixed to correctly re-thread the control
            intervals.
02/23/83 by Matthew Pierret: Changed to use file_reservation_map instead of
            block_map_array.
03/01/83 by Lindsey Spratt:  Fixed to use "next_control_interval" when
            replacing the next_bci_header, rather than
            "previous_control_interval".
08/09/83 by Matthew Pierret: Removed the obsolete dm_data_$area_ptr.
01/24/84 by Matthew Pierret: Added debugging entries for tracing
            modifications to the control interval thread.
05/21/84 by Matthew Pierret: Added RETURN and ERROR_RETURN procedures.
            Renamed dm_cm_cism_info include file to dm_cism_info.  Changed to
            use automatic code variable instead of p_code parameter.
06/12/84 by Matthew Pierret: Re-named cm_put_element to cm_modify.
07/24/84 by Matthew Pierret: Added raw_return_prev_next entry.  This entry
            does a "raw" free, meaning that it does not update threads or
            control information, just frees the ci. It also returns the values
            of the prev and next ci from the ci's bci_header. This entry is
            used by cm_destroy_collection.
09/28/84 by Matthew Pierret: Removed initial attributes from flags. Changed
            CHECK_VERSION_CHAR_4 to CHECK_CI_VERSION.  Added sub_err_ call for
            case where an unsupported control interval storage method was
            encountered.Added description of race entries.
01/08/85 by Matthew Pierret: Corrected test of gsr_code in the subroutine
            GET_STORAGE_RECORD_PTR to be for not-equal to 0 instead of equal.
*/

/* format: style2,ind3 */
/* format: indcomtxt,^indblkcom */

cm_free_ci:
   proc (p_file_opening_id, p_collection_id, p_control_interval_number, p_zero_on_free, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr parameter;
      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_control_interval_number
			       fixed bin (24) uns parameter;
      dcl	    p_zero_on_free	       bit (1) aligned parameter;

      dcl	    p_previous_control_interval_number
			       fixed bin (24) uns parameter;
      dcl	    p_next_control_interval_number
			       fixed bin (24) uns parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    control_interval_number
			       fixed bin (24) uns;
      dcl	    hc_cm_info_ptr	       ptr init (null);
      dcl	    1 previous_bci_header  aligned like bci_header;
      dcl	    previous_control_interval
			       fixed bin (24) unsigned;
      dcl	    1 next_bci_header      aligned like bci_header;
      dcl	    next_control_interval  fixed bin (24) unsigned;

      dcl	    1 automatic_bci_header aligned like bci_header;
      dcl	    1 automatic_cm_file_header
			       aligned like cm_file_header;
      dcl	    map_idx	       fixed bin (17);
      dcl	    (collection_header_was_updated, return_prev_and_next_ci, this_is_raw_free)
			       bit (1) aligned;

/* Based */
/* Builtin */

      dcl	    (addr, divide, length, null, size, substr, unspec)
			       builtin;

/* Constant */

      dcl	    myname	       init ("cm_free_ci") char (32) varying int static options (constant);
      dcl	    BITS_PER_WORD	       init (36) fixed bin (17) int static options (constant);
      dcl	    BYTES_PER_WORD	       init (4) fixed bin (17) int static options (constant);
      dcl	    NO_CONTROL_INTERVAL    init (0) fixed bin (24) unsigned int static options (constant);
      dcl	    OFFSET_OF_BCI_HEADER   init (0) fixed bin (21) internal static options (constant);

/* Entry */

      dcl	    file_manager_$free     entry (bit (36) aligned, uns fixed bin (24), uns fixed bin (24), fixed bin (35));
      dcl	    file_manager_$simple_put
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    ioa_		       entry () options (variable);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$ci_0_invalid_free
			       ext fixed bin (35);
      dcl	    dm_error_$ci_not_in_collection
			       ext fixed bin (35);
      dcl	    dm_error_$unimplemented_ci_version
			       ext fixed bin (35);
      dcl	    dm_error_$unimplemented_cism
			       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* Static */

      dcl	    static_trace_thread_switch
			       init ("0"b) bit (1) aligned internal static;

/* END OF DECLARATIONS */
%page;
      this_is_raw_free, return_prev_and_next_ci = "0"b;
      code = 0;

      call cm_opening_info$get (p_file_opening_id, p_collection_id, cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);


      go to JOIN;



info:
   entry (p_cm_info_ptr, p_control_interval_number, p_zero_on_free, p_code);

      this_is_raw_free, return_prev_and_next_ci = "0"b;
      code = 0;
      cm_info_ptr = p_cm_info_ptr;

      go to JOIN;

raw_return_prev_next:
   entry (p_cm_info_ptr, p_control_interval_number, p_zero_on_free, p_previous_control_interval_number,
        p_next_control_interval_number, p_code);

      this_is_raw_free, return_prev_and_next_ci = "1"b;
      code = 0;
      cm_info_ptr = p_cm_info_ptr;

      go to JOIN;
%page;
JOIN:
      p_code = 0;
      collection_header_was_updated = "0"b;

      call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);

      collection_header_ptr = cm_info.header_ptr;

      call CHECK_VERSION ("collection_header", collection_header.version, COLLECTION_HEADER_VERSION_2);

      control_interval_number = p_control_interval_number;

      if control_interval_number = 0
      then call ERROR_RETURN (dm_error_$ci_0_invalid_free);

   /*** The Header Collection will be accessed several times, so get
        opening info for the Header Collection (pointed to by hc_cm_info_ptr) to
        make these accesses more efficient. */

      call cm_opening_info$get (cm_info.file_oid, HEADER_COLLECTION_ID, hc_cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

   /*** Determine if this collection is in blocked or unblocked mode. */

      if collection_header.control_interval_storage_method = UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
      then
UNBLOCKED:
         do;

         /*** This is an unblocked collection. */

	  call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID, CM_FILE_HEADER_ELEMENT_ID, (0),
	       addr (automatic_cm_file_header), length (unspec (automatic_cm_file_header)), null, ("0"b),
	       cm_file_header_ptr, (0), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  call CHECK_VERSION ("cm_file_header", cm_file_header.version, CM_FILE_HEADER_VERSION_1);

	  frmf_number_of_control_intervals = cm_file_header.number_of_control_intervals_per_block;
	  frm_number_of_fragments = cm_file_header.number_of_blocks;

UB_BEGIN_BLOCK:
	  begin;
	     dcl	   fragment_buffer	      (divide (frmf_number_of_control_intervals, BITS_PER_WORD * 2, 17, 0) + 1)
				      fixed bin (71);
	     dcl	   file_reservation_map_buffer
				      (frm_number_of_fragments) fixed bin (71);

	  /*** Get proper block of allocation map.  This requires getting the cm_file_header
	       which contains a pointer to the array of allocation block maps, getting
	       that array (file_reservation_map), searching that array until the proper block
	       is found. */

	     call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID, cm_file_header.allocation_map_element_id, (0),
		addr (file_reservation_map_buffer), length (unspec (file_reservation_map_buffer)), null, ("0"b),
		file_reservation_map_ptr, (0), code);
	     if code ^= 0
	     then call ERROR_RETURN (code);

FIND_APPROPRIATE_BLOCK_LOOP:
	     do map_idx = 1 to frm_number_of_fragments
		while (
		^(file_reservation_map (map_idx).lowest_numbered_control_interval <= control_interval_number
		& control_interval_number
		< file_reservation_map (map_idx).lowest_numbered_control_interval + frmf_number_of_control_intervals))
		;
	     end FIND_APPROPRIATE_BLOCK_LOOP;

	     if map_idx > frm_number_of_fragments
	     then call ERROR_RETURN (dm_error_$ci_not_in_collection);

	  /*** Get the file_reservation_map_fragment.  An exclusive get is used here to avoid being
	       locked out later when trying to put back the updated file_reservation_map_fragment. */

	     call cm_get_element$exclusive (cm_info.file_oid, HEADER_COLLECTION_ID,
		file_reservation_map (map_idx).element_id, (0), addr (fragment_buffer),
		length (unspec (fragment_buffer)), null, ("0"b), file_reservation_map_fragment_ptr, (0), code);
	     if code ^= 0
	     then call ERROR_RETURN (code);

	     if substr (file_reservation_map_fragment,
		control_interval_number - file_reservation_map (map_idx).lowest_numbered_control_interval + 1, 1)
		= "0"b
	     then call RETURN;			/* Already free */

	     substr (file_reservation_map_fragment,
		control_interval_number - file_reservation_map (map_idx).lowest_numbered_control_interval + 1, 1) =
		"0"b;				/* Set to free */


	     bci_header_ptr = addr (automatic_bci_header);

	     call cm_get_bci_header$exclusive (cm_info.file_oid, control_interval_number, bci_header_ptr, code);
	     if code ^= 0
	     then call ERROR_RETURN (code);

	     call CHECK_CI_VERSION (bci_header.layout_type);

	     if bci_header.collection_id ^= cm_info.collection_id
	     then call ERROR_RETURN (dm_error_$ci_not_in_collection);

	     previous_control_interval = bci_header.previous_control_interval;
	     next_control_interval = bci_header.next_control_interval;

	     if ^this_is_raw_free
	     then
UPDATE_PREV_AND_NEXT_CI:
	        do;

	        /*** The first actual updating done in freeing a control interval is to update
		   the threads of the previous and next control intervals. These control
		   intervals are determined by looking in the bci_header of the control
		   interval to be freed. In getting that control interval's bci_header, an
		   exclusive lock is obtained since it will be needed when it is freed. */

		 if previous_control_interval = NO_CONTROL_INTERVAL
		 then
		    do;
		       unblocked_storage_record_ptr = GET_STORAGE_RECORD_PTR ();
		       unblocked_storage_record.first_control_interval = next_control_interval;
		       collection_header_was_updated = "1"b;
		    end;
		 else
		    do;
		       call cm_get_bci_header (cm_info.file_oid, previous_control_interval,
			  addr (previous_bci_header), code);
		       if code ^= 0
		       then call ERROR_RETURN (code);

		       call CHECK_CI_VERSION (bci_header.layout_type);

		       previous_bci_header.next_control_interval = next_control_interval;
		    end;

		 if next_control_interval = NO_CONTROL_INTERVAL
		 then
		    do;
		       unblocked_storage_record_ptr = GET_STORAGE_RECORD_PTR ();
		       unblocked_storage_record.last_control_interval = previous_control_interval;
		       collection_header_was_updated = "1"b;
		    end;
		 else
		    do;
		       call cm_get_bci_header (cm_info.file_oid, next_control_interval, addr (next_bci_header), code);
		       if code ^= 0
		       then call ERROR_RETURN (code);

		       call CHECK_CI_VERSION (bci_header.layout_type);

		       next_bci_header.previous_control_interval = previous_control_interval;
		    end;

	        /*** Dislay tracing information if desired. */

		 if static_trace_thread_switch
		 then call ioa_ ("Control interval ^d freed.", control_interval_number);

	        /*** Modify previous and next control intervals' headers. */

		 if previous_control_interval ^= 0
		 then
		    do;
		       call file_manager_$simple_put (cm_info.file_oid, (previous_control_interval),
			  OFFSET_OF_BCI_HEADER, addr (previous_bci_header),
			  size (previous_bci_header) * BYTES_PER_WORD, code);
		       if code ^= 0
		       then call ERROR_RETURN (code);
		       if static_trace_thread_switch
		       then call ioa_ ("^8xControl interval ^d changed to have next of ^d.",
			       previous_control_interval, previous_bci_header.next_control_interval);
		    end;
		 if next_control_interval ^= 0
		 then
		    do;
		       call file_manager_$simple_put (cm_info.file_oid, (next_control_interval), OFFSET_OF_BCI_HEADER,
			  addr (next_bci_header), size (next_bci_header) * BYTES_PER_WORD, code);
		       if code ^= 0
		       then call ERROR_RETURN (code);
		       if static_trace_thread_switch
		       then call ioa_ ("^8xControl interval ^d changed to have previous of ^d.",
			       next_control_interval, next_bci_header.previous_control_interval);
		    end;
	        end UPDATE_PREV_AND_NEXT_CI;

	  /*** Release disk address held by control interval. */

	     call file_manager_$free (cm_info.file_oid, control_interval_number, 1, code);
	     if code ^= 0
	     then call ERROR_RETURN (code);

	  /*** Write out the allocation map block. The window between releasing the disk
	       address and writing back the updated map should be closed. */

	     call cm_modify$info (hc_cm_info_ptr, file_reservation_map_fragment_ptr, -1,
		file_reservation_map (map_idx).element_id, (0), code);
	     if code ^= 0
	     then call ERROR_RETURN (code);

	     if file_reservation_map (map_idx).flags.no_control_intervals_are_available
	     then
	        do;
		 file_reservation_map (map_idx).flags.no_control_intervals_are_available = "0"b;
		 call cm_modify$info (hc_cm_info_ptr, file_reservation_map_ptr, -1,
		      cm_file_header.allocation_map_element_id, (0), (0));
	        end;

	  /*** If the collection_header was updated, put it back. */

	     if collection_header_was_updated
	     then
	        do;
		 call cm_modify$info (hc_cm_info_ptr, unblocked_storage_record_ptr, -1,
		      collection_header.storage_record_element_id, (0), code);
		 if code ^= 0
		 then call ERROR_RETURN (code);
	        end;

	  /*** Return the previous and next control interval numbers. */

	     if return_prev_and_next_ci
	     then
	        do;
		 p_previous_control_interval_number = previous_control_interval;
		 p_next_control_interval_number = next_control_interval;
	        end;
	  end UB_BEGIN_BLOCK;
         end UNBLOCKED;
      else call sub_err_ (dm_error_$unimplemented_cism, myname, ACTION_CANT_RESTART, null, 0,
	      "^/This routine does not implement control interval storage method ^d.",
	      collection_header.control_interval_storage_method);


/**** ***************************************************************************

      The following code is to support the blocked control interval storage method.
      This method is not yet supported and will not be supported in MR11.

      else
      BLOCKED:
      do;
      blocked_storage_record_ptr = GET_STORAGE_RECORD_PTR ();

      camb_number_of_control_intervals = blocked_storage_record.number_of_control_intervals_per_block;
      cam_number_of_blocks = blocked_storage_record.number_of_blocks;

      begin;
      dcl	   block_buffer	      (divide (camb_number_of_control_intervals, BITS_PER_WORD * 2, 17, 0) + 1)
      fixed bin (71);
      dcl	   cam_buffer	      (cam_number_of_blocks) fixed bin (71);

      call
      cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID,
      blocked_storage_record.block_map_array_element_id, (0), addr (cam_buffer), length (unspec (cam_buffer)),
      null, ("0"b), collection_allocation_map_ptr, (0), code);
      if code ^= 0
      then call ERROR_RETURN (code);

      do map_idx = 1 to cam_number_of_blocks
      while (
      ^(collection_allocation_map (map_idx).lowest_numbered_control_interval <= control_interval_number
      & control_interval_number
      < collection_allocation_map (map_idx).lowest_numbered_control_interval + camb_number_of_control_intervals));
      end;

      if map_idx > cam_number_of_blocks
      then call ERROR_RETURN (dm_error_$ci_not_in_collection);

      call
      cm_get_element$exclusive (cm_info.file_oid, HEADER_COLLECTION_ID,
      collection_allocation_map (map_idx).element_id, (0), addr (block_buffer), length (unspec (block_buffer)), null,
      ("0"b), collection_allocation_map_block_ptr, (0), code);
      if code ^= 0
      then call ERROR_RETURN (code);

      if substr (collection_allocation_map_block,
      control_interval_number - collection_allocation_map (map_idx).lowest_numbered_control_interval + 1, 1)
      = "0"b
      then call RETURN;

      substr (collection_allocation_map_block,
      control_interval_number - collection_allocation_map (map_idx).lowest_numbered_control_interval + 1, 1) =
      "0"b;

      call
      cm_modify$info (hc_cm_info_ptr, collection_allocation_map_block_ptr, -1,
      collection_allocation_map (map_idx).element_id, (0), code);
      if code ^= 0
      then
      call ERROR_RETURN (code);

      if collection_allocation_map (map_idx).flags.no_control_intervals_are_available
      then
      do;
      collection_allocation_map (map_idx).flags.no_control_intervals_are_available = "0"b;
      call
      cm_modify$info (hc_cm_info_ptr, collection_allocation_map_ptr, -1,
      blocked_storage_record.block_map_array_element_id, (0), (0));
      if code ^= 0
      then
      call ERROR_RETURN (code);
      end;

      end;
      end BLOCKED;

      ************************************************************************ ****/

MAIN_RETURN:
      return;


trace_thread_modifications_on:
   entry ();
      static_trace_thread_switch = "1"b;
      return;

trace_thread_modifications_off:
   entry ();
      static_trace_thread_switch = "0"b;
      return;
%page;
RETURN:
   proc ();

      go to MAIN_RETURN;

   end RETURN;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH ();
      go to MAIN_RETURN;

   end ERROR_RETURN;


FINISH:
   proc ();

   end FINISH;

GET_STORAGE_RECORD_PTR:
   proc () returns (ptr);

      dcl	    gsr_p_storage_record_ptr
			       ptr;
      dcl	    gsr_code	       fixed bin (35) init (0);

      if cm_info.storage_record_ptr = null
      then call cm_opening_info$get_storage_record (cm_info_ptr, gsr_code);

      if gsr_code ^= 0
      then call ERROR_RETURN (gsr_code);

      gsr_p_storage_record_ptr = cm_info.storage_record_ptr;

      return (gsr_p_storage_record_ptr);

   end GET_STORAGE_RECORD_PTR;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", cv_p_correct_version,
	      cv_p_structure_name, cv_p_given_version);

      return;

   end CHECK_VERSION;


CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a control interval; received ^a.", BASIC_CI_LAYOUT_1, ccv_p_given_version);
      else return;

   end CHECK_CI_VERSION;
%page;
%include dm_hdr_collection_id;

%include dm_cm_hdr_col_ids;
%page;
%include dm_cm_info;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_file_header;
%page;
%include dm_cm_storage_record;
%page;
%include dm_cm_reservation_map;
%page;
%include dm_cism_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_free_ci;




		    cm_free_opening_info.pl1        01/04/85  0947.4re  01/03/85  1148.4       51417



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:
         This   routine  frees  the  opening  information  maintained  for  a
     collection, and removes the  collection  from  the  collection_manager_'s
     per-process opening table.
*/

/* HISTORY:
Written by Matthew Pierret, 03/25/83.
Modified:
05/21/84 by Matthew Pierret: Renamed include file dm_cm_cism_info to
            dm_cism_info.
10/01/84 by Matthew Pierret: Added FREE_STORAGE routine, which actually frees
            the structures.  FINISH now calls this routine.  Added RETURN
            and ERROR_RETURN routines.  Removed "in (dm_area)" from free
            statements, as it is unnecessary, and removed declarations for
            dm_area, dm_area_ptr and get_dm_free_area_. Changed 
            REPORT_WRONG_VERSION to the standard CHECK_VERSION.

*/

/* format: style2,ind3 */

cm_free_opening_info:
   proc (p_file_opening_id, p_collection_id, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    collection_opening_id  bit (72) aligned;
      dcl	    (per_process_opening_table_ptr, temp_cm_info_ptr)
			       ptr;

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("cm_free_opening_info") char (32) varying internal static options (constant);
      dcl	    NO_ERRORS	       init (0) fixed bin (35) internal static options (constant);

/* Entry */

      dcl	    cm_opening_info$opening_table_ptr
			       entry () returns (ptr);
      dcl	    opening_manager_$get_opening
			       entry (ptr, bit (72) aligned, ptr, fixed bin (35));
      dcl	    opening_manager_$free_opening
			       entry (ptr, bit (72) aligned, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$no_opening,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code, code = 0;
      cm_info_ptr, collection_header_ptr, blocked_storage_record_ptr, unblocked_storage_record_ptr = null;

      per_process_opening_table_ptr = cm_opening_info$opening_table_ptr ();
      if per_process_opening_table_ptr = null
      then call RETURN (NO_ERRORS);

      collection_opening_id = p_file_opening_id || p_collection_id;

      call opening_manager_$get_opening (per_process_opening_table_ptr, collection_opening_id, temp_cm_info_ptr, code);
      if code ^= 0
      then if code = dm_error_$no_opening
	 then call RETURN (NO_ERRORS);
	 else call ERROR_RETURN (code);

      if temp_cm_info_ptr = null
      then call RETURN (NO_ERRORS);

      call CHECK_VERSION (temp_cm_info_ptr -> cm_info.version, CM_INFO_VERSION_2, "cm_info");
      cm_info_ptr = temp_cm_info_ptr;

      if cm_info.header_ptr ^= null
      then
         do;
	  call CHECK_VERSION (cm_info.header_ptr -> collection_header.version, COLLECTION_HEADER_VERSION_2,
	       "collection_header");

	  collection_header_ptr = cm_info.header_ptr;

	  if cm_info.storage_record_buffer_ptr ^= null
	  then if collection_header.control_interval_storage_method = UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
	       then unblocked_storage_record_ptr = cm_info.storage_record_buffer_ptr;
	       else if collection_header.control_interval_storage_method = BLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
	       then blocked_storage_record_ptr = cm_info.storage_record_buffer_ptr;
         end;


      call opening_manager_$free_opening (per_process_opening_table_ptr, collection_opening_id, p_code);
      if p_code ^= 0
      then return;

      on cleanup call FINISH ();

      call FREE_STORAGE ();
MAIN_RETURN:
      return;

RETURN:
   proc (r_p_code);

      dcl	    r_p_code	       fixed bin (35);

      p_code = r_p_code;
      go to MAIN_RETURN;

   end RETURN;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      call RETURN (er_p_code);

   end ERROR_RETURN;
%page;
FINISH:
   proc ();

      call FREE_STORAGE ();

   end FINISH;

FREE_STORAGE:
   proc ();

      if cm_info_ptr ^= null
      then free cm_info;
      if collection_header_ptr ^= null
      then free collection_header;
      if blocked_storage_record_ptr ^= null
      then free blocked_storage_record;
      if unblocked_storage_record_ptr ^= null
      then free unblocked_storage_record;

   end FREE_STORAGE;
%page;
CHECK_VERSION:
   proc (cv_p_given_version, cv_p_correct_version, cv_p_structure_name);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of ^a structure; received ^8a.", cv_p_correct_version, cv_p_structure_name,
	      cv_p_given_version);

      return;

   end CHECK_VERSION;
%page;
%include dm_cm_info;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_storage_record;
%page;
%include dm_cism_info;
%page;
%include sub_err_flags;
   end cm_free_opening_info;




		    cm_get_bci_header.pl1           05/06/86  1320.4rew 05/06/86  1257.0       60786



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(86-02-27,Pierret), approve(86-02-27,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Added must_be_zero field to my_ci_parts;
                                                   END HISTORY COMMENTS */


/* DESCRIPTION:

         This routine gets and validates the header (bci_header) of a
     specified control interval.  Four entries each provide this service in a
     slightly different manner.  The bci_header begins at the first word of
     the addressable portion of the control interval.  The caller supplies a
     pointer (p_bci_header_ptr) to a buffer in which to put the bci_header.
     The caller must also supply the opening id of the file
     (p_file_opening_id) in which the specified control interval resides.
     
          If called through teh $cm_get_bci_header or $exclusive entrypoints,
     number of the control interval is specified with the
     p_control_interval_number parameter.  If called through the $exclusive
     entrypoint, an exclusive lock is obtained on the control interval;
     otherwise a shared lock is obtained.
     
          If called through the $slot or $slot_exclusive entrypoints, the
     number of the control interval is specified as part of the p_element_id
     parameter (addr(p_element_id)->element_id.control_interval_id).  Also
     specified is the index into the slot table of an element in p_element_id
     (addr(p_element_id)->element_id.index).  The specified slot is returned,
     using the caller-supplied buffer at p_datum_slot_ptr.  If called through
     the $slot_exclusive entrypoint, an exclusive lock is obtained.
     
          Possible errors are those errors that can be encountered while doing
     a file_manager_$get, dm_error_$ci_not_allocated if the returned bci_header
     is all zeroes and dm_error_$misformatted_ci if the returned bci_header
     does not have a layout type of BASIC_CI_LAYOUT_1.
*/

/* HISTORY:

Written by Matthew Pierret, 07/21/82.
Modified:
10/20/82 by Matthew Pierret: Converted to use file_manager_.
01/26/83 by Matthew Pierret: Added $slot and $slot_exclusive entries,
            obsoleting cm_get_header_and_slot. Changed to return
            dm_error_$ci_not_allocated if bci_header is all zeroes.
10/01/84 by Matthew Pierret: Changed to use my_ci_parts instead of 
            automatic_cip_buffer (an array of fixed bin (71) elements) as
            the local storage for the ci_parts structure. my_ci_parts is
            able to change size as the ci_parts structure changes.
05/20/85 by S. Cox: Added must_be_zero field to my_ci_parts.
*/

/* format: style2,ind3 */

cm_get_bci_header:
   proc (p_file_opening_id, p_control_interval_number, p_bci_header_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_control_interval_number
			       fixed bin (24) unsigned parameter;
      dcl	    p_bci_header_ptr       ptr parameter;
      dcl	    p_datum_slot_ptr       ptr parameter;
      dcl	    p_element_id	       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (exclusive_get, get_slot)
			       bit (1) aligned;
      dcl	    1 my_ci_parts	       aligned,
	      2 number_of_parts    fixed bin init (-1),
	      2 must_be_zero       fixed bin init (0),
	      2 part	       (2) like ci_parts.part;
      dcl	    control_interval_number
			       fixed bin (24) unsigned;
      dcl	    slot_number	       fixed bin (12) unsigned;

/* Based */
/* Builtin */

      dcl	    (addr, null, size, unspec)
			       builtin;

/* Constant */

      dcl	    BYTES_PER_WORD	       init (4) fixed bin (17) int static options (constant);

/* Entry */

      dcl	    file_manager_$get      entry (bit (36) aligned, uns fixed bin (24), ptr, fixed bin (35));
      dcl	    file_manager_$get_exclusive
			       entry (bit (36) aligned, uns fixed bin (24), ptr, fixed bin (35));

/* External */

      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$misformatted_ci
	    )		       ext fixed bin (35);

/* END OF DECLARATIONS */

      exclusive_get = "0"b;
      get_slot = "0"b;
      control_interval_number = p_control_interval_number;
      go to JOIN;


exclusive:
   entry (p_file_opening_id, p_control_interval_number, p_bci_header_ptr, p_code);

      exclusive_get = "1"b;
      get_slot = "0"b;
      control_interval_number = p_control_interval_number;
      go to JOIN;

slot_exclusive:
   entry (p_file_opening_id, p_bci_header_ptr, p_datum_slot_ptr, p_element_id, p_code);

      exclusive_get = "1"b;
      get_slot = "1"b;
      control_interval_number = addr (p_element_id) -> element_id.control_interval_id;
      slot_number = addr (p_element_id) -> element_id.index;
      go to JOIN;

slot:
   entry (p_file_opening_id, p_bci_header_ptr, p_datum_slot_ptr, p_element_id, p_code);

      exclusive_get = "0"b;
      get_slot = "1"b;
      control_interval_number = addr (p_element_id) -> element_id.control_interval_id;
      slot_number = addr (p_element_id) -> element_id.index;
      go to JOIN;


JOIN:
      p_code = 0;
      bci_header_ptr = p_bci_header_ptr;

      my_ci_parts.number_of_parts = 1;
      my_ci_parts.part (1).offset_in_bytes = 0;
      my_ci_parts.part (1).length_in_bytes = size (bci_header) * BYTES_PER_WORD;
      my_ci_parts.part (1).local_ptr = bci_header_ptr;

      if get_slot
      then if slot_number > 0 & p_datum_slot_ptr ^= null
	 then
	    do;
	       my_ci_parts.number_of_parts = 2;

	       my_ci_parts.part (2).offset_in_bytes = (size (bci_header) + slot_number - 1) * BYTES_PER_WORD;
	       my_ci_parts.part (2).length_in_bytes = BYTES_PER_WORD;
	       my_ci_parts.part (2).local_ptr = p_datum_slot_ptr;
	    end;

      if exclusive_get
      then call file_manager_$get_exclusive (p_file_opening_id, control_interval_number, addr (my_ci_parts), p_code);
      else call file_manager_$get (p_file_opening_id, control_interval_number, addr (my_ci_parts), p_code);
      if p_code = 0
      then if bci_header.layout_type ^= BASIC_CI_LAYOUT_1
	 then if unspec (bci_header) = "0"b
	      then p_code = dm_error_$ci_not_allocated;
	      else p_code = dm_error_$misformatted_ci;

      return;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_ci_parts;
%page;
%include dm_element_id;

   end cm_get_bci_header;




		    cm_get_ci_ptr.pl1               01/04/85  0947.4re  01/03/85  1148.5       30078



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

          This routine implements the 
     collection_manager_$get_control_interval_ptr entry.  It gets a pointer
     to the addressable portion of a control interval.  The pointer is actually
     to the control interval in the file, not to a copy.  The following errors
     can occur as a result of consistency checks, but do not prevent the return
     of p_the control_interval_ptr:

     dm_error_$ci_not_allocated - the entire control interval header is "0"b
     dm_error_$ci_not_in_collection - the control interval does not belong to
                                      the specified collection.
     error_table_$unimplemented_version - the layout_type is not one supported
                                      by the collection_manager_.
          
*/

/* HISTORY:

Written by Matthew Pierret, 03/16/84.
Modified:
08/23/84 by Matthew Pierret:  Changed to verify control interval. Added
            ERROR_RETURN procedure.
*/

/* format: style2,ind3 */

cm_get_ci_ptr:
   proc (p_file_opening_id, p_collection_id, p_control_interval_id, p_control_interval_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned;	/*A file opening identifier. */
      dcl	    p_collection_id	       bit (36) aligned;	/*A collection identifier.*/
      dcl	    p_control_interval_id  fixed bin (24) uns;	/*Number of desired control interval.*/
      dcl	    p_control_interval_ptr ptr;		/*Pointer to addressable portion of CI.*/
      dcl	    p_code	       fixed bin (35);	/*Standard error code.*/

/* Automatic */

      dcl	    code		       fixed bin (35);

/* Based */
/* Builtin */

      dcl	    (null, unspec)	       builtin;

/* Constant */
/* Entry */

      dcl	    file_manager_$get_ci_ptr
			       entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));

/* External */

      dcl	    dm_error_$ci_not_allocated
			       fixed bin (35) ext;
      dcl	    dm_error_$ci_not_in_collection
			       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;


/* END OF DECLARATIONS */
%page;
      code = 0;
      p_control_interval_ptr = null;

      call file_manager_$get_ci_ptr (p_file_opening_id, (p_control_interval_id), p_control_interval_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      if p_control_interval_ptr -> bci_header.layout_type ^= BASIC_CI_LAYOUT_1
      then if unspec (p_control_interval_ptr -> bci_header) = ""b
	 then call ERROR_RETURN (dm_error_$ci_not_allocated);
	 else call ERROR_RETURN (error_table_$unimplemented_version);
      else if p_control_interval_ptr -> bci_header.collection_id ^= p_collection_id
      then call ERROR_RETURN (dm_error_$ci_not_in_collection);
      else p_code = 0;

MAIN_RETURN:
      return;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;

%page;
%include dm_cm_basic_ci;

   end cm_get_ci_ptr;




		    cm_get_element.pl1              04/04/85  1112.8r w 04/04/85  0912.6      230445



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

   This module implements collection_manager_$get 
   (cm_get_element$cm_get_element), collection_manager_$get_exclusive
   (cm_get_element$exclusive) and collection_manager_$get_by_ci_ptr
   (cm_get_element$by_ci_ptr);

   This module gets the specified element.  The location of the element
   is p_position elements from p_element_id.  The data is returned in the
   buffer located at p_buffer_ptr (if it fits).  p_buffer_length is the
   bit length of that caller-supplied buffer.  If the buffer is too small
   to hold the data, space is allocated in the provided area and the 
   data is returned there.
*/

/* HISTORY:

Written 02/25/82 by Matthew Pierret.
Modified:
03/23/82 by Matthew Pierret: Changed to return dm_error_$invalid_element_id
            if given a slot index of less-than 1.
03/25/82 by Matthew Pierret: Fixed bug which improperly set p_element_ptr/length.
04/07/82 by Matthew Pierret: Changed p_buffer_length to be a bit length.
05/10/82 by Lindsey Spratt: Use the precision and scale of (35,18) when
	  dividing to find the length in bytes from the length in bits.
	  Also, subtract the datum header length when setting the returned
	  element_length.
06/09/82 by Matthew Pierret: Added code to support getting element portions
            if portion_beginning_index is equal to 1. Added consistency check
            to make sure that the control interval in which the element resides
            belongs to the specified collection. 
06/15/82 by Matthew Pierret: Changed to use bci_header, dm_cm_basic_ci.incl.pl1,
            add_ci_part to cm_add_ci_part, ..BYTE_LENGTH to ..LENGTH_IN_BYTES,
            calling sequence of cm_add_ci_part.
07/09/82 by Matthew Pierret: Added exclusive entry. Replaced calls to 
            cm_add_ci_part with in-line code.
09/02/82 by Matthew Pierret:  Added ability to position forward or backward.
            p_element_id is now an input/output parameter, as it is set to the
            id of the element positioned to. 
10/19/82 by Matthew Pierret:  Added check for free datum slot.
            Changed to use dm_error_$no_element.
10/20/82 by Matthew Pierret:  Converted to use file_manager_.
11/08/82 by Matthew Pierret:  Changed to support multi-datum elements.
12/01/82 by Lindsey Spratt: Changed to initialize p_new_buffer_was_allocated
	  to "0"b.  Also, removed the get_element entry name.
01/04/83 by Lindsey Spratt:  Fixed to use a local buffer when getting the
	  first datum of a multi-datum element; also, to return an error
	  code when the supplied buffer is too small, no area was supplied
	  and the element is multi-datum.
01/26/83 by Matthew Pierret: Changed to provide better error reporting.
            Errors encountered getting continuation datums are reported via
            sub_err_, as they represent inconsistencies in the collection's
            data.
02/07/83 by Matthew Pierret: Changed to use cm_get_id$header_return_slot to
            position to an element.  Added the $info* entries.
            Added $bypass_info. This entry is called by cm_opening_info$get.
            It does not attempt to get cm_info. If it did, an infinite loop
            would occur with cm_get_element and cm_opening_info calling each
            repeatedly.
04/03/83 by Lindsey L. Spratt:  Changed length variables to be declared fixed
            bin (35) instead of fixed bin (17).
04/03/83 by Lindsey L. Spratt:  Fixed to use a (71,18) when doing the division
            to set the element_length_in_bytes in the multi-datum case.
04/06/83 by Lindsey L. Spratt:  Fixed multi-datum case to subtract the initial
            datum length from the element_length_in_bytes (which was already
            being decremented for each of the other datums).  Added an error
            check for the multi-datum length inconsistency.
04/29/83 by Matthew Pierret: Changed to use addcharno instead of addr(substr())
            and to use dm_error_$long_return_element.
05/04/83 by Matthew Pierret:  Changed dm_error_$col_is_inconsistent to
            $programming_error.
07/14/83 by Matthew Pierret:  Changed to consider the case of an
            element_id.index of 0 without intended positioning away to be in
            error.  dm_error_$no_element is returned. Changed to allow an
            element_id_string of "0"b if positioning is specified.
10/13/83 by Lindsey L. Spratt:  Changed to not get the opening_info in the get
            or exclusive_get entries.
10/17/83 by Lindsey L. Spratt:  Fixed to properly copy the
            position_from_specified_element value for the NO_INFO_JOIN
            entries.
01/24/84 by Matthew Pierret:  Fixed multi-datum gets to stop inadvertently
            attempting to get two ci parts instead of one by forgetting to
            reset ci_parts.number_of_parts to 1.
02/07/84 by Matthew Pierret:  Changed to make use of the 
            file_manager_$get_ci_ptr operation to reduce the number of calls
            to file_manager_$get.  Added the p_position argument to the
            $bypass_info entry so that it has the same calling sequence as
            $cm_get_element and $exclusive, and removed all other entries.
            A lot of extra code is generated by the compiler when a routine
            has multiple entrypoints with the same arguments in different 
            places.  This is no longer the case for cm_get_element.
03/15/84 by Lindsey L. Spratt:  Fixed MULTI_DATUM_GET to set the
            cd_datum_header.  (Matt and Lee B.  helped)
03/16/84 by Matthew Pierret:  Changed to special case 
            dm_error_$ci_not_allocated when returned from fm_$get_ci_ptr.
05/09/84 by Matthew Pierret:  Changed the buffer used to be even word aligned.
07/18/84 by Matthew Pierret:  Changed to return dm_error_$ci_not_in_collection
            if the error is detected on the first control interval examined,
            but to call sub_err_ on subsequent control intervals.  This is 
            because the former indicates that the caller probably supplied
            the wrong element id, while the latter indicates an inconsistency
            in the collection.
10/01/84 by Matthew Pierret:  Changed for the changes in datum structures
            (they are all based on datum_ptr and datum_contents_length_in_bits)
            Changed expression of converting bits to bytes for efficiency:
            ceil (divide (bits ,BITS_PER_BYTE ,35 ,18)) is better as
            divide (bits + BITS_PER_BYTE -1, BITS_PER_BYTE, 17, 0).
            Added comment to explain why buffer_ptr=null need not be checked
            when determining whether to allocate a new buffer.
12/03/84 by Matthew Pierret:  Added the local cd_datum_header, which was 
            removed from dm_cm_datum.incl.pl1.
*/

/* format: style2,ind3,ll79 */

cm_get_element:
   proc (p_file_opening_id, p_collection_id, p_element_id, p_position,
        p_buffer_ptr, p_buffer_length, p_area_ptr, p_new_buffer_was_allocated,
        p_element_ptr, p_element_length, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_position	       fixed bin (17);
      dcl	    p_buffer_ptr	       ptr;
      dcl	    p_buffer_length	       fixed bin (35);
      dcl	    p_area_ptr	       ptr;
      dcl	    p_new_buffer_was_allocated
			       bit (1) aligned;
      dcl	    p_element_ptr	       ptr;
      dcl	    p_element_length       fixed bin (35);
      dcl	    p_code	       fixed bin (35);
      dcl	    p_input_ci_ptr	       ptr;
      dcl	    p_return_ci_ptr	       ptr;

/* Automatic */

      dcl	    (file_opening_id, collection_id)
			       bit (36) aligned;
      dcl	    (continuation_datum_id_string, continued_datum_id_string)
			       init ("0"b) bit (36) aligned;

      dcl	    code		       fixed bin (35) init (0);
      dcl	    buffer_length_in_bits  fixed bin (35) init (0);
      dcl	    buffer_length_in_double_words
			       fixed bin (17) init (0);
      dcl	    datum_contents_length_in_bytes
			       fixed bin (17) init (0);
      dcl	    element_length_in_bits fixed bin (35) init (0);
      dcl	    element_length_in_bytes
			       fixed bin (35) init (0);
      dcl	    remaining_element_length_in_bytes
			       fixed bin (35) init (0);
      dcl	    position_from_specified_element
			       fixed bin (17) init (0);
						/* This should probably be 35, eventually. */

      dcl	    exclusive_get	       bit (1) aligned init ("0"b);
      dcl	    return_last_used_ci_ptr
			       bit (1) aligned init ("0"b);

      dcl	    ci_ptr	       ptr init (null);
      dcl	    work_area_ptr	       ptr init (null);
      dcl	    buffer_ptr	       ptr init (null);
      dcl	    current_buffer_ptr     ptr init (null);
      dcl	    datum_contents_ptr     ptr init (null);

      dcl	    1 cd_datum_header      aligned like continued_datum.header;

/* Based */

      dcl	    1 continued_datum_id   aligned like datum_id
			       based (addr (continued_datum_id_string));
      dcl	    1 continuation_datum_id
			       aligned like datum_id
			       based (
			       addr (continuation_datum_id_string));
      dcl	    work_area	       area based (work_area_ptr);
      dcl	    buffer	       (buffer_length_in_double_words) fixed
			       bin (71) based (buffer_ptr);
      dcl	    datum_contents_string  char (datum_contents_length_in_bytes)
			       based;

/* Builtin */

      dcl	    (addr, addcharno, ceil, divide, length, null, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("cm_get_element") char (32)
			       varying internal static
			       options (constant);
      dcl	    (
	    BITS_PER_BYTE	       init (9),
	    BYTES_PER_DOUBLE_WORD  init (8)
	    )		       fixed bin int static options (constant);
      dcl	    (
	    THIS_IS_FIRST_CI_SEEN  init ("1"b),
	    THIS_IS_NOT_FIRST_CI_SEEN
			       init ("0"b)
	    )		       bit (1) aligned internal static
			       options (constant);

/* Entry */

      dcl	    file_manager_$get_ci_ptr
			       entry (bit (36) aligned, fixed bin (27),
			       ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$ci_not_in_collection,
	    dm_error_$no_element,
	    dm_error_$long_return_element,
	    dm_error_$programming_error
	    )		       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */
%page;
      exclusive_get = "0"b;
      return_last_used_ci_ptr = "0"b;
      position_from_specified_element = p_position;
      ci_ptr = null ();
      go to JOIN;

exclusive:
   entry (p_file_opening_id, p_collection_id, p_element_id, p_position,
        p_buffer_ptr, p_buffer_length, p_area_ptr, p_new_buffer_was_allocated,
        p_element_ptr, p_element_length, p_code);

      exclusive_get = "1"b;
      return_last_used_ci_ptr = "0"b;
      position_from_specified_element = p_position;
      ci_ptr = null ();
      go to JOIN;


by_ci_ptr:
   entry (p_input_ci_ptr, p_file_opening_id, p_collection_id, p_element_id,
        p_position, p_buffer_ptr, p_buffer_length, p_area_ptr,
        p_new_buffer_was_allocated, p_element_ptr, p_element_length,
        p_return_ci_ptr, p_code);

      exclusive_get = "0"b;
      return_last_used_ci_ptr = "1"b;
      position_from_specified_element = p_position;
      ci_ptr = p_input_ci_ptr;
      go to JOIN;
%page;
JOIN:
      p_code = 0;
      p_new_buffer_was_allocated = "0"b;
      file_opening_id = p_file_opening_id;
      collection_id = p_collection_id;
      element_id_string = p_element_id;
      buffer_ptr = p_buffer_ptr;			/* format: equalind0 */

      if buffer_ptr = null
      then buffer_length_in_bits = -1;			/* no buffer */
      else buffer_length_in_bits = p_buffer_length;

      if position_from_specified_element = 0
      then
         do;
	  if element_id.index <= 0
	  then call ERROR_RETURN (dm_error_$no_element);
	  call GET_CI_PTR (THIS_IS_FIRST_CI_SEEN, file_opening_id,
	       collection_id, (element_id.control_interval_id), ci_ptr);
	  if element_id.index
	       > ci_ptr -> basic_control_interval.header.number_of_datums
	  then call ERROR_RETURN (dm_error_$no_element);
         end;
      else
         do;
	  call cm_get_id$ptr (file_opening_id, collection_id,
	       (element_id_string), position_from_specified_element,
	       (element_id_string = "0"b), ci_ptr, ci_ptr, element_id_string,
	       code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;

      /*** This is the control interval in which the elment to be retrieved lives.
        Return it if it has been requested.  This is done here because ci_ptr may change
        later on if the element is a multi-datum element, but we want to return
        the ptr to the control interval in which the element starts. */

      if return_last_used_ci_ptr
      then p_return_ci_ptr = ci_ptr;

      /*** Copy datum slot into local storage for efficiency. */

      datum_slot_ptr =
	 addr (ci_ptr
	 -> basic_control_interval.datum_position_table (element_id.index));

      /*** If no element corresponds to this datum slot, report to caller that
        the element could not be found. */

      if datum_slot.offset_in_bytes = FREE_SLOT /* no datum here */
	 | datum_slot.flags.is_continuation		/* this datum is not the start of an element */
      then call ERROR_RETURN (dm_error_$no_element);


      if ^datum_slot.flags.is_continued
      then
SIMPLE_GET:
         do;

	  /*** The datum described by datum_slot is the entire element.  Get the datum
in the supplied buffer or in the supplied work area if
the the buffer is not supplied or is too small.
There is no need to check to see if buffer_ptr is null,
as if it is, buffer_length_in_bytes is -1, and so will
always pass the test to see if the buffer is to small.. */

	  datum_contents_ptr =
	       addcharno (ci_ptr, datum_slot.offset_in_bytes);
	  datum_contents_length_in_bytes =
	       divide (datum_slot.length_in_bits + BITS_PER_BYTE - 1,
	       BITS_PER_BYTE, 17, 0);

	  if datum_contents_length_in_bytes * BITS_PER_BYTE
	       > buffer_length_in_bits		/* datum_contents_length_in_bytes * BITS_PER_BYTE is used */
						/* in this test instead of datum_slot.length_in_bits      */
						/* because the buffer must be large enough to fit the     */
						/* contents when copied in bytes.                         */
	  then
SG_ALLOC_BUFFER:
	     do;					/* Buffer is too small. Try allocating a buffer in the work area. */
	        work_area_ptr = p_area_ptr;
	        if work_area_ptr = null
	        then
		 do;
		    p_element_length =
		         datum_contents_length_in_bytes * BITS_PER_BYTE;
						/* Not the actual length of the element, but the minimum */
						/* size a buffer must be to hold the element. */
		    call ERROR_RETURN (dm_error_$long_return_element);
		 end;
	        else
		 do;				/* Allocate the buffer. */
		    buffer_length_in_double_words =
		         divide (datum_contents_length_in_bytes,
		         BYTES_PER_DOUBLE_WORD, 35, 0) + 1;
		    on cleanup call FINISH ();
		    alloc buffer in (work_area);
		    p_new_buffer_was_allocated = "1"b;
		 end;
	     end SG_ALLOC_BUFFER;

	  /*** Now, copy the datum contents into the buffer. */

	  buffer_ptr -> datum_contents_string =
	       datum_contents_ptr -> datum_contents_string;

	  p_element_ptr = buffer_ptr;
	  p_element_length = datum_slot.length_in_bits;

         end SIMPLE_GET;

      else call MULTI_DATUM_GET ();			/* The element consists of more than one datum. */

      if p_element_id ^= element_id_string
      then p_element_id = element_id_string;

RETURN:
      return;
%page;
FINISH:
   proc ();

      if buffer_ptr ^= p_buffer_ptr & buffer_ptr ^= null
      then
         do;
	  p_new_buffer_was_allocated = "0"b;
	  free buffer in (work_area);
         end;

   end FINISH;

ERROR_RETURN:
   proc (er_code);

      dcl	    er_code	       fixed bin (35);

      p_code = er_code;
      call FINISH ();
      goto RETURN;

   end ERROR_RETURN;
%page;
CHECK_CI_LAYOUT:
   proc (ccl_p_ci_layout);
      dcl	    ccl_p_ci_layout	       char (4) aligned;

      if ccl_p_ci_layout ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (error_table_$unimplemented_version, myname,
	      ACTION_CANT_RESTART, null, 0,
	      "^/Expected a version ^a control interval. Received version ^a instead."
	      , BASIC_CI_LAYOUT_1, ccl_p_ci_layout);

   end CHECK_CI_LAYOUT;
%page;
GET_CI_PTR:
   proc (gcp_p_this_is_initial_ci, gcp_p_foid, gcp_p_collection_id,
        gcp_p_ci_id, gcp_p_ci_ptr);

      dcl	    gcp_p_this_is_initial_ci
			       bit (1) aligned;
      dcl	    gcp_p_foid	       bit (36) aligned;
      dcl	    gcp_p_collection_id    bit (36) aligned;
      dcl	    gcp_p_ci_id	       fixed bin (24) unsigned;
      dcl	    gcp_p_ci_ptr	       ptr;

      if gcp_p_this_is_initial_ci = THIS_IS_FIRST_CI_SEEN
      then
         do;
	  if gcp_p_ci_ptr = null ()
	  then gcp_p_ci_ptr = REALLY_GET_CI_PTR (gcp_p_this_is_initial_ci);
	  else /* gcp_p_ci_ptr = gcp_p_ci_ptr */
	       ;
         end;
      else
         do;
	  if gcp_p_ci_ptr = null
	  then call sub_err_ (dm_error_$programming_error, myname,
		  ACTION_CANT_RESTART, null (), 0, "^/^a ^d ^a,^/^a",
		  "Control interval", gcp_p_ci_id,
		  "was not the first one examined",
		  "yet there is no previous control interval.");
	  else gcp_p_ci_ptr = REALLY_GET_CI_PTR (gcp_p_this_is_initial_ci);
         end;

      call CHECK_CI_LAYOUT ((gcp_p_ci_ptr -> bci_header.layout_type));

      if gcp_p_ci_ptr -> bci_header.collection_id ^= gcp_p_collection_id
      then if gcp_p_this_is_initial_ci
	 then call ERROR_RETURN (dm_error_$ci_not_in_collection);
	 else call sub_err_ (dm_error_$programming_error, myname,
		 ACTION_CANT_RESTART, null, 0,
		 "^/^a ^d ^a ^3bo ^a^/^a ^3bo.", "Control interval",
		 gcp_p_ci_id, "is in collection",
		 gcp_p_ci_ptr -> bci_header.collection_id,
		 "but was expected to", "be in collection",
		 gcp_p_collection_id);
      else return;

REALLY_GET_CI_PTR:
   proc (rgcp_p_is_initial_ci) returns (ptr);

      dcl	    rgcp_p_is_initial_ci   bit (1) aligned;
      dcl	    rgcp_ci_ptr	       ptr init (null ());
      dcl	    rgcp_code	       fixed bin (35) init (0);

      call file_manager_$get_ci_ptr (gcp_p_foid, (gcp_p_ci_id), rgcp_ci_ptr,
	 rgcp_code);
      if rgcp_code ^= 0
      then if rgcp_code ^= dm_error_$ci_not_allocated
	 then call ERROR_RETURN (rgcp_code);
	 else if rgcp_p_is_initial_ci = THIS_IS_FIRST_CI_SEEN
	 then call ERROR_RETURN (dm_error_$no_element);	/* First datum of element. */
						/* No CI means no element. */
	 else
	    do;					/* Is a continuation datum. */
						/* No CI means improperly formed continued datum. */
	       call sub_err_ (rgcp_code, myname, ACTION_CANT_RESTART, null,
		  0,
		  "^/Control interval ^d was expected to hold the continuation of ^/the datum at slot ^d of control interval ^d."
		  , gcp_p_ci_id, continued_datum_id.index,
		  continued_datum_id.control_interval_id);
	    end;
      else return (rgcp_ci_ptr);


   end REALLY_GET_CI_PTR;

   end GET_CI_PTR;
%page;
MULTI_DATUM_GET:
   proc ();


      /*** The datum is by definition a "continued" datum, described by the
        continued_datum structure.  Set a pointer to the beginning of that structure,
        extract header information and datum contents from it. */

      datum_ptr = addcharno (ci_ptr, datum_slot.offset_in_bytes);
						/* Points to beginning of continued_datum. */
      datum_contents_length_in_bits =
	 datum_slot.length_in_bits - CD_DATUM_HEADER_LENGTH_IN_BITS;
      datum_contents_ptr = addr (continued_datum.contents);
      datum_contents_length_in_bytes =
	 divide (datum_contents_length_in_bits + BITS_PER_BYTE - 1,
	 BITS_PER_BYTE, 17, 0);

      element_length_in_bits = continued_datum.header.full_length;
						/* Full length of element. */
      element_length_in_bytes =
	 divide (element_length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE,
	 35, 0);

      if element_length_in_bytes * BITS_PER_BYTE > buffer_length_in_bits
						/* element_length_in_bytes * BITS_PER_BYTE is used in this        */
						/* test instead of datum_slot.length_in_bits because the buffer   */
						/* must be large enough to fit the contents when copied in bytes. */
      then
MG_ALLOC_BUFFER:
         do;					/* Buffer is too small. Try allocating a buffer in the work area. */
	  work_area_ptr = p_area_ptr;
	  if work_area_ptr = null
	  then
	     do;
	        p_element_length = element_length_in_bytes * BITS_PER_BYTE;
						/* Not the actual length of the element, but the minimum size a  */
						/* buffer must be to hold the element. */
	        call ERROR_RETURN (dm_error_$long_return_element);
	     end;
	  else
	     do;					/* Allocate the buffer. */
	        buffer_length_in_double_words =
		   divide (element_length_in_bytes, BYTES_PER_DOUBLE_WORD,
		   17, 0) + 1;
	        on cleanup call FINISH ();
	        alloc buffer in (work_area);
	        p_new_buffer_was_allocated = "1"b;
	     end;
         end MG_ALLOC_BUFFER;

      if datum_contents_length_in_bytes <= 0
      then
         do;
	  current_buffer_ptr = buffer_ptr;
	  remaining_element_length_in_bytes = element_length_in_bytes;
         end;
      else
         do;
	  buffer_ptr -> datum_contents_string =
	       datum_contents_ptr -> datum_contents_string;
	  current_buffer_ptr =
	       addcharno (buffer_ptr, datum_contents_length_in_bytes);
	  remaining_element_length_in_bytes =
	       element_length_in_bytes - datum_contents_length_in_bytes;
						/* This is to indicate how much is left to be gotten. */
         end;

      continued_datum_id_string = element_id_string;	/* datum id of the continued datum, i.e., the the datum most recently */
						/* copied.  The element is continued in another datum. */
      cd_datum_header = continued_datum.header;

      continuation_datum_id = cd_datum_header.continuation; /* datum id of the datum which is the continuation of the continued datum. */

GET_EACH_DATUM_LOOP:
      do while (continuation_datum_id_string ^= "0"b
	 & remaining_element_length_in_bytes > 0);

         call GET_CI_PTR (THIS_IS_NOT_FIRST_CI_SEEN, file_opening_id,
	    collection_id, (continuation_datum_id.control_interval_id),
	    ci_ptr);

         if continuation_datum_id.index
	    > ci_ptr -> basic_control_interval.header.number_of_datums
         then call sub_err_ (dm_error_$programming_error, myname,
	         ACTION_CANT_RESTART, null, 0,
	         "^/There is no datum at slot ^d of control interval ^d.  A continuation^/of the datum at slot ^d of control interval ^d was expected to be there."
	         , continuation_datum_id.index,
	         continuation_datum_id.control_interval_id,
	         continued_datum_id.index,
	         continued_datum_id.control_interval_id);

         datum_slot_ptr =
	    addr (ci_ptr
	    -> basic_control_interval
	    .datum_position_table (continuation_datum_id.index));
         datum_ptr = addcharno (ci_ptr, datum_slot.offset_in_bytes);
         if datum_slot.is_continued
         then
	  do;
	     datum_contents_length_in_bits =
		datum_slot.length_in_bits
		- length (unspec (continued_continuation_datum.header));
	     datum_contents_length_in_bytes =
		divide (datum_contents_length_in_bits + BITS_PER_BYTE - 1,
		BITS_PER_BYTE, 17, 0);
	     datum_contents_ptr =
		addr (continued_continuation_datum.contents);

	     continued_datum_id_string = continuation_datum_id_string;
	     continuation_datum_id =
		continued_continuation_datum.header.continuation;
	  end;
         else
	  do;
	     datum_contents_length_in_bytes =
		divide (datum_slot.length_in_bits + BITS_PER_BYTE - 1,
		BITS_PER_BYTE, 17, 0);
	     datum_contents_ptr = addr (continuation_datum.contents);
	     continuation_datum_id_string = "0"b;
	  end;

         current_buffer_ptr -> datum_contents_string =
	    datum_contents_ptr -> datum_contents_string;

         current_buffer_ptr =
	    addcharno (current_buffer_ptr, datum_contents_length_in_bytes);

         remaining_element_length_in_bytes =
	    remaining_element_length_in_bytes
	    - datum_contents_length_in_bytes;

      end GET_EACH_DATUM_LOOP;

      if remaining_element_length_in_bytes > 0
      then call sub_err_ (dm_error_$programming_error, myname,
	      ACTION_CANT_RESTART, null, 0,
	      "^/The length of the element at slot ^d of control interval ^d is^/recorded as ^d bits.  The actual length is ^d bits."
	      , element_id.index, element_id.control_interval_id,
	      element_length_in_bits,
	      (element_length_in_bits
	      - remaining_element_length_in_bytes * BITS_PER_BYTE));

      p_element_ptr = buffer_ptr;
      p_element_length = cd_datum_header.full_length;

   end MULTI_DATUM_GET;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_element_id;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_get_element;




		    cm_get_element_buffered.pl1     04/04/85  1112.8r w 04/04/85  0912.6      177354



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */



/* DESCRIPTION

   This module implements collection_manager_$get_from_ci_buffer
   (cm_get_element_buffered$whole) and 
   collection_manager_$get_portion_from_ci_buffer 
   (cm_get_element_buffered$portion).

   This module gets the specified element.  The location of the element
   is p_position elements from p_element_id.  The data is returned in the
   buffer located at p_buffer_ptr (if it fits).  p_buffer_length is the
   bit length of that caller-supplied buffer.  If the buffer is too small
   to hold the data or the requested element is an overlength element,
   space is allocated in the provided area and the data is returned
   there.
*/

/* HISTORY:
Written by Matthew Pierret, 11/15/82.
Modified:
01/27/83 by Matthew Pierret: Enhanced error reporting ability. Added 
            consistency checks for multi-datum elements and changed to report
            certain errors getting continuation datums via sub_err_, as they
            indicate an inconsistency internal to the collection.
            Changed to use dm_error_$unimplemented_ci_version.
04/29/83 by Matthew Pierret: Changed to use addcharno instead of addr(substr())
            and dm_error_$long_return_element instead of $long_element.
            Also changed to use ERROR_RETURN routine for all error returns.
05/04/83 by Matthew Pierret:  Fixed used of addcharno.  Was adding byte too
            many on each use of addcharno. Changed to use 
            dm_error_$programming_error instead of $col_is_inconsistent.
11/07/83 by Matthew Pierret: Added $whole and $portion. $whole is the old
            behavior - return whole element. $portion returns a portion of the
            element.  Disallowed specifying element_id.index of zero.
11/17/83 by Lindsey L. Spratt:  Fixed to use the
            datum_contents_length_in_(bits bytes) in the SIMPLE_GET do-group,
            rather than referring back to datum_slot_table.length_in_bits,
            which is incorrect (too large) when doing a get_element_portion.
04/13/84 by Matthew Pierret:  Changed names of variable which contained
            "buffered_ci" to contain "ci_buffer" instead to conform with
            documentation.
05/09/84 by Matthew Pierret:  Changed to align allocated buffers on even word
            boundaries.
07/23/84 by Matthew Pierret:  Changed declaration of buffer to be fixed bin(71)
            instead allowing it to default to fixed bin (17).  Also changed
            the FINISH procedure to check buffer_ptr instead of
            p_new_buffer_was_allocated to determine if buffer should be freed.
10/01/84 by Matthew Pierret:  Changed to base all datum structures on datum_ptr
            and datum_contents_length_in_bits.  Changed to use 
            bytes = divide (bits+BITS_PER_BYTE-1, BITS_PER_BYTE, 17, 0)
            to convert bits to bytes more efficiently.  This is only used in 
            the critical path, SIMPLE_GET.
12/03/84 by Matthew Pierret:  Added the local cdcn_datum_header, which was 
            removed from dm_cm_datum.incl.pl1.
*/

/* format: style2,ind3 */

cm_get_element_buffered:
   proc ();
      call sub_err_ (dm_error_$programming_error, myname, ACTION_CAN_RESTART, null, 0, "This is not a valid entry point.")
	 ;

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_ci_buffer_ptr	       ptr;
      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_buffer_ptr	       ptr;
      dcl	    p_buffer_length	       fixed bin (35);
      dcl	    p_area_ptr	       ptr;
      dcl	    p_new_buffer_was_allocated
			       bit (1) aligned;
      dcl	    p_element_ptr	       ptr;
      dcl	    p_element_length       fixed bin (35);
      dcl	    p_portion_beginning_index
			       fixed bin (35);
      dcl	    p_portion_length       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    1 automatic_bci_header aligned like bci_header;
      dcl	    1 automatic_datum_slot aligned like datum_slot;
      dcl	    automatic_cip_buffer   (8) fixed bin (71) init (0, 0, 0, 0, 0, 0, 0, 0);
      dcl	    (continuation_datum_id_string, continued_datum_id_string)
			       bit (36) aligned;
      dcl	    buffer_length_in_bytes fixed bin (17) init (0);
      dcl	    ci_buffer_length_in_bytes
			       fixed bin (17) init (0);
      dcl	    datum_contents_length_in_bytes
			       fixed bin (17) init (0);
      dcl	    datum_contents_offset_in_bytes
			       fixed bin (17) init (0);
      dcl	    datum_header_length_in_bytes
			       fixed bin (17) init (0);
      dcl	    element_length_in_bytes
			       fixed bin (17) init (0);
      dcl	    old_buffer_length_in_bytes
			       fixed bin (17) init (0);
      dcl	    slot_idx	       fixed bin (17) init (0);

      dcl	    new_buffer_allowed     bit (1) aligned init ("0"b);
      dcl	    use_supplied_buffer    bit (1) aligned init ("0"b);
      dcl	    get_whole_element      bit (1) aligned;

      dcl	    work_area_ptr	       ptr init (null);
      dcl	    buffer_ptr	       ptr init (null);
      dcl	    ci_buffer_ptr	       ptr init (null);
      dcl	    current_buffer_ptr     ptr init (null);

      dcl	    1 cdcn_datum_header    aligned like continued_continuation_datum.header;

/* Based */

      dcl	    1 continuation_datum_id
			       aligned like datum_id based (addr (continuation_datum_id_string));
      dcl	    datum_contents_string  char (datum_contents_length_in_bytes) based;
      dcl	    work_area	       area based (work_area_ptr);
      dcl	    buffer	       (buffer_length_in_bytes / BYTES_PER_DOUBLE_WORD + 1) fixed bin (71)
			       based (buffer_ptr);

/* Builtin */

      dcl	    (addcharno, addr, ceil, divide, floor, min, null, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("cm_get_element_buffered") char (32) varying internal static
			       options (constant);
      dcl	    BYTES_PER_DOUBLE_WORD  init (8) fixed bin int static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin int static options (constant);

/* Entry */

      dcl	    file_manager_$get      entry (bit (36) aligned, uns fixed bin (24), ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$ci_not_in_collection,
	    dm_error_$ci_not_allocated,
	    dm_error_$no_element,
	    dm_error_$no_output_buffer,
	    dm_error_$misformatted_ci,
	    dm_error_$programming_error,
	    dm_error_$long_return_element,
	    error_table_$bad_arg
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

whole:
   entry (p_ci_buffer_ptr, p_file_opening_id, p_collection_id, p_element_id, p_buffer_ptr, p_buffer_length, p_area_ptr,
        p_new_buffer_was_allocated, p_element_ptr, p_element_length, p_code);

      get_whole_element = "1"b;
      goto JOIN;

portion:
   entry (p_ci_buffer_ptr, p_file_opening_id, p_collection_id, p_element_id, p_buffer_ptr, p_buffer_length, p_area_ptr,
        p_portion_beginning_index, p_portion_length, p_new_buffer_was_allocated, p_element_ptr, p_element_length, p_code);

      get_whole_element = "0"b;
      if p_portion_length < 1 | p_portion_beginning_index ^= 1
      then call ERROR_RETURN (error_table_$bad_arg);
      goto JOIN;

%page;
JOIN:
      p_code = 0;

      element_id_string = p_element_id;

      if element_id.control_interval_id = 0
      then ci_buffer_length_in_bytes = CONTROL_INTERVAL_ZERO_ADDRESSABLE_LENGTH_IN_BYTES;
      else ci_buffer_length_in_bytes = CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES;

      basic_control_interval_ptr, ci_buffer_ptr = p_ci_buffer_ptr;

      call CHECK_CI_VERSION (basic_control_interval.header.layout_type);

      if basic_control_interval.header.collection_id ^= p_collection_id
      then call ERROR_RETURN (dm_error_$ci_not_in_collection);


      if element_id_string = "0"b | element_id.index > basic_control_interval.header.number_of_datums
      then call ERROR_RETURN (dm_error_$no_element);


/*
     Verify the existence of an output buffer and record its length.
     If no buffer is supplied, check for an area. If no area is supplied,
     the call is in error.
*/

      if p_buffer_ptr ^= null
      then
         do;
	  buffer_ptr = p_buffer_ptr;
	  buffer_length_in_bytes = floor (divide (p_buffer_length, BITS_PER_BYTE, 35, 18));
	  use_supplied_buffer = "1"b;
         end;

      if p_area_ptr ^= null
      then
         do;
	  work_area_ptr = p_area_ptr;
	  new_buffer_allowed = "1"b;
         end;

      if ^use_supplied_buffer & ^new_buffer_allowed
      then call ERROR_RETURN (dm_error_$no_output_buffer);


/*
     If no element corresponds to this datum slot, report to caller that
     the element could not be found.
*/

      if basic_control_interval.datum_position_table (element_id.index).offset_in_bytes = FREE_SLOT
	 | basic_control_interval.datum_position_table (element_id.index).flags.is_continuation
      then call ERROR_RETURN (dm_error_$no_element);


      if ^basic_control_interval.datum_position_table (element_id.index).flags.is_continued
      then
SIMPLE_GET:
         do;

/*
     The datum described by the datum slot is the entire element.  Get the 
     datum and return.
*/

	  if get_whole_element
	  then datum_contents_length_in_bits =
		  basic_control_interval.datum_position_table (element_id.index).length_in_bits;
	  else datum_contents_length_in_bits =
		  min (p_portion_length,
		  basic_control_interval.datum_position_table (element_id.index).length_in_bits);
	  datum_contents_length_in_bytes =
	       divide (datum_contents_length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);

	  if ^use_supplied_buffer | (use_supplied_buffer & datum_contents_length_in_bytes > buffer_length_in_bytes)
	  then if new_buffer_allowed
	       then
		do;
		   buffer_length_in_bytes = datum_contents_length_in_bytes;
		   on cleanup call FINISH ();
		   alloc buffer in (work_area);
		   p_new_buffer_was_allocated = "1"b;
		end;
	       else
		do;
		   p_element_length = datum_contents_length_in_bytes * BITS_PER_BYTE;
		   call ERROR_RETURN (dm_error_$long_return_element);
		end;


/*
     The buffer is set up and can hold the datum. Move the datum from the 
     ci_buffer to the buffer.
*/

	  datum_contents_offset_in_bytes =
	       basic_control_interval.datum_position_table (element_id.index).offset_in_bytes;

	  buffer_ptr -> datum_contents_string =
	       addcharno (ci_buffer_ptr, datum_contents_offset_in_bytes) -> datum_contents_string;

	  p_element_ptr = buffer_ptr;
	  p_element_length = datum_contents_length_in_bits;

         end SIMPLE_GET;

      else
MULTI_DATUM_GET:
         do;

/*
     The element consists of more than one datum.
*/

	  datum_ptr =
	       addcharno (ci_buffer_ptr, basic_control_interval.datum_position_table (element_id.index).offset_in_bytes)
	       ;

	  element_length_in_bytes = ceil (divide (continued_datum.header.full_length, BITS_PER_BYTE, 35, 18));

	  if use_supplied_buffer
	  then if element_length_in_bytes > buffer_length_in_bytes
	       then use_supplied_buffer = "0"b;

	  if ^use_supplied_buffer
	  then if new_buffer_allowed
	       then
		do;

/*
     A buffer must be allocated in the area to hold the element.  This may be 
     because no buffer was supplied or because the supplied buffer is too
     small to hold the entire element.
*/

		   buffer_length_in_bytes = element_length_in_bytes;
		   on cleanup call FINISH ();
		   alloc buffer in (work_area);
		   p_new_buffer_was_allocated = "1"b;

		end;
	       else
		do;
		   p_element_length = datum_contents_length_in_bytes * BITS_PER_BYTE;
		   call ERROR_RETURN (dm_error_$long_return_element);
		end;

/*
     buffer_ptr points to an appropriately sized buffer.  Copy the initial
     datum contents into the buffer. Set current_buffer_ptr to point to the end
     of the datum contents in the buffer, i.e., the place to put the next
     datum. Get the continuation datums and
     append them to the end of the retrieved element (at current_buffer_ptr).
*/

	  datum_contents_length_in_bytes =
	       ceil (
	       divide (basic_control_interval.datum_position_table (element_id.index).length_in_bits, BITS_PER_BYTE, 35,
	       18));

	  datum_contents_offset_in_bytes =
	       basic_control_interval.datum_position_table (element_id.index).offset_in_bytes;

	  buffer_ptr -> datum_contents_string =
	       addcharno (ci_buffer_ptr, datum_contents_offset_in_bytes) -> datum_contents_string;

	  current_buffer_ptr = addcharno (buffer_ptr, datum_contents_length_in_bytes);

	  continued_datum_id_string = element_id_string;
	  continuation_datum_id_string = unspec (continued_datum.header.continuation);

	  unspec (automatic_bci_header) = "0"b;
	  unspec (automatic_datum_slot) = "0"b;

	  bci_header_ptr = addr (automatic_bci_header);
	  datum_slot_ptr = addr (automatic_datum_slot);

	  ci_parts_ptr = addr (automatic_cip_buffer);

GET_EACH_DATUM_LOOP:
	  do while (continuation_datum_id_string ^= "0"b & element_length_in_bytes > 0);

	     unspec (cdcn_datum_header.continuation) = "0"b;

	     call cm_get_bci_header$slot (p_file_opening_id, bci_header_ptr, datum_slot_ptr,
		continuation_datum_id_string, p_code);
	     if p_code ^= 0
	     then if p_code = dm_error_$no_element | p_code = dm_error_$ci_not_allocated
		     | p_code = dm_error_$misformatted_ci
		then call REPORT_MULTI_DATUM_INCONSISTENCY (addr (continued_datum_id_string)
			-> element_id.control_interval_id, addr (continued_datum_id_string) -> element_id.index,
			continuation_datum_id.control_interval_id, continuation_datum_id.index, p_code);
		else call ERROR_RETURN (p_code);


	     call VERIFY_MULTI_DATUM_CONSISTENCY (addr (continued_datum_id_string) -> element_id.control_interval_id,
		addr (continued_datum_id_string) -> element_id.index, p_collection_id,
		continuation_datum_id.control_interval_id, continuation_datum_id.index, bci_header.collection_id,
		(datum_slot.offset_in_bytes = FREE_SLOT), (^datum_slot.flags.is_continuation));

	     if datum_slot.flags.is_continued
	     then datum_header_length_in_bytes = CDCN_DATUM_HEADER_LENGTH_IN_BYTES;
	     else datum_header_length_in_bytes = 0;

	     datum_contents_length_in_bytes =
		ceil (divide (datum_slot.length_in_bits, BITS_PER_BYTE, 35, 18)) - datum_header_length_in_bytes;

	     ci_parts.number_of_parts = 1;

	     ci_parts.part (1).offset_in_bytes = datum_slot.offset_in_bytes + datum_header_length_in_bytes;
	     ci_parts.part (1).length_in_bytes = datum_contents_length_in_bytes;
	     ci_parts.part (1).local_ptr = current_buffer_ptr;

	     if datum_slot.flags.is_continued
	     then
	        do;

		 ci_parts.number_of_parts = 2;
		 ci_parts.part (2).offset_in_bytes = datum_slot.offset_in_bytes;
		 ci_parts.part (2).length_in_bytes = CDCN_DATUM_HEADER_LENGTH_IN_BYTES;
		 ci_parts.part (2).local_ptr = addr (cdcn_datum_header);

	        end;

	     call file_manager_$get (p_file_opening_id, (continuation_datum_id.control_interval_id), ci_parts_ptr,
		p_code);
	     if p_code ^= 0
	     then call ERROR_RETURN (p_code);


	     current_buffer_ptr = addcharno (current_buffer_ptr, datum_contents_length_in_bytes);

	     element_length_in_bytes = element_length_in_bytes - datum_contents_length_in_bytes;

	     continued_datum_id_string = continuation_datum_id_string;
	     continuation_datum_id = cdcn_datum_header.continuation;

	  end GET_EACH_DATUM_LOOP;


	  p_element_ptr = buffer_ptr;
	  p_element_length = continued_datum.header.full_length;

         end MULTI_DATUM_GET;


RETURN:
      return;
%page;
FINISH:
   proc ();

      if buffer_ptr ^= null & buffer_ptr ^= p_buffer_ptr & buffer_ptr ^= p_element_ptr
      then
         do;
	  free buffer in (work_area);
	  p_new_buffer_was_allocated = "0"b;
         end;

   end FINISH;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH ();
      goto RETURN;

   end ERROR_RETURN;
%page;
CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;
      dcl	    dm_error_$unimplemented_ci_version
			       ext fixed bin (35);

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, "s", null, 0,
	      "^/Expected version ""^4a"" control interval; received ""^4a"".", BASIC_CI_LAYOUT_1, ccv_p_given_version);

      return;

   end CHECK_CI_VERSION;
%page;
REPORT_MULTI_DATUM_INCONSISTENCY:
   proc (rmdi_p_cd_ci, rmdi_p_cd_index, rmdi_p_cn_ci, rmdi_p_cn_index, rmdi_p_code);

      dcl	    (rmdi_p_cd_ci, rmdi_p_cn_ci)
			       fixed bin (24) unsigned unaligned;
      dcl	    (rmdi_p_cd_index, rmdi_p_cn_index)
			       fixed bin (12) unsigned unaligned;
      dcl	    rmdi_p_code	       fixed bin (35);

      call sub_err_ (rmdi_p_code, ACTION_CANT_RESTART, null, 0,
	 "^/The element in control interval ^d, slot ^d claims to be continued at^/control interval ^d, slot ^d. ^[^s^a^;^[^a^s^;^s^a^]"
	 , rmdi_p_cd_ci, rmdi_p_cd_index, rmdi_p_cn_ci, rmdi_p_cn_index, (rmdi_p_code = dm_error_$no_element),
	 (rmdi_p_code = dm_error_$ci_not_allocated), "That slot is a free slot.",
	 "That control interval is not allocated for use.", "That control interval is incorrectly formatted.");

   end REPORT_MULTI_DATUM_INCONSISTENCY;
%page;
VERIFY_MULTI_DATUM_CONSISTENCY:
   proc (vmdi_p_cd_ci, vmdi_p_cd_index, vmdi_p_cd_collection_id, vmdi_p_cn_ci, vmdi_p_cn_index, vmdi_p_cn_collection_id,
        vmdi_p_cn_slot_is_free, vmdi_p_cn_slot_is_not_continuation);

      dcl	    (vmdi_p_cd_ci, vmdi_p_cn_ci)
			       fixed bin (24) unsigned unaligned;
      dcl	    (vmdi_p_cd_index, vmdi_p_cn_index)
			       fixed bin (12) unsigned unaligned;
      dcl	    (vmdi_p_cd_collection_id, vmdi_p_cn_collection_id)
			       bit (36) aligned;
      dcl	    (vmdi_p_cn_slot_is_free, vmdi_p_cn_slot_is_not_continuation)
			       bit (1) aligned;

      if vmdi_p_cn_collection_id ^= vmdi_p_cd_collection_id
      then call sub_err_ (dm_error_$programming_error, ACTION_CANT_RESTART, null, 0,
	      "^/The element in control interval ^d, slot ^d claims to be continued at^/control interval ^d, slot ^d, but the two are in different collections.^/The former is in collection ^3bo;^/the latter is in collection ^3bo."
	      , vmdi_p_cd_ci, vmdi_p_cd_index, vmdi_p_cn_ci, vmdi_p_cn_index, vmdi_p_cd_collection_id,
	      vmdi_p_cn_collection_id);
      else if vmdi_p_cn_slot_is_free | vmdi_p_cn_slot_is_not_continuation
      then call sub_err_ (dm_error_$programming_error, ACTION_CANT_RESTART, null, 0,
	      "^/The element in control interval ^d, slot ^d claims to be continued at^/control interval ^d, slot ^d. ^[^That slot ^[is free^;is not a continuation datum^]."
	      , vmdi_p_cd_ci, vmdi_p_cd_index, vmdi_p_cn_ci, vmdi_p_cn_index, vmdi_p_cn_slot_is_free);

   end VERIFY_MULTI_DATUM_CONSISTENCY;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_element_id;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_ci_lengths;
%page;
%include dm_ci_parts;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_get_element_buffered;




		    cm_get_element_portion.pl1      04/04/85  1112.8r w 04/04/85  0912.7      218916



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION

   This module implements collection_manager_$get_portion 
   (cm_get_element_portion$cm_get_element_portion) and the not-yet-used
   collection_manager_$get_portion_exclusive (cm_get_element_portion$exclusive)

   This module gets an element or element portion located at (p_element_id
   + p_position elements). The data is returned in the buffer located at
   p_buffer_ptr (if it fits). p_buffer_length is the bit length of
   that caller-supplied buffer. If the buffer is too small to hold the data
   or the requested element is an overlength element, space is allocated in
   the provided area and the data is returned there.

   p_portion_beginning_index is a 1-origined index of the bit in the element
   which is the first bit of the portion.  At this time only portions at the
   head of the element can be retrieved (p_portion_beginning_index equal to 1).
   
   p_portion_length is the length in bits of the portion.  A value of -1
   indicates that the portion runs on to the end of the element.
*/

/* HISTORY:
Written by Matthew Pierret, 07/10/82.
Modified:
09/02/82 by Matthew Pierret:  To do forward and backward positioning.
10/19/82 by Matthew Pierret:  Added check for free datum slot.
            Changed to use dm_error_$no_element.
10/20/82 by Matthew Pierret:  Converted to use file_manager_.
11/10/82 by Matthew Pierret:  Added multi-datum support.
01/27/83 by Matthew Pierret:  Changed to initialize p_new_buffer_was_allocated
            to "0"b. Removed get_element_portion entry name.
            Fixed to use a local buffer when getting the first datum of a
            general multi-datum get. Changed to return error in the case where
            the supplied buffer is too small, no area was supplied and the
            element is multi-datum. Added more extensive error reporting.
            Added checks for consistency of each datum in multi-datum element.
            Changed to detect errors occurring on continuation datums which
            indicate internal inconsistency.
02/07/83 by Matthew Pierret: Changed to use cm_get_id$header_return_slot to
            position to an element.  Added the $info* entries.
04/29/83 by Matthew Pierret: Changed to use addcharno instead of addr(substr))
            and dm_error_$long_return_element isntead of $long_element.
05/05/83 by Matthew Pierret: Fixed use of addcharno. Was adding one char too
            many.
07/14/83 by Matthew Pierret: Added ERROR_RETURN routine. This routine is called
            whenever an error is encountered to set p_code and return from
            the main procedure. Changed to disallow specifying an
            elemenet_id.index equal to 0 without also specifying non-zero
            positioning.
10/14/83 by Lindsey L. Spratt:  CHanged to use the
            cm_get_id$info_header_return_slot entry instead of then
            cm_get_id$header_return_slot entry.
02/13/84 by Matthew Pierret:  Changed to use file_manager_$get_ci_ptr to get a
            pointer to a control interval and directly access the data in it.
            Also changed to use new entry cm_get_id$ptr, which makes use of
            this same mechansim for accessing control intervals.
03/15/84 by Lindsey L. Spratt:  Fixed MULTI_DATUM_GET to set the
            cd_datum_header.  (Matt and Lee B.)
03/16/84 by Matthew Pierret:  Changed to special case
            dm_error_$ci_not_allocated when returned from fm_$get_ci_ptr.
05/09/84 by Matthew Pierret:  Changed to allocate output buffers on even word
            boundaries.
07/18/84 by Matthew Pierret:  Changed to return dm_error_$ci_not_in_collection
            instead of calling sub_err_ if the first control interval gotten
            is not in the specified collection.
10/01/84 by Matthew Pierret:  Changed to base all datum structures on datum_ptr
            and datum_contents_length_in_bits.  Changed to use
            bytes = divide (bits + BITS_PER_BYTE -1, BITS_PER_BYTE, 17, 0)
            to convert bits to bytes more efficiently. This is only used in
            the critical path (SIMPLE_GET).
12/03/84 by Matthew Pierret:  Added the local cd_datum_header which was
            removed from dm_cm_datum.incl.pl1.
*/

/* format: style2,ind3,ll79,^indprocbody */
%page;
cm_get_element_portion:
   proc (p_file_opening_id, p_collection_id, p_element_id, p_position,
        p_buffer_ptr, p_buffer_length, p_area_ptr, p_portion_beginning_index,
        p_portion_length, p_new_buffer_was_allocated, p_element_ptr,
        p_element_length, p_code);

/* START OF DECLARATIONS */
/* Parameter */

   dcl	 p_file_opening_id	    bit (36) aligned;
   dcl	 p_collection_id	    bit (36) aligned;
   dcl	 p_element_id	    bit (36) aligned;
   dcl	 p_position	    fixed bin (17);
   dcl	 p_buffer_ptr	    ptr;
   dcl	 p_buffer_length	    fixed bin (35);
   dcl	 p_area_ptr	    ptr;
   dcl	 p_portion_beginning_index
			    fixed bin (35);
   dcl	 p_portion_length	    fixed bin (35);
   dcl	 p_new_buffer_was_allocated
			    bit (1) aligned;
   dcl	 p_element_ptr	    ptr;
   dcl	 p_element_length	    fixed bin (35);
   dcl	 p_code		    fixed bin (35);

/* Automatic */

   dcl	 (file_opening_id, collection_id)
			    bit (36) aligned;
   dcl	 (continuation_datum_id_string, continued_datum_id_string)
			    init ("0"b) bit (36) aligned;

   dcl	 code		    fixed bin (35) init (0);
   dcl	 buffer_length_in_bits  fixed bin (35) init (0);
   dcl	 buffer_length_in_double_words
			    fixed bin (35) init (0);
   dcl	 datum_contents_length_in_bytes
			    fixed bin (17) init (0);
   dcl	 portion_length_in_bits fixed bin (35) init (0);
   dcl	 portion_length_in_bytes
			    fixed bin (17) init (0);
   dcl	 position_from_specified_element
			    fixed bin (17) init (0);
   dcl	 remaining_portion_length_in_bytes
			    fixed bin (17) init (0);

   dcl	 exclusive_get	    bit (1) aligned init ("0"b);

   dcl	 ci_ptr		    ptr init (null);
   dcl	 work_area_ptr	    ptr init (null);
   dcl	 buffer_ptr	    ptr init (null);
   dcl	 current_buffer_ptr	    ptr init (null);
   dcl	 datum_contents_ptr	    ptr init (null);

   dcl	 1 cd_datum_header	    aligned like continued_datum.header;

/* Based */

   dcl	 1 continued_datum_id   aligned like datum_id
			    based (addr (continued_datum_id_string));
   dcl	 1 continuation_datum_id
			    aligned like datum_id
			    based (addr (continuation_datum_id_string));
   dcl	 work_area	    area based (work_area_ptr);
   dcl	 buffer		    (buffer_length_in_double_words) fixed
			    bin (71) based (buffer_ptr);
   dcl	 datum_contents_string  char (datum_contents_length_in_bytes) based;

/* Builtin */

   dcl	 (addr, addcharno, ceil, divide, length, min, null, unspec)
			    builtin;

/* Condition */

   dcl	 cleanup		    condition;

/* Constant */

   dcl	 myname		    init ("cm_put_element_portion")
			    char (32) varying internal static
			    options (constant);
   dcl	 (
	 BITS_PER_BYTE	    init (9) fixed bin,
	 BYTES_PER_DOUBLE_WORD  init (8) fixed bin,
	 THIS_IS_FIRST_CI_SEEN  init ("1"b) bit (1) aligned,
	 THIS_IS_NOT_FIRST_CI_SEEN
			    init ("1"b) bit (1) aligned,
	 TO_END_OF_ELEMENT	    init (-1) fixed bin (35)
	 )		    internal static options (constant);

/* Entry */

   dcl	 file_manager_$get_ci_ptr
			    entry (bit (36) aligned, uns fixed bin (24),
			    ptr, fixed bin (35));
   dcl	 sub_err_		    entry () options (variable);

/* External */

   dcl	 (
	 error_table_$bad_arg,
	 error_table_$unimplemented_version
	 )		    fixed bin (35) ext;
   dcl	 (
	 dm_error_$ci_not_allocated,
	 dm_error_$ci_not_in_collection,
	 dm_error_$no_element,
	 dm_error_$programming_error,
	 dm_error_$long_return_element
	 )		    fixed bin (35) ext;

/* END OF DECLARATIONS */

   exclusive_get = "0"b;
   goto JOIN;

exclusive:
   entry (p_file_opening_id, p_collection_id, p_element_id, p_position,
        p_buffer_ptr, p_buffer_length, p_area_ptr, p_portion_beginning_index,
        p_portion_length, p_new_buffer_was_allocated, p_element_ptr,
        p_element_length, p_code);

/* This entry is not actually implemented.  What is needed to implement
   it fully is a file_manager_$get_ci_ptr_exclusive entry. */

   exclusive_get = "1"b;
   goto JOIN;

%page;
/* format: ^indblkcom,indcomtxt */
/* format: equalind25 */
JOIN:
   p_code		        = 0;
   p_new_buffer_was_allocated
		        = "0"b;
   file_opening_id	        = p_file_opening_id;
   collection_id	        = p_collection_id;
   position_from_specified_element
		        = p_position;
   portion_length_in_bits   = p_portion_length;
   element_id_string        = p_element_id;
   buffer_ptr	        = p_buffer_ptr;		/* format: equalind0 */


   if buffer_ptr = null
   then buffer_length_in_bits = -1;			/* no buffer */
   else buffer_length_in_bits = p_buffer_length;

   if position_from_specified_element = 0
   then
      do;
         if element_id.index <= 0
         then call ERROR_RETURN (dm_error_$no_element);
         call GET_CI_PTR (THIS_IS_FIRST_CI_SEEN, file_opening_id,
	    collection_id, (element_id.control_interval_id), ci_ptr);
         if element_id.index
	    > ci_ptr -> basic_control_interval.header.number_of_datums
         then call ERROR_RETURN (dm_error_$no_element);
      end;
   else
      do;
         call cm_get_id$ptr (file_opening_id, collection_id,
	    (element_id_string), position_from_specified_element,
	    (element_id_string = "0"b), (null) /* input ci_ptr */, ci_ptr,
	    element_id_string, code);
         if code ^= 0
         then call ERROR_RETURN (code);
      end;

/*** Set pointer to datum_slot instead of accessing ci_ptr->bci.dpt(ei.i)
     for efficiency. */

   datum_slot_ptr =
        addr (ci_ptr
        -> basic_control_interval.datum_position_table (element_id.index));

/*** If no element corresponds to this datum slot, report to caller that
     the element could not be found. */

   if datum_slot.offset_in_bytes = FREE_SLOT /* no datum here */
        | datum_slot.flags.is_continuation		/* this datum is not the start of an element */
   then call ERROR_RETURN (dm_error_$no_element);



/*** Report if caller supplied an invalid p_portion_length argument.  The
     portion length must be positive or a special value. */

   if portion_length_in_bits < 1 & portion_length_in_bits ^= TO_END_OF_ELEMENT
   then call ERROR_RETURN (error_table_$bad_arg);

   datum_ptr = addcharno (ci_ptr, datum_slot.offset_in_bytes);

   if ^datum_slot.flags.is_continued
   then
SIMPLE_GET:
      do;

      /*** The datum described by datum_slot is the entire element.  Get the datum
	 portion and return. */

         datum_contents_ptr = addr (datum.contents);	/* Points to the datum contents in the control interval. */
						/* This should one day be changed to point at the start  */
						/* of an element portion. */

         if portion_length_in_bits = TO_END_OF_ELEMENT
         then datum_contents_length_in_bits = datum_slot.length_in_bits;
         else datum_contents_length_in_bits =
	         min (portion_length_in_bits, datum_slot.length_in_bits);

         datum_contents_length_in_bytes =
	    ceil (
	    divide (datum_contents_length_in_bits, BITS_PER_BYTE, 35, 18));

         if datum_contents_length_in_bytes * BITS_PER_BYTE
	    > buffer_length_in_bits			/* datum_contents_length_in_bytes * BITS_PER_BYTE is used */
						/* in this test instead of datum_slot.length_in_bits      */
						/* because the buffer must be large enough to fit the     */
						/* contents when copied in bytes.                         */
         then
SG_ALLOC_BUFFER:
	  do;					/* Buffer is too small. Try allocating a buffer in the work area. */
	     work_area_ptr = p_area_ptr;
	     if work_area_ptr = null
	     then
	        do;
		 p_element_length =
		      datum_contents_length_in_bytes * BITS_PER_BYTE;
						/* Not the actual length of the element, but the minimum */
						/* size a buffer must be to hold the element. */
		 call ERROR_RETURN (dm_error_$long_return_element);
	        end;
	     else
	        do;				/* Allocate the buffer. */
		 buffer_length_in_double_words =
		      ceil (
		      divide (datum_contents_length_in_bytes,
		      BYTES_PER_DOUBLE_WORD, 35, 18));
		 on cleanup call FINISH ();
		 alloc buffer in (work_area);
		 p_new_buffer_was_allocated = "1"b;
	        end;
	  end SG_ALLOC_BUFFER;

      /*** Now, copy the datum contents into the buffer. */

         buffer_ptr -> datum_contents_string =
	    datum_contents_ptr -> datum_contents_string;

         p_element_ptr = buffer_ptr;
         p_element_length = datum_slot.length_in_bits;

      end SIMPLE_GET;

   else if portion_length_in_bits ^= TO_END_OF_ELEMENT
	   & portion_length_in_bits
	   <= (datum_slot.length_in_bits - CD_DATUM_HEADER_LENGTH_IN_BITS)
   then
SIMPLE_MULTI_DATUM_GET:
      do;

      /*** The element consists of more than one datum, but the retreival
	 can be satisfied by using only the first datum. This do-group is almost
	 identical to the SIMPLE_GET do-group. */

         datum_contents_ptr = addr (continued_datum.contents);
						/* Points to the datum contents in the control interval. */

         if portion_length_in_bits = TO_END_OF_ELEMENT
         then datum_contents_length_in_bits =
	         datum_slot.length_in_bits - CD_DATUM_HEADER_LENGTH_IN_BITS;
         else datum_contents_length_in_bits =
	         min (portion_length_in_bits,
	         datum_slot.length_in_bits - CD_DATUM_HEADER_LENGTH_IN_BITS);

         datum_contents_length_in_bytes =
	    ceil (
	    divide (datum_contents_length_in_bits, BITS_PER_BYTE, 35, 18));

         if datum_contents_length_in_bytes * BITS_PER_BYTE
	    > buffer_length_in_bits			/* datum_contents_length_in_bytes * BITS_PER_BYTE is used */
						/* in this test instead of datum_slot.length_in_bits      */
						/* because the buffer must be large enough to fit the     */
						/* contents when copied in bytes.                         */
         then
SMG_ALLOC_BUFFER:
	  do;					/* Buffer is too small. Try allocating a buffer in the work area. */
	     work_area_ptr = p_area_ptr;
	     if work_area_ptr = null
	     then
	        do;
		 p_element_length =
		      datum_contents_length_in_bytes * BITS_PER_BYTE;
						/* Not the actual length of the element, but the minimum */
						/* size a buffer must be to hold the element. */
		 call ERROR_RETURN (dm_error_$long_return_element);
	        end;
	     else
	        do;				/* Allocate the buffer. */
		 buffer_length_in_double_words =
		      ceil (
		      divide (datum_contents_length_in_bytes,
		      BYTES_PER_DOUBLE_WORD, 35, 18));
		 on cleanup call FINISH ();
		 alloc buffer in (work_area);
		 p_new_buffer_was_allocated = "1"b;
	        end;
	  end SMG_ALLOC_BUFFER;

      /*** Now, copy the datum contents into the buffer. */

         buffer_ptr -> datum_contents_string =
	    datum_contents_ptr -> datum_contents_string;

         p_element_ptr = buffer_ptr;
         p_element_length = datum_contents_length_in_bits;

      end SIMPLE_MULTI_DATUM_GET;

   else call MULTI_DATUM_GET ();

   if p_element_id ^= element_id_string
   then p_element_id = element_id_string;

MAIN_RETURN:
   return;
%page;
FINISH:
   proc ();

   if buffer_ptr ^= p_buffer_ptr & buffer_ptr ^= null
   then
      do;
         free buffer in (work_area);
         p_new_buffer_was_allocated = "0"b;
      end;

   call TERMINATE_CI_PTR (ci_ptr);

   end FINISH;


ERROR_RETURN:
   proc (er_code);

   dcl	 er_code		    fixed bin (35);

   p_code = er_code;
   call FINISH ();
   goto MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_CI_LAYOUT:
   proc (ccl_p_ci_layout);
   dcl	 ccl_p_ci_layout	    char (4) aligned;

   if ccl_p_ci_layout ^= BASIC_CI_LAYOUT_1
   then call sub_err_ (error_table_$unimplemented_version, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected a version ^a control interval. Received version ^a instead."
	   , BASIC_CI_LAYOUT_1, ccl_p_ci_layout);

   end CHECK_CI_LAYOUT;
%page;
GET_CI_PTR:
   proc (gcp_p_this_is_first_ci_seen, gcp_p_foid, gcp_p_collection_id,
        gcp_p_ci_id, gcp_p_ci_ptr);

   dcl	 gcp_p_this_is_first_ci_seen
			    bit (1) aligned;
   dcl	 gcp_p_foid	    bit (36) aligned;
   dcl	 gcp_p_collection_id    bit (36) aligned;
   dcl	 gcp_p_ci_id	    fixed bin (24) unsigned;
   dcl	 gcp_p_ci_ptr	    ptr;
   dcl	 gcp_code		    fixed bin (35);


   if gcp_p_ci_ptr ^= null
   then call TERMINATE_CI_PTR (gcp_p_ci_ptr);

   call file_manager_$get_ci_ptr (gcp_p_foid, (gcp_p_ci_id), gcp_p_ci_ptr,
        gcp_code);
   if gcp_code ^= 0
   then if gcp_code ^= dm_error_$ci_not_allocated
        then call ERROR_RETURN (gcp_code);
        else if continuation_datum_id_string = "0"b
        then call ERROR_RETURN (dm_error_$no_element);	/* First datum of element. No CI means no element. */
						/* A continuation datum of a multi-datum element. No CI means an improperly formed conntinued datum. */
        else call sub_err_ (gcp_code, myname, ACTION_CANT_RESTART, null, 0,
	        "^/Control interval ^d was expected to hold the continuation of ^/the datum at slot ^d of control interval ^d."
	        , gcp_p_ci_id, continued_datum_id.index,
	        continued_datum_id.control_interval_id);


   call CHECK_CI_LAYOUT ((gcp_p_ci_ptr -> bci_header.layout_type));

   if gcp_p_ci_ptr -> bci_header.collection_id ^= gcp_p_collection_id
   then
      do;
         if gcp_p_this_is_first_ci_seen
         then call ERROR_RETURN (dm_error_$ci_not_in_collection);
         else call sub_err_ (dm_error_$programming_error, myname,
	         ACTION_CANT_RESTART, null, 0,
	         "^/Control interval ^d is in collection ^3bo but was expected to^/be in collection ^3bo."
	         , gcp_p_ci_id, gcp_p_ci_ptr -> bci_header.collection_id,
	         gcp_p_collection_id);
      end;

   return;

   end GET_CI_PTR;
%page;
TERMINATE_CI_PTR:
   proc (tcp_p_ci_ptr);

   dcl	 tcp_p_ci_ptr	    ptr;

   tcp_p_ci_ptr = null;

   return;

   end TERMINATE_CI_PTR;
%page;
MULTI_DATUM_GET:
   proc ();


/*** The datum is by definition a "continued" datum, described by the
     continued_datum structure.  Set a pointer to the beginning of that structure,
     extract header information and datum contents from it. */

   datum_contents_length_in_bits =
        datum_slot.length_in_bits - CD_DATUM_HEADER_LENGTH_IN_BITS;
						/* Length of the datum contents in bits. */
   datum_contents_ptr = addr (continued_datum.contents);	/* Points to beginning of datum contents. */
   datum_contents_length_in_bytes =
        ceil (divide (datum_contents_length_in_bits, BITS_PER_BYTE, 35, 18));

   if portion_length_in_bits = TO_END_OF_ELEMENT
   then portion_length_in_bits = continued_datum.header.full_length;
   else portion_length_in_bits =
	   min (portion_length_in_bits, continued_datum.header.full_length);

   portion_length_in_bytes =
        ceil (divide (portion_length_in_bits, BITS_PER_BYTE, 71, 18));
						/* This length can be very large. */

   if portion_length_in_bytes * BITS_PER_BYTE > buffer_length_in_bits
						/* portion_length_in_bytes * BITS_PER_BYTE is used in this        */
						/* test instead of datum_slot.length_in_bits because the buffer   */
						/* must be large enough to fit the contents when copied in bytes. */
   then
MG_ALLOC_BUFFER:
      do;						/* Buffer is too small. Try allocating a buffer in the work area. */
         work_area_ptr = p_area_ptr;
         if work_area_ptr = null
         then
	  do;
	     p_element_length = portion_length_in_bytes * BITS_PER_BYTE;
						/* Not the actual length of the portion, but the minimum size a  */
						/* buffer must be to hold the portion. */
	     call ERROR_RETURN (dm_error_$long_return_element);
	  end;
         else
	  do;					/* Allocate the buffer. */
	     buffer_length_in_double_words =
		ceil (
		divide (portion_length_in_bytes, BYTES_PER_DOUBLE_WORD, 35,
		18));
	     on cleanup call FINISH ();
	     alloc buffer in (work_area);
	     p_new_buffer_was_allocated = "1"b;
	  end;
      end MG_ALLOC_BUFFER;

   if datum_contents_length_in_bytes <= 0
   then
      do;
         current_buffer_ptr = buffer_ptr;
         remaining_portion_length_in_bytes = portion_length_in_bytes;
      end;
   else
      do;
         buffer_ptr -> datum_contents_string =
	    datum_contents_ptr -> datum_contents_string;
         current_buffer_ptr =
	    addcharno (buffer_ptr, datum_contents_length_in_bytes);
         remaining_portion_length_in_bytes =
	    portion_length_in_bytes - datum_contents_length_in_bytes;
						/* This is to indicate how much is left to be gotten. */
      end;

   continued_datum_id_string = element_id_string;		/* datum id of the continued datum, i.e., the the datum most recently */
						/* copied.  The element is continued in another datum. */
   cd_datum_header = continued_datum.header;

   continuation_datum_id = cd_datum_header.continuation;	/* datum id of the datum which is the continuation of the continued datum. */

GET_EACH_DATUM_LOOP:
   do while (continuation_datum_id_string ^= "0"b
        & remaining_portion_length_in_bytes > 0);

      call GET_CI_PTR (THIS_IS_NOT_FIRST_CI_SEEN, file_opening_id,
	 collection_id, (continuation_datum_id.control_interval_id), ci_ptr);

      if continuation_datum_id.index
	 > ci_ptr -> basic_control_interval.header.number_of_datums
      then call sub_err_ (dm_error_$programming_error, myname,
	      ACTION_CANT_RESTART, null, 0,
	      "^/There is no datum at slot ^d of control interval ^d.  A continuation^/of the datum at slot ^d of control interval ^d was expected to be there."
	      , continuation_datum_id.index,
	      continuation_datum_id.control_interval_id,
	      continued_datum_id.index,
	      continued_datum_id.control_interval_id);

      datum_slot_ptr =
	 addr (ci_ptr
	 -> basic_control_interval
	 .datum_position_table (continuation_datum_id.index));

      datum_ptr = addcharno (ci_ptr, datum_slot.offset_in_bytes);

      if datum_slot.is_continued
      then
         do;
	  datum_contents_length_in_bits =
	       datum_slot.length_in_bits
	       - length (unspec (continued_continuation_datum.header));
	  datum_contents_length_in_bytes =
	       ceil (
	       divide (datum_contents_length_in_bits, BITS_PER_BYTE, 35, 18))
	       ;
	  datum_contents_ptr = addr (continued_continuation_datum.contents);

	  continued_datum_id_string = continuation_datum_id_string;
	  continuation_datum_id =
	       continued_continuation_datum.header.continuation;
         end;
      else
         do;
	  datum_contents_length_in_bytes =
	       ceil (
	       divide (datum_slot.length_in_bits, BITS_PER_BYTE, 35, 18));
	  datum_contents_ptr = addr (continuation_datum.contents);

	  continuation_datum_id_string = "0"b;
         end;

      datum_contents_length_in_bytes =
	 min (datum_contents_length_in_bytes,
	 remaining_portion_length_in_bytes);

      current_buffer_ptr -> datum_contents_string =
	 datum_contents_ptr -> datum_contents_string;

      current_buffer_ptr =
	 addcharno (current_buffer_ptr, datum_contents_length_in_bytes);

      remaining_portion_length_in_bytes =
	 remaining_portion_length_in_bytes - datum_contents_length_in_bytes;

   end GET_EACH_DATUM_LOOP;

   if remaining_portion_length_in_bytes > 0
   then call sub_err_ (dm_error_$programming_error, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/The length of the element at slot ^d of control interval ^d is^/recorded as ^d bits.  The actual length is ^d bits."
	   , element_id.index, element_id.control_interval_id,
	   portion_length_in_bits,
	   (portion_length_in_bits
	   - remaining_portion_length_in_bytes * BITS_PER_BYTE));

   p_element_ptr = buffer_ptr;
   p_element_length = cd_datum_header.full_length;

   end MULTI_DATUM_GET;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_element_id;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_ci_parts;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_get_element_portion;




		    cm_get_header.pl1               04/04/85  1112.8r w 04/04/85  0911.8       47484



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

        This module implements collection_manager_$get_header.  It returns
   to the caller the caller-defined collection header of the specified
   collection (p_collection_id).  The header is returned in the specified
   buffer (p_buffer_ptr, p_buffer_length) if it will fit, or in a newly
   allocated buffer in the specified area (p_area_ptr).
*/

/* HISTORY:
Written by Matthew Pierret, 04/01/82.
Modified:
04/13/82 by Lindsey Spratt: Fixed to set the collmgr_header_ptr. Previously,
	  the collmgr_header_buffer_ptr was being set, but not the
	  collmgr_header_ptr.  The collmgr_header_buffer_ptr is no longer
	  used.
05/20/82 by Matthew Pierret: Changed to use collection_header instead of 
            collmgr_header.collection (), and to call cm_get_collection_header.
08/04/82 by Matthew Pierret: Changed to use bit(36)aligned collection id.
11/04/82 by Matthew Pierret:  Changed to use opening info (cm_info) and
            upgraded to COLLECTION_HEADER_VERSION_2.
01/27/83 by Matthew Pierret:  Upgraded to CM_INFO_VERSION_2. Changed to report
            certain errors attempting to get the header via sub_err_. These
            errors indicate an internal inconsistency.
10/02/84 by Matthew Pierret:  Removed error_table_$unimplemented_version,
               added addr.  Added DESCRIPTION.
12/03/84 by Matthew Pierret:  Changed to use dm_hdr_collection_id.incl.pl1 
            instead of the obsolete cm_cm_header.incl.pl1.
*/

/* format: style2,ind3 */

cm_get_header:
   proc (p_file_opening_id, p_collection_id, p_buffer_ptr, p_buffer_length, p_area_ptr, p_new_buffer_was_allocated,
        p_header_ptr, p_header_length, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_buffer_ptr	       ptr;
      dcl	    p_buffer_length	       fixed bin (17);
      dcl	    p_area_ptr	       ptr;
      dcl	    p_new_buffer_was_allocated
			       bit (1) aligned;
      dcl	    p_header_ptr	       ptr;
      dcl	    p_header_length	       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */
/* Based */
/* Builtin */

      dcl	    (addr, null)	       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("cm_get_header") char (32) varying int static options (constant);
      dcl	    UNINITIALIZED_ELEMENT_ID
			       bit (36) aligned init ("0"b) int static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$no_header_record,
	    dm_error_$ci_not_allocated,
	    dm_error_$ci_not_in_collection,
	    dm_error_$no_element
	    )		       ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code = 0;
      p_new_buffer_was_allocated = "0"b;

      call cm_opening_info$get (p_file_opening_id, p_collection_id, cm_info_ptr, p_code);
      if p_code ^= 0
      then return;

      call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);

      collection_header_ptr = cm_info.header_ptr;

      call CHECK_VERSION ("collection_header", collection_header.version, COLLECTION_HEADER_VERSION_2);


      if collection_header.header_record_element_id = UNINITIALIZED_ELEMENT_ID
      then
         do;
	  p_code = dm_error_$no_header_record;
	  return;
         end;

      element_id_string = collection_header.header_record_element_id;
      call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID, element_id_string, 0, p_buffer_ptr, (p_buffer_length),
	 p_area_ptr, p_new_buffer_was_allocated, p_header_ptr, p_header_length, p_code);

      if p_code ^= 0
      then if p_code = dm_error_$no_element | p_code = dm_error_$ci_not_allocated
	      | p_code = dm_error_$ci_not_in_collection
	 then call sub_err_ (p_code, myname, ACTION_CANT_RESTART, null, 0,
		 "^/An internal inconsistency was encountered attempting to get the user header^/for collection ^3bo at control interval ^d, slot ^d."
		 , p_collection_id, element_id.control_interval_id, element_id.index);

      return;

%page;
CHECK_VERSION:
   proc (p_structure_name, p_given_version, p_correct_version);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

      if p_given_version ^= p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", p_correct_version, p_structure_name,
	      p_given_version);

      return;

   end CHECK_VERSION;
%page;
%include dm_cm_info;
%page;
%include dm_cm_collection_header;
%page;
%include dm_element_id;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_get_header;




		    cm_get_id.pl1                   04/04/85  1112.8r w 04/04/85  0912.7      177561



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

          This module implements collection_manager_$get_id (cm_get_id$id)
     cm_get_id$ptr is an internal interface.

          This routine returns the identifier of an element relative to another
     element. The desired element is p_position_change elements away from the
     "start" element in a forward direction if positive, or if negative, is
     abs (p_position_change) away in a backward direction.  The element from
     which to start is determined as follows: (1) if p_is_absolute_position
     is on, then (1a) if p_position_change is positive (position forward),
     the start is the imaginary element which precedes the first element of the
     collection; else (1b) if p_position_change is negative (position backward)
     the start is the imaginary element which succeeds the last element of the
     collection; else (1c) if p_position_change is equal to 0 the error
     dm_error_$beginning_of_collection is returned; (2) if 
     p_is_absolute_position is off, the start is the element specified by
     p_input_element_id_string. 

          There are two entries into this routine, id and ptr.
     The id entry point inplements collection_manager_$get_id.
     The id entry point works as described above.  In the course of looking
     through control intervals, it gets a pointer to each control interval 
     of interest.
     The ptr entry point is an internal interface.
     The ptr entry point works the same, but allows the caller to supply the 
     pointer to the first control interval to be examined.  The caller expects
     the pointer to the last control interval examined.  p_input_ci_ptr and
     p_return_ci_ptr are sed for these purposes.  The supplied pointer and the
     returned pointer, which may be the same, must not be terminated.  All 
     other control interval pointers used must be terminated.     

*/

/* HISTORY:

Written by Matthew Pierret, 09/03/82.
Modified:
11/05/82 by Matthew Pierret:  Added $info_* entries.  Made to get opening
            info (cm_info) by calling cm_opening_info$full_get ($full_get
            gets the storage record)
11/22/82 by Lindsey Spratt:  Fixed the $element entry to do a
	  cm_opening_info$full_get.  Fixed $info_element entry to set
	  cm_info_ptr from p_cm_info_ptr.
01/20/83 by Lindsey Spratt:  Fixed to check for the fetch of the first ci to
	  return ci 0 when not looking in the header collection (always the
	  owner of ci 0) as an indication of the current collection being
	  empty.
01/27/83 by Matthew Pierret: Changed to use cm_opening_info$get_storage_record.
            Updraded to CM_INFO_VERSION_2. Added check to see if control
            interval thread is consistent.
02/07/83 by Matthew Pierret: Changed to accept p_bci_header_ptr and
            p_slot_table_ptr so that this routine can be used by cm_ modules
            that have already gotten the two structures. This will help
            centralize all positioning in cm_.
05/04/83 by Matthew Pierret:  Changed to use dm_error_$programming_error
            instead of $col_is_inconsistent.
10/13/83 by Lindsey L. Spratt:  Renamed the header and header_return_slot
            entries to be info_header and info_header_return_slot.  Added new
            header and header_return_slot entries which expect file_opening_id
            and collection_id instead of a cm_info_ptr, then do a
            cm_opening_info$get themselves.  Changed handling of error codes
            to use the "call ERROR_RETURN (code);" technique.  Changed naming
            of variables in internal procedures to use a prefix unique to that
            internal procedure.
02/06/84 by Matthew Pierret:  Removed all entries except $id and added $ptr.
            All collection_manager_ modules which use cm_get_id now use the
            $ptr entry.  This entry can receive as input and return as output
            a pointer to a control interval, as returned by
            file_manager_$get_ci_ptr.  Use of this pointer allows direct
            access to look at file control intervals.  This module was
            substantially rewritten to get ci_ptr's to access control
            intervals.
02/10/84 by Matthew Pierret:  Changed to initialize its return element id
            string and to check for infinite looping.
03/16/84 by Matthew Pierret:  Changed to special-case the error code
            dm_error_$ci_not_allocated when returned from fm_$get_ci_ptr.
05/21/84 by Matthew Pierret:  Renamed include fle dm_cm_cism_info to
            dm_cism_info.
07/17/84 by Matthew Pierret:  Changed to return dm_error_$ci_not_in_collection
            instead of calling sub_err_ if there is a mismatch on the first
            control interval seen.
10/02/84 by Matthew Pierret:  Changed CHECK_CI_LAYOUT to return 
            dm_error_$unimplemented_ci_version.  Modified DESCRIPTION to
            correctly reflect the workings of this module.
            Moved include files from internal procedures to main procedure,
            making refernces to the structures in those procedures by
            explicit pointer reference.
*/

/* format: style2,ind3,ll80,^indprocbody */
%page;
cm_get_id$id:
   procedure (p_file_opening_id, p_collection_id, p_input_element_id_string,
        p_position_change, p_is_absolute_position, p_return_element_id_string,
        p_code);



/* START OF DECLARATIONS */
/* Parameter */

   dcl	 p_file_opening_id	    bit (36) aligned parameter;
   dcl	 p_collection_id	    bit (36) aligned parameter;
   dcl	 p_input_element_id_string
			    bit (36) aligned parameter;
   dcl	 p_return_element_id_string
			    bit (36) aligned parameter;
   dcl	 p_position_change	    fixed bin (17) parameter;
   dcl	 p_is_absolute_position bit (1) aligned parameter;
   dcl	 p_input_ci_ptr	    ptr parameter;
   dcl	 p_return_ci_ptr	    ptr parameter;
   dcl	 p_code		    fixed bin (35) parameter;

/* Automatic */

   dcl	 (ci_idx, current_slot_index, position_change)
			    fixed bin (17);
   dcl	 (current_ci_id, most_recent_ci_id)
			    fixed bin (24) uns init (0);

   dcl	 (file_opening_id, collection_id, input_element_id_string,
	 return_element_id_string)
			    bit (36) aligned init ("0"b);

   dcl	 (is_absolute_position, terminate_last_ci_ptr)
			    bit (1) aligned init ("0"b);

   dcl	 (ci_ptr, input_ci_ptr) ptr init (null);

/* Based */

   dcl	 1 input_element_id	    aligned
			    based (addr (input_element_id_string))
			    like element_id;

/* Builtin */

   dcl	 (addr, max, min, null) builtin;

/* Constant */

   dcl	 myname		    init ("cm_get_id") char (32) varying
			    internal static options (constant);
   dcl	 LIMIT_TO_STOP_INFINITE_LOOPING
			    init (1e6) fixed bin (35) internal
			    static options (constant);
   dcl	 (
	 LOWEST_SLOT_INDEX	    init (0),
	 HIGHEST_SLOT_INDEX	    init (1e4)
	 )		    fixed bin (17) internal static
			    options (constant);
   dcl	 (
	 IS_FIRST		    init ("1"b),
	 NOT_FIRST	    init ("0"b)
	 )		    bit (1) aligned internal static
			    options (constant);

/* Entry */

   dcl	 sub_err_		    entry () options (variable);

/* External */

   dcl	 (
	 dm_error_$beginning_of_collection,
	 dm_error_$ci_not_allocated,
	 dm_error_$ci_not_in_collection,
	 dm_error_$end_of_collection,
	 dm_error_$no_element,
	 dm_error_$programming_error,
	 dm_error_$unimplemented_cism,
	 dm_error_$unimplemented_ci_version
	 )		    fixed bin (35) ext static;
   dcl	 error_table_$unimplemented_version
			    ext fixed bin (35);

/* END OF DECLARATIONS */

/*
id:
   entry (p_file_opening_id, p_collection_id, p_input_element_id_string,
        p_position_change, p_is_absolute_position, p_return_element_id_string,
        p_code);
*/

   input_ci_ptr = null;
   terminate_last_ci_ptr = "1"b;

   goto JOIN;

ptr:
   entry (p_file_opening_id, p_collection_id, p_input_element_id_string,
        p_position_change, p_is_absolute_position, p_input_ci_ptr,
        p_return_ci_ptr, p_return_element_id_string, p_code);

   p_return_ci_ptr = null;
   terminate_last_ci_ptr = "0"b;
   input_ci_ptr = p_input_ci_ptr;

   goto JOIN;
%page;
/* format: equalind25 */
JOIN:
   p_code		        = 0;
   p_return_element_id_string
		        = "0"b;
   file_opening_id	        = p_file_opening_id;
   collection_id	        = p_collection_id;
   is_absolute_position     = p_is_absolute_position;
   input_element_id_string  = p_input_element_id_string;
   position_change	        = p_position_change;		/* format: equalind0 */

   if is_absolute_position
   then call SET_DEFAULT_POSITION (file_opening_id, collection_id,
	   position_change, current_ci_id, current_slot_index);
   else
      do;
         current_ci_id = input_element_id.control_interval_id;
         current_slot_index = input_element_id.index;
      end;

LOOP_THROUGH_CONTROL_INTERVALS:
   do ci_idx = 1 to LIMIT_TO_STOP_INFINITE_LOOPING while (position_change ^= 0);

      call GET_CI_PTR (file_opening_id, collection_id, current_ci_id,
	 input_ci_ptr, ci_ptr);

      if most_recent_ci_id ^= 0
      then if position_change > 0
	      & ci_ptr -> bci_header.previous_control_interval
	      ^= most_recent_ci_id
	 then call sub_err_ (dm_error_$programming_error, myname,
		 ACTION_CANT_RESTART, null, 0,
		 "^/^a ^d ^a ^d;^/^a ^d ^a ^d.", "Control interval",
		 most_recent_ci_id, "has a next control interval of",
		 current_ci_id, "control interval", current_ci_id,
		 "has a previous control interval of",
		 ci_ptr -> bci_header.previous_control_interval);
	 else if position_change < 0
		 & ci_ptr -> bci_header.next_control_interval
		 ^= most_recent_ci_id
	 then call sub_err_ (dm_error_$programming_error, myname,
		 ACTION_CANT_RESTART, null, 0,
		 "^/^a ^d ^a ^d;^/^a ^d ^a ^d.", "Control interval",
		 most_recent_ci_id, current_ci_id,
		 "has a previous control interval of", "control interval",
		 current_ci_id, "has a next control interval of",
		 ci_ptr -> bci_header.next_control_interval);

      call POSITION_THROUGH_CI (ci_ptr, position_change, current_slot_index);

      if position_change ^= 0
      then
         do;
	  most_recent_ci_id = current_ci_id;

	  if position_change > 0
	  then if ci_ptr -> bci_header.next_control_interval = 0
	       then call ERROR_RETURN (dm_error_$end_of_collection);
	       else
		do;
		   current_ci_id =
		        ci_ptr -> bci_header.next_control_interval;
		   current_slot_index = LOWEST_SLOT_INDEX;
		end;				/* position_change is necessarily < 0 */
	  else if ci_ptr -> bci_header.previous_control_interval = 0
	  then call ERROR_RETURN (dm_error_$beginning_of_collection);
	  else
	     do;
	        current_ci_id =
		   ci_ptr -> bci_header.previous_control_interval;
	        current_slot_index = HIGHEST_SLOT_INDEX;
	     end;

         end;


   end LOOP_THROUGH_CONTROL_INTERVALS;

   if position_change ^= 0
   then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART,
	   null, 0, "^/^a^/ ^d elements to^/position past.",
	   "This module was looping without bound loop while attempting to",
	   "position among the elements.  There are still", position_change);

   element_id.control_interval_id = current_ci_id;
   element_id.index = current_slot_index;

   p_return_element_id_string = element_id_string;
   p_code = 0;
   if terminate_last_ci_ptr
   then call TERMINATE_CI_PTR (ci_ptr);
   else p_return_ci_ptr = ci_ptr;

MAIN_RETURN:
   return;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
   dcl	 cv_p_received_version  char (8) aligned;
   dcl	 cv_p_expected_version  char (8) aligned;
   dcl	 cv_p_structure_name    char (*);

   if cv_p_received_version ^= cv_p_expected_version
   then call sub_err_ (error_table_$unimplemented_version, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected version ^a of the ^a structure.
Received version ^a instead.", cv_p_expected_version, cv_p_structure_name,
	   cv_p_received_version);

   end CHECK_VERSION;



CHECK_CI_LAYOUT:
   proc (ccl_p_ci_layout);
   dcl	 ccl_p_ci_layout	    char (4) aligned;

   if ccl_p_ci_layout ^= BASIC_CI_LAYOUT_1
   then call sub_err_ (dm_error_$unimplemented_ci_version, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected a version ^a control interval. Received version ^a instead."
	   , BASIC_CI_LAYOUT_1, ccl_p_ci_layout);

   end CHECK_CI_LAYOUT;

%page;

FINISH:
   proc ();

   if ci_ptr ^= input_ci_ptr
   then call TERMINATE_CI_PTR (ci_ptr);

   end FINISH;

ERROR_RETURN:
   proc (er_p_code);
   dcl	 er_p_code	    fixed bin (35) parameter;

   call FINISH;
   p_code = er_p_code;
   go to MAIN_RETURN;

   end ERROR_RETURN;

%page;
POSITION_THROUGH_CI:
   proc (ptc_p_ci_ptr, ptc_p_position_change, ptc_p_current_slot_index);

   dcl	 ptc_p_ci_ptr	    ptr;
   dcl	 (ptc_p_position_change, ptc_p_current_slot_index)
			    fixed bin (17);
   dcl	 ptc_slot_idx	    fixed bin (17);

   if ptc_p_position_change > 0
   then
LOOP_FORWARD_THROUGH_SLOTS:
      do ptc_slot_idx = max (1, ptc_p_current_slot_index + 1)
	 to ptc_p_ci_ptr -> basic_control_interval.header.number_of_datums
	 while (ptc_p_position_change > 0);
         if ^(ptc_p_ci_ptr
	    -> basic_control_interval.datum_position_table (ptc_slot_idx)
	    .flags.is_continuation
	    | ptc_p_ci_ptr
	    -> basic_control_interval.datum_position_table (ptc_slot_idx)
	    .offset_in_bytes = FREE_SLOT)
         then ptc_p_position_change = ptc_p_position_change - 1;

         ptc_p_current_slot_index = ptc_slot_idx;
      end LOOP_FORWARD_THROUGH_SLOTS;
   else
LOOP_BACKWARD_THROUGH_SLOTS:
      do ptc_slot_idx =
	 min (ptc_p_current_slot_index - 1,
	 ptc_p_ci_ptr -> basic_control_interval.header.number_of_datums)
	 to 1 by -1 while (ptc_p_position_change < 0);
         if ^(ptc_p_ci_ptr
	    -> basic_control_interval.datum_position_table (ptc_slot_idx)
	    .flags.is_continuation
	    | ptc_p_ci_ptr
	    -> basic_control_interval.datum_position_table (ptc_slot_idx)
	    .offset_in_bytes = FREE_SLOT)
         then ptc_p_position_change = ptc_p_position_change + 1;

         ptc_p_current_slot_index = ptc_slot_idx;
      end LOOP_BACKWARD_THROUGH_SLOTS;

   return;

   end POSITION_THROUGH_CI;
%page;
GET_CI_PTR:
   proc (gcp_p_file_opening_id, gcp_p_collection_id, gcp_p_ci_id,
        gcp_p_input_ci_ptr, gcp_p_ci_ptr);

   dcl	 gcp_p_file_opening_id  bit (36) aligned;
   dcl	 gcp_p_collection_id    bit (36) aligned;
   dcl	 gcp_p_ci_id	    fixed bin (24) unsigned;
   dcl	 gcp_p_input_ci_ptr	    ptr;
   dcl	 gcp_p_ci_ptr	    ptr;
   dcl	 gcp_this_is_first_look_at_ci
			    bit (1) aligned;
   dcl	 gcp_code		    fixed bin (35);


   if gcp_p_ci_ptr = null
   then
      do;
         gcp_this_is_first_look_at_ci = IS_FIRST;
         if gcp_p_input_ci_ptr ^= null
         then
	  do;
	     gcp_p_ci_ptr = gcp_p_input_ci_ptr;
	  end;
         else
	  do;
	     call REALLY_GET_CI_PTR (IS_FIRST);
	  end;
      end;
   else
      do;
         gcp_this_is_first_look_at_ci = NOT_FIRST;
         if gcp_p_input_ci_ptr ^= gcp_p_ci_ptr
         then
	  do;
	     call TERMINATE_CI_PTR (gcp_p_ci_ptr);
	  end;
         call REALLY_GET_CI_PTR (NOT_FIRST);
      end;

   call CHECK_CI_LAYOUT (gcp_p_ci_ptr -> bci_header.layout_type);

   if gcp_p_ci_ptr -> bci_header.collection_id ^= gcp_p_collection_id
   then
      do;
         if gcp_this_is_first_look_at_ci
         then
	  do;
	     call ERROR_RETURN (dm_error_$ci_not_in_collection);
	  end;
         else
	  do;
	     call sub_err_ (dm_error_$programming_error, myname,
		ACTION_CANT_RESTART, null, 0,
		"^/Control interval ^d is in collection ^3bo but was expected to^/be in collection ^3bo."
		, gcp_p_ci_id, gcp_p_ci_ptr -> bci_header.collection_id,
		gcp_p_collection_id);
	  end;
      end;

   return;

REALLY_GET_CI_PTR:
   proc (rgcp_p_is_first);

   dcl	 rgcp_p_is_first	    bit (1) aligned;
   dcl	 file_manager_$get_ci_ptr
			    entry (bit (36) aligned, fixed bin (27), ptr,
			    fixed bin (35));

   call file_manager_$get_ci_ptr (gcp_p_file_opening_id, (gcp_p_ci_id),
        gcp_p_ci_ptr, gcp_code);
   if gcp_code ^= 0
   then if gcp_code ^= dm_error_$ci_not_allocated
        then call ERROR_RETURN (gcp_code);
        else if rgcp_p_is_first
        then call ERROR_RETURN (dm_error_$no_element);
        else call sub_err_ (gcp_code, myname, ACTION_CANT_RESTART, null, 0,
	        "^/Control interval ^d was expected to be ^[next^;previous^] from^/control interval ^d."
	        , gcp_p_ci_id, (position_change > 0), most_recent_ci_id);

   end REALLY_GET_CI_PTR;

   end GET_CI_PTR;
%page;
TERMINATE_CI_PTR:
   proc (tcp_p_ci_ptr);

   dcl	 tcp_p_ci_ptr	    ptr;

   return;

   end TERMINATE_CI_PTR;
%page;
SET_DEFAULT_POSITION:
   proc (sdp_p_file_opening_id, sdp_p_collection_id, sdp_p_position_change,
        sdp_p_ci_id, sdp_p_slot_index);

   dcl	 (sdp_p_file_opening_id, sdp_p_collection_id)
			    bit (36) aligned;
   dcl	 sdp_p_position_change  fixed bin (17);
   dcl	 sdp_p_ci_id	    fixed bin (24) unsigned;
   dcl	 sdp_p_slot_index	    fixed bin (17);
   dcl	 sdp_code		    fixed bin (35);
   dcl	 sdp_cm_info_ptr	    ptr;

   call cm_opening_info$full_get (sdp_p_file_opening_id, sdp_p_collection_id,
        sdp_cm_info_ptr, sdp_code);
   if sdp_code ^= 0
   then call ERROR_RETURN (sdp_code);

   call CHECK_VERSION (sdp_cm_info_ptr -> cm_info.version, CM_INFO_VERSION_2,
        "cm_info");

   call CHECK_VERSION (sdp_cm_info_ptr -> cm_info.header_ptr
        -> collection_header.version, COLLECTION_HEADER_VERSION_2,
        "collection_header");

   if sdp_cm_info_ptr -> cm_info.header_ptr
        -> collection_header.control_interval_storage_method
        ^= UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
   then call sub_err_ (dm_error_$unimplemented_cism, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected control interval storage method ^d; received ^d.",
	   UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD,
	   sdp_cm_info_ptr -> cm_info.header_ptr
	   -> collection_header.control_interval_storage_method);


   if sdp_p_position_change > 0
   then
      do;
         sdp_p_slot_index = LOWEST_SLOT_INDEX;
         sdp_p_ci_id = GET_FIRST_CI ();
         if sdp_p_ci_id = 0 & sdp_p_collection_id ^= HEADER_COLLECTION_ID
         then call ERROR_RETURN (dm_error_$no_element);
      end;
   else if sdp_p_position_change < 0
   then
      do;
         sdp_p_slot_index = HIGHEST_SLOT_INDEX;
         sdp_p_ci_id = GET_LAST_CI ();
         if sdp_p_ci_id = 0 & sdp_p_collection_id ^= HEADER_COLLECTION_ID
         then call ERROR_RETURN (dm_error_$no_element);
      end;
   else call ERROR_RETURN (dm_error_$beginning_of_collection);

   return;


GET_FIRST_CI:
   proc () returns (fixed bin (24) unsigned);

   return (sdp_cm_info_ptr -> cm_info.storage_record_ptr
        -> unblocked_storage_record.first_control_interval);

   end GET_FIRST_CI;


GET_LAST_CI:
   proc () returns (fixed bin (24) unsigned);

   return (sdp_cm_info_ptr -> cm_info.storage_record_ptr
        -> unblocked_storage_record.last_control_interval);

   end GET_LAST_CI;

   end SET_DEFAULT_POSITION;
%page;
%include dm_element_id;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_cm_storage_record;
%page;
%include dm_cm_info;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cism_info;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

%include dm_hdr_collection_id;
   end cm_get_id$id;




		    cm_modify.pl1                   04/04/85  1112.8re  04/04/85  0824.1      276336



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/*  DESCRIPTION

       This module implements collection_manager_$modify (cm_modify$cm_modify),
   collection_manager_$modify_in_ci_buffer (cm_modify$buffered) and
   collection_manager_$modify_unprotected (cm_modify$unprotected), and
   implements entries internal to collection_manager_.

        This module takes the element value pointed to by p_element_ptr and puts it in
   the location described by p_element_id. An element must already be
   allocated at that location. In the simple case where both the old value is
   stored as a single datum and the new value can be stored as a single datum,
   the following attempts are made to store the new value in the old element's
   control interval: (1) exactly replace the contents if there is no change in
   length - do not change any other information; (2) store the new value in the
   same place as the old if no more bytes are required to do so; (3) store the
   new value in the free pool and remove the old; (4) compact the control
   interval if there is enough overall free space to store the new value, and
   store the new value in the newly-enlarged free pool; (5) if Ordered ESM,
   return dm_error_$long_element; else store value in another control interval
   and store in this control interval a continued_datum pointing to where the
   value is actually stored.
   
        The following entry points exist:
   $cm_modify: Called externally (via collection_manager_ transfer
   vector).  This is the main entry.

   $unprotected: Called externally. This entry requires the new value be
   identical in length to the old value. The file_manager_$raw_put entry is
   used to put the new value, thereby not obtaining an exclusive lock on the
   control interval. The new and old values must also be single datum elements.

   $buffered: Called externally. This entry operates on a control interval
   buffer (set up by collection_manager_$setup_buffered_ci) and copies data
   info the buffer directly rather than use file_manager_.

   $info, $unprotected_info, $buffered_info: Called internally by another
   collection_manager_ module which must have set up opening information on
   which this entry relies. In all other respects, identical to their
   corresponding entry.
   
        Internal subroutines which detect an error situation return to the
   external caller via the ERROR_RETURN subroutine. This subroutine sets the
   output error code (p_code), cleans up (via FINISH) and transfers to the
   RETURN label preceding the return statement in the main procedure.  For
   this reason, there are no error code checks following calls to internal
   subroutines.
*/

/* HISTORY:
Written by Matthew Pierret.
Modified:
03/26/82 by Matthew Pierret: Fixed bug that tested for beginning of element 
            incorrectly. Also added check for the collection id to which
            the control interval belongs.
04/07/82 by Matthew Pierret: Added calculation of maximum space available.
04/27/82 by Matthew Pierret: Changed calling sequence of cm_compact_and_add.
05/10/82 by Lindsey Spratt:  Changed division to calculate length_in_bytes to
	  use precision and scale of (35,18) instead of (17, 2).  The
	  length_in_bytes was one short when the length_in_bits was not a
	  multiple of the number of bits per byte. Changed the test which
	  decides whether to use put_datum_in_place or put_datum_in_pool to
	  take into account the datum_header length.
05/11/82 by Lindsey Spratt:  Changed the calculation of
	  p_maximum_space_available to adjust for the datum header length
	  when adding in the length of the element attempting to be "put",
	  but for which there was insufficient room.
06/15/82 by Matthew Pierret: Changed to deal with only complete elements.
            cm_put_element_portion has been written to handle element portions.
            Changed to bci_header, dm_cm_basic_ci.incl.pl1. 
06/21/82 by Matthew Pierret: Changed to use cm_compact.
08/04/82 by Matthew Pierret: Changed to use bit(36)aligned collection id.
09/10/82 by Matthew Pierret: Changed to call cm_compact with element_id.index
            equal to 0, meaning do not leave room for a new slot.
09/21/82 by Lindsey Spratt:  Changed to call cm_compact$replacement, which
	  frees the storage associated with the datum at p_element_id.  This
	  storage was not being freed.  This is done instead of the previous
	  technique of using a 0 index.
10/03/82 by Matthew Pierret:  Added opening info, $info entry.
            Added support for multi-datum elements.
            Changed calculation of p_maximum_space_available to include
            scatterred free space. Previously ony the free pool was being
            considered.
11/18/82 by Lindsey Spratt: Changed to set element_id_string to p_element_id,
	  and changed all of the uses of p_element_id to element_id_string.
12/01/82 by Lindsey Spratt: Changed to always get the cd_datum_header if the
	  is_continued flag is on, and set the continuation variable.
12/02/82 by Lindsey Spratt:  Fixed to add the old storage for the datum to the
            pool_free_space only if the old storage starts at the
            start_of_used_space, as recorded in the bci_header.
01/06/83 by Matthew Pierret: Added $buffered and $buffered_info entries. These
            entries accept a pointer to a control interval buffer, and access
            the control interval buffer rather than have file_manager_ access
            the control interval in the file.
01/12/83 by Lindsey Spratt:  Added declarations of put_into_ci_buffer and
	  sys_info$max_seg_size.  Fixed declaration of dm_error_$no_element,
	  also fixed dcl of p_continuation in an internal proc (was bit(1),
	  is now bit(36)).  Corrected to use BASIC_CI_LAYOUT_1.
01/27/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2. Changed to use
            cm_bet_bci_header$slot instead of cm_get_header_and_slot.
            Changed to use dm_error_$ci_not_in_collection instead of
            $ci_in_wrong_collection. Changed to use addcharno.
            Removed put_element label. Changed calling sequence to 
            cm_recursive_put, adding element_id_string. This is so that
            cm_recursive_put knows the orignin of the element.
04/27/83 by Matthew Pierret:  Added $unprotected("" _info) entries which do
            not obtain an exclusive lock to update the datum contents.  This
            is used for heavily updated and non-critical elements.  The old
            and new elements must be identical in size, so that only the
            contents themselves are changed, avoiding messing up a reader of
            the control interval header.  Also, only single datum elements are
            supported.
                 Also changed to call ERROR_RETURN whenever an error is
            detected, even if in an interal subroutine.  Callers of internal
            subroutines can assume that if the caller is returned to, no error
            has occurred.
04/28/83 by Matthew Pierret:  Fixed bug in cm_put_element introduced in last
            collection_manager_ installation.  A wrong variable was being set,
            leaving the correct one uninitialized.
05/02/83 by Matthew Pierret:  Changed to not allow buffered puts to use
            SIMPLE_REPLACE_DATUM_CONTENTS, since that routine updates the file
            directly.  The previous action caused buffered elements to become
            inconsistent, particularly the branch_ci_header in index
            collections.
05/04/83 by Matthew Pierret:  Fixed use of addcharno (was adding one char too
            many).
04/13/84 by Matthew Pierret:  Changed declaration of p_element_length to
            correctly be fixed bin (35) instead of (17).
05/21/84 by Matthew Pierret:  Renamed include file dm_cm_esm_info to 
            dm_esm_info.
06/01/84 by Matthew Pierret:  Changed to reset datum_slot.offset_in_bytes
            after calling cm_compact$replacement.  The value is used in the
            call to cm_put_datum_in_pool to determine if the existing datum is
            the first datum past the pool and can therefore be partially 
            re-used.  A compaction removes the existing datum's storage, so 
            is invalid to try to re-use it.
06/12/84 by Matthew Pierret:  Changed name of module from cm_put_element to
            cm_modify.  Switched length/ptr parameter pairs to ptr/length.
10/02/84 by Matthew Pierret:  Changed byte length calculations to use the
            function bytes<-divide(bits+BITS_PER_BYTE-1,BITS_PER_BYTE,17,0)
            instead of ceil(divide(bits,BITS_PER_BYTE,35,18)), the former being
            more efficient.  Changed SETUP_HEADER_AND_SLOT into the pair
            GET_SLOT_FROM_BUFFER and GET_HEADER_AND_SLOT_FROM_FILE.  Changed
            subroutines to follow the variable name prefixing convention.
            Changed the continuation variable to continuation_datum_id.
            Fixed to set the element_length_in_bits to the full length of the
            element (current_element_length_in_bits) isntead of the length of 
            the first datum (datum_slot.length_in_bits).  Removed the declared
            but un-used variables BYTES_PER_WORD and sys_info$max_seg_size.
            Changed to only check the ci version once and to use the 
            standard sub_err_ calling sequence.
02/27/85 by Matthew C. Pierret:  Changed to use
            cm_compact$buffered_replacement instead of cm_compact$replacement
            if entered through the buffered entry (is_buffered equals "1"b).
*/

/* format: style2,ind3 */

cm_modify:
   proc (p_file_opening_id, p_collection_id, p_element_ptr, p_element_length, p_element_id, p_maximum_space_available,
        p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_ci_buffer_ptr	       ptr parameter;
      dcl	    p_cm_info_ptr	       ptr parameter;
      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_element_length       fixed bin (35) parameter;
      dcl	    p_element_ptr	       ptr parameter;
      dcl	    p_element_id	       bit (36) aligned parameter;
      dcl	    p_maximum_space_available
			       fixed bin (35) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    1 automatic_bci_header aligned like bci_header;
      dcl	    1 automatic_datum_slot aligned like datum_slot;
      dcl	    continuation_datum_id  bit (36) aligned init ("0"b);
      dcl	    (current_element_length_in_bits, element_length_in_bits, header_space_required, old_datum_length_in_bytes,
	    pool_free_bytes, remaining_length_in_bits, total_free_bytes, code)
			       fixed bin (35) init (0);
      dcl	    (element_length_in_bytes, remaining_length_in_bytes)
			       fixed bin (17) init (0);

      dcl	    (using_ordered_esm, is_buffered, is_unprotected)
			       bit (1) aligned init ("0"b);

/* Based */
/* Builtin */

      dcl	    (addcharno, addr, unspec, divide, null)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("cm_modify") char (32) varying internal static options (constant);
      dcl	    BITS_PER_BYTE	       fixed bin init (9) int static options (constant);
      dcl	    END_OF_ELEMENT	       fixed bin init (-1) int static options (constant);

/* Entry */

      dcl	    file_manager_$get      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    file_manager_$put      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    file_manager_$raw_put  entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    file_manager_$simple_get
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    sub_err_	       entry options (variable);

/* External */

      dcl	    (
	    dm_error_$bad_element_length,
	    dm_error_$ci_not_in_collection,
	    dm_error_$long_element,
	    dm_error_$no_element,
	    dm_error_$unimplemented_ci_version,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */

      is_unprotected = "0"b;
      is_buffered = "0"b;
      unspec (automatic_bci_header) = ""b;
      unspec (automatic_datum_slot) = ""b;
      bci_header_ptr = addr (automatic_bci_header);
      datum_slot_ptr = addr (automatic_datum_slot);
      go to NO_INFO_JOIN;

buffered:
   entry (p_ci_buffer_ptr, p_file_opening_id, p_collection_id, p_element_ptr, p_element_length, p_element_id,
        p_maximum_space_available, p_code);

      is_buffered = "1"b;
      bci_header_ptr = p_ci_buffer_ptr;
      call CHECK_CI_VERSION ((bci_header.layout_type));
      goto NO_INFO_JOIN;

unprotected:
   entry (p_file_opening_id, p_collection_id, p_element_ptr, p_element_length, p_element_id, p_maximum_space_available,
        p_code);

      is_unprotected = "1"b;
      is_buffered = "0"b;
      unspec (automatic_bci_header) = ""b;
      unspec (automatic_datum_slot) = ""b;
      bci_header_ptr = addr (automatic_bci_header);
      datum_slot_ptr = addr (automatic_datum_slot);
      go to NO_INFO_JOIN;


NO_INFO_JOIN:
      code = 0;
      call cm_opening_info$get (p_file_opening_id, p_collection_id, cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      go to JOIN;


info:
   entry (p_cm_info_ptr, p_element_ptr, p_element_length, p_element_id, p_maximum_space_available, p_code);

      is_unprotected = "0"b;
      is_buffered = "0"b;
      unspec (automatic_bci_header) = ""b;
      unspec (automatic_datum_slot) = ""b;
      bci_header_ptr = addr (automatic_bci_header);
      datum_slot_ptr = addr (automatic_datum_slot);
      cm_info_ptr = p_cm_info_ptr;
      go to JOIN;

/* ******************** Not currently used ********************

   buffered_info:
   entry (p_cm_info_ptr, p_ci_buffer_ptr, p_element_ptr, p_element_length, p_element_id, p_maximum_space_available,
   p_code);

   is_unprotected = "0"b;
   is_buffered = "1"b;
   cm_info_ptr = p_cm_info_ptr;
   bci_header_ptr = p_ci_buffer_ptr;
   call CHECK_CI_VERSION (bci_header.layout_type);

   go to JOIN;

   ** ************************************************************ */

unprotected_info:
   entry (p_cm_info_ptr, p_element_ptr, p_element_length, p_element_id, p_maximum_space_available, p_code);

      is_unprotected = "1"b;
      is_buffered = "0"b;
      unspec (automatic_bci_header) = ""b;
      unspec (automatic_datum_slot) = ""b;
      bci_header_ptr = addr (automatic_bci_header);
      datum_slot_ptr = addr (automatic_datum_slot);
      cm_info_ptr = p_cm_info_ptr;
      goto JOIN;
%page;
JOIN:
      call CHECK_VERSION (cm_info.version, CM_INFO_VERSION_2, "cm_info");
      collection_header_ptr = cm_info.header_ptr;
      call CHECK_VERSION (collection_header.version, COLLECTION_HEADER_VERSION_2, "collection_header");

      p_code, code = 0;
      p_maximum_space_available = -1;

      element_id_string = p_element_id;

      if collection_header.element_storage_method = ORDERED_ELEMENT_STORAGE_METHOD
      then using_ordered_esm = "1"b;
      else using_ordered_esm = "0"b;

      if is_buffered
      then call GET_SLOT_FROM_BUFFER (element_id.index, bci_header_ptr, datum_slot_ptr);
      else call GET_HEADER_AND_SLOT_FROM_FILE (cm_info.file_oid, element_id_string, bci_header_ptr, datum_slot_ptr);
      if bci_header.collection_id ^= cm_info.collection_id
      then call ERROR_RETURN (dm_error_$ci_not_in_collection);

/**** Get the length of the existing element (current_element_length_in_bits). */

      if datum_slot.flags.is_continued
      then if is_buffered
	 then call GET_DATUM_HEADER_VALUES_FROM_BUFFER (bci_header_ptr, datum_slot.offset_in_bytes,
		 current_element_length_in_bits, continuation_datum_id);
	 else call GET_DATUM_HEADER_VALUES_FROM_FILE (cm_info.file_oid, (element_id.control_interval_id),
		 (datum_slot.offset_in_bytes), current_element_length_in_bits, continuation_datum_id);
      else current_element_length_in_bits = datum_slot.length_in_bits;

/**** Get the length of the new element (element_length_in_bits). */

      if p_element_length ^= END_OF_ELEMENT
      then element_length_in_bits = p_element_length;
      else element_length_in_bits = current_element_length_in_bits;

      if element_length_in_bits < 1
      then call ERROR_RETURN (dm_error_$bad_element_length);

      if ^datum_slot.flags.is_continued & element_length_in_bits = current_element_length_in_bits & ^is_buffered
      then
SIMPLE_REPLACE:
         do;

         /*** The length of the old and new elements are the same.  This means that only the
	    datum contents need to be changed, and the contents can be changed in place.
	    This special-case replacement can be done quickly. */

	  call SIMPLE_REPLACE_DATUM_CONTENTS (cm_info.file_oid, (element_id.control_interval_id), p_element_ptr,
	       element_length_in_bits, (datum_slot.offset_in_bytes), is_unprotected);

         end SIMPLE_REPLACE;
      else if is_unprotected & (element_length_in_bits ^= current_element_length_in_bits | datum_slot.flags.is_continued)
      then
GENERAL_REPLACE_UNPROTECTED:
         call ERROR_RETURN (dm_error_$bad_element_length);
      else
GENERAL_REPLACE:
         do;

         /*** More work may be necessary than simply changing the contents of
	    the datum which holds the element. */

	  remaining_length_in_bits = element_length_in_bits;
						/* Length of portion of element not yet re-written. */
         /*** Determine the amount of free space in bytes in this control
	    interval. */

	  call cm_determine_free_space$all (bci_header_ptr, 0, total_free_bytes, pool_free_bytes);

         /*** Record the length of the existing datum. This is needed to accurately determine
	    the effective free space (total_free_bytes + old_datum_length_in_bytes)
	    and to determine the change in free space caused by replacing the datum. */

	  old_datum_length_in_bytes = divide (datum_slot.length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);

	  total_free_bytes = total_free_bytes + old_datum_length_in_bytes;

         /*** If the old datum was allocated at the beginning of the used space, then its
	    old storage space is available as part of the free pool (cm_put_datum_in_pool
	    is capable of recovering this space).  Otherwise,  the only way to recover the
	    old storage for the datum is to compact the control interval. */

	  if datum_slot.offset_in_bytes = bci_header.start_of_used_space
	  then pool_free_bytes = pool_free_bytes + old_datum_length_in_bytes;

	  if datum_slot.flags.is_continued
	  then
	     do;

	     /*** The existing element is a multi-datum element. Put the new value from
		rightmost datum of the element to the leftmost. */

	        call cm_recursive_modify (cm_info_ptr, element_id_string, p_element_ptr, remaining_length_in_bits,
		   total_free_bytes, continuation_datum_id, code);
	        if code ^= 0
	        then call ERROR_RETURN (code);

	     end;

	  if remaining_length_in_bits >= MINIMUM_MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS
	  then
	     do;

	     /*** As it is not possible, by convention, for the first datum of an element
		to be maximum-sized, maximum-sized datums must be allocated to hold the
		tail of the element.  If part of the tail has already been put by
		cm_recursive_modify, that part is ignored because remaining_length_in_bits
		was decremented.   */

	        call cm_put_overlength_tail (cm_info_ptr, p_element_ptr, remaining_length_in_bits,
		   continuation_datum_id, code);
	        if code ^= 0
	        then call ERROR_RETURN (code);
	     end;

         /*** Now all of the element except for a less-than maximum-sized datum has
	    been stored.  If the remainder is too big to fit in this control interval,
	    store it in another control interval and leave an indirect in this
	    control interval. */

	  if continuation_datum_id ^= "0"b
	  then header_space_required = CD_DATUM_HEADER_LENGTH_IN_BYTES;

	  remaining_length_in_bytes = divide (remaining_length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);

	  if remaining_length_in_bytes + header_space_required <= old_datum_length_in_bytes
	  then
PUT_IN_PLACE:
	     do;

	     /*** The remainder can be placed where the old datum is. */

	        if is_buffered
	        then if continuation_datum_id = "0"b
		   then call cm_put_datum_in_place$buffered (bci_header_ptr, p_element_ptr, remaining_length_in_bits,
			   datum_slot_ptr, code);
		   else call cm_put_datum_in_place$buffered_continued (bci_header_ptr, p_element_ptr,
			   remaining_length_in_bits, datum_slot_ptr, element_length_in_bits, continuation_datum_id,
			   code);

	        else if continuation_datum_id = "0"b
	        then call cm_put_datum_in_place (cm_info.file_oid, element_id_string, p_element_ptr,
		        remaining_length_in_bits, datum_slot_ptr, bci_header_ptr, code);
	        else call cm_put_datum_in_place$continued (cm_info.file_oid, element_id_string, p_element_ptr,
		        remaining_length_in_bits, datum_slot_ptr, bci_header_ptr, element_length_in_bits,
		        continuation_datum_id, code);

	     end PUT_IN_PLACE;
	  else
PUT_IN_POOL:
	     do;

	     /*** The remainder is too large to be stored in the space which the old value
		currently occupies. Find another place in the control interval to put the
		new value. */

	        if remaining_length_in_bits > (total_free_bytes - header_space_required) * BITS_PER_BYTE
	        then
		 do;

		 /*** The remainder won't fit in this control interval.  Allocate another
		      datum in which to store the remainder. */

		    if using_ordered_esm
		    then call ERROR_RETURN (dm_error_$long_element);

		    call cm_put_cn_datum (cm_info_ptr, p_element_ptr, remaining_length_in_bits,
		         (continuation_datum_id), continuation_datum_id, code);
		    if code ^= 0
		    then call ERROR_RETURN (code);

		    remaining_length_in_bits = 0;
		    header_space_required = CD_DATUM_HEADER_LENGTH_IN_BYTES;

		 end;

	     /*** The remainder can be placed in this control interval.  Try to put it
		in the place it previously occupied.  Otherwise, compact the control
		interval and place it in the pool. */

	        if remaining_length_in_bits > (pool_free_bytes - header_space_required) * BITS_PER_BYTE
	        then
		 do;

		    if is_buffered
		    then call cm_compact$buffered_replacement (bci_header_ptr, (bci_header.number_of_datums),
			    element_id_string, code);
		    else call cm_compact$replacement (cm_info.file_oid, (bci_header.number_of_datums),
			    element_id_string, bci_header_ptr, code);
		    if code ^= 0
		    then call ERROR_RETURN (code);
		    datum_slot.offset_in_bytes = 0;	/* The compaction removed the storage taken up by the element. */
		 end;

	        if continuation_datum_id = "0"b
	        then
		 do;

		    datum_slot.flags.is_continued = "0"b;

		    if is_buffered
		    then call cm_put_datum_in_pool$buffered (bci_header_ptr, p_element_ptr, remaining_length_in_bits,
			    datum_slot_ptr, code);
		    else call cm_put_datum_in_pool (cm_info.file_oid, element_id_string, p_element_ptr,
			    remaining_length_in_bits, datum_slot_ptr, bci_header_ptr, code);

		 end;
	        else
		 do;

		    datum_slot.flags.is_continued = "1"b;

		    if is_buffered
		    then call cm_put_datum_in_pool$buffered_continued (bci_header_ptr, p_element_ptr,
			    remaining_length_in_bits, datum_slot_ptr, element_length_in_bits, continuation_datum_id,
			    code);
		    else call cm_put_datum_in_pool$continued (cm_info.file_oid, element_id_string, p_element_ptr,
			    remaining_length_in_bits, datum_slot_ptr, bci_header_ptr, element_length_in_bits,
			    continuation_datum_id, code);

		 end;

	     end PUT_IN_POOL;

	  if code ^= 0
	  then call ERROR_RETURN (code);

         end GENERAL_REPLACE;

/**** Successful return. */

      call FINISH ();
RETURN:						/* Transferred to from ERROR_RETURN. */
      return;

%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (8) aligned;
      dcl	    p_expected_version     char (8) aligned;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;


CHECK_CI_VERSION:
   proc (p_given_version);

      dcl	    p_given_version	       char (4) aligned;

      if p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^4a"" control interval; received ""^4a"".", BASIC_CI_LAYOUT_1, p_given_version);

      return;

   end CHECK_CI_VERSION;
%page;
FINISH:
   proc ();


      if p_code = 0 | p_code = dm_error_$long_element
      then p_maximum_space_available =
	      BITS_PER_BYTE * (total_free_bytes - header_space_required) - remaining_length_in_bits;

      return;

   end FINISH;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH ();
      goto RETURN;

   end ERROR_RETURN;
%page;
SIMPLE_REPLACE_DATUM_CONTENTS:
   proc (srdc_p_file_opening_id, srdc_p_control_interval_id, srdc_p_datum_contents_ptr, srdc_p_datum_contents_length,
        srdc_p_datum_contents_offset, srdc_p_is_unprotected);

      dcl	    (
	    srdc_p_file_opening_id bit (36) aligned,
	    srdc_p_control_interval_id
			       fixed bin (27),
	    srdc_p_datum_contents_length
			       fixed bin (35),
	    srdc_p_datum_contents_ptr
			       ptr,
	    srdc_p_datum_contents_offset
			       fixed bin (17),
	    srdc_p_is_unprotected  bit (1) aligned
	    )		       parameter;
      dcl	    srdc_code	       fixed bin (35) init (0);
      dcl	    1 srdc_ci_part	       aligned,
	      2 number_of_parts    fixed bin (17) init (1),
	      2 part	       (1) like ci_parts.part;

      srdc_ci_part.part (1).offset_in_bytes = srdc_p_datum_contents_offset;
      srdc_ci_part.part (1).length_in_bytes =
	 divide (srdc_p_datum_contents_length + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);
      srdc_ci_part.part (1).local_ptr = srdc_p_datum_contents_ptr;

      if srdc_p_is_unprotected
      then call file_manager_$raw_put (srdc_p_file_opening_id, srdc_p_control_interval_id, addr (srdc_ci_part), srdc_code)
	      ;
      else call file_manager_$put (srdc_p_file_opening_id, srdc_p_control_interval_id, addr (srdc_ci_part), srdc_code);

      if srdc_code ^= 0
      then call ERROR_RETURN (srdc_code);

      return;

   end SIMPLE_REPLACE_DATUM_CONTENTS;
%page;
GET_SLOT_FROM_BUFFER:
   proc (gs_p_slot_index, gs_p_bci_ptr, gs_p_slot_ptr);

      dcl	    gs_p_slot_index	       fixed bin (12) uns unal parameter;
      dcl	    gs_p_bci_ptr	       ptr parameter;
      dcl	    gs_p_slot_ptr	       ptr parameter;

      if gs_p_slot_index > gs_p_bci_ptr -> basic_control_interval.header.number_of_datums | gs_p_slot_index <= 0
      then call ERROR_RETURN (dm_error_$no_element);
      else gs_p_slot_ptr = addr (gs_p_bci_ptr -> basic_control_interval.datum_position_table (gs_p_slot_index));

   end GET_SLOT_FROM_BUFFER;


GET_HEADER_AND_SLOT_FROM_FILE:
   proc (ghs_p_file_oid, ghs_p_element_id, ghs_p_bci_header_ptr, ghs_p_slot_ptr);

      dcl	    ghs_p_file_oid	       bit (36) aligned parameter;
      dcl	    ghs_p_element_id       bit (36) aligned parameter;
      dcl	    ghs_p_bci_header_ptr   ptr parameter;
      dcl	    ghs_p_slot_ptr	       ptr parameter;

      dcl	    ghs_code	       fixed bin (35) init (0);

      call cm_get_bci_header$slot (ghs_p_file_oid, ghs_p_bci_header_ptr, ghs_p_slot_ptr, ghs_p_element_id, ghs_code);
      if ghs_code ^= 0
      then call ERROR_RETURN (ghs_code);
      else call CHECK_CI_VERSION (ghs_p_bci_header_ptr -> bci_header.layout_type);

      return;

   end GET_HEADER_AND_SLOT_FROM_FILE;
%page;
GET_DATUM_HEADER_VALUES_FROM_FILE:
   proc (gdf_p_file_oid, gdf_p_ci_number, gdf_p_datum_offset, gdf_p_full_length, gdf_p_continuation_datum_id);

      dcl	    gdf_p_file_oid	       bit (36) aligned parameter;
      dcl	    gdf_p_ci_number	       fixed bin (27) parameter;
      dcl	    gdf_p_datum_offset     fixed bin (21) parameter;
      dcl	    gdf_p_full_length      fixed bin (35) parameter;
      dcl	    gdf_p_continuation_datum_id
			       bit (36) aligned parameter;

      dcl	    gdf_code	       fixed bin (35) init (0);
      dcl	    1 gdf_continued_datum_header
			       aligned like continued_datum.header;

      call file_manager_$simple_get (gdf_p_file_oid, gdf_p_ci_number, gdf_p_datum_offset,
	 addr (gdf_continued_datum_header), (CD_DATUM_HEADER_LENGTH_IN_BYTES), gdf_code);
      if gdf_code ^= 0
      then call ERROR_RETURN (gdf_code);

      gdf_p_full_length = gdf_continued_datum_header.full_length;
      gdf_p_continuation_datum_id = unspec (gdf_continued_datum_header.continuation);

      return;

   end GET_DATUM_HEADER_VALUES_FROM_FILE;
%page;
GET_DATUM_HEADER_VALUES_FROM_BUFFER:
   proc (gdb_p_ci_ptr, gdb_p_datum_offset, gdb_p_full_length, gdb_p_continuation_datum_id);

      dcl	    gdb_p_ci_ptr	       ptr parameter;
      dcl	    gdb_p_datum_offset     fixed bin (15) uns unal parameter;
      dcl	    gdb_p_full_length      fixed bin (35) parameter;
      dcl	    gdb_p_continuation_datum_id
			       bit (36) aligned parameter;

      dcl	    gdb_datum_ptr	       ptr;

      gdb_datum_ptr = addcharno (gdb_p_ci_ptr, gdb_p_datum_offset);

      gdb_p_full_length = gdb_datum_ptr -> continued_datum.full_length;
      gdb_p_continuation_datum_id = unspec (gdb_datum_ptr -> continued_datum.continuation);

      return;

   end GET_DATUM_HEADER_VALUES_FROM_BUFFER;
%page;
%include dm_cm_info;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_ci_parts;
%page;
%include dm_element_id;
%page;
%include dm_esm_info;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_modify;




		    cm_opening_info.pl1             04/04/85  1112.8r w 04/04/85  0912.7      125613



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         This   routine   handles   all  manipulation  of  opening  info  for
     collections.

     $get gets a pointer to a cm_info structure associated with  the  supplied
     p_file_oid and p_collection_id.  If no cm_info exists yet, it creates one
     by  extracting  information out of the collection header and stores it in
     the opening info area (dm_data_$area_ptr). If cm_info exists and the
     current transaction is not the same as that identified by 
     cm_info.current_txn_id, the information is copied from the collection
     header to the location where cm_info is stored.

     $full_get is the same as $get, except it also gets the storage record
     for the collection.  The reason for the two entries is because most
     operations do not need the information in the storage record, and
     shouldn't pay the expense and possible concurrency problems of getting
     the storage record.

     $get_storage_record - given a pointer to a cm_info structure, sets
     cm_info.storage_record_ptr to the location of the collection's storage
     record.  If cm_info.storage_record_ptr = null or cm_info.current_txn_id
     ^= the current transaciton, the storage record is retrieved from the
     collection header.

     These entries call cm_get_element, depending on it not in turn calling
     one of these entries again.  If cm_get_element is ever changed to use
     opening info, these entries will have to be changed to get elements
     in another way.
     
     $opening_table_ptr - is a function which returns the value of the static
     variable static_opening_table_ptr.
     
     $degug_(on off) - turn debugging features (on off) for this process.
*/

/* HISTORY:

Written by Matthew Pierret, 11/01/82.
Modified:
11/22/82 by Lindsey Spratt:  Changed to initialize collection_header_ptr to
	  null.
12/10/82 by Lindsey Spratt:  Changed to refresh the cm_info if the txn has
	  changed.  Also, fixed to not free the cm_info (in FINISH) if not
	  allocated by this module.
01/25/83 by Matthew Pierret: Added $get_storage_record entry. Changed to
            convert certain error codes to dm_error_$collection_not_found
            when error is encountered attempting to get the collection_header.
            It is assumed that the caller supplied an incorrect collection_id.
            Changed to report an internal inconsistency if the same errors
            are encountered attempting to get the storage record, as this 
            indicates that the collection_header.storage_record_element_id
            is invalid.
            Changed to use cm_info version 2.
            Changed to use cm_get_element$bypass_info to prevent looping.
03/24/83 by Matthew Pierret: Added $opening_table_ptr entry.
04/08/83 by Matthew Pierret: Chnaged to set cm_info.storage_record_ptr to null
            after refreshing. Changed to not use dm_data_$(area_ptr
            current_txn_id), but to call (get_dm_free_area_ 
            tm_$get_current_txn_id) instead.
04/08/83 by Lindsey L. Spratt:  Fixed to initialize the storage_record_ptr to
            null when refreshing the opening.
04/12/83 by Lindsey L. Spratt:  Changed to only get the storage_record when
            the get_storage_record flag is on and the
            cm_info.storage_record_ptr is null.  Added the debug displays and
	  the debug_on/off entries.
02/08/84 by Matthew Pierret:  Changed to new calling sequence of 
            cm_get_element$bypass_info, which now includes a position arg.
10/02/84 by Matthew Pierret:  Changed to use cm_get_element instead of
            cm_get_element$bypass_info (now obsolete).  Added ERROR_RETURN 
            procedure. Changed CHECK_VERSION to follow variable name
            prefixing convention.  Made dm_area_ptr a static variable,
            initialized to null, so that get_dm_free_area_ need only be called
            once per process.  Changed the get_info and get_storage_record
            flags to both be set for each of the entries which use them.
*/

/* format: style2,ind3 */

cm_opening_info:
   proc ();

      return;


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_oid	       bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_cm_info_ptr	       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (get_info, get_storage_record)
			       bit (1) aligned;
      dcl	    (alloc_new_cm_info, refresh_cm_info, init_table)
			       bit (1) aligned init ("0"b);
      dcl	    code		       fixed bin (35);
      dcl	    current_transaction_id bit (36) aligned init ("0"b);

/* Based */

      dcl	    work_area	       area (sys_info$max_seg_size) based (dm_area_ptr);

/* Builtin */

      dcl	    (addr, max, null, size)
			       builtin;

/* Constant */

      dcl	    DONT_POSITION	       init (0) fixed bin internal static options (constant);
      dcl	    BITS_PER_WORD	       init (36) fixed bin internal static options (constant);
      dcl	    NUMBER_OF_BUCKETS      init (20) fixed bin internal static options (constant);
      dcl	    myname	       init ("cm_opening_info") char (32) varying internal static options (constant);

/* Entry */

      dcl	    ioa_		       entry () options (variable);
      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    opening_manager_$get_opening
			       entry (ptr, bit (72) aligned, ptr, fixed bin (35));
      dcl	    opening_manager_$put_opening
			       entry (ptr, bit (72) aligned, ptr, fixed bin (35));
      dcl	    opening_manager_$init  entry (fixed bin, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);
      dcl	    transaction_manager_$get_current_txn_id
			       entry (bit (36) aligned, fixed bin (35));

/* External */

      dcl	    (
	    dm_error_$ci_not_in_collection,
	    dm_error_$collection_not_found,
	    dm_error_$programming_error,
	    dm_error_$no_element,
	    dm_error_$no_current_transaction
	    )		       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;
      dcl	    sys_info$max_seg_size  fixed bin (35) ext;

/* Static */

      dcl	    internal_debug	       bit (1) init ("0"b) aligned internal static;
      dcl	    static_opening_table_ptr
			       init (null) ptr internal static;
      dcl	    dm_area_ptr	       init (null) ptr internal static;

/* END OF DECLARATIONS */

opening_table_ptr:
   entry () returns (ptr);

      return (static_opening_table_ptr);

debug_on:
   entry ();
      internal_debug = "1"b;
      return;
debug_off:
   entry ();
      internal_debug = "0"b;
      return;

get_storage_record:
   entry (p_cm_info_ptr, p_code);

      get_info = "0"b;
      get_storage_record = "1"b;
      cm_info_ptr = p_cm_info_ptr;
      call CHECK_VERSION (cm_info.version, CM_INFO_VERSION_2, "cm_info");
      call CHECK_VERSION (cm_info.header_ptr -> collection_header.version, COLLECTION_HEADER_VERSION_2,
	 "collection_header");

      goto JOIN;

full_get:
   entry (p_file_oid, p_collection_id, p_cm_info_ptr, p_code);

      get_info = "1"b;
      get_storage_record = "1"b;
      collection_header_ptr, cm_info_ptr = null;
      go to JOIN;

get:
   entry (p_file_oid, p_collection_id, p_cm_info_ptr, p_code);

      get_info = "1"b;
      get_storage_record = "0"b;
      collection_header_ptr, cm_info_ptr = null;
      go to JOIN;

JOIN:
      p_code, code = 0;
      call transaction_manager_$get_current_txn_id (current_transaction_id, code);
      if code ^= 0
      then if code ^= dm_error_$no_current_transaction
	 then call ERROR_RETURN (code);
	 else code = 0;

      if dm_area_ptr = null
      then dm_area_ptr = get_dm_free_area_ ();

      if get_info
      then
GET_HEADER:
         do;

	  if static_opening_table_ptr = null
	  then
	     do;
	        alloc_new_cm_info, refresh_cm_info, init_table = "1"b;
	        call opening_manager_$init (NUMBER_OF_BUCKETS, static_opening_table_ptr, code);
	        if code ^= 0
	        then call ERROR_RETURN (code);
	     end;
	  else
	     do;
	        call opening_manager_$get_opening (static_opening_table_ptr, (p_file_oid || p_collection_id),
		   cm_info_ptr, code);
	        if code ^= 0
	        then
		 do;
		    code = 0;
		    refresh_cm_info, alloc_new_cm_info = "1"b;
		 end;
	        else
		 do;
		    call CHECK_VERSION (cm_info.version, CM_INFO_VERSION_2, "cm_info");
		    if cm_info.current_txn_id ^= current_transaction_id
		    then refresh_cm_info = "1"b;
		 end;
	     end;

	  if refresh_cm_info
	  then
	     do;

/*
     The opening info could not be found, so create a cm_info structure
     and set up an entry in the opening_info_table for it.
*/
	        if internal_debug
	        then
		 do;
		    call ioa_ ("Getting opening info for collection ^3bo in file ^3bo.", p_collection_id, p_file_oid);
		    if init_table
		    then call ioa_ ("^5xInitialized the opening table.");
		    if alloc_new_cm_info
		    then call ioa_ ("^5xAllocating a new opening.");
		    else call ioa_ (
			    "^5xRefreshing the opening because it was last valid for txn ^3bo,^/^10xand the current txn is ^3bo."
			    , cm_info.current_txn_id, current_transaction_id);
		 end;

	        if alloc_new_cm_info
	        then
		 do;
		    alloc cm_info in (work_area);
		    cm_info.version = CM_INFO_VERSION_2;
		 end;

	        call cm_get_element (p_file_oid, HEADER_COLLECTION_ID, p_collection_id, DONT_POSITION,
		   cm_info.header_ptr, size (collection_header) * BITS_PER_WORD, dm_area_ptr, ("1"b),
		   cm_info.header_ptr, (0), code);
	        if code ^= 0
	        then
		 do;
		    if code = dm_error_$ci_not_in_collection | code = dm_error_$no_element
		    then call ERROR_RETURN (dm_error_$collection_not_found);
		    else call ERROR_RETURN (code);
		 end;
	        collection_header_ptr = cm_info.header_ptr;
	        call CHECK_VERSION (collection_header.version, COLLECTION_HEADER_VERSION_2, "collection_header");


	        cm_info.current_txn_id = current_transaction_id;
	        cm_info.file_oid = p_file_oid;
	        cm_info.collection_id = p_collection_id;
	        cm_info.storage_record_ptr = null;


	        if alloc_new_cm_info
	        then
		 do;
		    call opening_manager_$put_opening (static_opening_table_ptr, (p_file_oid || p_collection_id),
		         cm_info_ptr, code);
		    if code ^= 0
		    then call ERROR_RETURN (code);
		 end;
	     end;
         end GET_HEADER;

      if get_storage_record
      then if cm_info.storage_record_ptr = null
	 then
	    do;
	       if internal_debug
	       then call ioa_ ("^5xGetting the storage record for collection ^3bo of file ^3bo.", cm_info.collection_id,
		       cm_info.file_oid);
	       call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID,
		  cm_info.header_ptr -> collection_header.storage_record_element_id, DONT_POSITION,
		  cm_info.storage_record_buffer_ptr,
		  max (size (blocked_storage_record), size (unblocked_storage_record)) * BITS_PER_WORD, dm_area_ptr,
		  ("1"b), cm_info.storage_record_ptr, (0), code);
	       if code ^= 0
	       then if code ^= dm_error_$ci_not_in_collection & code ^= dm_error_$no_element
		  then call ERROR_RETURN (code);
		  else call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
			  "^/^a ^3bo ^a^/^a^/control interval ^d, slot ^d. ^[That control interval is not part of the ^/header_collection.^;That slot contains no data.^]"
			  , "The storage record for collection", cm_info.collection_id,
			  "is not at the location recorded",
			  "in the collection's header.  The header claims the storage record is at",
			  addr (cm_info.header_ptr -> collection_header.storage_record_element_id)
			  -> element_id.control_interval_id,
			  addr (cm_info.header_ptr -> collection_header.storage_record_element_id)
			  -> element_id.index);


	       cm_info.current_txn_id = current_transaction_id;
	       cm_info.storage_record_buffer_ptr = cm_info.storage_record_ptr;
	    end;

      p_cm_info_ptr = cm_info_ptr;
MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
FINISH:
   proc ();					/*
     Free anything that this instance of cm_opening_info allocated.
     The storage record need not be freed, as it can not have been 
     allocated if this routine was called.
*/

      if alloc_new_cm_info
      then
         do;
	  if collection_header_ptr ^= null
	  then free collection_header in (work_area);

	  if cm_info_ptr ^= null & p_cm_info_ptr ^= cm_info_ptr
	  then free cm_info in (work_area);
         end;
      return;

   end FINISH;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  char (8) aligned;
      dcl	    cv_p_expected_version  char (8) aligned;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^a instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include dm_cm_info;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_storage_record;
%page;
%include dm_element_id;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;
   end cm_opening_info;




		    cm_postcommit_increment.pl1     04/02/87  1313.6rew 04/02/87  1258.7      103419



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/* DESCRIPTION:

         This routine increments each word of a contiguous string of words by
     the  respective  values  in  a caller-supplied array of words.  Given the
     identifier of  an  element  (p_element_id)  in  which  the  words  to  be
     incremented  reside, and the bit-offset from the beginning of the element
     to  the  beginning  of  the  string  of   words,   this   routine   calls
     file_manager_$postcommit_increment  to  do  the actual increment.  If the
     element is a multi-datum element, a separate call for each datum is made.

     The reason for this special entry to increment words  instead  of  having
     the  caller  increment the words and call collection_manager_$modify with
     the updated element is because it is  intended  that  the  words  not  be
     updated   until  the  current  transaction  commits.    Currently
     the  only  user  of  this  routine  is  index_manager_  for  updating its
     key_count_array.

     This           routine           implements           the           entry
     collection_manager_$postcommit_increment.
*/

/* HISTORY:

Written by Matthew C. Pierret, 02/15/85.
Modified:
03/06/85 by R. Michael Tague: Finished implementation.
04/22/85 by R. Michael Tauge: Converted one ERROR_RETURN to use ERROR_SIGNAL,
            Removed es_arg_count and es_code dcl, declared addbitno, divide,
	  and unspec builtins, made version check for CI use CHECK_VERSION
	  instead of a special CHECK_CI_VERSION, and changed ERROR_SIGNAL to
	  use a different mechanism of constructing error strings.
*/

/****^  HISTORY COMMENTS:
  1) change(86-02-27,Pierret), approve(86-02-27,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Converted one ERROR_RETURN to use ERROR_SIGNAL,
     Removed es_arg_count and es_code dcl, declared addbitno, divide,
     and unspec builtins, made version check for CI use CHECK_VERSION
     instead of a special CHECK_CI_VERSION, and changed ERROR_SIGNAL to
     use a different mechanism of constructing error strings.
  2) change(86-04-22,Pierret), approve(86-04-22,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Removed local_cm_postcommit_info structure and es_message_overlay, using
     instead cm_postcommit_info and substr (es_message, 1, es_message_length),
     respectively.
  3) change(87-01-15,Hergert), approve(87-04-01,MCR7632),
     audit(87-02-02,Dupuis), install(87-04-02,MR12.1-1020):
     For TR phx20754, arranged to keep the element id of the key_count_array so
     that we can use it at postcommit time if necessary. We save it in
     local_fm_increment_info and pass it on to fm_put_.
                                                   END HISTORY COMMENTS */



/* format: style5,^indcomtxt */
cm_postcommit_increment:
        proc (p_file_opening_id, p_collection_id, p_element_id,
	  p_cm_increment_info_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

        dcl     p_file_opening_id	bit (36) aligned;
					      /* opening identifier of file */
        dcl     p_collection_id	bit (36) aligned;
					      /* identifier of collection */
        dcl     p_element_id		bit (36) aligned;
					      /* identifier of element */
        dcl     p_cm_increment_info_ptr ptr;	      /* points to cm_ioncrement_info structure */
        dcl     p_code		fixed bin (35); /* status code */

/* Automatic */

        dcl     code		fixed bin (35);
        dcl     collection_id		bit (36) aligned;
        dcl     file_opening_id	bit (36) aligned;
        dcl     1 local_bci_header	aligned like bci_header;
        dcl     1 local_datum_slot	aligned like datum_slot;
        dcl     1 local_fm_increment_info
				aligned like fm_increment_info;

/* Builtin */

        dcl     (addbitno, addr, divide, null, substr, unspec)
				builtin;

/* Constant */

        dcl     myname		init ("cm_postcommit_increment")
				char (32) varying internal
				static options (constant);

        dcl     BITS_PER_BYTE		fixed bin init (9) internal
				static options (constant);
        dcl     BITS_PER_WORD		fixed bin init (36) internal
				static options (constant);
        dcl     (NO_PAD, NO_NL)	init ("0"b) bit (1) aligned
				internal static options (constant);
        dcl     NOT_CONTINUED		bit (1) init ("0"b) internal
				static options (constant);

/* Entry */

        dcl     cu_$arg_list_ptr	entry (ptr);
        dcl     file_manager_$postcommit_increment
				entry (bit (36) aligned, fixed bin (27),
				ptr, fixed bin (35));
        dcl     ioa_$general_rs	entry (ptr, fixed bin, fixed bin,
				char (*), fixed bin (21),
				bit (1) aligned, bit (1) aligned);
        dcl     sub_err_		entry () options (variable);

/* External */

        dcl     dm_error_$ci_not_in_collection
				fixed bin (35) ext;
        dcl     dm_error_$invalid_increment_offset
				fixed bin (35) ext;
        dcl     dm_error_$invalid_increment_words
				fixed bin (35) ext;
        dcl     dm_error_$long_increment_length
				fixed bin (35) ext;
        dcl     dm_error_$programming_error
				fixed bin (35) ext;
        dcl     dm_error_$unimplemented_entry
				fixed bin (35) ext;
        dcl     error_table_$unimplemented_version
				fixed bin (35) ext;

/* END OF DECLARATIONS */

        file_opening_id = p_file_opening_id;
        collection_id = p_collection_id;
        element_id_string = p_element_id;
        cm_increment_info_ptr = p_cm_increment_info_ptr;
        call CHECK_VERSION (cm_increment_info.version,
	  CM_INCREMENT_INFO_VERSION_1, "cm_increment_info");
        unspec (local_fm_increment_info) = ""b;
        local_fm_increment_info.version = FM_INCREMENT_INFO_VERSION_1;

        p_code = 0;
        code = 0;

        unspec (local_bci_header) = ""b;
        unspec (local_datum_slot) = ""b;

        if cm_increment_info.offset_in_bits < 0 then
	      call ERROR_SIGNAL (dm_error_$invalid_increment_offset);
        if cm_increment_info.number_of_words < 1 then
	      call ERROR_SIGNAL (dm_error_$invalid_increment_words);
        call cm_get_bci_header$slot (file_opening_id, addr (local_bci_header),
	  addr (local_datum_slot), element_id_string, code);
        if code ^= 0 then
	      call ERROR_SIGNAL (code);
        else
	      call CHECK_VERSION (local_bci_header.layout_type,
		BASIC_CI_LAYOUT_1, "basic_control_interval");
        if local_bci_header.collection_id ^= collection_id then
	      call ERROR_SIGNAL (dm_error_$ci_not_in_collection);

        if local_datum_slot.flags.is_continued = NOT_CONTINUED then
	      call SINGLE_DATUM (code);
        else
	      call MULTI_DATUM (code);
        call FINISH (code);

MAIN_RETURN:
        return;

%page;
/* *************************************************************************
   * CHECK_VERSION - standard structure version check routine.	     *
   ************************************************************************* */

CHECK_VERSION:
        proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name)
	  ;
        dcl     cv_p_received_version	char (*) aligned;
        dcl     cv_p_expected_version	char (*) aligned;
        dcl     cv_p_structure_name	char (*);

        if cv_p_received_version ^= cv_p_expected_version then
	      call ERROR_SIGNAL (error_table_$unimplemented_version,
		"^/Expected version ^a of the ^a structure.  Received version ^d instead.",
		cv_p_expected_version, cv_p_structure_name,
		cv_p_received_version);

        end CHECK_VERSION;
%page;
/* *************************************************************************
   * ERROR_SIGNAL - This routine calls sub_err_ instead of returning.      *
   ************************************************************************* */

ERROR_SIGNAL:
        proc () options (variable);
        dcl     es_arg_list_ptr	ptr;
        dcl     es_message		char (1024);
        dcl     es_message_length	fixed bin (21);
        dcl     es_based_error_code	fixed bin (35) based;

        call cu_$arg_list_ptr (es_arg_list_ptr);
        if es_arg_list_ptr -> arg_list.arg_count > 0 then
	      do;
	      if es_arg_list_ptr -> arg_list.arg_count > 1 then
		    call ioa_$general_rs (es_arg_list_ptr, 2, 3, es_message,
		        es_message_length, NO_PAD, NO_NL);
	      else
		    es_message_length = 0;
	      call sub_err_ (es_arg_list_ptr -> arg_list.arg_ptrs (1)
		-> es_based_error_code, myname, ACTION_CANT_RESTART, null,
		0, substr (es_message, 1, es_message_length));
	      end;
        else
	      call sub_err_ (dm_error_$programming_error, myname,
		ACTION_CANT_RESTART, null, 0,
		"The ERROR_SIGNAL routine was called without any arguments.")
		;
        end ERROR_SIGNAL;
%page;
/* *************************************************************************
   * FINISH - all exits pass through here.			     *
   ************************************************************************* */

FINISH:
        proc (f_p_code);
        dcl     f_p_code		fixed bin (35);

        p_code = f_p_code;
        end FINISH;
%page;
/* *************************************************************************
   * MULTI_DATUM - This procedure handler the case where an element is     *
   * spread across several datums.  This is not currently implemented.     *
   ************************************************************************* */

MULTI_DATUM:
        proc (md_code);
        dcl     md_code		fixed bin (35);

        md_code = 0;
        call ERROR_SIGNAL (dm_error_$unimplemented_entry,
	  "^/Multi-datum postincrement handlers have not been implemented.");
        end MULTI_DATUM;
%page;
/* *************************************************************************
   * SINGLE_DATUM - This procedure is called when the entire element is    *
   * contained is one datum.  Only one postcommit handler need be set up.  *
   ************************************************************************* */

SINGLE_DATUM:
        proc (sd_code);
        dcl     sd_code		fixed bin (35);
        dcl     sd_ci_num		fixed bin (27);

        sd_code = 0;
        if local_datum_slot.length_in_bits
	  < cm_increment_info.offset_in_bits
	  + cm_increment_info.number_of_words * BITS_PER_WORD then
	      call ERROR_SIGNAL (dm_error_$long_increment_length);

        sd_ci_num = element_id.control_interval_id;
        local_fm_increment_info.offset_in_bytes =
	  local_datum_slot.offset_in_bytes
	  + divide (cm_increment_info.offset_in_bits, BITS_PER_BYTE, 24, 0);
        local_fm_increment_info.increments_ptr =
	  addbitno (cm_increment_info.increments_ptr,
	  cm_increment_info.offset_in_bits);
        local_fm_increment_info.number_of_words =
	  cm_increment_info.number_of_words;
        local_fm_increment_info.element_id = element_id_string;

        call file_manager_$postcommit_increment (file_opening_id, sd_ci_num,
	  addr (local_fm_increment_info), sd_code);
        end SINGLE_DATUM;
%page;
%include arg_list;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_entry_dcls;
%page;
%include dm_cm_increment_info;
%page;
%include dm_element_id;
%page;
%include dm_fm_increment_info;
%page;
%include sub_err_flags;

        end cm_postcommit_increment;




		    cm_put.pl1                      04/04/85  1112.8r w 04/04/85  0912.5       84825



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION

        This module implements collection_manager_$put.

        This module is a transfer vector of sorts for routines which put
   an element.  Two things determine the proper routine to invoke: the Element
   Storage Method used by the collection and the entry through which this
   routine was invoked.  The ESM is determined by looking in the
   collection_header.  The $info and $buffered_info entries are passed the
   collection_header as part of the cm_info structure; The other entries get
   the collection_header by setting up a cm_info structure
   (cm_opening_info$get).  If entered through one of the buffered entries,
   this is a "buffered allocation".  Buffered puts are only supported for
   ordered ESM collections.
   
        If Ordered ESM is in force, p_element_id contains the control
   interval/slot number to put; if Basic ESM, p_element_id holds ci/slot
   of the "related" element (see the documentation for explanation of related
   element).  If BESM, a free slot is looked for; if OESM slots to the right
   of the specified slot are shifted over one.  An optimization exists which
   should be implemented in the next phase which will keep track of whether a
   free slot exists in a ci.


   ***** NOTE: The term "put" was previously referred to as "allocate" *****
   ***** "Put" means to allocate space for a new element, and put the  *****
   ***** value of the element in that space.                           *****
*/

/* HISTORY:
Written by Matthew C Pierret.
Modified:
03/23/82 by Matthew Pierret: Added "header" entry to allow collection manager
            routines to supply the collmgr_header.  This saves a get of that
            structure and assures that all modules are working on the same copy
            of the structure.
04/07/82 by Matthew Pierret: Added calculation of maxim space available.
                 Added following logic: If the requested control 
            interval is 0 but the requested collection is not the header
            collection (meaning that no particular control interval is
            requested) then check the last_used_ci for the collection. If
            non-zero, then set element_id.control_interval_id to be the
            last_used_ci. If zero, then allocate a new control interval and set
            element_id.control_interval_id to be the new control interval.
            This is done for Basic ESM only. It is an error for such a situation
            to occur using Ordered ESM
04/17/82 by Matthew Pierret: Removed call to cm_get_header_and_slot. This is
            now done at a later stage for each control interval attempted.
            This approach helps eliminate inconsistencies between the ci
            header this routine looks at and the one its subroutines look at.
06/08/82 by Matthew Pierret: Changed to use collection_header instead of
            collmgr_header.collection (). Also made calculation of maximum
            free space take datum header into account, returning only the
            largest element acceptable instead of the largest datum.
06/15/82 by Matthew Pierret: Changed to use bci_header, dm_cm_basic_ci.incl.
08/03/82 by Matthew Pierret: Changed to use last_control_interval in calling
            sequence to cm_allocate_basic_element.
09/07/82 by Matthew Pierret: Fixed p_code/code bug in call to cm_get_element.
11/09/82 by Matthew Pierret: Added opening info. Moved calculation of free
            space into lower routines.
01/07/83 by Matthew Pierret: Added $buffered and $buffered_info entries.
            Basic ESM still does not support buffered allocation.
01/07/83 by Matthew Pierret: Fixed bug which set bci_header_ptr to the addr of
            a local automatic_bci_header even if p_ci_buffer_ptr was supplied.
02/02/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2.
05/21/84 by Matthew Pierret: Renamed include file dm_cm_esm_info to dm_esm_info
10/03/84 by Matthew Pierret: Removed un-used constants. Added unspec builtin.
            Removed unnecessary calls-by-value to CHECK_VERSION.  Changed to
            use the standard sub_err_ action flags and to use the code
            dm_error_$unimplemented_esm instead of 0 in sub_err_ call
            reporting that the Basic ESM cannot use the buffered access method.
*/


/* format: style2,ind3 */

cm_put:
   proc (p_file_opening_id, p_collection_id, p_element_ptr, p_element_length, p_element_id, p_maximum_space_available,
        p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr;
      dcl	    p_ci_buffer_ptr	       ptr;
      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_element_length       fixed bin (35);
      dcl	    p_element_ptr	       ptr;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_maximum_space_available
			       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    1 automatic_bci_header aligned like bci_header;
      dcl	    element_length_in_bits fixed bin (35);
      dcl	    is_buffered	       bit (1) aligned init ("0"b);

/* Based */
/* Builtin */

      dcl	    (addr, null, unspec)   builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("cm_put") char (32) varying int static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$unimplemented_esm
			       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);


/* END OF DECLARATIONS */

      unspec (automatic_bci_header) = "0"b;
      bci_header_ptr = addr (automatic_bci_header);

      goto NO_INFO_JOIN;

buffered:
   entry (p_ci_buffer_ptr, p_file_opening_id, p_collection_id, p_element_ptr, p_element_length, p_element_id,
        p_maximum_space_available, p_code);

      is_buffered = "1"b;
      bci_header_ptr = p_ci_buffer_ptr;

NO_INFO_JOIN:
      call cm_opening_info$get (p_file_opening_id, p_collection_id, cm_info_ptr, p_code);
      if p_code ^= 0
      then return;

      goto JOIN;


info:
   entry (p_cm_info_ptr, p_element_ptr, p_element_length, p_element_id, p_maximum_space_available, p_code);

      cm_info_ptr = p_cm_info_ptr;
      unspec (automatic_bci_header) = "0"b;
      bci_header_ptr = addr (automatic_bci_header);

      goto JOIN;

/********************* Not yet used. ********************

buffered_info:
   entry (p_cm_info_ptr, p_ci_buffer_ptr, p_element_ptr, p_element_length, p_element_id, p_maximum_space_available,
      p_code);

      is_buffered = "1"b;
      cm_info_ptr = p_cm_info_ptr;
      bci_header_ptr = p_ci_buffer_ptr;

      goto JOIN;

************************************************************ */
%page;

JOIN:
      call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);

      collection_header_ptr = cm_info.header_ptr;

      call CHECK_VERSION ("collection_header", collection_header.version, COLLECTION_HEADER_VERSION_2);

      p_code = 0;
      p_maximum_space_available = -1;

      element_id_string = p_element_id;

      if collection_header.flags.fixed_size_elements
      then element_length_in_bits = collection_header.maximum_element_size;
      else element_length_in_bits = p_element_length;

      if collection_header.element_storage_method = ORDERED_ELEMENT_STORAGE_METHOD
      then if is_buffered
	 then call cm_put_ordered_element$buffered (cm_info_ptr, bci_header_ptr, element_length_in_bits, p_element_ptr,
		 element_id_string, p_maximum_space_available, p_code);
	 else call cm_put_ordered_element (cm_info_ptr, bci_header_ptr, element_length_in_bits, p_element_ptr,
		 element_id_string, p_maximum_space_available, p_code);

      else if is_buffered
      then call sub_err_ (dm_error_$unimplemented_esm, myname, ACTION_CANT_RESTART, null, 0,
	      "Buffered element allocation is not supported for collections using the^/Basic element storage method.");
      else call cm_put_basic_element (cm_info_ptr, bci_header_ptr, element_length_in_bits, p_element_ptr,
	      element_id_string, p_maximum_space_available, p_code);


      if p_code = 0
      then p_element_id = element_id_string;


      return;					/* Effective end of cm_put */

%page;
CHECK_VERSION:
   proc (p_structure_name, p_given_version, p_correct_version);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;

      if p_given_version ^= p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", p_correct_version, p_structure_name,
	      p_given_version);

      return;

   end CHECK_VERSION;
%page;
%include dm_cm_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_collection_header;
%page;
%include dm_esm_info;
%page;
%include dm_element_id;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_put;




		    cm_put_basic_element.pl1        04/04/85  1112.8r w 04/04/85  0912.8      118053



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

        This module allocates space for an element according to the rules
   of the Basic Element Storage Method, then puts the element at the allocated
   spot.

        This parameters of this module are:

   p_cm_info_ptr - which points to the opening info for the collection and
                   is set be the caller, cm_put;
   p_basic_control_interval_ptr - which points to a copy of the header of
                   control interval into which the element will be put,
                   if possible, or to an empty buffer the size of bci_header.
                   On output, points to a copy of the header of the control
                   interval in which the element was successfully put;
   p_element_length - the length of the element in bits;
   p_element_ptr - points to the element to be put;
   p_element_id - on input, the p_element_id->element_id.control_interval_id
                   is the first control interval to be tried in attempting
                   to put the element; on output is the element_id of the
                   newly-put element;
   p_maximum_space_available - on output, is the amount of free space
                   available in the control interval in which the element
                   was put, after the element was put;
   p_code - is a status code.
                   
   Currently this module does not support Threaded BESM.
*/

/* HISTORY:
Written by Matthew C Pierret.
Modified:
04/09/82 by Lindsey Spratt: Changed to use the dm_element_id include file.
	  Now uses the "local" element_id_string/element_id consistently.
04/13/82 by Matthew Pierret: Fixed to set p_element_id before returning.
04/14/82 by Matthew Pierret: Changed to attempt to allocate element in the
            last used control interval of the collection if not enough room
            in the given control interval, and to assume the last used control
            interval if a control interval id of 0 is requested, i.e.
            element_id.control_interval_id is 0.
                 Also changed declaration of control_interval_id from aligned
            to unaligned, so that calls to cm$allocate_control_interval would
            be made by reference.
                 Also changed to use cm_get_datum_slots instead of the now
            obsolete cm_get_slot_table;
                 Changed to reset bci_header.free_slot_is_present,
            necessitating searching for a free slot even after the first has
            been found.
                 Removed use of automatic control_interval_id variable, using
            element_id.control_interval_id directly instead.
04/15/82 by Matthew Pierret: Fixed bug which "forgot" to set collmgr_header_ptr
            and initialize p_code to 0.
04/16/82 by Matthew Pierret: Added following logic: If a new control interval
            must be allocated, call cm_allocate_element$header recursively, so
            all of the necessary checks are made. This was the source of a bug
            which allocated a new control interval but did not get a new 
            basic_control_interval header (bci_header).
04/17/82 by Matthew Pierret: Converted the code which deals with actually
            allocating an element into a separate module called
            cm_allocate_basic_in_ci. Retained only code which is used in
            deciding what control interval to attempt to allocate an element in.
05/19/82 by Matthew Pierret: Changed use of collmgr_header.collection() to
            collection_header, and removed collmgr_header_ptr from calling
            sequence of cm_allocate_basic_in_ci.
08/03/82 by Matthew Pierret: Changed calling sequence to take last_control_interval.
            Removed version check of collection_header since it is never
            actually used in this module.
11/03/82 by Matthew Pierret: Multi-datum support. Opening info. Max space
            available.
02/02/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2.
            Added version check for bci_header. Fixed bug in compaction.
            This bug occurred when the start_of_used_space was adjacent to the
            last slot. bci_header.number_of_datums was being incremented
            before the call to cm_compact, causing the leftmost datum to be
            overwritten by the new last slot. cm_determine_free_space expects
            bci_header.number_of_datums to be incremented, so it is incremented
            before calling cm_determine_free_space and decremented before
            calling cm_compact. cm_find_free_slot was changed to not update
            bci_header.number_of_datums, instead returning the new argument
            number_of_slots_after_allocation.
08/04/83 by Matthew Pierret: Changed to use a new cm_determine_free_space
            entry, $does_new_datum_fit.  This entry returns flags indicating
            whether the datum will fit in the ci and the pool.  It also 
            takes into consideration the fact that the datum is new and may
            need a new datum slot.  Previously, cm_allocate_basic_element
            had to juggle bci_header.number_of_datums around to get correct
            results. Now, that field value is set only once near the end of 
            this module.
            Changed cm_find_free_slot to return a flag indicating the value
            bci_header.free_slot_is_present after allocation.
01/04/85 by Matthew Pierret: In response to audit failure: moved position of
            format and main procedure statements to standard location; fixed
            DESCRIPTION to refer to cm_put instead of cm_allocate_element;
            moved declaration of error_table_$unimplemented_version to main 
            procedure; declared all builtins; fixed unnecessary calls-by-value
            of CHECK_VERSION; removed the extra "the" in a sub_err_ call;
            renamed module to cm_put_basic_element from 
            cm_allocate_basic_element in accordance with the new
            collection_manager_ entries naming scheme.
            Also changed to follow completely the ERROR_RETURN and 
            subroutine variable prefixing mechanisms.
*/

/* format: style2,ind3,ll79,^indnoniterdo,^indprocbody */

cm_put_basic_element:
   proc (p_cm_info_ptr, p_basic_control_interval_header_ptr, p_element_length,
        p_element_ptr, p_element_id, p_maximum_space_available, p_code);


/* START OF DECLARATIONS */
/* Parameter */

   dcl	 p_cm_info_ptr	    ptr parameter;
   dcl	 p_basic_control_interval_header_ptr
			    ptr parameter;
   dcl	 p_element_length	    fixed bin (35) parameter;
   dcl	 p_element_ptr	    ptr parameter;
   dcl	 p_element_id	    bit (36) aligned parameter;
   dcl	 p_maximum_space_available
			    fixed bin (35) parameter;
   dcl	 p_code		    fixed bin (35) parameter;

/* Automatic */

   dcl	 1 my_datum_slot	    aligned like datum_slot;
   dcl	 code		    fixed bin (35);
   dcl	 continuation	    bit (36) aligned init ("0"b);
   dcl	 control_interval_id    fixed bin (24) uns init (0);
   dcl	 (element_length_in_bits, element_length_in_bytes, total_free_bytes)
			    fixed bin (35) init (0);
   dcl	 (number_of_slots_before_allocation,
	 number_of_slots_after_allocation, slot_index_to_use)
			    fixed bin (17) init (0);
   dcl	 (is_continued, fits_in_ci, fits_in_pool,
	 has_free_slot_after_allocation)
			    bit (1) aligned init ("0"b);

/* Based */
/* Builtin */

   dcl	 (ceil, divide, addr, null, unspec)
			    builtin;

/* Controlled */
/* Constant */

   dcl	 myname		    init ("cm_put_basic_element")
			    char (32) varying int static
			    options (constant);
   dcl	 BITS_PER_BYTE	    init (9) fixed bin internal static
			    options (constant);
   dcl	 IS_NOT_A_CONTINUATION  init ("0"b) bit (1) aligned internal
			    static options (constant);

/* Entry */

   dcl	 sub_err_		    entry options (variable);

/* External */

   dcl	 dm_error_$programming_error
			    ext fixed bin (35);
   dcl	 error_table_$unimplemented_version
			    ext fixed bin (35);

/* END OF DECLARATIONS */

   p_code, code = 0;

   cm_info_ptr = p_cm_info_ptr;
   call CHECK_VERSION (cm_info.version, CM_INFO_VERSION_2, "cm_info");
   bci_header_ptr = p_basic_control_interval_header_ptr;
   datum_slot_ptr = addr (my_datum_slot);
   element_id_string = p_element_id;
   element_length_in_bits = p_element_length;

/**** Allocate the tail of the element if it is larger than a single datum. */

   if element_length_in_bits
        > MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS - BITS_PER_BYTE
   then
      do;
      call cm_put_overlength_tail (cm_info_ptr, p_element_ptr,
	 element_length_in_bits, continuation, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      is_continued = "1"b;
   end;

   element_length_in_bytes =
        ceil (divide (element_length_in_bits, BITS_PER_BYTE, 35, 18));

/**** Find a control interval in which to allocate the datum/element. */

   call cm_find_ci_to_alloc_datum (cm_info_ptr, element_length_in_bytes,
        (element_id.control_interval_id), is_continued, "0"b, bci_header_ptr,
        control_interval_id, code);
   if code ^= 0
   then call ERROR_RETURN (code);
   else call CHECK_BCI_VERSION (bci_header.layout_type);

/**** Find a slot in the slot table available for use. */

   call cm_find_free_slot (cm_info.file_oid, control_interval_id,
        bci_header_ptr, slot_index_to_use, number_of_slots_after_allocation,
        has_free_slot_after_allocation, code);
   if code ^= 0
   then call ERROR_RETURN (code);

   element_id.control_interval_id = control_interval_id;
   element_id.index = slot_index_to_use;

/**** Verify that the datum actually fits. */

   call cm_determine_free_space$does_new_datum_fit (bci_header_ptr,
        element_length_in_bytes, (slot_index_to_use), is_continued,
        IS_NOT_A_CONTINUATION, fits_in_ci, fits_in_pool, total_free_bytes);

   if ^fits_in_ci
   then call sub_err_ (dm_error_$programming_error, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Control interval ^d was selected in which to allocate a datum, but^/^10xthere is not enough free space in which to fit the datum.^/^10xThe datum is ^d bytes long;there are ^d free."
	   , control_interval_id, element_length_in_bytes, total_free_bytes);

   unspec (datum_slot) = ""b;
   datum_slot.flags.is_continued = is_continued;

   if fits_in_pool
   then bci_header.number_of_datums = number_of_slots_after_allocation;
   else
      do;
      call cm_compact (cm_info.file_oid, number_of_slots_after_allocation,
	 element_id_string, bci_header_ptr, code);	/* cm_compact updates bci_header.number_of_datums */
      if code ^= 0
      then call ERROR_RETURN (code);
   end;

   bci_header.flags.free_slot_is_present = has_free_slot_after_allocation;

/**** Put the datum in the free pool. */

   if is_continued
   then call cm_put_datum_in_pool$continued (cm_info.file_oid,
	   element_id_string, p_element_ptr, element_length_in_bits,
	   datum_slot_ptr, bci_header_ptr, p_element_length, continuation,
	   code);
   else call cm_put_datum_in_pool (cm_info.file_oid, element_id_string,
	   p_element_ptr, element_length_in_bits, datum_slot_ptr,
	   bci_header_ptr, code);
   if code ^= 0
   then call ERROR_RETURN (code);


   p_element_id = element_id_string;

   call FINISH ();
MAIN_RETURN:
   return;
%page;
CHECK_VERSION:
   proc (cv_p_given_version, cv_p_correct_version, cv_p_structure_name);

   dcl	 cv_p_structure_name    char (*);
   dcl	 cv_p_given_version	    char (8) aligned;
   dcl	 cv_p_correct_version   char (8) aligned;

   if cv_p_given_version ^= cv_p_correct_version
   then call sub_err_ (error_table_$unimplemented_version, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected version ""^8a"" of ^a structure; received ""^8a"".",
	   cv_p_correct_version, cv_p_structure_name, cv_p_given_version);
   else return;

   end CHECK_VERSION;

CHECK_BCI_VERSION:
   proc (cbv_p_given_version);
   dcl	 cbv_p_given_version    char (4) aligned;

   if cbv_p_given_version ^= BASIC_CI_LAYOUT_1
   then call sub_err_ (error_table_$unimplemented_version, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected version ""^4a"" of bci_header structure; received ""^4a""."
	   , BASIC_CI_LAYOUT_1, cbv_p_given_version);
   else return;

   end CHECK_BCI_VERSION;
%page;
ERROR_RETURN:
   proc (er_p_code);

   dcl	 er_p_code	    fixed bin (35);

   p_code = er_p_code;
   call FINISH ();
   goto MAIN_RETURN;

   end ERROR_RETURN;

FINISH:
   proc ();

   if p_code = 0
   then p_maximum_space_available = total_free_bytes * BITS_PER_BYTE;

   end FINISH;
%page;
%include dm_element_id;
%page;
%include dm_cm_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_datum_constants;
%page;
%include sub_err_flags;
%page;
%include dm_cm_entry_dcls;

   end cm_put_basic_element;




		    cm_put_cn_datum.pl1             04/04/85  1112.8r w 04/04/85  0912.8       63990



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

/* format: style2,ind3 */

cm_put_cn_datum:
   proc (p_cm_info_ptr, p_datum_contents_ptr, p_datum_contents_length, p_continuation, p_datum_id, p_code);

/* DESCRIPTION:

         This  routine  allocates  a  single  datum.    The  datum  must be a
     continuation or continued-continuation datum of an element.  The  routine
     first  finds  a  control  interval that has enough free space to hold the
     datum, allocating a new control interval if necessary.  Then a free  slot
     is found and the datum is place in the free pool.

     p_datum_id is the control interval id / slot index found for the datum.
     p_continuation is "0"b if searching for a continuation_datum; the value
     of this datum's continuation if searching for a continued continuation
     datum
*/

/* HISTORY:

Written by Matthew Pierret, 11/02/82.
Modified:
12/01/82 by Lindsey Spratt:  Added setting of the is_continuation and
	  is_continued flags. 
02/02/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2. Fixed bug in
            deciding when to set bci_header.number_of_datums.
08/04/83 by Matthew Pierret: Changed to use cm_determine_free_space
            $does_new_datum_fit.  This entry understands that the space needed
            is for a new datum, and takes into consideration the need for a 
            new datum slot. Because of this, this routine does not have to set
            bci_header.number_of_datums to what it will be after the allocation
            to get the correct results before calling cm_dfs$dndf.
            Changed cm_find_free_slot to return a flag indicating the value
            bci_header.free_slot_is_present after allocation.

11/01/84 by Lindsey L. Spratt:  Changed the main procedure name, and myname,
            to agree with the segment name (cm_put_cn_datum).  The old
            procedure name was cm_allocate_cn_datum.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr parameter;
      dcl	    p_datum_contents_ptr   ptr parameter;
      dcl	    p_datum_contents_length
			       fixed bin (35) parameter;
      dcl	    p_continuation	       bit (36) aligned parameter;
      dcl	    p_datum_id	       bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/*  Automatic */

      dcl	    1 automatic_bci_header aligned like bci_header;
      dcl	    1 automatic_datum_slot aligned like datum_slot;
      dcl	    (fits_in_ci, fits_in_pool, has_free_slot_after_allocation)
			       bit (1) aligned init ("0"b);
      dcl	    control_interval_id    fixed bin (24) unsigned init (0);
      dcl	    (datum_contents_length_in_bytes, total_free_bytes)
			       fixed bin (35) init (0);
      dcl	    (number_of_slots_after_allocation, slot_idx)
			       fixed bin (17) init (0);

/* Based */

      dcl	    datum_id_string	       bit (36) aligned based (datum_id_ptr);

/* Builtin */

      dcl	    (addr, ceil, divide, null, unspec)
			       builtin;

/* Constant */

      dcl	    myname	       init ("cm_put_cn_datum") char (32) varying internal static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin internal static options (constant);
      dcl	    IS_A_CONTINUATION      init ("1"b) bit (1) aligned internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code = 0;
      cm_info_ptr = p_cm_info_ptr;
      call CHECK_VERSION ((cm_info.version), (CM_INFO_VERSION_2), "cm_info");

      datum_id_ptr = addr (p_datum_id);

      datum_contents_length_in_bytes = ceil (divide (p_datum_contents_length, BITS_PER_BYTE, 35, 18));

      unspec (automatic_bci_header) = "0"b;
      unspec (automatic_datum_slot) = "0"b;

      bci_header_ptr = addr (automatic_bci_header);
      datum_slot_ptr = addr (automatic_datum_slot);

      call cm_find_ci_to_alloc_datum (cm_info_ptr, datum_contents_length_in_bytes, 0, (p_continuation ^= "0"b), "1"b,
	 bci_header_ptr, control_interval_id, p_code);
      if p_code ^= 0
      then return;

      call cm_find_free_slot (cm_info.file_oid, control_interval_id, bci_header_ptr, slot_idx,
	 number_of_slots_after_allocation, has_free_slot_after_allocation, p_code);
      if p_code ^= 0
      then return;

      datum_id.control_interval_id = control_interval_id;
      datum_id.index = slot_idx;

      call cm_determine_free_space$does_new_datum_fit (bci_header_ptr, datum_contents_length_in_bytes, (slot_idx),
	 (p_continuation ^= "0"b), IS_A_CONTINUATION, fits_in_ci, fits_in_pool, total_free_bytes);

      if ^fits_in_ci
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Control interval ^d was selected in which to allocate a datum, but the^/^10xthere is not enough free space in which to fit the datum.^/^10xThe datum is ^d bytes long;there are ^d free."
	      , control_interval_id, datum_contents_length_in_bytes, total_free_bytes);


      if fits_in_pool
      then bci_header.number_of_datums = number_of_slots_after_allocation;
      else
         do;
	  call cm_compact (cm_info.file_oid, number_of_slots_after_allocation, datum_id_string, bci_header_ptr, p_code);
	  if p_code ^= 0
	  then return;

         end;

      bci_header.flags.free_slot_is_present = has_free_slot_after_allocation;
      datum_slot.flags.is_continuation = "1"b;

      if p_continuation = "0"b
      then call cm_put_datum_in_pool (cm_info.file_oid, datum_id_string, p_datum_contents_ptr, p_datum_contents_length,
	      datum_slot_ptr, bci_header_ptr, p_code);

      else
         do;
	  datum_slot.flags.is_continued = "1"b;
	  call cm_put_datum_in_pool$continued (cm_info.file_oid, datum_id_string, p_datum_contents_ptr,
	       p_datum_contents_length, datum_slot_ptr, bci_header_ptr, -1, p_continuation, p_code);
         end;

      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (8);
      dcl	    p_expected_version     char (8);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
%include dm_cm_info;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;
   end cm_put_cn_datum;




		    cm_put_datum_in_place.pl1       01/04/85  0947.4re  01/03/85  1149.0      106281



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

          This routine places a datum in the place indicated by the supplied 
     datum slot (p_datum_slot_ptr).  It assumes that the caller has already
     determined that the datum will fit there. Four entries work as follows:
     
     $cm_put_datum_in_place - 
       (1) Update datum_slot.length_in_bits, bci_header.scattered_free_space.
       (2) Invoke file_manager_ to put:
           (a) the datum contents at the offset in datum_slot.offset_in_bytes;
           (b) the datum slot at the location indicated by p_element_id;
           (c) the bci_header at the base of the addressable control interval
     This entry assumes that p_datum_slot_ptr -> datum_slot.flags and 
     .offset_in_bytes are set correctly.
     
     $continued - 
       (1) Update datum_slot.(length_in_bits length_in_bits),
           bci_header.scattered_free_space.
       (2) Setup a local datum header using p_element_length_in_bits and
           p_continuation.
       (3) Invoke file_manager_ to put:
           (a) the datum header at the offset in datum_slot.offset_in_bytes;
           (b) the datum contents at the offset in datum_slot.offset_in_bytes
               + the length of the datum header;
           (c) the datum slot at the location indicated by p_element_id;
           (d) the bci_header at the base of the addressable control interval
     This entry assumes that p_datum_slot_ptr -> datum_slot.is_continuation &
     .offset_in_bytes are set correctly.

     $buffered - same as $cm_put_datum_in_place except:
       (2) Directly copies datum contents only.
       This entry also assumes that p_datum_slot_ptr points directly into the 
       control interval buffer.

     $buffered_continued - same as $continued except:
       (3) Directly copies (a) and (b) only.
       This entry also assumes that p_datum_slot_ptr points directly
       into the control interval buffer.
*/

/* HISTORY:
Written by Matthew Pierret.
Modified:
04/13/82 by Matthew Pierret: Fixed bug. Uninitialized element_ptr was being 
            used instead of p_element_ptr.
05/10/82 by Lindsey Spratt:  Fixed scattered_free_space calculation to account
	  for the datum header length. Extended the division of the
	  element_length_in_bits to use (35,18) as the precision and scale
	  instead of (17,2).  This is because the element_length_in_bytes
	  was coming up 1 too small when the element length wasn't an
	  integral number of bytes.
06/15/82 by Matthew Pierret: Changed to use bci_header, dm_cm_basic_ci.incl.pl1,
            ignore non-addressable portion of CI, change calling sequence of 
            cm_add_ci_part.
08/04/82 by Matthew Pierret: Removed calls to cm_add_ci_part, making that code
            in-line.
10/20/82 by Matthew Pierret:  Converted to use file_manager_.  Changed to
            handle zero-length datum contents.
11/09/82 by Matthew Pierret:  Added "continued" entry for storing continued
            datums (Cd and CdCn).
01/04/83 by Matthew Pierret: Added $buffered and $buffered_continued to do
            puts into a supplied ci buffer.
01/14/83 by Lindsey Spratt:  Fixed to set bci_header_ptr = p_bci_header_ptr
	  for main entry.
01/21/83 by Matthew Pierret: Changed based_ci_string character overlay to be based_ci, a bit (9)
            array.  This was to remove the "addr(substr())" construct, which
            is not guaranteed to be correct in all cases.
10/03/84 by Matthew Pierret: Removed un-used dm_cm_entry_dcls.incl.pl1,
            substr and ceil.  Changed bit-to-byte calculation to
            divide (bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0) from
            ceil (divide (bits, BITS_PER_BYTE, 35, 18)).  The former is more
            efficient.  Changed to declare correct calling sequence of
            file_manager_$put.
12/03/84 by Matthew Pierret:  Added the local cd_datum_header and
            cdcn_datum_header, which were removed from dm_cm_datum.incl.pl1.
*/

/* format: style2,ind3 */

cm_put_datum_in_place:
   proc (p_file_opening_id, p_element_id, p_datum_contents_ptr, p_datum_contents_length_in_bits, p_datum_slot_ptr,
        p_bci_header_ptr, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_datum_contents_ptr   ptr;
      dcl	    p_datum_contents_length_in_bits
			       fixed bin (35);
      dcl	    p_datum_slot_ptr       ptr;
      dcl	    p_bci_header_ptr       ptr;
      dcl	    p_ci_buffer_ptr	       ptr;
      dcl	    p_element_length_in_bits
			       fixed bin (35);
      dcl	    p_continuation	       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    automatic_ci_parts_buffer
			       (18) fixed bin (71);	/* Max of 3 parts */
      dcl	    is_buffered	       bit (1) aligned init ("0"b);
      dcl	    replace_bci_header     bit (1) aligned init ("0"b);
      dcl	    based_byte_string_length
			       fixed bin (35) init (0);
      dcl	    datum_contents_length_in_bytes
			       fixed bin (17);
      dcl	    datum_header_length_in_bytes
			       fixed bin (35) init (0);
      dcl	    old_datum_length_in_bytes
			       fixed bin (17);
      dcl	    ci_datum_contents_ptr  ptr init (null);
      dcl	    ci_datum_header_ptr    ptr init (null);
      dcl	    datum_header_ptr       ptr init (null);

      dcl	    1 cd_datum_header      aligned like continued_datum.header;
      dcl	    1 cdcn_datum_header    aligned like continued_continuation_datum.header;

/* Based */

      dcl	    1 based_ci	       aligned based (bci_header_ptr),
	      2 byte	       (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES) bit (9) unaligned;
      dcl	    based_byte_string      char (based_byte_string_length) based;

/* Builtin */

      dcl	    (addr, divide, null, size, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    BITS_PER_BYTE	       fixed bin init (9) int static options (constant);
      dcl	    BYTES_PER_WORD	       fixed bin init (4) int static options (constant);

/* Entry */

      dcl	    file_manager_$put      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));

/* External */
/* END OF DECLARATIONS */

      bci_header_ptr = p_bci_header_ptr;
      datum_slot_ptr = p_datum_slot_ptr;

      goto JOIN;

buffered:
   entry (p_ci_buffer_ptr, p_datum_contents_ptr, p_datum_contents_length_in_bits, p_datum_slot_ptr, p_code);

      bci_header_ptr = p_ci_buffer_ptr;
      datum_slot_ptr = p_datum_slot_ptr;
      is_buffered = "1"b;

      goto JOIN;

continued:
   entry (p_file_opening_id, p_element_id, p_datum_contents_ptr, p_datum_contents_length_in_bits, p_datum_slot_ptr,
        p_bci_header_ptr, p_element_length_in_bits, p_continuation, p_code);

      bci_header_ptr = p_bci_header_ptr;

      goto CD_JOIN;

buffered_continued:
   entry (p_ci_buffer_ptr, p_datum_contents_ptr, p_datum_contents_length_in_bits, p_datum_slot_ptr,
        p_element_length_in_bits, p_continuation, p_code);

      bci_header_ptr = p_ci_buffer_ptr;
      is_buffered = "1"b;

CD_JOIN:
      datum_slot_ptr = p_datum_slot_ptr;

      datum_slot.flags.is_continued = "1"b;

      if p_element_length_in_bits < 0
      then
         do;
	  datum_slot.flags.is_continuation = "1"b;
	  datum_header_length_in_bytes = CDCN_DATUM_HEADER_LENGTH_IN_BYTES;

	  unspec (cdcn_datum_header.continuation) = p_continuation;
	  datum_header_ptr = addr (cdcn_datum_header);
         end;
      else
         do;
	  datum_slot.flags.is_continuation = "0"b;
	  datum_header_length_in_bytes = CD_DATUM_HEADER_LENGTH_IN_BYTES;

	  cd_datum_header.full_length = p_element_length_in_bits;
	  unspec (cd_datum_header.continuation) = p_continuation;

	  datum_header_ptr = addr (cd_datum_header);
         end;

      goto JOIN;
%page;
JOIN:
      p_code = 0;

      datum_contents_length_in_bits = p_datum_contents_length_in_bits;
      datum_contents_length_in_bytes = divide (datum_contents_length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);
      old_datum_length_in_bytes = divide (datum_slot.length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);

      if old_datum_length_in_bytes > datum_contents_length_in_bytes + datum_header_length_in_bytes
      then
         do;
	  bci_header.scattered_free_space =
	       bci_header.scattered_free_space + old_datum_length_in_bytes - datum_contents_length_in_bytes
	       - datum_header_length_in_bytes;

	  replace_bci_header = "1"b;
         end;

      datum_slot.length_in_bits = datum_contents_length_in_bits + datum_header_length_in_bytes * BITS_PER_BYTE;

      if is_buffered
      then
         do;
	  if datum_contents_length_in_bytes > 0
	  then
	     do;
	        based_byte_string_length = datum_contents_length_in_bytes;
	        ci_datum_contents_ptr =
		   addr (based_ci.byte (datum_slot.offset_in_bytes + datum_header_length_in_bytes + 1));
	        ci_datum_contents_ptr -> based_byte_string = p_datum_contents_ptr -> based_byte_string;
	     end;

	  if datum_header_length_in_bytes > 0
	  then
	     do;
	        based_byte_string_length = datum_header_length_in_bytes;
	        ci_datum_header_ptr = addr (based_ci.byte (datum_slot.offset_in_bytes + 1));
	        ci_datum_header_ptr -> based_byte_string = datum_header_ptr -> based_byte_string;
	     end;
         end;
      else
         do;
	  element_id_string = p_element_id;

	  automatic_ci_parts_buffer = 0;
	  ci_parts_ptr = addr (automatic_ci_parts_buffer);
	  ci_parts.number_of_parts = 0;

	  if datum_contents_length_in_bytes > 0
	  then
	     do;
	        ci_parts.number_of_parts = ci_parts.number_of_parts + 1;

	        ci_parts.part (ci_parts.number_of_parts).offset_in_bytes =
		   datum_slot.offset_in_bytes + datum_header_length_in_bytes;
	        ci_parts.part (ci_parts.number_of_parts).length_in_bytes = datum_contents_length_in_bytes;
	        ci_parts.part (ci_parts.number_of_parts).local_ptr = p_datum_contents_ptr;

	     end;

	  if datum_slot.is_continued
	  then
	     do;
	        ci_parts.number_of_parts = ci_parts.number_of_parts + 1;

	        ci_parts.part (ci_parts.number_of_parts).offset_in_bytes = datum_slot.offset_in_bytes;
	        ci_parts.part (ci_parts.number_of_parts).length_in_bytes = datum_header_length_in_bytes;
	        ci_parts.part (ci_parts.number_of_parts).local_ptr = datum_header_ptr;

	     end;

	  ci_parts.number_of_parts = ci_parts.number_of_parts + 1;

	  ci_parts.part (ci_parts.number_of_parts).offset_in_bytes =
	       BYTES_PER_WORD * ((element_id.index - 1) + size (bci_header));
	  ci_parts.part (ci_parts.number_of_parts).length_in_bytes = BYTES_PER_WORD;
	  ci_parts.part (ci_parts.number_of_parts).local_ptr = datum_slot_ptr;

	  if replace_bci_header
	  then
	     do;
	        ci_parts.number_of_parts = ci_parts.number_of_parts + 1;

	        ci_parts.part (ci_parts.number_of_parts).offset_in_bytes = 0;
	        ci_parts.part (ci_parts.number_of_parts).length_in_bytes = size (bci_header) * BYTES_PER_WORD;
	        ci_parts.part (ci_parts.number_of_parts).local_ptr = bci_header_ptr;


	     end;


	  call file_manager_$put (p_file_opening_id, (element_id.control_interval_id), ci_parts_ptr, p_code);

         end;

      return;

%page;
%include dm_cm_basic_ci;
%page;
%include dm_ci_parts;
%page;
%include dm_ci_lengths;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_cm_datum;
%page;
%include dm_element_id;

   end cm_put_datum_in_place;




		    cm_put_datum_in_pool.pl1        01/04/85  0947.4re  01/03/85  1149.0      124875



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

        This routine puts a datum in the free pool of a control interval.
   It assumes that the caller has already determined that the datum will fit
   in the free pool.  This will put the datum in the file copy of the
   specified control interval (p_element_id.control_interval_id) or on a
   buffered copy of the control interval, depending on whether the entry into
   this routine was from a non-buffered or buffered entry point.
   
        The areas of a control interval that this routine may modify are
   highlighted with *'s, as follows:
   
    ---------------------------------------------------------------
    |        || | | | | | | ||                   ||                |
    | Header || | | Slots | ||     Free pool     ||   Used space   |
    |        || | | | | | | ||   (Un-used space) ||                |
    ----------------------------------------------------------------
     ********      *                     (**)*****(****)
       (1)        (2)                     (4)  (3)  
   
   (1) The start_of_used_space component of bci_header is modified to the 
   location of the start of the new datum. The caller may also have modified
   other components of bci_header and is relying on this routine to actually
   put the modified bci_header back into the file copy of the control interval.
   
   (2) The datum_slot for the datum to put has its length_in_bits component
   and perhaps the is_continuation flag set by this routine.  The 
   offset_in_bytes and is_continued flag are set by the caller.  The 
   length_in_bits is p_datum_contents_length_in_bits plus the length of the
   datum header, if there is one.
   
   (3) This is the actual contents of the datum.  This may actually spill over
   into the used space portion of the control interval if this call is made to
   replace a datum which happened to start at the start of the used space.
   This routine, however, does not make that determination, trusting the caller
   to have correctly calculated the proper offset for the datum.
   
   (4) This is the header of the datum, and is only put if called through the
   $continued or $buffered_continued entry points.  It is a continued_datum
   header if p_element_length_in_bits is non-negative. p_element_length_in_bits
   and p_continuation are used to fill in the continued_datum.header
   (cd_datum_header) structure.  If negative, this indicates the datum
   requires a continued_continuation_datum header (cdcn_datum_header), which 
   only uses p_continuation.
   
        If the datum is to be put into a buffered copy of the control interval
   (i.e., routine was entered through $buffered or $buffered_continued),
   p_ci_buffer_ptr points to the control interval buffer, and, because of
   the construction of the control interval, to bci_header.  p_datum_slot_ptr
   is assumed to point at the datum slot in the control interval buffer.
   Any modifications to bci_header and datum_slot, then, are made directly
   to the control interval buffer.
   
        If the datum is to be put into the file copy of the control interval
   (i.e., routine was entered through $cm_put_datum_in_pool or $continued)
   p_bci_header_ptr and p_datum_slot_ptr are assumed to point to copies of
   the bci_header and datum_slot in the caller's local storage.  Modifications
   made to these structures, and to datum header structures, do not change the
   file copy of the control interval.  The modified structures must be put back
   into the file copy via a call to file_manager_$put.
   
*/

/* HISTORY:
Written by Matthew Pierret.
Modified:
04/13/82 by Matthew Pierret: Fixed bug. Uninitialized element_ptr was being used 
            instead of p_element_ptr.
06/15/82 by Matthew Pierret: Changed to use bci_header, dm_cm_basic_ci.incl.pl1,
            ignore non-addressable portion of CI, new calling sequence of 
            cm_add_ci_part.
08/04/82 by Matthew Pierret: Removed calls to cm_add_ci_part, making that code
            in-line.
10/20/82 by Matthew Pierret:  Converted to use file_manager_. Changed
            from element_(ptr length_in_bytes length_in_bits) to
            datum_contents_=.
01/04/83 by Matthew Pierret: Added $buffered and $buffered_continued to do
            puts into a supplied ci buffer.
01/21/83 by Matthew Pierret: Removed an invalid use of p_bci_header_ptr when
            entered through $buffered or $buffered_continued. These entries
            do not take that parameter.
            Changed based_ci_string character overlay to be based_ci, a bit (9)
            array.  This was to remove the "addr(substr())" construct, which
            is not guaranteed to be correct in all cases.
10/03/84 by Matthew Pierret:  Removed dm_cm_entry_dcls.incl.pl1, ceil and
            null.  Changed calculation of bits to bytes from
            bytes = ceil (divide (bits, BITS_PER_BYTES, 35, 18)) to
            bytes = divide (bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0),
            the latter being more efficient.  Added size, unspec and 
            DESCRIPTION section.  Also changed buffer upon which ci_parts
            is based from automatic__parts_buffer to my_ci_parts, which is
            a structure "like"-ed to ci_parts.
10/05/84 by Matthew Pierret:  Changed to increment the scattered_free_space
            if the datum already existed (datum_slot.offset_in_bytes is not
            equal to FREE_SLOT) and the existing datum is not at the beginning 
            of the used space (datum_slot.offset_in_bytes is equal to 
            bci_header.start_of_used_space).  If it is at the beginning of
            the used space, the space it takes up is recovered immediately.
12/03/84 by Matthew Pierret:  Added the local cdcn_datum_header and
            cd_datum_header structures which were removed from
            dm_cm_datum.incl.pl1
*/

/* format: style2,ind3 */

cm_put_datum_in_pool:
   proc (p_file_opening_id, p_element_id, p_datum_contents_ptr, p_datum_contents_length_in_bits, p_datum_slot_ptr,
        p_bci_header_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_datum_contents_ptr   ptr;
      dcl	    p_datum_contents_length_in_bits
			       fixed bin (35);
      dcl	    p_datum_slot_ptr       ptr;
      dcl	    p_bci_header_ptr       ptr;
      dcl	    p_ci_buffer_ptr	       ptr;
      dcl	    p_element_length_in_bits
			       fixed bin (35);
      dcl	    p_continuation	       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    is_buffered	       bit (1) aligned init ("0"b);
      dcl	    1 my_ci_parts	       aligned,
	      2 number_of_parts    fixed bin,
	      2 part	       (4) like ci_parts.part;
      dcl	    based_byte_string_length
			       fixed bin (35) init (0);
      dcl	    datum_contents_length_in_bytes
			       fixed bin (17) init (0);
      dcl	    datum_header_length_in_bytes
			       fixed bin (17) init (0);
      dcl	    old_datum_length_in_bytes
			       fixed bin (17) init (0);
      dcl	    (ci_datum_contents_ptr, ci_datum_header_ptr, datum_header_ptr)
			       ptr;

      dcl	    1 cd_datum_header      aligned like continued_datum.header;
      dcl	    1 cdcn_datum_header    aligned like continued_continuation_datum.header;

/* Based */

      dcl	    1 based_ci	       based (bci_header_ptr),
	      2 byte	       (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES) bit (9) unaligned;
      dcl	    based_byte_string      char (based_byte_string_length) based;

/* Builtin */

      dcl	    (addr, divide, null, size, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    BITS_PER_BYTE	       fixed bin init (9) int static options (constant);
      dcl	    BYTES_PER_WORD	       fixed bin init (4) int static options (constant);
      dcl	    HEADER_PART_IDX	       fixed bin init (1) int static options (constant);
      dcl	    DATUM_SLOT_PART_IDX    fixed bin init (2) int static options (constant);
      dcl	    DATUM_CONTENTS_PART_IDX
			       fixed bin init (3) int static options (constant);
      dcl	    DATUM_HEADER_PART_IDX  fixed bin init (4) int static options (constant);

/* Entry */

      dcl	    file_manager_$put      entry (bit (36) aligned, uns fixed bin (24), ptr, fixed bin (35));

/* External */
/* END OF DECLARATIONS */

      bci_header_ptr = p_bci_header_ptr;
      datum_slot_ptr = p_datum_slot_ptr;

      goto JOIN;

buffered:
   entry (p_ci_buffer_ptr, p_datum_contents_ptr, p_datum_contents_length_in_bits, p_datum_slot_ptr, p_code);

      bci_header_ptr = p_ci_buffer_ptr;
      datum_slot_ptr = p_datum_slot_ptr;
      is_buffered = "1"b;

      goto JOIN;

continued:
   entry (p_file_opening_id, p_element_id, p_datum_contents_ptr, p_datum_contents_length_in_bits, p_datum_slot_ptr,
        p_bci_header_ptr, p_element_length_in_bits, p_continuation, p_code);

      bci_header_ptr = p_bci_header_ptr;

      goto CD_JOIN;

buffered_continued:
   entry (p_ci_buffer_ptr, p_datum_contents_ptr, p_datum_contents_length_in_bits, p_datum_slot_ptr,
        p_element_length_in_bits, p_continuation, p_code);

      bci_header_ptr = p_ci_buffer_ptr;
      is_buffered = "1"b;

CD_JOIN:
      datum_slot_ptr = p_datum_slot_ptr;

      datum_slot.flags.is_continued = "1"b;

      if p_element_length_in_bits < 0
      then
         do;
	  datum_slot.flags.is_continuation = "1"b;
	  datum_header_length_in_bytes = CDCN_DATUM_HEADER_LENGTH_IN_BYTES;

	  unspec (cdcn_datum_header.continuation) = p_continuation;
	  datum_header_ptr = addr (cdcn_datum_header);
         end;
      else
         do;
	  datum_slot.flags.is_continuation = "0"b;
	  datum_header_length_in_bytes = CD_DATUM_HEADER_LENGTH_IN_BYTES;

	  cd_datum_header.full_length = p_element_length_in_bits;
	  unspec (cd_datum_header.continuation) = p_continuation;

	  datum_header_ptr = addr (cd_datum_header);
         end;

      goto JOIN;
%page;
JOIN:
      p_code = 0;

      datum_contents_length_in_bits = p_datum_contents_length_in_bits;
      datum_contents_length_in_bytes = divide (datum_contents_length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);

      if datum_slot.offset_in_bytes = bci_header.start_of_used_space
      then datum_slot.offset_in_bytes =
	      datum_slot.offset_in_bytes - (datum_contents_length_in_bytes + datum_header_length_in_bytes)
	      + divide (datum_slot.length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);
      else
         do;
	  if datum_slot.offset_in_bytes ^= FREE_SLOT
	  then bci_header.scattered_free_space =
		  bci_header.scattered_free_space
		  + divide (datum_slot.length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);
	  else /* no old space to remember */
	       ;

	  datum_slot.offset_in_bytes =
	       bci_header.start_of_used_space - (datum_contents_length_in_bytes + datum_header_length_in_bytes);
         end;

      datum_slot.length_in_bits = datum_header_length_in_bytes * BITS_PER_BYTE + datum_contents_length_in_bits;
      bci_header.start_of_used_space = datum_slot.offset_in_bytes;

      if is_buffered
      then
COPY_INTO_BUFFERED_CI:
         do;

	  based_byte_string_length = datum_contents_length_in_bytes;
	  ci_datum_contents_ptr = addr (based_ci.byte (datum_slot.offset_in_bytes + datum_header_length_in_bytes + 1));
	  ci_datum_contents_ptr -> based_byte_string = p_datum_contents_ptr -> based_byte_string;

	  if datum_header_length_in_bytes > 0
	  then
	     do;
	        based_byte_string_length = datum_header_length_in_bytes;
	        ci_datum_header_ptr = addr (based_ci.byte (datum_slot.offset_in_bytes + 1));
	        ci_datum_header_ptr -> based_byte_string = datum_header_ptr -> based_byte_string;
	     end;

         end COPY_INTO_BUFFERED_CI;
      else
COPY_INTO_FILE_CI:
         do;

	  element_id_string = p_element_id;

	  ci_parts_ptr = addr (my_ci_parts);
	  ci_parts.number_of_parts = 3;

	  ci_parts.part (DATUM_SLOT_PART_IDX).offset_in_bytes =
	       BYTES_PER_WORD * ((element_id.index - 1) + size (bci_header));
	  ci_parts.part (DATUM_SLOT_PART_IDX).length_in_bytes = BYTES_PER_WORD;
	  ci_parts.part (DATUM_SLOT_PART_IDX).local_ptr = datum_slot_ptr;

	  ci_parts.part (HEADER_PART_IDX).offset_in_bytes = 0;
	  ci_parts.part (HEADER_PART_IDX).length_in_bytes = size (bci_header) * BYTES_PER_WORD;
	  ci_parts.part (HEADER_PART_IDX).local_ptr = bci_header_ptr;

	  ci_parts.part (DATUM_CONTENTS_PART_IDX).offset_in_bytes =
	       datum_slot.offset_in_bytes + datum_header_length_in_bytes;
	  ci_parts.part (DATUM_CONTENTS_PART_IDX).length_in_bytes = datum_contents_length_in_bytes;
	  ci_parts.part (DATUM_CONTENTS_PART_IDX).local_ptr = p_datum_contents_ptr;

	  if datum_slot.is_continued
	  then
	     do;
	        ci_parts.number_of_parts = 4;

	        ci_parts.part (DATUM_HEADER_PART_IDX).offset_in_bytes = datum_slot.offset_in_bytes;
	        ci_parts.part (DATUM_HEADER_PART_IDX).length_in_bytes = datum_header_length_in_bytes;
	        ci_parts.part (DATUM_HEADER_PART_IDX).local_ptr = datum_header_ptr;

	     end;

	  call file_manager_$put (p_file_opening_id, (element_id.control_interval_id), ci_parts_ptr, p_code);

         end COPY_INTO_FILE_CI;

      return;

%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_element_id;
%page;
%include dm_ci_parts;
%page;
%include dm_ci_lengths;

   end cm_put_datum_in_pool;




		    cm_put_header.pl1               04/04/85  1112.8r w 04/04/85  0912.8       68031



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

          The entry cm_put_header$cm_put_header implements
     collection_manager_$put_header.
          The entry cm_put_header$unprotected implements
     collection_manager_$put_unprotected_header.

          This routine puts a caller-supplied header associated with a 
     collection.  If the header is not already present (indicated by
     collection_header.header_record_id equal to "0"b), the given header is
     allocated.  If the header is already present, it is replaced by the 
     given header.  If entered via the $unprotected entry, the replacement
     is done without obtaining an exclusive lock on the control interval in 
     which the header is stored, but the new header must be the same length
     as the old one.
*/

/* Written by Matthew Pierret.
Modified:
06/08/82 by Matthew Pierret: Changed call to cm_allocate_element$header to
            be to cm_allocate_element. The collection_header that was being 
            passed was for the collection whose header was being put; 
            cm_allocate_element$header assumes that it is the header of the 
            collection that the header is being put into, i.e. the header collection.
06/15/82 by Matthew Pierret: Changed calling sequence of cm_put_element.
08/04/82 by Matthew Pierret: Changed to use bit(36)aligned collection id.
11/05/82 by Matthew Pierret: Changed to get opening info for specified 
            collection and header collection, and to pass a pointer to the
            header collection info (hc_cm_info_ptr) to 
            cm_(allocate put)_element$info;
01/27/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2. Changed to report
            certain errors from cm_put_element which indicate internal
            inconsistencies via sub_err_.
06/12/84 by Matthew Pierret: Re-named cm_put_element to cm_modify,
            cm_allocate_element to cm_put.
10/03/84 by Matthew Pierret: Changed to use ERROR_RETURN procedure to return
            in the case of an error.  Added addr and 
            error_table_$unimplemented_version in the main procedure.
            Changed to use local code variable instead of p_code parameter.
*/

/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

cm_put_header:
   proc (p_file_opening_id, p_collection_id, p_header_ptr, p_header_length, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_header_ptr	       ptr;
      dcl	    p_header_length	       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    hc_cm_info_ptr	       ptr init (null);
      dcl	    is_unprotected	       bit (1) aligned init ("0"b);

/* Based */
/* Builtin */

      dcl	    (addr, null)	       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       char (32) varying init ("cm_put_header") int static options (constant);
      dcl	    UNINITIALIZED_ELEMENT_ID
			       bit (36) aligned init ("0"b) int static options (constant);
      dcl	    END_OF_ELEMENT	       fixed bin (35) init (-1);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$ci_not_in_collection,
	    dm_error_$misformatted_ci,
	    dm_error_$no_element,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      goto JOIN;

unprotected:
   entry (p_file_opening_id, p_collection_id, p_header_ptr, p_header_length, p_code);

      is_unprotected = "1"b;

JOIN:
      p_code, code = 0;

      call cm_opening_info$get (p_file_opening_id, p_collection_id, cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);

      collection_header_ptr = cm_info.header_ptr;

      call CHECK_VERSION ("collection_header", collection_header.version, COLLECTION_HEADER_VERSION_2);

      call cm_opening_info$get (cm_info.file_oid, HEADER_COLLECTION_ID, hc_cm_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      if collection_header.header_record_element_id = UNINITIALIZED_ELEMENT_ID
      then
         do;
	  element_id_string = p_collection_id;

	  call cm_put$info (hc_cm_info_ptr, p_header_ptr, p_header_length, element_id_string, (0), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  collection_header.header_record_element_id = element_id_string;
	  call cm_modify$info (hc_cm_info_ptr, collection_header_ptr, END_OF_ELEMENT, p_collection_id, (0), code);
	  if code ^= 0
	  then if code = dm_error_$no_element | code = dm_error_$ci_not_allocated
		  | code = dm_error_$ci_not_in_collection | code = dm_error_$misformatted_ci
	       then call sub_err_ (code, myname, ACTION_CANT_RESTART, null, 0,
		       "^/An internal inconsistency was encountered attempting to restore the^/collection header of collection ^3bo at control interval ^d, slot ^d."
		       , cm_info.collection_id,
		       addr (collection_header.header_record_element_id) -> element_id.control_interval_id,
		       addr (collection_header.header_record_element_id) -> element_id.index);

         end;
      else
         do;
	  element_id_string = collection_header.header_record_element_id;

	  if is_unprotected
	  then call cm_modify$unprotected_info (hc_cm_info_ptr, p_header_ptr, p_header_length, element_id_string, (0),
		  code);
	  else call cm_modify$info (hc_cm_info_ptr, p_header_ptr, p_header_length, element_id_string, (0), code);

	  if code ^= 0
	  then if code = dm_error_$no_element | code = dm_error_$ci_not_allocated
		  | code = dm_error_$ci_not_in_collection | code = dm_error_$misformatted_ci
	       then call sub_err_ (code, myname, ACTION_CANT_RESTART, null, 0,
		       "^/An internal inconsistency was encountered attempting to restore the user^/header of collection ^3bo at control interval ^d, slot ^d."
		       , cm_info.collection_id,
		       addr (collection_header.header_record_element_id) -> element_id.control_interval_id,
		       addr (collection_header.header_record_element_id) -> element_id.index);
         end;

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (p_structure_name, p_given_version, p_correct_version);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;

      if p_given_version ^= p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of ^a structure; received ^8a.", p_correct_version, p_structure_name,
	      p_given_version);

      return;

   end CHECK_VERSION;
%page;
%include dm_cm_info;
      ;
%page;
%include dm_cm_collection_header;
%page;
%include dm_element_id;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_put_header;




		    cm_put_ordered_element.pl1      04/04/85  1112.8r w 04/04/85  0912.8      212490



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

        This module allocates space for an element according to the rules of
   the Ordered Element Storage Method, then puts the element at the allocated
   spot.  There are two modes of operation, with an entry for each, those
   being the normal approach and the buffered approach.  In the buffered
   approach, a pointer to a copy of the control interval into which the
   element must be put is passed to the $buffered entry.
   
        An element can be put either as a single datum in the specified
   control interval or as a continued datum in the specified control interval
   with subsequent maximum-sized continuation datums in other control
   intervals.  Each maximum-sized continuation datum effectively fills up
   an entire control interval on its own.  The contents of an element is
   stored byte-aligned, so if the element length in bits does not correspond
   to an integral number of bytes, the last byte is padded with enough extra
   bits to make the total length correspond to an integral number of bytes.
   In the multi-datum element case, this means that the last maximum-sized
   datum may be slightly less than the maximum (up to 8 bits) size in bits.
   The maximum size of a datum is MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS
   (declared in dm_cm_datum_constants.incl.pl1).

        The Ordered Element Storage Method requires that the first datum
   (either the whole element or the first datum of a multi-datum element) be
   put in the specified control interval.  If there is not enough room in that
   control interval for the first datum, the code dm_error_$long_element is
   return along with total amount of free space in bits in the control
   interval, not including the space required for the datum slot and the datum
   header.  The caller can use this information in determining how much space
   must be freed in the control interval before the datum will fit.
   
        The Ordered Element Storage Method also requires that the element uses
   the specified datum slot.  If that slot is already in use, it and all
   following slots are shifted one slot to the right.  If the specified slot
   is more than one slot past the last slot, the intervening slots are
   initialized as free slots, but are counted in the number_of_datums for the
   control interval.
   
        The parameters are:
   
   p_cm_info_ptr - points to collection opening info set up by the caller.
   p_bci_header_ptr - only in the normal entry, points to a copy of
             bci_header local to the caller.  On output it will be filled with
             the contents of the bci_header of the control interval in which
             the element is pout.
   p_ci_buffer_ptr - only in the buffered entry, points to the control
             interval buffer set up by the caller.  This routine modifies the
             contents of this control interval buffer, not the file copy of
             the control interval, so the caller must be prepared to write the
             entire buffer into the file.  If the element is stored as a
             multi-datum element, only the first datum is in  this control
             interval buffer; the rest are stored in other control intervals
             by modifying the file copy of each control interval.
   p_element_length - is the length of the element is bits.
   p_element_ptr - points to the element to be put.
   p_element_id - is the identifier the element is to have.  It contains a
             control interval id and a slot index.  This is how the caller
             specifies the control interval in which the element is to be put
             and the slot which it should use.
   p_free_space - is the total amount of free space in bits in the control
             interval, not including the datum slot and datum header, but
             including the datum contents if successfully put.
   p_code - is a status code. It is dm_error_$long_element if there is not
             enough room in the control interval for the first datum of the
             element.
*/

/* HISTORY:
Written by Matthew C Pierret.
Modified:
04/09/82 by Lindsey Spratt: Changed to use the dm_element_id include file.
	  Now uses the "local" element_id_string/element_id consistently.
04/13/82 by Matthew Pierret: Fixed to set p_element_id before returning.
04/14/82 by Matthew Pierret: Changed to accept slot index greater than the
            the current number of datums + 1. Use cm_get_datum_slots instead
            of cm_get_slot_table and cm_put_datum_slots instead of 
            cm_shift_slots.
04/15/82 by Matthew Pierret: Fixed some plus/minus 1 bugs and made to take
            uninitialized slot space into consideration when calculating
            free space.
04/19/82 by Matthew Pierret: Added code to get the basic_control_interval header.
04/27/82 by Matthew Pierret: Changed calling segquence of cm_compact_and_add.
05/10/82 by Lindsey Spratt:  Changed division to find element_length_in_bytes
	  to use a precision and scale of (35,18) rather than (17,2).  The
	  length in bytes was coming out one short when the length in bits
	  was not an integral multiple of the number of bits per byte.
06/03/82 by Lindsey Spratt:  Changed to only shift the slots if using the free
	  pool, since cm_compact_and_add does the shift when using
	  compaction.
06/21/82 by Matthew Pierret: Changed to use cm_compact.
08/03/82 by Matthew Pierret: Changed to use cm_get_bci_header.
10/27/82 by Lindsey Spratt:  Changed to set the
	  automatic_datum_slot.offset_in_bytes to FREE_SLOT before calling
	  cm_put_datum_in_pool.
11/09/82 by Matthew Pierret: Changed to calculate p_free_space which is the
            total number of free bits left in the control interval after
            successfully allocating the element, or the number of extra bits
            needed if the element would not fit.
            Changed to use cm_determine_free_space and to support multi-datum
            elements.
11/22/82 by Matthew Pierret:  Changed to properly initialize datum slot.
01/07/83 by Matthew Pierret:  Added $buffered entry.  Qualified all references
            to bci_header with the pointer ci_buffer_or_ci_header_ptr. This is
            because the normal entry takes a pointer to a bci_header structure
            (p_bci_header_ptr), while $buffered entry takes a pointer to the
            base of a buffered control interval (p_ci_buffer_ptr).
            ci_buffer_or_ci_header_ptr is given the value of one of these 
            parameters to make it clear that bci_header can be referencing an
            automatic header or an actual buffered ci.
01/11/83 by Lindsey Spratt (for Matthew Pierret):  Fixed to set the
	  datum_contents_length_in_bits based on whether the element is
	  continued or not.  Also fixed to set dm_error_$long_element if the
	  total_free_bytes*BITS_PER_BYTE is less than the
	  datum_contents_length_in_bits, rather than "less than or equal to".
01/18/83 by Matthew Pierret: Fixed references to basic_control_interval that
            were not qualified with a locator.
            Added call to cm_compact$buffered_replacement, 
            cm_put_datum_in_pool$buffered("" _continued).
            Fixed bug in determination of whether slots should be shifted in
            the buffered case. If element_id.index = number_of_datums, the
            last datum should be shifted, but was not.
01/31/83 by Lindsey Spratt:  Fixed to not increment the
	  bci_header.number_of_datums when there is not enough room in the
	  CI for the new element.  Also fixed to use cm_compact$buffered
	  rather than $buffered_replacement, so that the task of moving
	  slots to the right is done by cm_compact rather than before
	  calling cm_compact (when necessary).  The old behavior caused
	  datum contents to be overwritten by the last datum_slot when the
	  start_of_used_space was immediately after the datum_position_table
	  (before the addition of the new slot).
	       Changed to set new_last_slot_idx, rather than
	  basic_control_interval.number_of_datums, as this made the
	  basic_control_interval inconsistent.  bci.nod is now only set to
	  new_last_slot_idx when appropriate.
02/03/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2.
08/04/83 by Matthew Pierret: Changed to use 
            cm_determine_free_space$does_new_datum_fit.  This entry takes into
            account the fact that the datum also needs space for a new datum 
            slot and possibly datum header space, returning flags indicating
            whether the datum can fit in the ci and in the pool.  Also returned
            is amount of space left in the ci.  Added an ERROR_RETURN
            routine and the forced all error returns to go through it.
            Added verification to see if the calculated datum contents length
            differs from the actual number of bits left after allocating an
            overlength tail.
            Changed to always return -1 for p_free_space if the allocation
            fails for any reason other than a lack of space 
            (dm_error_$long_element).
09/25/84 by Matthew Pierret:  Changed to correctly calculate the length of
            the first datum rather than rely on cm_put_overlength_tail to do
            so.  Added BITS_TO_BYTES conversion function which uses a slightly
            optimized conversion algorithm. Changed to use datum_slot_ptr 
            instead of addr (automatic_datum_slot).  Changed automatic_*
            to my_=.  Changed to use a my_ci_parts structure instead of
            using a fixed bin (71) array buffer.
01/04/85 by Matthew C. Pierret:  Added must_be_zero elment to my_ci_parts.
*/


/* format: style2,ind3 */
/* format: ^indblkcom,indcomtxt */
/* ADD AFTER AUDIT IS DONE: ll79,^indnoniterdo,^indprocbody */

cm_put_ordered_element:
   proc (p_cm_info_ptr, p_bci_header_ptr, p_element_length, p_element_ptr, p_element_id, p_free_space, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr;
      dcl	    p_ci_buffer_ptr	       ptr;
      dcl	    p_bci_header_ptr       ptr;
      dcl	    p_element_length       fixed bin (35);
      dcl	    p_element_ptr	       ptr;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_free_space	       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    1 my_ci_parts	       aligned,
	      2 number_of_parts    fixed bin init (1),
	      2 must_be_zero       fixed bin init (0),
	      2 part	       (1) like ci_parts.part;
      dcl	    1 my_datum_slot	       aligned like datum_slot;
      dcl	    1 datum_slot_table     (1024) aligned like datum_slot;

      dcl	    code		       fixed bin (35);
      dcl	    continuation	       bit (36) aligned init ("0"b);

      dcl	    (datum_contents_length_in_bytes, number_of_slots, previous_last_slot_idx, new_last_slot_idx, slot_idx,
	    uninitialized_slot_space)
			       fixed bin (17) init (0);
      dcl	    (datum_contents_length_in_bits, unallocated_element_length_in_bits, total_free_bytes)
			       fixed bin (35) init (0);

      dcl	    (is_buffered, is_continued, must_shift_slots_to_the_right, must_initialize_slots_to_the_left, fits_in_ci,
	    fits_in_pool)	       bit (1) aligned init ("0"b);

      dcl	    ci_buffer_or_ci_header_ptr
			       ptr;

/* Based */
/* Builtin */

      dcl	    (abs, ceil, divide, addr, max, mod, null, size, string, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("cm_put_ordered_element") char (32) varying internal static options (constant);
      dcl	    BYTES_PER_WORD	       init (4) fixed bin int static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin int static options (constant);
      dcl	    IS_NOT_A_CONTINUATION  init ("0"b) bit (1) aligned internal static options (constant);

/* Entry */

      dcl	    file_manager_$get      entry (bit (36) aligned, fixed bin (24) uns, ptr, fixed bin (35));
      dcl	    file_manager_$put      entry (bit (36) aligned, fixed bin (24) uns, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$long_element,
	    dm_error_$programming_error,
	    error_table_$unimplemented_version
	    )		       ext fixed bin (35);

/* END OF DECLARATIONS */



      ci_buffer_or_ci_header_ptr = p_bci_header_ptr;
      goto JOIN;


buffered:
   entry (p_cm_info_ptr, p_ci_buffer_ptr, p_element_length, p_element_ptr, p_element_id, p_free_space, p_code);

      is_buffered = "1"b;
      ci_buffer_or_ci_header_ptr = p_ci_buffer_ptr;
      goto JOIN;



JOIN:
      p_code, code = 0;
      p_free_space = -1;
      bci_header_ptr, basic_control_interval_ptr = null;

      cm_info_ptr = p_cm_info_ptr;
      call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);

      element_id_string = p_element_id;

      if ^is_buffered
      then
         do;
	  call cm_get_bci_header (cm_info.file_oid, (element_id.control_interval_id), ci_buffer_or_ci_header_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;

      if p_element_length > MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS
      then
         do;
	  is_continued = "1"b;
	  datum_contents_length_in_bytes =
	       BITS_TO_BYTES (mod (p_element_length, MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS));
	  datum_contents_length_in_bits = datum_contents_length_in_bytes * BITS_PER_BYTE;
         end;
      else
         do;
	  is_continued = "0"b;
	  datum_contents_length_in_bits = p_element_length;
	  datum_contents_length_in_bytes = BITS_TO_BYTES (datum_contents_length_in_bits);
         end;

/**** Determine whether a) the requested slot is in the middle of the slot
      array or b) the requested slot is beyond the end of the slot array. */

      if is_buffered
      then
         do;
	  if element_id.index <= ci_buffer_or_ci_header_ptr -> basic_control_interval.header.number_of_datums
	  then if unspec (ci_buffer_or_ci_header_ptr -> basic_control_interval.datum_position_table (element_id.index))
		  = ""b
	       then must_shift_slots_to_the_right = "0"b;
	       else must_shift_slots_to_the_right = "1"b;
	  else if element_id.index > ci_buffer_or_ci_header_ptr -> basic_control_interval.header.number_of_datums + 1
	  then must_initialize_slots_to_the_left = "1"b;
	  else must_initialize_slots_to_the_left = "0"b;
         end;

      else
         do;
	  ci_parts_ptr = addr (my_ci_parts);
	  ci_parts.part (1).local_ptr = addr (datum_slot_table);

	  number_of_slots = ci_buffer_or_ci_header_ptr -> bci_header.number_of_datums - element_id.index + 1;

	  if number_of_slots > 0
	  then
	     do;

	     /*** There exist slots to the right of the requested slot.  Get those slots.
		If the requested slot is not free, shift the slots one slot to the right
		to make room for the new one.  Otherwise simply use the free slot without
		bothering the slots to the right. */

	        ci_parts.part (1).offset_in_bytes =
		   BYTES_PER_WORD * (size (ci_buffer_or_ci_header_ptr -> bci_header) + element_id.index - 1);
	        ci_parts.part (1).length_in_bytes = BYTES_PER_WORD * number_of_slots;

	        call file_manager_$get (cm_info.file_oid, (element_id.control_interval_id), ci_parts_ptr, code);
	        if code ^= 0
	        then call ERROR_RETURN (code);

	        if unspec (datum_slot_table (1)) = ""b
	        then must_shift_slots_to_the_right = "0"b;
	        else must_shift_slots_to_the_right = "1"b;
	     end;
	  else
	     do;
	        number_of_slots = element_id.index - ci_buffer_or_ci_header_ptr -> bci_header.number_of_datums - 1;
	        if number_of_slots > 0
	        then
		 do;

		 /*** The requested slot is beyond the end of the slot array.  This means that
		      all slots between the current end of the array and the new slot must be
		      initialized as free slots. */

		    must_initialize_slots_to_the_left = "1"b;
		    uninitialized_slot_space = number_of_slots * size (datum_slot) * BYTES_PER_WORD;

		    ci_parts.part (1).offset_in_bytes =
		         BYTES_PER_WORD
		         * (size (ci_buffer_or_ci_header_ptr -> bci_header) + element_id.index - number_of_slots);
		    ci_parts.part (1).length_in_bytes = BYTES_PER_WORD * number_of_slots;

		    call file_manager_$get (cm_info.file_oid, (element_id.control_interval_id), ci_parts_ptr, code);
		    if code ^= 0
		    then call ERROR_RETURN (code);
		 end;
	     end;
         end;

      previous_last_slot_idx = ci_buffer_or_ci_header_ptr -> bci_header.number_of_datums;

      if must_shift_slots_to_the_right
      then new_last_slot_idx = max (element_id.index, ci_buffer_or_ci_header_ptr -> bci_header.number_of_datums + 1);
      else new_last_slot_idx = max (element_id.index, ci_buffer_or_ci_header_ptr -> bci_header.number_of_datums);

/**** See if first datum will fit in control interval. */

      call cm_determine_free_space$does_new_datum_fit (ci_buffer_or_ci_header_ptr, (datum_contents_length_in_bytes),
	 (element_id.index), is_continued, IS_NOT_A_CONTINUATION, fits_in_ci, fits_in_pool, total_free_bytes);

      if ^fits_in_ci
      then call ERROR_RETURN (dm_error_$long_element);

      if is_continued
      then
         do;

         /*** This is an overlength element requiring more than one datum to store.
	    Store maximum-sized chunks of the element in newly allocated control
	    intervals from right to left, until only a single datum is left. */

	  unallocated_element_length_in_bits = p_element_length;
	  call cm_put_overlength_tail (cm_info_ptr, p_element_ptr, unallocated_element_length_in_bits, continuation,
	       code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  if unallocated_element_length_in_bits ^= datum_contents_length_in_bits
	  then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		  "^/^a^/^d ^a ^d ^a^/^a", "The calculated length of the first datum of an multi-datum element is",
		  datum_contents_length_in_bits, "bits; after all but the first datum were put",
		  unallocated_element_length_in_bits, "bits remain.", "The two should be equal.");

	  datum_contents_length_in_bits = unallocated_element_length_in_bits;
	  datum_contents_length_in_bytes = BITS_TO_BYTES (datum_contents_length_in_bits);
         end;

      if ^fits_in_pool
      then
DATUM_FITS_IN_CI_BUT_NOT_IN_POOL:
         do;
	  if is_buffered
	  then call cm_compact$buffered (ci_buffer_or_ci_header_ptr, new_last_slot_idx, element_id_string, code);
	  else call cm_compact (cm_info.file_oid, new_last_slot_idx, element_id_string, ci_buffer_or_ci_header_ptr,
		  code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  ci_buffer_or_ci_header_ptr -> basic_control_interval.number_of_datums = new_last_slot_idx;
         end DATUM_FITS_IN_CI_BUT_NOT_IN_POOL;
      else
DATUM_FITS_IN_POOL:
         do;					/* datum_contents_length_in_bytes <= pool_free_bytes */
	  ci_buffer_or_ci_header_ptr -> basic_control_interval.number_of_datums = new_last_slot_idx;

	  if (must_shift_slots_to_the_right | must_initialize_slots_to_the_left)
	  then
	     do;
	        if is_buffered
	        then
		 do;
		    if must_shift_slots_to_the_right
		    then
		       do slot_idx = ci_buffer_or_ci_header_ptr -> basic_control_interval.header.number_of_datums
			  to element_id.index + 1 by -1;
			ci_buffer_or_ci_header_ptr -> basic_control_interval.datum_position_table (slot_idx) =
			     ci_buffer_or_ci_header_ptr
			     -> basic_control_interval.datum_position_table (slot_idx - 1);
		       end;
		    else if must_initialize_slots_to_the_left
		    then
		       do slot_idx = ci_buffer_or_ci_header_ptr -> basic_control_interval.header.number_of_datums - 1
			  to previous_last_slot_idx by -1;
			unspec (ci_buffer_or_ci_header_ptr
			     -> basic_control_interval.datum_position_table (slot_idx)) = "0"b;
		       end;
		 end;
	        else /* not buffered, datum_contents_length_in_bytes <= pool_free_bytes, and mssttr or misttl */
		 do;
		    if must_shift_slots_to_the_right
		    then ci_parts.part (1).offset_in_bytes = ci_parts.part (1).offset_in_bytes + BYTES_PER_WORD;

		    call file_manager_$put (cm_info.file_oid, (element_id.control_interval_id), ci_parts_ptr, code);

		    if code ^= 0
		    then call ERROR_RETURN (code);
		 end;
	     end;
         end DATUM_FITS_IN_POOL;

/* Initialize datum_slot */

      if is_buffered
      then datum_slot_ptr =
	      addr (ci_buffer_or_ci_header_ptr -> basic_control_interval.datum_position_table (element_id.index));
      else datum_slot_ptr = addr (my_datum_slot);

      unspec (datum_slot) = ""b;

/* Put new datum in the control interval's free pool */

      if is_buffered
      then if is_continued
	 then call cm_put_datum_in_pool$buffered_continued (ci_buffer_or_ci_header_ptr, p_element_ptr,
		 datum_contents_length_in_bits, datum_slot_ptr, p_element_length, continuation, code);
	 else call cm_put_datum_in_pool$buffered (ci_buffer_or_ci_header_ptr, p_element_ptr,
		 datum_contents_length_in_bits, datum_slot_ptr, code);

      else if is_continued
      then call cm_put_datum_in_pool$continued (cm_info.file_oid, element_id_string, p_element_ptr,
	      datum_contents_length_in_bits, datum_slot_ptr, ci_buffer_or_ci_header_ptr, p_element_length, continuation,
	      code);
      else call cm_put_datum_in_pool (cm_info.file_oid, element_id_string, p_element_ptr, datum_contents_length_in_bits,
	      datum_slot_ptr, ci_buffer_or_ci_header_ptr, code);


      p_element_id = element_id_string;
      call FINISH ();
MAIN_RETURN:
      return;



ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH ();
      goto MAIN_RETURN;

   end ERROR_RETURN;


FINISH:
   proc ();

      if p_code = 0 | p_code = dm_error_$long_element
      then p_free_space = total_free_bytes * BITS_PER_BYTE;

      return;

   end FINISH;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", cv_p_correct_version,
	      cv_p_structure_name, cv_p_given_version);
      else return;

   end CHECK_VERSION;
%page;

BITS_TO_BYTES:
   proc (btb_p_bits) returns (fixed bin (17));

/* This function takes a length in bits and returns the number of bytes
   necessary to hold that many bits. The expression which figures this out
   is an optimization of the expression:
   ceil (divide (btb_p_bits, BITS_PER_BYTE, 35, 18)
*/

      dcl	    btb_p_bits	       fixed bin (35);

      return (divide (btb_p_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0));

   end BITS_TO_BYTES;
%page;
%include dm_cm_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_element_id;
%page;
%include dm_ci_parts;
%page;
%include sub_err_flags;
%page;
%include dm_cm_entry_dcls;

   end cm_put_ordered_element;




		    cm_put_overlength_tail.pl1      04/04/85  1112.8r w 04/04/85  0912.8       77049



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         This routine takes a pointer to an element (p_element_ptr) and
   allocates maximum-sized datums in which to store the element.  Starting
   from the end of the element, it takes a maximum-sized piece off the end,
   allocates a control interval, and stores the piece as a datum in the first
   slot of the new control interval.  It stops when the element has been
   reduced to less than a maximum-sized datum.  This routine can be called
   with an element that already has had part of the element allocated in this
   fashion, providing that the allocated portion is at the end and is all
   maximum-sized datums.  In this case, the caller passes the datum_id of the
   leftmost datum (p_continuation_datum_id) which is stored as part of the
   first datum allocated by this routine.
   
        The first datum stored (the rightmost datum) is handled as a special
   case if it is the last datum of the element (p_continuation_datum_id =
   "0"b).  First, since it is the last datum, it is not itself continued,
   i.e. it is a continuation_datum rather than a continued_continuation_datum. 
   Second, if the total length of the element is not an integral number of
   bytes, the last byte of this datum is padded to make it an integral number
   of bytes.
   
        On output, p_remainder_length_in_bits is set to the number of bits of
   the element not stored by this routine.  This is the leftmost part of the
   element and the remaining number of bits must be less than the maximum size
   of a datum. It can be zero.  p_continuation_datum_id is set to be the
   datum_id of the last (logically, leftmost) datum stored.  
*/

/* HISTORY:

Written by Matthew Pierret, 10/27/82.
Modified:
12/23/82 by Lindsey Spratt:  Fixed to set cm_info_ptr.
01/03/83 by Lindsey Spratt:  Fixed to set p_continuation and to update
	  remainder_length_in_bits and p_remainder_length_in_bits.   Changed
	  to use the info_header entry in cm_allocate_ci to get a current
	  and valid value for the bci_header.
01/05/83 by Lindsey Spratt:  Fixed to set the continued_datum_is_present flag.
01/05/83 by Matthew Pierret: Changed to make rightmost datum (the first datum
            stored in this routine) pad the last byte to make all datums to the
            left be an integral number of bytes.
02/03/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2. Added version check
03/09/83 by Lindsey Spratt:  Fixed use of based_bit_array, was too low by 1.
	  Moved setting of dclib to MDCLIB into case for datum_count ^=
	  1 or p_continuation ^= "0"b.  Fixed to initialize datum_slot.flags
	  to "0"b.
04/04/83 by Lindsey L. Spratt:  Fixed to check p_code after calling
            cm_put_datum_in_pool$*.  Fixed to initialize the datum_slot for
            each datum.
04/05/83 by Lindsey L. Spratt:  Changed to explicitly calculate the
            datum_contents_ptr using the addbitno builtin instead of the addr
            builtin and a based_bit_array.
09/24/84 by Matthew Pierret: To add ERROR_RETURN and LIMIT, and remove call-
            by-value to CHECK_VERSION.
*/

/* format: style2,ind3 */

cm_put_overlength_tail:
   proc (p_cm_info_ptr, p_element_ptr, p_remainder_length_in_bits, p_continuation_datum_id, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr parameter;
      dcl	    p_element_ptr	       ptr parameter;
      dcl	    p_remainder_length_in_bits
			       fixed bin (35) parameter;
      dcl	    p_continuation_datum_id
			       bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    1 my_bci_header	       aligned like bci_header;
      dcl	    1 my_datum_slot	       aligned like datum_slot;
      dcl	    code		       fixed bin (35);
      dcl	    control_interval_id    fixed bin (24) uns init (0);
      dcl	    datum_count	       fixed bin (17) init (0);
      dcl	    (remainder_length_in_bits, datum_contents_length_in_bits, number_of_bits_in_last_byte)
			       fixed bin (35) init (0);
      dcl	    datum_contents_ptr     ptr init (null);

/* Based */
/* Builtin */

      dcl	    (addbitno, addr, mod, null, unspec)
			       builtin;

/*	 Constant */

      dcl	    myname	       init ("cm_put_overlength_tail") char (32) varying internal static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin internal static options (constant);
      dcl	    LIMIT		       init (131071) fixed bin (17) internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$programming_error
			       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code, code = 0;
      cm_info_ptr = p_cm_info_ptr;
      call CHECK_VERSION ("cm_info", cm_info.version, CM_INFO_VERSION_2);

      bci_header_ptr = addr (my_bci_header);
      datum_slot_ptr = addr (my_datum_slot);


      remainder_length_in_bits = p_remainder_length_in_bits;

      do datum_count = 1 to LIMIT
	 while (remainder_length_in_bits > MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS - BITS_PER_BYTE);

         call cm_allocate_ci$info_header (cm_info_ptr, control_interval_id, bci_header_ptr, code);
         if code ^= 0
         then call ERROR_RETURN (code);

         bci_header.number_of_datums = 1;
         bci_header.flags.continuation_datum_is_present = "1"b;

         element_id.control_interval_id = control_interval_id;
         element_id.index = 1;

         unspec (datum_slot) = ""b;
         datum_slot.is_continuation = "1"b;

         if datum_count = 1 & p_continuation_datum_id = "0"b
         then
	  do;
	     number_of_bits_in_last_byte = mod (remainder_length_in_bits, BITS_PER_BYTE);
	     if number_of_bits_in_last_byte = 0
	     then number_of_bits_in_last_byte = BITS_PER_BYTE;
	     datum_contents_length_in_bits =
		MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS - BITS_PER_BYTE + number_of_bits_in_last_byte;
	     datum_contents_ptr = addbitno (p_element_ptr, remainder_length_in_bits - datum_contents_length_in_bits);
	     call cm_put_datum_in_pool (cm_info.file_oid, element_id_string, datum_contents_ptr,
		datum_contents_length_in_bits, datum_slot_ptr, bci_header_ptr, code);
	     if code ^= 0
	     then call ERROR_RETURN (code);
	  end;
         else
	  do;
	     datum_contents_length_in_bits = MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS;
	     datum_contents_ptr = addbitno (p_element_ptr, remainder_length_in_bits - datum_contents_length_in_bits);
	     call cm_put_datum_in_pool$continued (cm_info.file_oid, element_id_string, datum_contents_ptr,
		datum_contents_length_in_bits, datum_slot_ptr, bci_header_ptr, -1, p_continuation_datum_id, code);
	     if code ^= 0
	     then call ERROR_RETURN (code);
	  end;
         p_continuation_datum_id = element_id_string;
         remainder_length_in_bits = remainder_length_in_bits - datum_contents_length_in_bits;

      end;
      if datum_count > LIMIT
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null (), 0,
	      "^/The program was looping infinitely.");

      p_remainder_length_in_bits = remainder_length_in_bits;

MAIN_RETURN:
      return;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", cv_p_correct_version,
	      cv_p_structure_name, cv_p_given_version);
      else return;

   end CHECK_VERSION;
%page;
%include dm_cm_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_cm_entry_dcls;
%page;
%include dm_element_id;
%page;
%include sub_err_flags;

   end cm_put_overlength_tail;




		    cm_recursive_modify.pl1         04/04/85  1112.8r w 04/04/85  0912.0      183069



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */



/* DESCRIPTION:

   This  routine puts an element that is already a multi-datum element.
   The new element value  may  or  may  not  be  multi-datum  itself.    The
   arguments   received   are   the   datum   id   of   a   continuation  or
   continued_continuation datum (p_datum_id_string), the  pointer  to  the  element
   (p_element_ptr),     the     length    of    the    element    in    bits
   (p_element_length_in_bits) the amount of space available in  the  control
   interval       of       which       this      is      a      continuation
   (p_available_space_in_previous_ci).    If  the  datum  is  continued,  it
   recursively  invokes cm_recursive_modify on its continuation datum.  Then it
   determines if the previous control interval has enough room to store what
   is left of the element.  If so, it frees the datum it is working  on  and
   returns.  If there is more than a maximum-sized datum left of the element
   and  the  current datum is already maximum-sized, it stores the uppermost
   (rightmost) maximum-sized portion, truncates  that  portion  off  of  the
   element,  and returns its datum id (which is unchanged).  If the datum is
   not already maximum-sized, it allocates new datums to hold the overlength
   tail.  If the element remains is less than maximum-size and  the  current
   datum  is  also  (and  the previous ci cannot hold the what's left of the
   element) it either puts what's left in the datum, or,  if  there  is  not
   enough  room  in  the  control  interval,  frees  the  current  datum and
   allocates a bigger one.  Then it returns to the caller the new datum id.
*/

/* HISTORY:

Written by Matthew Pierret, 10/27/82.
Modified:
12/01/82 by Lindsey Spratt:  Changed declaration of datum_id_string from being
            based on addr(datum_id_ptr) to datum_id_ptr.
12/02/82 by Lindsey Spratt:  Fixed to include the old_datum_length_inbytes in
            the pool_free_space only when the old datum was stored as the
            start_of_used_space, otherwise the old_datum_length_in_bytes is
            just seen in the total_free_bytes and hence is only available via
            compaction.
01/05/83 by Lindsey Spratt:  Changed to initialize remaining_element_length_in_bits,
            to return after replacing max-sized datum, and to *not* return
            after allocating an overlength tail.
01/05/83 by Matthew Pierret: Changed to make all datums but the last always
            be an integral number of bytes.  If the datum is the last
            (continuation = "0"b), the last byte may be only partially filled.
            Changed to atempt to replace less-than-max-sized datums, instead
            of always using the free pool.
01/27/83 by Matthew Pierret: Upgraded to CM_INFO_VERSION_2. Changed calling
            sequence to accept p_continued_datum_id_string. This is the id of
            the datum from whence we came, The id is only used for error
            reporting. Changed to report an internal inconsistency via sub_err_
            if certain errors are returned from cm_get_bci_header$slot.
            Changed to use cm_get_bci_header$slot instead of
            cm_get_header_and_slot.
05/10/83 by Lindsey L. Spratt:  Changed to use addbitno (p_element_ptr,X)
            rather than addr( p_element_ptr -> based_bit_array.bit(X+1)
            because the PL/1 compiler doesn't handle this construct properly
            in calling sequences.  Also, the "+ 1" was being left off.
07/12/83 by Lindsey Spratt:  Fixed to set the parameter
            p_remaining_element_length_in_bits in the "put_in_place" case.  It
            was setting the local variable, remaining_element_length_in_bits,
            instead.  Fixed several sub_err_ calls to include the "myname"
            argument.
10/04/84 by Matthew Pierret:  Changed name from cm_recursive_put to
            cm_recursive_modify to conform to the new naming scheme for
            operations.  Added ERROR_RETURN and RETURN technology. Added
            more inline documentation, and restructured code slightly to
            make the flow of control clearer.  Removed unused varables.
10/05/84 by Matthew Pierret:  Change to use cm_compact$replacement instead of
            cm_compact.  cm_compact assumes that a new datum is being put
            and reserves space for it. In this routine, we are not allocating
            a new datum.
12/03/84 by Matthew Pierret:  Moved indcomtxt off main format statement as
            it was causing the HISTORY section to become non-standard.
*/

/* format: style2,ind3 */
/* format: indcomtxt */

cm_recursive_modify:
   proc (p_cm_info_ptr, p_continued_datum_id_string, p_element_ptr, p_remaining_element_length_in_bits,
        p_available_space_in_previous_ci, p_datum_id_string, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_cm_info_ptr	       ptr parameter;
      dcl	    p_continued_datum_id_string
			       bit (36) aligned parameter;
      dcl	    p_element_ptr	       ptr parameter;
      dcl	    p_remaining_element_length_in_bits
			       fixed bin (35) parameter;
      dcl	    p_available_space_in_previous_ci
			       fixed bin (35) parameter;
      dcl	    p_datum_id_string      bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    automatic_bh_buffer    (3) fixed bin (71) init (0, 0, 0);
      dcl	    automatic_ds_buffer    (1) fixed bin (35) init (0);
      dcl	    code		       fixed bin (35);
      dcl	    continuation_datum_id_string
			       bit (36) aligned init ("0"b);
      dcl	    need_maximum_size_datum
			       bit (1) aligned init ("0"b);
      dcl	    current_datum_is_maximum_size
			       bit (1) aligned init ("0"b);
      dcl	    (header_space_required, number_of_bits_in_last_byte, old_datum_length_in_bytes, pool_free_bytes,
	    remaining_element_length_in_bits, total_free_bytes)
			       fixed bin (35) init (0);

/* Based */

      dcl	    datum_id_string	       bit (36) aligned based (datum_id_ptr);

/* Builtin */

      dcl	    (addbitno, addr, ceil, divide, mod, null)
			       builtin;

/* Constant */

      dcl	    myname	       init ("cm_recursive_modify") char (32) varying int static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin (17) int static options (constant);
      dcl	    NONE_OF_ELEMENT_REMAINS
			       init (0) fixed bin (35) internal static options (constant);
      dcl	    DONT_MODIFY_REMAINING_LENGTH
			       init (-1) fixed bin (35) internal static options (constant);

/* Entry */

      dcl	    file_manager_$simple_get
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$programming_error,
	    dm_error_$no_element,
	    dm_error_$misformatted_ci
	    )		       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code, code = 0;

      datum_id_ptr = addr (p_datum_id_string);

      cm_info_ptr = p_cm_info_ptr;
      call CHECK_VERSION (cm_info.version, CM_INFO_VERSION_2, "cm_info");

      bci_header_ptr = addr (automatic_bh_buffer);
      datum_slot_ptr = addr (automatic_ds_buffer);

      remaining_element_length_in_bits = p_remaining_element_length_in_bits;

      call cm_get_bci_header$slot (cm_info.file_oid, bci_header_ptr, datum_slot_ptr, datum_id_string, code);
      if code ^= 0
      then if code = dm_error_$no_element | code = dm_error_$ci_not_allocated | code = dm_error_$misformatted_ci
	 then call REPORT_MULTI_DATUM_INCONSISTENCY (addr (p_continued_datum_id_string)
		 -> element_id.control_interval_id, addr (p_continued_datum_id_string) -> element_id.index,
		 datum_id.control_interval_id, datum_id.index, code);
	 else call ERROR_RETURN (code);

      call VERIFY_MULTI_DATUM_CONSISTENCY (addr (p_continued_datum_id_string) -> element_id.control_interval_id,
	 addr (p_continued_datum_id_string) -> element_id.index, cm_info.collection_id, datum_id.control_interval_id,
	 datum_id.index, bci_header.collection_id, (datum_slot.offset_in_bytes = FREE_SLOT),
	 (^datum_slot.flags.is_continuation), code);


      call cm_determine_free_space$effective (bci_header_ptr, 0, (datum_slot.is_continued), (datum_slot.is_continuation),
	 total_free_bytes, pool_free_bytes);
      old_datum_length_in_bytes = ceil (divide (datum_slot.length_in_bits, BITS_PER_BYTE, 35, 18));

      if datum_slot.offset_in_bytes = bci_header.start_of_used_space
      then pool_free_bytes = pool_free_bytes + old_datum_length_in_bytes;

      total_free_bytes = total_free_bytes + old_datum_length_in_bytes;

      if datum_slot.is_continued
      then
         do;
	  call GET_CONTINUATION (cm_info.file_oid, (datum_id.control_interval_id), (datum_slot.offset_in_bytes),
	       continuation_datum_id_string);
	  call cm_recursive_modify (cm_info_ptr, datum_id_string, p_element_ptr, remaining_element_length_in_bits,
	       total_free_bytes, continuation_datum_id_string, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;


      if remaining_element_length_in_bits > MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS
      then need_maximum_size_datum = "1"b;
      else need_maximum_size_datum = "0"b;
      if datum_slot.length_in_bits >= MINIMUM_MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS
      then current_datum_is_maximum_size = "1"b;
      else current_datum_is_maximum_size = "0"b;

      if need_maximum_size_datum & current_datum_is_maximum_size
      then
REPLACE_MAX_WITH_MAX:
         do;
	  if continuation_datum_id_string = "0"b
	  then
CONTINUATION_DATUM:
	     do;
	        number_of_bits_in_last_byte = mod (remaining_element_length_in_bits, BITS_PER_BYTE);
	        if number_of_bits_in_last_byte = 0
	        then number_of_bits_in_last_byte = BITS_PER_BYTE;
	        datum_contents_length_in_bits =
		   MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS - BITS_PER_BYTE + number_of_bits_in_last_byte;

	        call cm_put_datum_in_place (cm_info.file_oid, datum_id_string,
		   addbitno (p_element_ptr, remaining_element_length_in_bits - datum_contents_length_in_bits),
		   datum_contents_length_in_bits, datum_slot_ptr, bci_header_ptr, code);
	     end CONTINUATION_DATUM;
	  else
CONTINUED_CONTINUATION_DATUM:
	     do;
	        datum_contents_length_in_bits = MAXIMUM_DATUM_CONTENTS_LENGTH_IN_BITS;
	        call cm_put_datum_in_place$continued (cm_info.file_oid, datum_id_string,
		   addbitno (p_element_ptr, remaining_element_length_in_bits - datum_contents_length_in_bits),
		   datum_contents_length_in_bits, datum_slot_ptr, bci_header_ptr, -1, continuation_datum_id_string,
		   code);
	     end CONTINUED_CONTINUATION_DATUM;
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  else call RETURN (remaining_element_length_in_bits - datum_contents_length_in_bits);
         end REPLACE_MAX_WITH_MAX;

      /*** Control cannot reach this point if this routine simply
	 replaced an existing maximum size datum with another
	 maximum size datum.  Two cases remain to consider: (1) we
	 still have more than a maximum size datum worth of the
	 element to store, but there is no existing maximum size
	 datum in which to put it; or (2) we don't need a maximum
	 size datum.  If (1) is the case, attempt to put each
	 remaining maximum size portion of the element in a new
	 maximum size datum. */

      if need_maximum_size_datum & ^current_datum_is_maximum_size
      then
INSERT_REMAINING_MAX_DATUMS:
         do;
	  call cm_put_overlength_tail (cm_info_ptr, p_element_ptr, remaining_element_length_in_bits,
	       continuation_datum_id_string, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  else /* remaining_element_length_in_bits was updated */
	       ;
         end INSERT_REMAINING_MAX_DATUMS;

      /*** By now we have cut the element down to a size that is storable in a single
	 datum.  Because this routine does not operate on the first datum of an element,
	 we kown that there exists a datum of this element previous to the current
	 datum.  If the remainder of the element can be stored in the control interval
	 in which the previous datum resides, delete the current datum.  The caller will
	 store the remainder of the element.  Otherwise, store the remainder in the
	 current datum (if it fits), in the control interval in
	 which the current datum resides (if it fits), are in
	 another control which does have space.  In the last case,
	 delete the current datum, as the new datum replaces the
	 current datum. */

      if remaining_element_length_in_bits <= p_available_space_in_previous_ci * BITS_PER_BYTE
      then
REMOVE_DATUM_FROM_ELEMENT:
         do;
	  call cm_delete_cn_datum$header (cm_info_ptr, bci_header_ptr, datum_slot_ptr, "1"b, datum_id_string, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  else
	     do;
	        p_datum_id_string = continuation_datum_id_string;
	        call RETURN (remaining_element_length_in_bits);
	     end;
         end REMOVE_DATUM_FROM_ELEMENT;
      else
REPLACE_CURRENT_DATUM:
         /*** If continuation_datum_id_string is equal to "0"b, this
	    is the last datum of the element.  Otherwise, it is an
	    intermediate datum.  */
         if continuation_datum_id_string ^= "0"b
      then header_space_required = CDCN_DATUM_HEADER_LENGTH_IN_BYTES;
      else header_space_required = 0;
      if remaining_element_length_in_bits <= BITS_PER_BYTE * (old_datum_length_in_bytes - header_space_required)
      then
PUT_DATUM_IN_PLACE:
         do;
	  if continuation_datum_id_string = "0"b
	  then call cm_put_datum_in_place (cm_info.file_oid, datum_id_string, p_element_ptr,
		  remaining_element_length_in_bits, datum_slot_ptr, bci_header_ptr, code);
	  else call cm_put_datum_in_place$continued (cm_info.file_oid, datum_id_string, p_element_ptr,
		  remaining_element_length_in_bits, datum_slot_ptr, bci_header_ptr, -1, continuation_datum_id_string,
		  code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  else call RETURN (NONE_OF_ELEMENT_REMAINS);
         end PUT_DATUM_IN_PLACE;
      else if remaining_element_length_in_bits <= BITS_PER_BYTE * (total_free_bytes - header_space_required)
      then
PUT_ELSEWHERE_IN_SAME_CI:
         do;
	  if remaining_element_length_in_bits > BITS_PER_BYTE * (pool_free_bytes - header_space_required)
	  then
	     do;
	        call cm_compact$replacement (cm_info.file_oid, (bci_header.number_of_datums), datum_id_string,
		   bci_header_ptr, code);
	        if code ^= 0
	        then call ERROR_RETURN (code);
	     end;
	  if continuation_datum_id_string = "0"b
	  then call cm_put_datum_in_pool (cm_info.file_oid, datum_id_string, p_element_ptr,
		  remaining_element_length_in_bits, datum_slot_ptr, bci_header_ptr, code);

	  else call cm_put_datum_in_pool$continued (cm_info.file_oid, datum_id_string, p_element_ptr,
		  remaining_element_length_in_bits, datum_slot_ptr, bci_header_ptr, -1, continuation_datum_id_string,
		  code);

	  if code ^= 0
	  then call ERROR_RETURN (code);
	  else call RETURN (NONE_OF_ELEMENT_REMAINS);
         end PUT_ELSEWHERE_IN_SAME_CI;
      else
PUT_IN_ANOTHER_CI:
         do;
	  call cm_delete_cn_datum$header (cm_info_ptr, bci_header_ptr, datum_slot_ptr, "1"b, datum_id_string, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  call cm_put_cn_datum (cm_info_ptr, p_element_ptr, remaining_element_length_in_bits,
	       continuation_datum_id_string, datum_id_string, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  else call RETURN (NONE_OF_ELEMENT_REMAINS);
         end PUT_IN_ANOTHER_CI;

MAIN_RETURN:
      return;

RETURN:
   proc (r_p_remaining_length);

      dcl	    r_p_remaining_length   fixed bin (35);

      if r_p_remaining_length ^= DONT_MODIFY_REMAINING_LENGTH
      then p_remaining_element_length_in_bits = r_p_remaining_length;
      go to MAIN_RETURN;

   end RETURN;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call RETURN (DONT_MODIFY_REMAINING_LENGTH);

   end ERROR_RETURN;
%page;
REPORT_MULTI_DATUM_INCONSISTENCY:
   proc (p_cd_ci, p_cd_index, p_cn_ci, p_cn_index, p_code);

      dcl	    (p_cd_ci, p_cn_ci)     fixed bin (24) unsigned unaligned;
      dcl	    (p_cd_index, p_cn_index)
			       fixed bin (12) unsigned unaligned;
      dcl	    p_code	       fixed bin (35);

      call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	 "^/The element in control interval ^d, slot ^d claims to be continued at^/control interval ^d, slot ^d. ^[^s^a^s^s^;^[^s^a^s^;^s^s^a^]"
	 , p_cd_ci, p_cd_index, p_cn_ci, p_cn_index, (p_code = dm_error_$no_element),
	 (p_code = dm_error_$ci_not_allocated), "That slot is a free slot.",
	 "That control interval is not allocated for use.", "That control interval is incorrectly formatted.");

   end REPORT_MULTI_DATUM_INCONSISTENCY;
%page;
VERIFY_MULTI_DATUM_CONSISTENCY:
   proc (p_cd_ci, p_cd_index, p_cd_collection_id, p_cn_ci, p_cn_index, p_cn_collection_id, p_cn_slot_is_free,
        p_cn_slot_is_not_continuation, p_code);

      dcl	    (p_cd_ci, p_cn_ci)     fixed bin (24) unsigned unaligned;
      dcl	    (p_cd_index, p_cn_index)
			       fixed bin (12) unsigned unaligned;
      dcl	    (p_cd_collection_id, p_cn_collection_id)
			       bit (36) aligned;
      dcl	    (p_cn_slot_is_free, p_cn_slot_is_not_continuation)
			       bit (1) aligned;
      dcl	    p_code	       fixed bin (35);

      if p_cn_collection_id ^= p_cd_collection_id
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	      "^/The element in control interval ^d, slot ^d claims to be continued at^/control interval ^d, slot ^d, but the two are in different collections.^/The former is in collection ^.3b;^/the latter is in collection ^.3b."
	      , p_cd_ci, p_cd_index, p_cn_ci, p_cn_index, p_cd_collection_id, p_cn_collection_id);
      else if p_cn_slot_is_free | p_cn_slot_is_not_continuation
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	      "^/The element in control interval ^d, slot ^d claims to be continued at^/control interval ^d, slot ^d. ^[^That slot ^[is free^;is not a continuation datum^]."
	      , p_cd_ci, p_cd_index, p_cn_ci, p_cn_index, p_cn_slot_is_free);

   end VERIFY_MULTI_DATUM_CONSISTENCY;
%page;
GET_CONTINUATION:
   proc (gc_p_file_oid, gc_p_ci, gc_p_offset, gc_p_continuation_datum_id);

      dcl	    gc_p_file_oid	       bit (36) aligned;
      dcl	    gc_p_ci	       fixed bin (27);
      dcl	    gc_p_offset	       fixed bin (21);
      dcl	    gc_p_continuation_datum_id
			       bit (36) aligned;
      dcl	    gc_code	       fixed bin (35);

      gc_code = 0;
      call file_manager_$simple_get (gc_p_file_oid, gc_p_ci, gc_p_offset, addr (gc_p_continuation_datum_id),
	 (CDCN_DATUM_HEADER_LENGTH_IN_BYTES), gc_code);
      if gc_code ^= 0
      then call ERROR_RETURN (gc_code);
      else return;


   end GET_CONTINUATION;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (8) aligned;
      dcl	    p_expected_version     char (8) aligned;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);


   end CHECK_VERSION;
%page;
%include dm_cm_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_element_id;
%page;
%include dm_cm_entry_dcls;
%page;
%include sub_err_flags;

   end cm_recursive_modify;




		    cm_replace_buffered_ci.pl1      01/04/85  0947.4re  01/03/85  1149.3       58428



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         This module implements collection_manager_$replace_ci_buffer.

         Puts  the  entire  collection_manager_-addressable  portion  of  the
     specified control interval.   The  caller  supplies  a buffer previously
     set up by cm_$setup_buffered_ci, and may use this control interval buffer
     in subsequent calls to collection_manager_$get_element_buffered.
*/

/* HISTORY:

Written by Matthew Pierret, 01/10/82.
Modified:
01/27/82 by Matthew Pierret: To use dm_error_$unimplemented_ci_version instead
            of error_table_$unimplemented_version.
01/24/84 by Matthew Pierret:  Added debugging entries for displaying previous
            and next control interval ids to help keep track of modifications
            of the control interval thread.
04/13/84 by Matthew Pierret:  Changed variable names p_control_interval_ptr
            and p_control_interval_length_in_bits to p_ci_buffer_ptr and
            p_ci_buffer_length to conform to documentation.  Also changed to
            copy p_ci_buffer_ptr into a local automatic variable.
10/08/84 by Matthew Pierret:  Added ERROR_RETURN. Removed unused variables,
            unneccessary call-by-values.  Changed to use 
            file_manager_$simple_put. Changed to use new sub_err_ flags.
*/

/* format: style2,ind3 */

cm_replace_buffered_ci:
   proc (p_file_opening_id, p_collection_id, p_control_interval_number, p_ci_buffer_ptr, p_ci_buffer_length_in_bits,
        p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_control_interval_number
			       fixed bin (24) unsigned parameter;
      dcl	    p_ci_buffer_ptr	       ptr parameter;
      dcl	    p_ci_buffer_length_in_bits
			       fixed bin (35) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    ci_buffer_length_in_bits
			       fixed bin (35);
      dcl	    ci_buffer_ptr	       ptr;
      dcl	    1 existing_bci_header  aligned like bci_header;

/* Based */
/* Builtin */

      dcl	    (addr, null)	       builtin;

/* Constant */

      dcl	    myname	       init ("cm_replace_buffered_ci") char (32) varying internal static options (constant);
      dcl	    BITS_PER_WORD	       init (9) fixed bin internal static options (constant);
      dcl	    START_OF_CI_OFFSET     init (0) fixed bin (21) internal static options (constant);

/* Entry */

      dcl	    file_manager_$simple_put
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    ioa_		       entry () options (variable);
      dcl	    cm_get_bci_header      entry (bit (36) aligned, uns fixed bin (24), ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$ci_not_in_collection,
	    dm_error_$ci_buffer_too_small,
	    dm_error_$unimplemented_ci_version
	    )		       fixed bin (35) ext;

/* Static */

      dcl	    static_trace_thread_switch
			       init ("0"b) bit (1) aligned internal static;

/* END OF DECLARATIONS */

      p_code, code = 0;
      ci_buffer_length_in_bits = p_ci_buffer_length_in_bits;
      ci_buffer_ptr = p_ci_buffer_ptr;

      call CHECK_CI_VERSION (ci_buffer_ptr -> bci_header.layout_type);

      if ci_buffer_ptr -> bci_header.collection_id ^= p_collection_id
      then call ERROR_RETURN (dm_error_$ci_not_in_collection);

      if ci_buffer_length_in_bits < CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES * BITS_PER_WORD
      then call ERROR_RETURN (dm_error_$ci_buffer_too_small);

/* If tracing ci thread modifications, compare next and previous with existing
   control header to see if anythng has changed. */

      if static_trace_thread_switch
      then
         do;
	  call cm_get_bci_header (p_file_opening_id, p_control_interval_number, addr (existing_bci_header), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  else call CHECK_CI_VERSION (existing_bci_header.layout_type);
	  if existing_bci_header.previous_control_interval ^= ci_buffer_ptr -> bci_header.previous_control_interval
	  then call ioa_ (
		  "Buffered control interval ^d changed during replacement.^/^8xPrevious control interval changed from ^d to ^d."
		  , p_control_interval_number, existing_bci_header.previous_control_interval,
		  ci_buffer_ptr -> bci_header.previous_control_interval);
	  if existing_bci_header.next_control_interval ^= ci_buffer_ptr -> bci_header.next_control_interval
	  then call ioa_ (
		  "Buffered control interval ^d changed during replacement.^/^8xNext control interval changed from ^d to ^d."
		  , p_control_interval_number, existing_bci_header.next_control_interval,
		  ci_buffer_ptr -> bci_header.next_control_interval);
         end;

/* Replace buffered control interval. */

      call file_manager_$simple_put (p_file_opening_id, (p_control_interval_number), START_OF_CI_OFFSET, ci_buffer_ptr,
	 (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES), code);
      if code ^= 0
      then call ERROR_RETURN (code);
      else
MAIN_RETURN:
         return;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      go to MAIN_RETURN;

   end ERROR_RETURN;

trace_thread_modifications_on:
   entry ();
      static_trace_thread_switch = "1"b;
      return;

trace_thread_modifications_off:
   entry ();
      static_trace_thread_switch = "0"b;
      return;
%page;
CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^4a control interval; received ^4a.", BASIC_CI_LAYOUT_1, ccv_p_given_version);
      else return;

   end CHECK_CI_VERSION;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_ci_lengths;
%page;
%include sub_err_flags;

   end cm_replace_buffered_ci;




		    cm_setup_buffered_ci.pl1        01/04/85  0947.4re  01/03/85  1149.5       43587



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         This module implements collection_manager_$setup_ci_buffer.

         Gets  the  entire  collection_manager_-addressable  portion  of  the
     specified control interval.   The  caller  supplies  a buffer for  the
     control  interval, and may use this control interval buffer in subsequent
     calls to collection_manager_$get_element_buffered.
*/

/* HISTORY:

Written by Matthew Pierret, 08/17/82.
Modified:
01/10/83 by Matthew Pierret:  Changed to refuse to setup ci if a continuation
            datum is present in the ci. Continuation datums are the source of
            some as-yet unsolved lost-update problems.
01/27/83 by Matthew Pierret:  Changed to use dm_error_$unimplemented_ci_version
04/13/84 by Matthew Pierret:  Changed p_control_interval_ptr and
            p_control_interval_length_in_bits to p_ci_buffer_ptr and
            p_ci_buffer_length_in_bits to conform to documentation.
10/08/84 by Matthew Pierret:  Changed to use ERROR_RETURN and to use local
            copies of parameters.  Change to use file_manager_$simple_get,
            eliminating the need for ci_parts.
*/

/* format: style2,ind3 */

cm_setup_buffered_ci:
   proc (p_file_opening_id, p_collection_id, p_control_interval_number, p_ci_buffer_ptr, p_ci_buffer_length_in_bits,
        p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_control_interval_number
			       fixed bin (24) unsigned parameter;
      dcl	    p_ci_buffer_ptr	       ptr parameter;
      dcl	    p_ci_buffer_length_in_bits
			       fixed bin (35) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    ci_buffer_length_in_bits
			       fixed bin (35);
      dcl	    ci_number	       fixed bin (27);
      dcl	    ci_ptr	       ptr;

/* Based */

      dcl	    based_bit_string       bit (ci_buffer_length_in_bits) based;

/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    myname	       init ("cm_setup_buffered_ci") char (32) varying internal static options (constant);
      dcl	    START_OF_CI_OFFSET     init (0) fixed bin (21) internal static options (constant);

/* Entry */

      dcl	    file_manager_$simple_get
			       entry (bit (36) aligned, fixed bin (27), fixed bin (21), ptr, fixed bin (21),
			       fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$cant_buffer_ci_continuations,
	    dm_error_$ci_not_in_collection,
	    dm_error_$ci_buffer_too_small,
	    dm_error_$unimplemented_ci_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code, code = 0;
      ci_ptr = null;
      ci_number = p_control_interval_number;
      ci_buffer_length_in_bits = p_ci_buffer_length_in_bits;
      if ci_buffer_length_in_bits < CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES * 9
      then call ERROR_RETURN (dm_error_$ci_buffer_too_small);

      ci_ptr = p_ci_buffer_ptr;
      call file_manager_$simple_get (p_file_opening_id, ci_number, START_OF_CI_OFFSET, ci_ptr,
	 (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES), code);
      if code ^= 0
      then call ERROR_RETURN (code);


      call CHECK_CI_VERSION (ci_ptr -> bci_header.layout_type);
      if ci_ptr -> bci_header.collection_id ^= p_collection_id
      then call ERROR_RETURN (dm_error_$ci_not_in_collection);
      else if ci_ptr -> bci_header.flags.continuation_datum_is_present
      then call ERROR_RETURN (dm_error_$cant_buffer_ci_continuations);


MAIN_RETURN:
      return;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      if ci_ptr ^= null
      then ci_ptr -> based_bit_string = ""b;
      go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_CI_VERSION:
   proc (ccv_p_given_version);

      dcl	    ccv_p_given_version    char (4) aligned;

      if ccv_p_given_version ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^4a control interval; received ^4a.", BASIC_CI_LAYOUT_1, ccv_p_given_version);
      else return;

   end CHECK_CI_VERSION;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_ci_lengths;
%page;
%include sub_err_flags;

   end cm_setup_buffered_ci;




		    cm_simple_get_element.pl1       01/04/85  0947.4re  01/03/85  1149.5       51516



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */



/* DESCRIPTION

        This module implements collection_manager_$simple_get_by_ci_ptr
   and collection_manager_$simple_get_from_ci_buffer.  The two entries
   behave identically.  Both exist to maintain symmetry of operations.

        This module copies the specified element (identified by
   p_element_id) from the given control interval to the caller's output
   buffer pointed to by p_buffer_ptr.  If the element does not fit in the
   buffer, i.e., the number of bytes required to hold the element is
   greater than the number of whole bytes in p_buffer_length,
   dm_error_$long_return_element is returned in the p_code parameter.
   
        The caller supplies a pointer (p_ci_ptr) to the control interval
   from which the element is to be copied.  This pointer may point to the
   actual control interval in the file or to a buffered copy of the
   control interval.  The former is obtained by calling
   collection_manager_$get_control_interval_pointer, the latter by calling
   collection_manager_$setup_ci_buffer.  The element must be wholely
   contained in the control interval, i.e., the element must be a single
   datum element.
*/

/* HISTORY:
Written by Matthew Pierret, 11/10/83.
   (63rd anniversary of O.S.Pierret's birth)
Modified:
04/13/84 by Matthew Pierret:  Changed name of p_buffered_ci_ptr to
            p_ci_buffer_ptr to conform to documentation.
10/04/84 by Matthew Pierret:  Changed bits-to-bytes calculation to
            bytes = divide (bits + BITS_PER_BYTE -1, BITS_PER_BYTE, 17, 0) from
            bytes = ceil (divide (bits, BITS_PER_BYTE, 35, 18)) as the former
            is more efficient.  Changed name to cm_simple_get_element from
            cm_simple_get_buf_element as it deals with both buffered and
            unbuffered elements.
*/

/* format: style2,ind3 */

cm_simple_get_element:
   proc (p_ci_buffer_ptr, p_collection_id, p_element_id, p_buffer_ptr, p_buffer_length, p_element_length, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_ci_buffer_ptr	       ptr;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_element_id	       bit (36) aligned;
      dcl	    p_buffer_ptr	       ptr;
      dcl	    p_buffer_length	       fixed bin (35);
      dcl	    p_element_length       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    buffer_length_in_bytes fixed bin (17);
      dcl	    datum_contents_length_in_bytes
			       fixed bin (17);
      dcl	    datum_contents_offset_in_bytes
			       fixed bin (17);
      dcl	    datum_slot_index       fixed bin (17);

      dcl	    buffer_ptr	       ptr;

/* Based */

      dcl	    datum_contents_string  char (datum_contents_length_in_bytes) based;

/* Builtin */

      dcl	    (addcharno, addr, divide, null)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("cm_simple_get_element") char (32) varying internal static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin int static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$ci_not_in_collection,
	    dm_error_$no_element,
	    dm_error_$unimplemented_ci_version,
	    dm_error_$long_return_element
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code = 0;

      datum_slot_index = addr (p_element_id) -> element_id.index;

      basic_control_interval_ptr = p_ci_buffer_ptr;

      if basic_control_interval.header.layout_type ^= BASIC_CI_LAYOUT_1
      then call sub_err_ (dm_error_$unimplemented_ci_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected a control interval with a layout type of ""^a"";^/received layout ""^a"".", BASIC_CI_LAYOUT_1,
	      basic_control_interval.header.layout_type);

      if basic_control_interval.header.collection_id ^= p_collection_id
      then call ERROR_RETURN (dm_error_$ci_not_in_collection);

      buffer_ptr = p_buffer_ptr;
      buffer_length_in_bytes = divide (p_buffer_length, BITS_PER_BYTE, 17, 0);

      datum_contents_offset_in_bytes = basic_control_interval.datum_position_table (datum_slot_index).offset_in_bytes;
      if datum_contents_offset_in_bytes = FREE_SLOT
      then call ERROR_RETURN (dm_error_$no_element);

      datum_contents_length_in_bits = basic_control_interval.datum_position_table (datum_slot_index).length_in_bits;
      if datum_contents_length_in_bits > buffer_length_in_bytes * BITS_PER_BYTE
      then call ERROR_RETURN (dm_error_$long_return_element);

      datum_contents_length_in_bytes = divide (datum_contents_length_in_bits + BITS_PER_BYTE - 1, BITS_PER_BYTE, 17, 0);

      /*** Copy the datum. */

      buffer_ptr -> datum_contents_string =
	 addcharno (basic_control_interval_ptr, datum_contents_offset_in_bytes) -> datum_contents_string;

      p_element_length = datum_contents_length_in_bits;
RETURN:
      return;
%page;
FINISH:
   proc ();

   end FINISH;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH ();
      goto RETURN;

   end ERROR_RETURN;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_cm_datum;
%page;
%include dm_cm_datum_constants;
%page;
%include dm_element_id;
%page;
%include sub_err_flags;

   end cm_simple_get_element;




		    collection_manager_.alm         04/04/85  1112.8re  04/04/85  0824.1       39573



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
	name	collection_manager_
"
" Written by Matthew Pierret, 02/01/82.
" Modified:
" 12/15/82 by Lindsey Spratt:  Fixed get_element_portion to refer to
"	    cm_get_element_portion$cm_get_element_portion.
" 12/17/82 by Matthew Pierret: Added cm_$id.
" 01/07/83 by Matthew Pierret: Added cm_$put_element_buffered and
"             cm_$allocate_element_buffered.
" 01/10/83 by Matthew Pierret: Added cm_$replace_buffered_ci, 
"             cm_$cm_free_elemnt_buffered.
" 04/27/83 by Matthew Pierret: Added cm_$put_unprotected_element,
"             cm_$put_unprotected_header.
" 11/07/83 by Matthew Pierret: Added cm_$get_element_portion_buffered.
"             Removed cm_$find_initial. Added cm_$simple_get_buffered_element.
" 03/16/84 by Matthew Pierret: Added cm_$get_control_interval_ptr,
"             cm_$simple_get_element_ptr.
" 04/03/84 by Matthew Pierret: Added cm_$compact_control_interval.
" 05/23/84 by Lee A. Newcomb:  commented out put_element_portion
"	    pending an updated implementation.
" 06/06/84 by Matthew Pierret: Re-named free_element* to delete and
"             delete_from_ci_buffer.
"             Re-named *_buffered_ci to =_ci_buffer.
"             Re-named simple_* to simple_get_(by_ci_ptr from_ci_buffer).
"             Re-named get_element* to appropriate enw names.
"             Re-named put_element* to modify<whatever>, and changed the
"             target module cm_put_element to cm_modify.
"             Re-named allocate_element* to put<whatever>, and changed the
"             target module cm_allocate_element to cm_put.
" 07/18/84 by Matthew Pierret: Added cm_$get_by_ci_ptr.
" 10/08/84 by Matthew Pierret: Re-named module names as follows:
"             cm_free_element -> cm_delete,
"             cm_free_element_buffered -> cm_delete_buffered,
"             cm_simple_get_buf_element -> cm_simple_get_element.
" 03/07/84 by R. Michael Tague: Added cm_postcommit_increment.
"
" Macro to generate a call to an external entrypoint in the manager

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

	ext_transfer allocate_control_interval,cm_allocate_ci$cm_allocate_ci

          ext_transfer compact_control_interval,cm_compact_ci$cm_compact_ci

	ext_transfer create_collection,cm_create_collection$cm_create_collection

          ext_transfer create_file,cm_create_file$cm_create_file

	ext_transfer destroy_collection,cm_destroy_collection$cm_destroy_collection

	ext_transfer free_control_interval,cm_free_ci$cm_free_ci

	ext_transfer delete,cm_delete$cm_delete

	ext_transfer delete_from_ci_buffer,cm_delete_buffered$cm_delete_buffered

	ext_transfer get,cm_get_element$cm_get_element

	ext_transfer get_control_interval_ptr,cm_get_ci_ptr$cm_get_ci_ptr

          ext_transfer get_by_ci_ptr,cm_get_element$by_ci_ptr

          ext_transfer get_from_ci_buffer,cm_get_element_buffered$whole

	ext_transfer get_header,cm_get_header$cm_get_header

          ext_transfer get_id,cm_get_id$id

	ext_transfer get_portion,cm_get_element_portion$cm_get_element_portion

"         ext_transfer get_portion_by_ci_ptr,cm_get_element_portion$ptr

          ext_transfer get_portion_from_ci_buffer,cm_get_element_buffered$portion

	ext_transfer modify,cm_modify$cm_modify

	ext_transfer modify_unprotected,cm_modify$unprotected

	ext_transfer modify_in_ci_buffer,cm_modify$buffered

" Commented out pending an updated version of target that works
"	ext_transfer modify_portion,cm_modify_portion$cm_modify_portion

	ext_transfer postcommit_increments,cm_postcommit_increment$cm_postcommit_increment

	ext_transfer put,cm_put$cm_put

	ext_transfer put_in_ci_buffer,cm_put$buffered

	ext_transfer put_header,cm_put_header$cm_put_header

	ext_transfer put_unprotected_header,cm_put_header$unprotected

          ext_transfer replace_ci_buffer,cm_replace_buffered_ci$cm_replace_buffered_ci

          ext_transfer setup_ci_buffer,cm_setup_buffered_ci$cm_setup_buffered_ci

	ext_transfer simple_get_by_ci_ptr,cm_simple_get_element$cm_simple_get_element

          ext_transfer simple_get_from_ci_buffer,cm_simple_get_element$cm_simple_get_element



	end




		    data_format_util_.alm           01/04/85  0947.4re  01/03/85  1149.5       26289



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
	name	data_format_util_
"
" Written by Matthew Pierret, 04/12/83.
"
" Modified:
" 12/13/82 by Lindsey Spratt: Changed to reference
"	    dmu_get_data_bit_length$dmu_get_data_bit_length.
" 02/09/83 by Lindsey Spratt: Changed cv_string_to_vector to reference
"	    dmu_cv_string_to_vector$old, add a (temporary) new entry named
"	    new_cv_string_to_vector which references
"	    dmu_cv_string_to_vector$new.
" 03/23/83 by Lindsey Spratt: Set up the compare_(vector_to_string
"	    string_to_string dim_to_field field_to_field) entries.
" 05/06/83 by Lindsey Spratt: Added the display_string entry.
" 10/14/83 by Matthew Pierret: Changed from data_mgmt_util_ to 
"             data_format_util_.  Added dim_table entries.
" 09/19/84 by Matthew Pierret: Changed targets to be module_name$module_name
"             instead of module_name$module_name_minus_prefix.
"
"
" Macro to generate a call to an external entrypoint in the manager

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

          ext_transfer build_sequential_spec,dmu_build_sequential_spec$dmu_build_sequential_spec
          ext_transfer cv_dim_to_dim_table,dfu_cv_dim_to_dim_table$dfu_cv_dim_to_dim_table
          ext_transfer cv_dim_to_field_table,dfu_cv_dim_to_field_table$dfu_cv_dim_to_field_table
          ext_transfer cv_field_to_dim_table,dfu_cv_field_to_dim_table$dfu_cv_field_to_dim_table
          ext_transfer cv_attr_to_dim_table,dfu_cv_attr_to_dim_table$dfu_cv_attr_to_dim_table
          ext_transfer cv_tva_to_dim_table,dfu_cv_tva_to_dim_table$dfu_cv_tva_to_dim_table
	ext_transfer cv_typed_array_to_table,dmu_cv_typed_array_to_table$dmu_cv_typed_array_to_table
	ext_transfer cv_table_to_typed_array,dmu_cv_table_to_typed_array$dmu_cv_table_to_typed_array
	ext_transfer cv_string_to_vector,dmu_cv_string_to_vector$old
	ext_transfer new_cv_string_to_vector,dmu_cv_string_to_vector$new
	ext_transfer cv_vector_to_string,dmu_cv_vector_to_string$dmu_cv_vector_to_string
	ext_transfer compare_string_to_string,dmu_compare_strings$dmu_compare_strings
	ext_transfer compare_vector_to_string,dmu_compare_vector_to_str$dmu_compare_vector_to_str
	ext_transfer compare_dim_to_field,dmu_compare_values$dmu_compare_values
	ext_transfer compare_field_to_field,dmu_compare_values$field_to_field
          ext_transfer compare_sequential,dmu_compare_sequential$dmu_compare_sequential
          ext_transfer general_modify_string,dmu_general_modify_string$dmu_general_modify_string
	ext_transfer get_data_bit_length,dmu_get_data_bit_length$dmu_get_data_bit_length
	ext_transfer display_string,dmu_display_string$dmu_display_string

	end





		    dfu_cv_attr_to_dim_table.pl1    10/24/88  1636.9r w 10/24/88  1400.1       73062



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

         This  routine  creates  a  dimension_table  structure.  The name  and
     descriptor for each dimension is gotten  selectively  from  the  supplied
     attribute_info   structure,  with  those  attributes  identified  by  the
     supplied    id_list    structure    being    selected.         If     the
     p_include_element_id_dimension   flag   is  on,  the  last  dimension  is
     constructed with the name "0" and a descriptor for a 'bit  (36)  aligned'
     field.
*/

/* HISTORY:

Written by Matthew Pierret, 08/24/83.
Modified:
11/28/83 by Matthew Pierret:  Changed to interpret id_list.id of -1 as meaning
            the element id.
12/07/84 by Maggie Sharpe:  to correct format and dcls; to change
            the call to CHANGE_VERSION_FB to pass appropriate arg
            by reference instead of value.
*/

/* format: style2,ind3 */

dfu_cv_attr_to_dim_table:
   proc (p_work_area_ptr, p_attribute_info_ptr, p_id_list_ptr, p_add_element_id_dimension, p_dimension_table_ptr);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_work_area_ptr	       ptr;		/*is a pointer to a work area.*/
      dcl	    p_attribute_info_ptr   ptr;		/*is a pointer to an attribute_info structure.*/
      dcl	    p_id_list_ptr	       ptr;		/*is a ponter to an id_list structure.*/
      dcl	    p_add_element_id_dimension
			       bit (1) aligned;	/*if on indicates that the last dimension */
						/* is to be set up as for an element_id.*/
      dcl	    p_dimension_table_ptr  ptr;		/*is a pointer to the dimension_table structure */
						/* created.*/

/* Automatic */

      dcl	    (attribute_idx, dimension_idx)
			       fixed bin (35) init (-1);

/* Based */

      dcl	    p_work_area	       area (10000) based (p_work_area_ptr);

/* Builtin */

      dcl	    (addr, fixed, hbound,
	     null, unspec)	       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("dfu_cv_attr_to_dim_table") char (32) varying internal static
			       options (constant);
      dcl	    ELEMENT_ID_ID	       init (-1) fixed bin internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_dimension_table_ptr = null;

      if p_work_area_ptr = null
      then call
	    sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	    "^/The first argument, an area pointer, is null.");
						/* FOR DM_ERROR_UTIL_:

	    dm_error_util_$signal (dm_error_$programming_error, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
	    "^/The first argument, an area pointer, is null.");
*/

      attribute_info_ptr = p_attribute_info_ptr;
      call CHECK_VERSION ((attribute_info.version), (ATTRIBUTE_INFO_VERSION_1), "attribute_info");

      if p_id_list_ptr = null
      then dt_number_of_dimensions = hbound (attribute_info.attribute, 1);
      else
         do;
	  id_list_ptr = p_id_list_ptr;
	  call CHECK_VERSION_FB (id_list.version, (ID_LIST_VERSION_1), "id_list");
	  dt_number_of_dimensions = hbound (id_list.id, 1);
         end;

      if p_add_element_id_dimension
      then dt_number_of_dimensions = dt_number_of_dimensions + 1;

      dt_maximum_dimension_name_length = attribute_info.maximum_attribute_name_length;

      on cleanup call FINISH ();

      alloc dimension_table in (p_work_area);

      do dimension_idx = 1 to hbound (dimension_table.dimension, 1) - fixed (p_add_element_id_dimension);
         if id_list_ptr = null
         then attribute_idx = dimension_idx;
         else if id_list.id (dimension_idx) = ELEMENT_ID_ID
         then call INIT_ELEMENT_ID_DIMENSION (dimension_idx);
         else
	  do;
	     do attribute_idx = 1 to hbound (attribute_info.attribute, 1)
	        while (attribute_idx ^= id_list.id (dimension_idx));
	     end;
	     if attribute_idx > hbound (attribute_info.attribute, 1)
	     then call
		   sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		   "^/The specified attribute id, ^d, is not recorded in attribute_info.", id_list.id (dimension_idx))
		   ;				/* FOR DM_ERROR_UTIL_:

		   dm_error_util_$signal (dm_error_$programming_error, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
		   "^/The specified attribute id, ^d, is not recorded in attribute_info.", id_list.id (dimension_idx))
		   ;
*/
	  end;

         dimension_table.dimension (dimension_idx).name = attribute_info.attribute (attribute_idx).name;
         dimension_table.dimension (dimension_idx).descriptor_ptr =
	  addr (dimension_table.dimension (dimension_idx).descriptor_string);
         dimension_table.dimension (dimension_idx).descriptor_string =
	  attribute_info.attribute (attribute_idx).descriptor;
      end;

      if p_add_element_id_dimension
      then call INIT_ELEMENT_ID_DIMENSION (dimension_idx);

      p_dimension_table_ptr = dimension_table_ptr;

      return;
%page;
FINISH:
   proc ();

      if dimension_table_ptr ^= null
      then if p_dimension_table_ptr = null
	 then free dimension_table;

   end FINISH;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (*);
      dcl	    p_expected_version     char (*);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);
						/* FOR DM_ERROR_UTIL_:

	    dm_error_util_$signal (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS
	    "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);
*/
   end CHECK_VERSION;



CHECK_VERSION_FB:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
						/* FOR DM_ERROR_UTIL_: 

	    dm_error_util_$signal (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS, 
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
*/
   end CHECK_VERSION_FB;
%page;
INIT_ELEMENT_ID_DIMENSION:
   proc (ieid_p_dimension_idx);

      dcl	    ieid_p_dimension_idx   fixed bin (35);

      dimension_table.dimension (ieid_p_dimension_idx).name = "0";
      arg_descriptor_ptr = addr (dimension_table.dimension (ieid_p_dimension_idx).descriptor_string);
      dimension_table.dimension (ieid_p_dimension_idx).descriptor_ptr = arg_descriptor_ptr;
      unspec (arg_descriptor) = "0"b;
      fixed_arg_descriptor.flag = "1"b;
      fixed_arg_descriptor.type = bit_dtype;
      fixed_arg_descriptor.precision = 36;

      return;

%page;	%include arg_descriptor;
%page;	%include std_descriptor_types;
   end INIT_ELEMENT_ID_DIMENSION;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_id_list;
%page;
%include vu_dimension_table;
%page;
%include sub_err_flags;
   end dfu_cv_attr_to_dim_table;




		    dfu_cv_dim_to_dim_table.pl1     01/04/85  0947.4re  01/03/85  1149.6      111690



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

   Allocate  a dimension_table with the extents supplied by the caller,  and
   selectively  copy  entries  from  the input dimension_table to the output
   dimension_table.   The id_list supplied by the caller is used to identify
   those dimensions to be copied.  If the  output  dimension_table  contains
   more  dimensions  than  the  input  dimension_table,  the entries for the
   excess dimensions are initialized to null values.
*/

/* HISTORY:

Written by Matthew Pierret, 10/04/83.
Modified:
12/07/84 by M. Sharpe:  to clean up format and dcls; to correct calls to
	  CHECK_VERSION* to pass appropriate args by reference.
*/

/* format: style2,ind3,^indblkcom */

dfu_cv_dim_to_dim_table:
   proc (p_work_area_ptr, p_number_of_dimensions, p_maximum_dimension_name_length, p_id_list_ptr,
      p_input_dimension_table_ptr, p_output_dimension_table_ptr);


/* START OF DECLARATIONS */

/* format: ll132 */

/* Parameter */

      dcl	    p_work_area_ptr	       ptr;		/* points to the area in which
						   to allocate
						   output_dimension_table. */
      dcl	    p_number_of_dimensions fixed bin (35);	/* is the number_of_dimensions
						   in output_dimension_table.  If
						   -1, the number of dimensions
						   is the same as in
						   input_dimension_table. */
      dcl	    p_maximum_dimension_name_length
			       fixed bin (35);	/* is the maximum dimension
						   name length for
						   output_dimension_table.  If
						   -1, the maximum dimension name
						   length for
						   input_dimension_table is
						   used. */
      dcl	    p_id_list_ptr	       ptr;		/* points to an id_list which
						   identifies the dimensions in
						   input_dimension_table to copy
						   to output_dimension_table.
						   The ids are the index in
						   input_dimension_table of the
						   dimensions.  If p_id_list_ptr
						   is null, copy all of the
						   dimensions. */
      dcl	    p_input_dimension_table_ptr
			       ptr;		/* points to the
						   dimension_table from which
						   dimensions are copied.  If
						   null, the
						   output_dimension_table is
						   empty. */
      dcl	    p_output_dimension_table_ptr
			       ptr;		/* points to the newly
						   allocated dimension_table. */

/* Automatic */

      dcl	    (dimension_idx, dimension_to_copy, number_of_dimensions_to_copy)
			       fixed bin (35);
      dcl	    (input_dimension_table_ptr, work_area_ptr)
			       ptr;

/* Based */

      dcl	    work_area	       area (sys_info$max_seg_size) based (work_area_ptr);

/* Builtin */

      dcl	    (addr, hbound, max, null)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("dfu_cv_dim_to_dim_table") char (32) varying internal static options (constant);
      dcl	    (
	    USE_DEFAULT_NUMBER_OF_DIMENSIONS
			       init (-1),
	    USE_DEFAULT_MAXIMUM_DIMENSION_NAME_LENGTH
			       init (-1)
	    )		       fixed bin (35) internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);
						/* FOR DM_ERROR_UTIL_: Replace preceding statement with following */
						/*    dcl	    dm_error_util_$signal  entry () options (variable); */

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;
      dcl	    sys_info$max_seg_size  fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_output_dimension_table_ptr = null;

      work_area_ptr = p_work_area_ptr;

      input_dimension_table_ptr = p_input_dimension_table_ptr;
      if input_dimension_table_ptr = null
      then
         do;

         /*** No input_dimension_table is supplied. Set the extents from the parameters. */

	  dt_number_of_dimensions = p_number_of_dimensions;
	  dt_maximum_dimension_name_length = p_maximum_dimension_name_length;
         end;
      else
         do;

         /*** An input_dimension_table is supplied.  Verify its version. */

	  call
	     CHECK_VERSION ((input_dimension_table_ptr -> dimension_table.version), DIMENSION_TABLE_VERSION_1,
	     "dimension_table");

         /*** Set up extents for output dimension_table. */

	  if p_number_of_dimensions = USE_DEFAULT_NUMBER_OF_DIMENSIONS
	  then dt_number_of_dimensions = input_dimension_table_ptr -> dimension_table.number_of_dimensions;
						/* Get number of dimensions from input_dimension_table. */
	  else dt_number_of_dimensions = p_number_of_dimensions;
						/* Get number_of_dimensions from parameter. */

	  if p_maximum_dimension_name_length = USE_DEFAULT_MAXIMUM_DIMENSION_NAME_LENGTH
	  then dt_maximum_dimension_name_length = input_dimension_table_ptr -> dimension_table.maximum_dimension_name_length;
						/* Get maximum_dimension_name_length from input_dimension_table. */
	  else dt_maximum_dimension_name_length =
		max (p_maximum_dimension_name_length,
		input_dimension_table_ptr -> dimension_table.maximum_dimension_name_length);
						/* Use larger of parameter and input_dimension_table. */

         /*** Set up id_list structure. This is done only in this do-group because
	    an id_list is useless if no input dimension_table is specified. */

	  id_list_ptr = p_id_list_ptr;
	  if id_list_ptr = null
	  then
	     do;
	        number_of_dimensions_to_copy = input_dimension_table_ptr -> dimension_table.number_of_dimensions;
	        if number_of_dimensions_to_copy > dt_number_of_dimensions
	        then call
		      sub_err_ (0, myname, ACTION_CANT_RESTART, null, 0,
		      "The caller specified that all ^d dimensions in the input^/dimension_table be copied into the output dimension_table;^/that table can only hold ^d dimensions."
		      , number_of_dimensions_to_copy, dt_number_of_dimensions);

/*
	FOR DM_ERROR_UTIL_: Replace preceding statement with following

	        then call dm_error_util_$signal (0, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
		"The caller specified that all ^d dimensions in the input^/dimension_table be copied into the output dimension_table;^/that table can only hold ^d dimensions.",
		number_of_dimensions_to_copy, dt_number_of_dimensions);
*/
	     end;
	  else
	     do;
	        call CHECK_VERSION_FB (id_list.version, (ID_LIST_VERSION_1), "id_list");
	        number_of_dimensions_to_copy = id_list.number_of_ids;
	        if number_of_dimensions_to_copy > dt_number_of_dimensions
	        then call
		      sub_err_ (0, myname, ACTION_CANT_RESTART, null, 0,
		      "The caller-specified id_list contains ^d dimension identifiers^/but the output dimension_table can only hold ^d dimensions."
		      , number_of_dimensions_to_copy, dt_number_of_dimensions);
/*
	FOR DM_ERROR_UTIL_: Replace preceding statement with following

	        then call dm_error_util_$signal
		   (0, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
		   "The caller-specified id_list contains ^d dimension identifiers^/but the output dimension_table can only hold ^d dimensions.",
		   number_of_dimensions_to_copy, dt_number_of_dimensions);

*/
	        if number_of_dimensions_to_copy > input_dimension_table_ptr -> dimension_table.number_of_dimensions
	        then call
		      sub_err_ (0, myname, ACTION_CANT_RESTART, null, 0,
		      "The caller-specified id_list contains ^d dimension identifiers^/but the input dimension_table can only hold ^d dimensions."
		      , number_of_dimensions_to_copy, dt_number_of_dimensions);
/*
	FOR DM_ERROR_UTIL_: Replace preceding statement with following

		then call dm_error_util_$signal (0, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
		"The caller-specified id_list contains ^d dimension identifiers^/but the input dimension_table can only hold ^d dimensions.",
		number_of_dimensions_to_copy, dt_number_of_dimensions);
*/
	     end;
         end;

   /*** Allocate output dimension_table. */

      on cleanup call FINISH ();

      allocate dimension_table in (work_area);

      if input_dimension_table_ptr ^= null
      then
COPY:
         do dimension_idx = 1 to number_of_dimensions_to_copy;
	  if id_list_ptr = null
	  then dimension_to_copy = dimension_idx;
	  else if id_list.id (dimension_idx) >= 1
		& id_list.id (dimension_idx) <= hbound (input_dimension_table_ptr -> dimension_table.dimension, 1)
	  then dimension_to_copy = id_list.id (dimension_idx);
	  else call
		sub_err_ (0, myname, ACTION_CANT_RESTART, null, 0,
		"^/The id_list used to identify dimensions to copy from one dimension_table^/to another contains an identifier, ^d, that does not identify a dimension^/in the input dimension_table."
		, (id_list.id (dimension_idx)));
/*
	FOR DM_ERROR_UTIL_: Replace preceding statement with following

	       else call dm_error_util_$signal (0, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
	       "^/The id_list used to identify dimensions to copy from one dimension_table^/to another contains an identifier, ^d, that does not identify a dimension^/in the input dimension_table.",
	       (id_list.id (dimension_idx)));
*/
	  dimension_table.dimension (dimension_idx).name =
	     input_dimension_table_ptr -> dimension_table.dimension (dimension_to_copy).name;
	  dimension_table.dimension (dimension_idx).descriptor_string =
	     input_dimension_table_ptr -> dimension_table.dimension (dimension_to_copy).descriptor_string;
	  dimension_table.dimension (dimension_idx).cv_to_print =
	     input_dimension_table_ptr -> dimension_table.dimension (dimension_to_copy).cv_to_print;
	  dimension_table.dimension (dimension_idx).cv_to_typed =
	     input_dimension_table_ptr -> dimension_table.dimension (dimension_to_copy).cv_to_typed;
	  if input_dimension_table_ptr -> dimension_table.dimension (dimension_to_copy).descriptor_ptr
	     = addr (input_dimension_table_ptr -> dimension_table.dimension (dimension_to_copy).descriptor_string)
	  then dimension_table.dimension (dimension_idx).descriptor_ptr =
		addr (dimension_table.dimension (dimension_idx).descriptor_string);
	  else ;					/* Allocate new descriptor. */
         end COPY;

      p_output_dimension_table_ptr = dimension_table_ptr;

      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);

      dcl	    p_received_version     char (*);
      dcl	    p_expected_version     char (*);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);
/*
	FOR DM_ERROR_UTIL_:

      dm_error_util_$signal (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
        "^/Expected version ^a of the ^a structure.^/Received version ^a instead.",
        p_expected_version, p_structure_name, p_received_version);
*/
   end CHECK_VERSION;


CHECK_VERSION_FB:
   proc (p_received_version, p_expected_version, p_structure_name);

      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
/*

        FOR DM_ERROR_UTIL_: Replace preceding statement with following

        then call dm_error_util_$signal (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
        "^/Expected version ^d of the ^a structure.^/Received version ^d instead.",
        p_expected_version, p_structure_name, p_received_version);

*/

   end CHECK_VERSION_FB;
%page;
FINISH:
   proc ();

      if dimension_table_ptr ^= null
      then free dimension_table;

   end FINISH;
%page;
%include vu_dimension_table;
%page;
%include dm_id_list;
%page;
%include sub_err_flags;
   end dfu_cv_dim_to_dim_table;




		    dfu_cv_dim_to_field_table.pl1   01/04/85  0947.4re  01/03/85  1149.6       88821



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         Given  a  pointer to a dimension_table, convert that dimension_table
     into a field_table.  The caller provides a pointer to the area  in  which
     to  allocate  the field_table.  In addition to returning a pointer to the
     newly allocated field_table, this  routine  returns  the  length  of  the
     largest possible record represented by the field_table, in bits.
*/

/* HISTORY:

Written by Matthew Pierret, 08/25/83.
Modified:
05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.  Changed to
            align fields in string.
09/12/84 by Matthew C. Pierret:  Changed the SET_FIELD_LOCATIONS loop to set
            the location after calculating what the location is, instead of
            before.  Added a prefix on each variable local to an internal
            subroutine.  Changed the format style from style2,ind3, so
            reformat before comparing with old version.
12/10/84 by R. Michael Tague:  Addressed auditing comments.
*/

/* format: style2,ind3 */
/* format: ll79,comcol50,indcomtxt,^indnoniterdo,indnoniterend,^indprocbody */

dfu_cv_dim_to_field_table:
   proc (p_work_area_ptr, p_dimension_table_ptr, p_field_table_ptr,
        p_maximum_record_length);


/* START OF DECLARATIONS */
/* Parameter */

   dcl	 p_work_area_ptr	    ptr;	         /* is a pointer to an area in */
				         /* which to allocate the field_table */
   dcl	 p_dimension_table_ptr  ptr;	         /* is a pointer to the input */
				         /* dimension_table. */
   dcl	 p_field_table_ptr	    ptr;	         /* is the pointer to the newly */
				         /* created field_table. */
   dcl	 p_maximum_record_length
			    fixed bin (35);/* is the length of the largest record */
				         /* record that can possibly be represented */
				         /* by the field_table. */

/* Automatic */

   dcl	 alignment	    fixed bin;
   dcl	 bits_past_alignment_boundary
			    fixed bin;
   dcl	 field_idx	    fixed bin;
   dcl	 position_in_varying_fields
			    fixed bin;
   dcl	 (code, location_of_next_field, varying_field_portion_length,
	 field_length_in_bits)  fixed bin (35);

/* Based */

   dcl	 p_work_area	    area (10000) based (p_work_area_ptr);

/* Builtin */

   dcl	 (addr, hbound, mod, null, rtrim, string)
			    builtin;

/* Condition */

   dcl	 cleanup		    condition;

/* Constant */

   dcl	 myname		    init ("dfu_cv_dim_to_field_table")
			    char (32) varying internal static
			    options (constant);
   dcl	 MAXIMUM_LENGTH_HELD_IN_ONE_BYTE
			    fixed bin (35) int static
			    options (constant)
			    init (511 /* 2 ** 9 - 1 */);
   dcl	 MAXIMUM_LENGTH_HELD_IN_TWO_BYTES
			    fixed bin (35) int static
			    options (constant)
			    init (262143511 /* 2 ** 18 - 1 */);
   dcl	 ONE_BYTE		    fixed bin int static options (constant)
			    init (9);
   dcl	 TWO_BYTES	    fixed bin int static options (constant)
			    init (18);
   dcl	 FOUR_BYTES	    fixed bin int static options (constant)
			    init (36);

/* Entry */

   dcl	 sub_err_		    entry () options (variable);
   dcl	 dmu_get_data_bit_length$alignment
			    entry (bit (36) aligned, fixed bin (35),
			    fixed bin (17), fixed bin (35));

/* External */

   dcl	 dm_error_$programming_error
			    fixed bin (35) ext;
   dcl	 error_table_$unimplemented_version
			    fixed bin (35) ext;

/* END OF DECLARATIONS */

   code = 0;
   p_field_table_ptr, field_table_ptr = null;

   dimension_table_ptr = p_dimension_table_ptr;
   call CHECK_VERSION ((dimension_table.version), DIMENSION_TABLE_VERSION_1,
        "dimension_table");

   ft_number_of_fields = dimension_table.number_of_dimensions;
   ft_length_of_field_names = 0;
   do field_idx = 1 to ft_number_of_fields;
      ft_length_of_field_names =
	 ft_length_of_field_names
	 + length (dimension_table.dimension (field_idx).name);
   end;

   on cleanup call FINISH ();

   alloc field_table in (p_work_area);
   field_table.field_names = "";

SET_NAME_AND_DESCRIPTOR:
   do field_idx = 1 to hbound (field_table.field, 1);
      field_table.field (field_idx).location_of_name =
	 length (rtrim (field_table.field_names)) + 1;
      field_table.field (field_idx).length_of_name =
	 length (dimension_table.dimension (field_idx).name);
      field_table.field_names =
	 rtrim (field_table.field_names)
	 || dimension_table.dimension (field_idx).name;

      if dimension_table.dimension (field_idx).descriptor_ptr
	 ^= addr (dimension_table.dimension (field_idx).descriptor_string)
      then call sub_err_ (dm_error_$programming_error, myname,
	      ACTION_CANT_RESTART, null, 0, "^/^10x^a^/^10x^a",
	      "A potentially multiple-word descriptor was supplied for a field."
	      ,
	      "Currently only single word descriptors are supported in the field_table."
	      );

      field_table.field (field_idx).descriptor =
	 dimension_table.dimension (field_idx).descriptor_string;
      string (field_table.field (field_idx).flags) = "0"b;
   end SET_NAME_AND_DESCRIPTOR;

   position_in_varying_fields = 0;
SETUP_VARYING_FIELD_MAP:
   do field_idx = 1 to hbound (field_table.field, 1);
      if FIELD_IS_VARYING (field_table.field (field_idx).descriptor)
      then
         do;
         field_table.field (field_idx).flags.length_is_in_characters =
	    FIELD_IS_CHARACTER_VARYING (field_table.field (field_idx)
	    .descriptor);
         position_in_varying_fields = position_in_varying_fields + 1;
         field_table.varying_field_map (position_in_varying_fields).field_id =
	    field_idx;
         field_table.varying_field_map (field_idx).varying_field_index =
	    position_in_varying_fields;
         end;
   end SETUP_VARYING_FIELD_MAP;

   location_of_next_field = 1;
   varying_field_portion_length = 0;
SET_FIELD_LOCATIONS:
   do field_idx = 1 to hbound (field_table.field, 1);
      call dmu_get_data_bit_length$alignment (field_table.field (field_idx)
	 .descriptor, field_length_in_bits, alignment, code);
      if code ^= 0
      then call sub_err_ (code, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Error encountered attempting to get the length in bits of field ^d, ^/with descriptor of ^3bo."
	      , field_idx, field_table.field (field_idx).descriptor);

      bits_past_alignment_boundary =
	 mod (location_of_next_field - 1, alignment);
      if bits_past_alignment_boundary > 0
      then location_of_next_field =
	      location_of_next_field + alignment
	      - bits_past_alignment_boundary;
      field_table.field (field_idx).location = location_of_next_field;

      if field_table.varying_field_map (field_idx).varying_field_index = 0
      then field_table.field (field_idx).length_in_bits = field_length_in_bits;
      else
         do;
         if field_length_in_bits < MAXIMUM_LENGTH_HELD_IN_ONE_BYTE
         then field_table.field (field_idx).length_in_bits = ONE_BYTE;
         else if field_length_in_bits < MAXIMUM_LENGTH_HELD_IN_TWO_BYTES
         then field_table.field (field_idx).length_in_bits = TWO_BYTES;
         else field_table.field (field_idx).length_in_bits = FOUR_BYTES;

         varying_field_portion_length =
	    varying_field_portion_length + field_length_in_bits;
         end;
      location_of_next_field =
	 location_of_next_field
	 + field_table.field (field_idx).length_in_bits;

   end SET_FIELD_LOCATIONS;
   field_table.location_of_first_varying_field = location_of_next_field;

   p_field_table_ptr = field_table_ptr;
   p_maximum_record_length =
        location_of_next_field + varying_field_portion_length;

   return;
%page;
FINISH:
   proc ();

   if field_table_ptr ^= null & field_table_ptr ^= p_field_table_ptr
   then free field_table;

   end FINISH;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
   dcl	 cv_p_received_version  char (8);
   dcl	 cv_p_expected_version  char (8);
   dcl	 cv_p_structure_name    char (*);

   if cv_p_received_version ^= cv_p_expected_version
   then call sub_err_ (error_table_$unimplemented_version, myname,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected version ^a of the ^a structure.^/Received version ^a instead."
	   , cv_p_expected_version, cv_p_structure_name,
	   cv_p_received_version);
   else return;

   end CHECK_VERSION;
%page;
FIELD_IS_VARYING:
   proc (fiv_p_descriptor_string) returns (bit (1) aligned);

   dcl	 fiv_p_descriptor_string
			    bit (36) aligned;
   dcl	 1 fiv_descriptor_type  unal based (addr (fiv_p_descriptor_string)),
	   2 unused1	    bit (1) unal,
	   2 type		    fixed bin (6) unsigned unal,
	   2 unused2	    bit (29) unal;
   dcl	 BIT_VARYING	    fixed bin (6) unsigned init (20);
   dcl	 CHAR_VARYING	    fixed bin (6) init (22);

   if fiv_descriptor_type.type = BIT_VARYING
        | fiv_descriptor_type.type = CHAR_VARYING
   then return ("1"b);
   else return ("0"b);

   end FIELD_IS_VARYING;
%page;
FIELD_IS_CHARACTER_VARYING:
   proc (ficv_p_descriptor_string) returns (bit (1) aligned);

   dcl	 ficv_p_descriptor_string
			    bit (36) aligned;
   dcl	 1 ficv_descriptor_type unal based (addr (ficv_p_descriptor_string)),
	   2 unused1	    bit (1) unal,
	   2 type		    fixed bin (6) unsigned unal,
	   2 unused2	    bit (29) unal;
   dcl	 BIT_VARYING	    fixed bin (6) unsigned init (20);
   dcl	 CHAR_VARYING	    fixed bin (6) init (22);

   if ficv_descriptor_type.type = CHAR_VARYING
   then return ("1"b);
   else return ("0"b);

   end FIELD_IS_CHARACTER_VARYING;
%page;
%include dm_field_table;
%page;
%include vu_dimension_table;
%page;
%include sub_err_flags;
   end dfu_cv_dim_to_field_table;




		    dfu_cv_field_to_dim_table.pl1   01/04/85  0947.4re  01/03/85  1149.7       58500



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

         Given  a  pointer  to a field_table, convert that field_table into a
     dimension_table.  The caller supplies the area in which to  allocate  the
     dimension_table..    The caller also supplies an id_list to specify which
     fields to convert into dimensions.
*/

/* HISTORY:

Written by Matthew Pierret, 08/25/83.
Modified:
05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.
12/07/84 by M. Sharpe to correct format and the call to CHECK_VERSION_FB
	  to pass appropriate arg by reference.
*/

/* format: style2,ind3 */

dfu_cv_field_to_dim_table:
   proc (p_work_area_ptr, p_field_table_ptr, p_id_list_ptr, p_dimension_table_ptr);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_work_area_ptr	       ptr;		/* is a pointer to an area in which to */
						/* allocate dimension_table*/
      dcl	    p_field_table_ptr      ptr;		/* is a pointer to the input */
						/* field_table to convert*/
      dcl	    p_id_list_ptr	       ptr;		/* is a pointer to the input */
						/* id_list which selects the fields to convert*/
      dcl	    p_dimension_table_ptr  ptr;		/* is the pointer to the */
						/* returned dimension_table*/

/* Automatic */

      dcl	    (dimension_idx, field_id)
			       fixed bin (17) init (-1);

/* Based */

      dcl	    p_work_area	       area (10000) based (p_work_area_ptr);

/* Builtin */

      dcl	    (addr, hbound, max, null, substr)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("dfu_cv_field_to_dim_table") char (32) varying internal static
			       options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_dimension_table_ptr = null;

      field_table_ptr = p_field_table_ptr;
      call CHECK_VERSION ((field_table.version), (FIELD_TABLE_VERSION_3), "field_table");
      if p_id_list_ptr = null
      then dt_number_of_dimensions = hbound (field_table.field, 1);
      else
         do;
	  id_list_ptr = p_id_list_ptr;
	  call CHECK_VERSION_FB (id_list.version, (ID_LIST_VERSION_1), "id_list");
	  dt_number_of_dimensions = hbound (id_list.id, 1);
         end;

      dt_maximum_dimension_name_length = 0;
      do dimension_idx = 1 to dt_number_of_dimensions;
         dt_maximum_dimension_name_length =
	  max (dt_maximum_dimension_name_length, field_table.field (dimension_idx).length_of_name);
      end;

      on cleanup call FINISH ();

      alloc dimension_table in (p_work_area);

      do dimension_idx = 1 to hbound (dimension_table.dimension, 1);

         if p_id_list_ptr = null
         then field_id = dimension_idx;
         else field_id = id_list.id (dimension_idx);

         if field_id >= 1				/* If field_id <1, leave dimension_table entryempty */
         then
	  do;
	     dimension_table.dimension (dimension_idx).name =
	        substr (field_table.field_names, field_table.field (field_id).location_of_name,
	        field_table.field (field_id).length_of_name);
	     if field_table.field (field_id).flags.descriptor_is_varying
	     then call
		   sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		   "^/The capability to handle varying length descriptors is not yet implemented.");
						/* FOR DM_ERROR_UTIL_: Replace preceding statement with following

		   dm_error_util_$signal (dm_error_$programming_error, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
		   "^/The capability to handle varying length descriptors is not yet implemented.");
*/
	     dimension_table.dimension (dimension_idx).descriptor_ptr =
	        addr (dimension_table.dimension (dimension_idx).descriptor_string);
	     dimension_table.dimension (dimension_idx).descriptor_string = field_table.field (field_id).descriptor;
	  end;
      end;

      p_dimension_table_ptr = dimension_table_ptr;

      return;
%page;
FINISH:
   proc ();

      if dimension_table_ptr ^= null & p_dimension_table_ptr ^= dimension_table_ptr
      then free dimension_table;

   end FINISH;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (*);
      dcl	    p_expected_version     char (*);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);
						/* FOR DM_ERROR_UTIL_: Replace preceding statement with following

	    dm_error_util_$signal (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
	    "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);
*/

   end CHECK_VERSION;



CHECK_VERSION_FB:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
						/* FOR DM_ERROR_UTIL_: Replace preceding statement with following

	    dm_error_util_$signal (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
*/

   end CHECK_VERSION_FB;
%page;
%include dm_field_table;
%page;
%include vu_dimension_table;
%page;
%include dm_id_list;
%page;
%include sub_err_flags;
   end dfu_cv_field_to_dim_table;




		    dfu_cv_tva_to_dim_table.pl1     01/04/85  0947.4re  01/03/85  1149.7       38538



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

         This   routine   converts   the  typed_vector_array.dimenstion_table
     sub-structure into a stand-alone dimension_table structure.
*/

/* HISTORY:

Written by Matthew Pierret, 08/24/83.
Modified:
12/07/84 by M. Sharpe:  to cleanup format and dcls; to modify the call to
	  CHECK_VERSION_FB to pass params by reference.
*/

/* format: style2,ind3 */

dfu_cv_tva_to_dim_table:
   proc (p_work_area_ptr, p_typed_vector_array_ptr, p_dimension_table_ptr);

/* START OF DECLARATIONS */
/* Parameter */
      dcl	    p_work_area_ptr	       ptr;		/* is a pointer to a work area */
      dcl	    p_typed_vector_array_ptr
			       ptr;		/* is a pointer to an input typed_vector_array */
      dcl	    p_dimension_table_ptr  ptr;		/* is a pointer to the output dimension_table */

/* Automatic */
      dcl	    dimension_idx	       fixed bin (35) init (-1);

/* Based */

      dcl	    p_work_area	       area (10000) based (p_work_area_ptr);
      dcl	    based_descriptor_string
			       bit (36) based;

/* Builtin */

      dcl	    (addr, hbound, null)   builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("dfu_cv_tva_to_dim_table") char (32) varying internal static
			       options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */
%page;
      p_dimension_table_ptr = null;

      typed_vector_array_ptr = p_typed_vector_array_ptr;
      call CHECK_VERSION_FB (typed_vector_array.version, TYPED_VECTOR_ARRAY_VERSION_2, "typed_vector_array");

      on cleanup call FINISH ();

      dt_number_of_dimensions = hbound (typed_vector_array.dimension_table, 1);
      dt_maximum_dimension_name_length = typed_vector_array.maximum_dimension_name_length;
      alloc dimension_table in (p_work_area);

      do dimension_idx = 1 to hbound (dimension_table.dimension, 1);
         dimension_table.dimension (dimension_idx).name = typed_vector_array.dimension_table (dimension_idx).name;
         dimension_table.dimension (dimension_idx).descriptor_ptr =
	  addr (dimension_table.dimension (dimension_idx).descriptor_string);
         dimension_table.dimension (dimension_idx).descriptor_string =
	  typed_vector_array.dimension_table (dimension_idx).descriptor_ptr -> based_descriptor_string;
         dimension_table.dimension (dimension_idx).cv_to_typed =
	  typed_vector_array.dimension_table (dimension_idx).cv_to_typed;
         dimension_table.dimension (dimension_idx).cv_to_print =
	  typed_vector_array.dimension_table (dimension_idx).cv_to_print;
      end;

      p_dimension_table_ptr = dimension_table_ptr;

      return;
%page;
FINISH:
   proc ();

      if dimension_table_ptr ^= null & p_dimension_table_ptr = null
      then free dimension_table;

   end FINISH;
%page;
CHECK_VERSION_FB:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
						/* FOR DM_ERROR_UTIL_: Replace preceding statement with following

	    dm_error_util_$signal (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART || NO_ANCILLARY_ACTIONS,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
*/

   end CHECK_VERSION_FB;
%page;
%include vu_dimension_table;
%page;
%include vu_typed_vector_array;
%page;
%include sub_err_flags;
   end dfu_cv_tva_to_dim_table;




		    dmu_compare_decimal_values.alm  01/04/85  0947.4re  01/03/85  1149.7       17649



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
" Written by Lindsey Spratt, 04/10/82.
" Modified:
" 01/14/83 by Lindsey Spratt:  Added dec4(ls fl) entries.
" 03/28/83 by Lindsey Spratt:  Changed from im_* to dmu_*.
" 
" 
	name	dmu_compare_decimal_values
	entry	dmu_compare_dec9ls

dmu_compare_dec9ls:
	lxl1	ap|2,*
	eppbp	ap|4,*		" bp -> ptr -> value1
	eppbp	bp|0,*		" bp -> value1
	eppbb	ap|6,*		" bb -> ptr -> value2
	eppbb	bb|0,*		" bb -> value2
	cmpn	(pr,rl),(pr,rl)
	desc9ls	bp|0,x1,0
	desc9ls	bb|0,x1,0
	tze	return_equal
	tmi	return_greater
	tra	return_less

	entry	dmu_compare_dec9fl

dmu_compare_dec9fl:
	lxl1	ap|2,*
	eppbp	ap|4,*		" bp -> ptr -> value1
	eppbp	bp|0,*		" bp -> value1
	eppbb	ap|6,*		" bb -> ptr -> value2
	eppbb	bb|0,*		" bb -> value2
	cmpn	(pr,rl),(pr,rl)
	desc9fl	bp|0,x1,0
	desc9fl	bb|0,x1,0
	tze	return_equal
	tmi	return_greater
	tra	return_less

	entry	dmu_compare_dec4ls

dmu_compare_dec4ls:
	lxl1	ap|2,*
	eppbp	ap|4,*		" bp -> ptr -> value1
	eppbp	bp|0,*		" bp -> value1
	eppbb	ap|6,*		" bb -> ptr -> value2
	eppbb	bb|0,*		" bb -> value2
	cmpn	(pr,rl),(pr,rl)
	desc4ls	bp|0,x1,0
	desc4ls	bb|0,x1,0
	tze	return_equal
	tmi	return_greater
	tra	return_less

	entry	dmu_compare_dec4fl

dmu_compare_dec4fl:
	lxl1	ap|2,*
	eppbp	ap|4,*		" bp -> ptr -> value1
	eppbp	bp|0,*		" bp -> value1
	eppbb	ap|6,*		" bb -> ptr -> value2
	eppbb	bb|0,*		" bb -> value2
	cmpn	(pr,rl),(pr,rl)
	desc4fl	bp|0,x1,0
	desc4fl	bb|0,x1,0
	tze	return_equal
	tmi	return_greater
	tra	return_less

return_equal:
	lda	=o400000,du
	sta	ap|8,*
	stz	ap|10,*
	short_return

return_greater:
	stz	ap|8,*
	stz	ap|10,*
	short_return

return_less:
	lda	=o400000,du
	sta	ap|10,*
	stz	ap|8,*
	short_return

	end




		    dmu_compare_sequential.pl1      10/24/88  1636.9r w 10/24/88  1400.1      190377



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* DESCRIPTION:

         This subroutine determines if a leaf key or record string satisfies  a
     sequential specification.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 07/07/82.
Modified:
08/17/82 by Matthew Pierret:  Changed from im_compare_sequential to
            dmu_compare_sequential, as this routine is now used by both
            index_manager_ and record_manager_.
09/27/82 by Matthew Pierret:  Corrected flaw in logic in subroutine "compare"
            which decides whether a key satisfies a specification.
10/07/82 by Lindsey Spratt:  Changed to use search_specification version 2,
	  and to take the and_group_id_list_ptr,
	  number_of_fully_structural_fields and partial_structural_field_id
	  parameters.  Constraints with field ids <=
	  number_of_fully_structural_fields are ignored.  If a constraint
	  has a field id = partial_structural_field_id, then it
	  is only used if its operator_code uses a regular expression or if
	  it is a "^=" comparison.  Any other comparisons on this field will
	  have been satisfied already.
03/22/83 by Lindsey Spratt:  Changed to use version 2 field_table.  Internal
	  procedure names were uppercased.  Did some restructuring of the
	  code in preparation for the version 4 search_specification which
	  suports "intra-tuple" comparisons.  Fixed an error in calculating
	  the location of varying field data.
05/02/83 by Lindsey L. Spratt:  Fixed SETUP_PTR_AND_LENGTH to allow for
            whether the field length is in characters or bits when locating a
            varying field.
05/03/83 by Lindsey L. Spratt:  Fixed to use the addbitno builtin when
            calculating the addr of a field value in a string.
05/23/83 by Matthew Pierret:  Changed to use version 4 specifications,
            which have intra-key/record comparisons. Removed the comments
            around the code which Lindsey wrote in expectation of this event,
            as described in the preceding journalization entries.
02/28/84 by Matthew Pierret: Changed to use the simple_search_specification
            structure and the simplified COMPARE_CONSTRAINT if such a 
            structure is supplied. Changed to check for varying-ness of data
            type by examining the field_descriptor instead of thefield_table's
            varying_field_map, since we already had the field_descriptor.
            Added ERROR_RETURN.  Changed to use the this_constraint structure
            instead of accessing the search specification.
03/01/84 by Matthew Pierret: Corrected a flaw in the logic which determines
            if the result of a comparison between two values is satisfactory.
            This was introduced in the last modification and failed to catch 
            the case where greater-equal was wanted and greater was the result.
03/08/84 by Matthew Pierret: Changed SETUP_PTR_AND_LENGTH to use a based
            overlay to pick up the length fields of varying fields instead
            of the less performant assignment using substr and copy.
05/02/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.
06/08/84 by Lee Baldwin:  Fixed to call dm_error_$unimplemented_data_type
            instead of $bad_descriptor_type which didn't exist.
10/13/84 by Lindsey L. Spratt:  In response to audit comments; changed to only
            have arg_descriptor included in the outermost proc, the two
            internal procs which use it either reference it explicitly or via
            a like dcl.  Moved the proc stmt to standard location.  Deleted
            unused dcls.
01/12/85 by Lee A. Newcomb:  Fixed to use error_table_$unsupported_operation
            instead of the non-existant error_table_$unimplemented_operation.
*/

/* format: style2,ind3 */
dmu_compare_sequential:
   proc (p_field_table_ptr, p_search_specification_ptr, p_and_group_id_list_ptr, p_number_of_fully_structural_fields,
        p_partial_structural_field_id, p_key_string, p_key_satisfies_specification, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_field_table_ptr      ptr parameter;
      dcl	    p_search_specification_ptr
			       ptr parameter;
      dcl	    p_and_group_id_list_ptr
			       ptr parameter;
      dcl	    p_number_of_fully_structural_fields
			       fixed bin;
      dcl	    p_partial_structural_field_id
			       fixed bin;
      dcl	    p_key_string	       bit (*) parameter;
      dcl	    p_key_satisfies_specification
			       bit (1) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    key_satisfies_specification
			       bit (1) aligned;

      dcl	    (and_group_list_idx, and_group_idx, constraint_idx)
			       fixed bin;
      dcl	    constraint_operator_code
			       fixed bin (18) uns unal;
      dcl	    (constraint_field_id, constraint_value_field_id)
			       fixed bin;

      dcl	    field_value_offset     fixed bin (35);
      dcl	    (field_value_length, second_value_length)
			       fixed bin (35);
      dcl	    (field_value_ptr, second_value_ptr)
			       ptr;
      dcl	    field_descriptor_ptr   ptr;
      dcl	    input_key_string_ptr   ptr init (null);
      dcl	    this_constraint_ptr    ptr init (null);

/* Based */

      dcl	    field_descriptor       bit (36) based (field_descriptor_ptr);
      dcl	    1 this_constraint      unaligned like search_specification.and_group.constraint based (this_constraint_ptr);
      dcl	    1 simple_search_specification
			       based (search_specification_ptr),
	      2 head	       like specification_head,
	      2 maximum_number_of_constraints
			       fixed bin (17) unal,
	      2 number_of_and_groups
			       fixed bin (17) unal,
	      2 range	       unal,
	        3 type	       fixed bin (17),
	        3 size	       fixed bin (17),
	      2 and_group,
	        3 number_of_constraints
			       fixed bin (17) unal,
	        3 constraint       like search_specification.and_group.constraint;

/* Builtin */

      dcl	    (addbitno, addr, bin, null, substr, unspec)
			       builtin;

/* Constant */

      dcl	    myname	       init ("dmu_compare_sequential") char (32) varying internal static options (constant);

      dcl	    BITS_PER_BYTE	       init (9) fixed bin internal static options (constant);
      dcl	    DEFAULT_VALUE_LENGTH   init (-1) fixed bin (35) internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);
      dcl	    dmu_compare_values     entry (ptr, ptr, ptr, fixed bin (35), bit (1) aligned, bit (1) aligned,
			       fixed bin (35));
      dcl	    dmu_compare_values$field_to_field
			       entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35), bit (1) aligned,
			       bit (1) aligned, fixed bin (35));
      dcl	    search_file_	       entry (ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21),
			       fixed bin (21), fixed bin (21), fixed bin (35));

/* External */

      dcl	    error_table_$unsupported_operation
			       fixed bin (35) ext;
      dcl	    dm_error_$unimplemented_data_type
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      search_specification_ptr = p_search_specification_ptr;

      field_table_ptr = p_field_table_ptr;

/**** ********** Removed for efficiency ********************

      call CHECK_VERSION (search_specification.version, SPECIFICATION_VERSION_4, "search_specification");
      call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");
      if id_list_ptr ^= null
      then call CHECK_VERSION (id_list.version, (ID_LIST_VERSION_1), "id_list");

 **** ******************************************************/

      input_key_string_ptr = addr (p_key_string);

      key_satisfies_specification = "0"b;

      if simple_search_specification.number_of_and_groups = 1
	 & simple_search_specification.and_group.number_of_constraints = 1
      then call COMPARE_CONSTRAINT;
      else
COMPARE_AND_GROUPS:
         do;

	  id_list_ptr = p_and_group_id_list_ptr;

	  if id_list_ptr ^= null
	  then
AND_GROUP_LIST_LOOP:
	     do and_group_list_idx = 1 to id_list.number_of_ids while (^key_satisfies_specification);

	        and_group_idx = id_list.id (and_group_list_idx);

	        key_satisfies_specification = "1"b;
	        call COMPARE_AND_GROUP;
	     end AND_GROUP_LIST_LOOP;
	  else
AND_GROUP_LOOP:
	     do and_group_idx = 1 to search_specification.number_of_and_groups while (^key_satisfies_specification);
	        key_satisfies_specification = "1"b;
	        call COMPARE_AND_GROUP;
	     end AND_GROUP_LOOP;

         end COMPARE_AND_GROUPS;

      p_code = 0;
MAIN_RETURN:
      p_key_satisfies_specification = key_satisfies_specification;

      return;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      goto MAIN_RETURN;

   end ERROR_RETURN;
%page;
COMPARE_CONSTRAINT:
   proc;


      constraint_field_id = simple_search_specification.and_group.constraint.field_id;
      constraint_operator_code = simple_search_specification.and_group.constraint.operator_code;
      constraint_value_field_id = simple_search_specification.and_group.constraint.value_field_id;

      field_descriptor_ptr = addr (field_table.field (constraint_field_id).descriptor);

      call SETUP_PTR_AND_LENGTH (constraint_field_id, field_descriptor_ptr, field_value_ptr, field_value_length);

      if constraint_value_field_id > 0
      then
         do;
	  call SETUP_PTR_AND_LENGTH (constraint_value_field_id, field_descriptor_ptr, second_value_ptr,
	       second_value_length);

	  if field_table.field (constraint_value_field_id).descriptor ^= field_descriptor
	  then call sub_err_ (error_table_$unsupported_operation, myname, ACTION_CANT_RESTART, null, 0,
		  "^/Currently fields to be compared must have identical descriptors.");

/**** FOR COMPARISON OF FIELDS WITH DIFFERENT DESCRIPTORS 

		         do;
			  call
			     CONVERT_AND_COMPARE (unspec (constraint_operator_code),
			     field_descriptor_ptr, field_value_ptr,
			     field_value_length, addr (field_table.field (constraint_value_field_id).descriptor),
			     second_value_ptr, second_value_length, key_satisfies_specification);

		         end;

**** END FOR COMPARISONS OF FIELDS WITH DIFFERENT DESCRIPTORS */

	  else
	     do;
	        call COMPARE (unspec (constraint_operator_code), second_value_ptr, second_value_length,
		   field_descriptor_ptr, field_value_ptr, field_value_length, key_satisfies_specification);

	     end;
         end;
      else
         do;

	  call COMPARE (unspec (constraint_operator_code), (simple_search_specification.and_group.constraint.value_ptr),
	       DEFAULT_VALUE_LENGTH, field_descriptor_ptr, field_value_ptr, field_value_length,
	       key_satisfies_specification);

         end;

      return;

   end COMPARE_CONSTRAINT;
%page;
COMPARE_AND_GROUP:
   proc;
      do constraint_idx = 1 to search_specification.and_group (and_group_idx).number_of_constraints
	 while (key_satisfies_specification);

         this_constraint_ptr = addr (search_specification.and_group (and_group_idx).constraint (constraint_idx));

         constraint_field_id = this_constraint.field_id;
         constraint_operator_code = this_constraint.operator_code;
         constraint_value_field_id = this_constraint.value_field_id;

         if constraint_field_id > p_number_of_fully_structural_fields
         then if constraint_field_id ^= p_partial_structural_field_id
	         | (USES_REGULAR_EXPRESSION_OPERATOR (constraint_operator_code)
	         | constraint_operator_code = NOT_EQUAL_OPERATOR_CODE | constraint_value_field_id >= 0)
	    then
CHECK_CONSTRAINT:
	       do;

		field_descriptor_ptr = addr (field_table.field (constraint_field_id).descriptor);

		call SETUP_PTR_AND_LENGTH (constraint_field_id, field_descriptor_ptr, field_value_ptr,
		     field_value_length);

		if constraint_value_field_id > 0
		then
		   do;
		      call SETUP_PTR_AND_LENGTH (constraint_value_field_id, field_descriptor_ptr, second_value_ptr,
			 second_value_length);

		      if field_table.field (constraint_value_field_id).descriptor ^= field_descriptor
		      then call sub_err_ (error_table_$unsupported_operation, myname, ACTION_CANT_RESTART, null, 0,
			      "^/Currently fields to be compared must have identical descriptors.");

/**** FOR COMPARISON OF FIELDS WITH DIFFERENT DESCRIPTORS 

		         do;
			  call
			     CONVERT_AND_COMPARE (unspec (constraint_operator_code),
			     field_descriptor_ptr, field_value_ptr,
			     field_value_length, addr (field_table.field (constraint_value_field_id).descriptor),
			     second_value_ptr, second_value_length, key_satisfies_specification);

		         end;

**** END FOR COMPARISONS OF FIELDS WITH DIFFERENT DESCRIPTORS */

		      else
		         do;
			  call COMPARE (unspec (constraint_operator_code), second_value_ptr, second_value_length,
			       field_descriptor_ptr, field_value_ptr, field_value_length,
			       key_satisfies_specification);

		         end;
		   end;
		else
		   do;

		      call COMPARE (unspec (constraint_operator_code), (this_constraint.value_ptr),
			 DEFAULT_VALUE_LENGTH, field_descriptor_ptr, field_value_ptr, field_value_length,
			 key_satisfies_specification);

		   end;
	       end CHECK_CONSTRAINT;
      end;
   end COMPARE_AND_GROUP;
%page;
SETUP_PTR_AND_LENGTH:
   proc (spl_p_field_id, spl_p_field_descriptor_ptr, spl_p_field_value_ptr, spl_p_field_value_length);

      dcl	    spl_p_field_id	       fixed bin;
      dcl	    spl_p_field_descriptor_ptr
			       ptr;
      dcl	    spl_p_field_value_ptr  ptr;
      dcl	    spl_p_field_value_length
			       fixed bin (35);

      dcl	    spl_temp_field_id      fixed bin;
      dcl	    spl_temp_field_value_length
			       fixed bin (35);
      dcl	    spl_varying_field_idx  fixed bin;
      dcl	    spl_varying_field_location
			       fixed bin (35);
      dcl	    spl_length_field_length
			       fixed bin (35);
      dcl	    spl_length_field_ptr   ptr;
      dcl	    spl_length_field_string
			       bit (spl_length_field_length) based (spl_length_field_ptr);

      dcl	    spl_descriptor_type    fixed bin (35) init (0);

      spl_descriptor_type = spl_p_field_descriptor_ptr -> arg_descriptor.type;

      if spl_descriptor_type ^= varying_bit_dtype & spl_descriptor_type ^= varying_char_dtype
      then
PREPARE_NONVARYING_FIELD:
         do;
	  spl_p_field_value_length = -1;
	  spl_p_field_value_ptr = addbitno (input_key_string_ptr, field_table.field (spl_p_field_id).location - 1);
         end PREPARE_NONVARYING_FIELD;
      else
PREPARE_VARYING_FIELD:
         do;
	  spl_length_field_length = field_table.field (spl_p_field_id).length_in_bits;
	  spl_length_field_ptr = addbitno (input_key_string_ptr, field_table.field (spl_p_field_id).location - 1);
	  spl_p_field_value_length = bin (spl_length_field_string, 35, 0);

	  spl_varying_field_location = field_table.location_of_first_varying_field;
SET_VARYING_FIELD_VALUE_OFFSET:
	  do spl_varying_field_idx = 1 to field_table.varying_field_map (spl_p_field_id).varying_field_index - 1;
	     spl_temp_field_id = field_table.varying_field_map (spl_varying_field_idx).field_id;
	     spl_length_field_length = field_table.field (spl_temp_field_id).length_in_bits;
	     spl_length_field_ptr = addbitno (input_key_string_ptr, field_table.field (spl_temp_field_id).location - 1);
	     spl_temp_field_value_length = bin (spl_length_field_string, 35, 0);

	     if field_table.field (spl_temp_field_id).length_is_in_characters
	     then spl_varying_field_location = spl_varying_field_location + spl_temp_field_value_length * BITS_PER_BYTE;
	     else spl_varying_field_location = spl_varying_field_location + spl_temp_field_value_length;
	  end SET_VARYING_FIELD_VALUE_OFFSET;

	  spl_p_field_value_ptr = addbitno (input_key_string_ptr, spl_varying_field_location - 1);
         end PREPARE_VARYING_FIELD;

      return;


   end SETUP_PTR_AND_LENGTH;
%page;
COMPARE:
   proc (c_p_operator_code_string, c_p_spec_value_ptr, c_p_spec_value_length, c_p_field_descriptor_ptr,
        c_p_field_value_ptr, c_p_field_value_length, c_p_key_satisfies_specification);

      dcl	    c_p_operator_code_string
			       bit (*);
      dcl	    c_p_spec_value_ptr     ptr;
      dcl	    c_p_spec_value_length  fixed bin (35);
      dcl	    c_p_field_descriptor_ptr
			       ptr;
      dcl	    c_p_field_value_ptr    ptr;
      dcl	    c_p_field_value_length fixed bin (35);
      dcl	    c_p_key_satisfies_specification
			       bit (1) aligned;

      dcl	    c_code	       fixed bin (35);

      dcl	    (c_want_key_equal_to_spec, c_want_key_greater_than_spec, c_invert_spec, c_want_key_match_regular_expression)
			       bit (1) aligned;
      dcl	    (c_spec_equal_to_key, c_spec_less_than_key)
			       bit (1) aligned;

      dcl	    1 c_p_field_descriptor based (c_p_field_descriptor_ptr) like arg_descriptor;

      dcl	    1 c_varying_spec_value based (c_p_spec_value_ptr),
	      2 length	       fixed bin (35),
	      2 string	       char (0 refer (c_varying_spec_value.length));

      c_code = 0;
      c_want_key_match_regular_expression = substr (c_p_operator_code_string, REGULAR_EXPRESSION_IDX, 1);
      c_invert_spec = substr (c_p_operator_code_string, NOT_IDX, 1);

      if c_want_key_match_regular_expression
      then
         do;
	  if c_p_field_value_length = -1
	  then
	     do;
	        if c_p_field_descriptor.type ^= char_dtype
	        then call ERROR_RETURN (dm_error_$unimplemented_data_type);

	        c_p_field_value_length = c_p_field_descriptor.size;
	     end;
	  call search_file_ (addr (c_varying_spec_value.string), 1, (c_varying_spec_value.length), c_p_field_value_ptr,
	       1, (c_p_field_value_length), 0, 0, c_code);
	  if c_code = 0
	  then c_p_key_satisfies_specification = "1"b;
	  else if c_code = 1
	  then c_p_key_satisfies_specification = "0"b;
	  else call ERROR_RETURN (c_code);

         end;
      else
         do;
	  c_want_key_equal_to_spec = substr (c_p_operator_code_string, EQUAL_IDX, 1);
	  c_want_key_greater_than_spec = substr (c_p_operator_code_string, GREATER_IDX, 1);

	  if c_p_spec_value_length = -1
	  then call dmu_compare_values (c_p_field_descriptor_ptr, c_p_spec_value_ptr, c_p_field_value_ptr,
		  c_p_field_value_length, c_spec_equal_to_key, c_spec_less_than_key, c_code);
	  else call dmu_compare_values$field_to_field (c_p_field_descriptor_ptr, c_p_spec_value_ptr,
		  c_p_spec_value_length, c_p_field_value_ptr, c_p_field_value_length, c_spec_equal_to_key,
		  c_spec_less_than_key, c_code);

	  if c_code ^= 0
	  then call ERROR_RETURN (c_code);

/* format: off */
	  if (c_want_key_equal_to_spec & c_spec_equal_to_key) 
						/* want equal and is equal */
	  |  (c_want_key_greater_than_spec & ^c_spec_equal_to_key & c_spec_less_than_key)
						/* want greater and is greater */
            then c_p_key_satisfies_specification = "1"b;
	  else c_p_key_satisfies_specification = "0"b;
                                                            /* format: on */
         end;

      if c_invert_spec
      then c_p_key_satisfies_specification = ^c_p_key_satisfies_specification;

      return;

   end COMPARE;
%page;
/* ******************** Removed for efficiency ********************************
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);
      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	    "^/The expected version for the ^a structure was ^d. Received ^d instead.", p_expected_version,
	    p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
CHECK_VERSION_CHAR:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (*) parameter;
      dcl	    p_expected_version     char (*) parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure. Received version ^a.", p_expected_version, p_structure_name,
	    p_received_version);

   end CHECK_VERSION_CHAR;

******************** End of code removed for efficiency *********************/
%page;
%include dm_specification;
%page;
%include dm_specification_head;
%page;
%include std_descriptor_types;
%page;
%include dm_id_list;
%page;
%include dm_field_table;
%page;
%include dm_operator_constants;
%page;
%include sub_err_flags;
%page;
%include arg_descriptor;
   end dmu_compare_sequential;




		    dmu_compare_strings.pl1         10/24/88  1636.9r w 10/24/88  1400.1      102699



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:  
          This program compares the value of two keys.
     It is responsible for "parsing" the key bit string into its constituent
     fields, using the information provided by the field_table.
          The comparison is done a-field-at-a-time, starting with field 1 and
     continuing with field 2, field 3, etc. until either an inequality is
     found or all of the fields have been compared.  
          Key1 must be a full key string.  Key2 may be a "truncated" key as 
     produced by the im_make_parent_key module.
*/

/* HISTORY:

Written by Lindsey Spratt, 11/03/82.

Modified:
12/08/82 by Lindsey Spratt:  Fixed code which extracts lengths of varying
	  strings to cope with different size variable lengths (currently 9,
	  18 and 36 bit length variables are possible).
06/29/83 by Lindsey L. Spratt:  Fixed to support comparison of a full key1
            string with a "truncated" key2 string.
05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.
11/09/84 by Lindsey L. Spratt:  Minor format changes.  Declared the builtins.
*/

/* format: style2,ind3 */
dmu_compare_strings:
   proc (p_field_table_ptr, p_key1_string_ptr, p_key1_string_length, p_key2_string_ptr, p_key2_string_length,
        p_key2_last_field_idx, p_first_inequal_field_id, p_key1_equal_to_key2, p_key1_less_than_key2, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_field_table_ptr      ptr;
      dcl	    p_key1_string_ptr      ptr parameter;
      dcl	    p_key1_string_length   fixed bin (24) parameter;
      dcl	    p_key2_string_ptr      ptr;
      dcl	    p_key2_string_length   fixed bin (24);
      dcl	    p_key2_last_field_idx  fixed bin (17) unaligned;
      dcl	    p_first_inequal_field_id
			       fixed bin (17) parameter;
      dcl	    p_key1_equal_to_key2   bit (1) aligned;
      dcl	    p_key1_less_than_key2  bit (1) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    1 truncated_field_descriptor
			       like arg_descriptor;
      dcl	    last_field_is_truncated
			       bit (1) aligned init ("0"b);
      dcl	    last_field_value_ptr   ptr init (null);
      dcl	    (last_field_value_length, last_field_value_length_in_bits)
			       fixed bin (35) init (-1);

      dcl	    field_idx	       fixed bin init (-1);
      dcl	    (current_field_id, current_field_variable_length, current_field_location)
			       fixed bin (35) init (-1);
      dcl	    maximum_field_idx      fixed bin (17) init (-1);
      dcl	    varying_field_idx      fixed bin init (-1);
      dcl	    myname	       init ("dmu_compare_strings") char (32) varying;
      dcl	    key2_field_value_length
			       fixed bin (35);
      dcl	    key2_field_value_ptr   ptr;
      dcl	    key2_field_value_offset
			       fixed bin (24);
      dcl	    key1_field_value_length
			       fixed bin (35);
      dcl	    key1_field_value_ptr   ptr;
      dcl	    key1_field_value_offset
			       fixed bin (24);
      dcl	    (key1_location_of_first_varying_field, key2_location_of_first_varying_field)
			       fixed bin (35) init (-1);
      dcl	    last_field_length_in_bits
			       fixed bin (35) init (-1);
      dcl	    field_descriptor_ptr   ptr init (null);

/* Based */

      dcl	    based_real_fix_bin_1u  based fixed bin (35) unaligned;

      dcl	    p_key1_string	       based (p_key1_string_ptr) bit (p_key1_string_length);
      dcl	    key1_bit_array	       (p_key1_string_length) bit (1) based (p_key1_string_ptr);
      dcl	    p_key2_string	       based (p_key2_string_ptr) bit (p_key2_string_length);
      dcl	    key2_bit_array	       (p_key2_string_length) bit (1) based (p_key2_string_ptr);


/* Builtin */

      dcl	    (addr, bin, copy, hbound, null, substr, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    (
	    BITS_PER_WORD	       init (36),
	    BITS_PER_BYTE	       init (9),
	    BYTES_PER_WORD	       init (4)
	    )		       internal static options (constant) fixed bin (17);

/* Entry */

      dcl	    dmu_compare_values$field_to_field
			       entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35), bit (1) aligned,
			       bit (1) aligned, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      field_table_ptr = p_field_table_ptr;
      call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      p_code = 0;
      p_key1_equal_to_key2 = "1"b;
      p_key1_less_than_key2 = "0"b;

      if p_key2_last_field_idx = -1
      then
         do;
	  maximum_field_idx = hbound (field_table.field, 1);
	  key1_location_of_first_varying_field, key2_location_of_first_varying_field =
	       field_table.location_of_first_varying_field;
	  last_field_is_truncated = "0"b;
         end;
      else
SETUP_TRUNCATED_FIELD:
         do;
	  maximum_field_idx = p_key2_last_field_idx;
	  arg_descriptor_ptr = addr (field_table.field (p_key2_last_field_idx).descriptor);

	  if field_table.varying_field_map (p_key2_last_field_idx).varying_field_index = 0
	  then if arg_descriptor.type = bit_dtype
	       then
		do;
		   if arg_descriptor.size > BITS_PER_WORD + BITS_PER_BYTE
		   then
		      do;
		         truncated_field_descriptor.packed = "1"b;
		         truncated_field_descriptor.flag = "1"b;
		         truncated_field_descriptor.type = varying_bit_dtype;
		         truncated_field_descriptor.size = arg_descriptor.size;
		         last_field_value_length =
			    addr (key2_bit_array (field_table.field (p_key2_last_field_idx).location))
			    -> based_real_fix_bin_1u;
		         last_field_length_in_bits = last_field_value_length + BITS_PER_WORD;
		         last_field_value_ptr =
			    addr (
			    key2_bit_array (field_table.field (p_key2_last_field_idx).location + BITS_PER_WORD));
		         last_field_is_truncated = "1"b;
		      end;
		end;
	       else if arg_descriptor.type = char_dtype
	       then
		do;
		   if arg_descriptor.size > BYTES_PER_WORD + 1
		   then
		      do;
		         truncated_field_descriptor.packed = "1"b;
		         truncated_field_descriptor.flag = "1"b;

		         truncated_field_descriptor.type = varying_char_dtype;
		         truncated_field_descriptor.size = arg_descriptor.size;
		         last_field_value_length =
			    addr (key2_bit_array (field_table.field (p_key2_last_field_idx).location))
			    -> based_real_fix_bin_1u;
		         last_field_value_length_in_bits = last_field_value_length * BITS_PER_BYTE + BITS_PER_WORD;
		         last_field_value_ptr =
			    addr (
			    key2_bit_array (field_table.field (p_key2_last_field_idx).location + BITS_PER_WORD));
		         last_field_is_truncated = "1"b;
		      end;
		end;

	  if last_field_is_truncated
	  then key2_location_of_first_varying_field =
		  field_table.field (p_key2_last_field_idx).location + last_field_length_in_bits;
	  else if p_key2_last_field_idx < field_table.number_of_fields
	  then key2_location_of_first_varying_field = field_table.field (p_key2_last_field_idx + 1).location;
	  else key2_location_of_first_varying_field = field_table.location_of_first_varying_field;
         end SETUP_TRUNCATED_FIELD;

FIELD_LOOP:
      do field_idx = 1 to maximum_field_idx while (p_code = 0 & p_key1_equal_to_key2);
         if last_field_is_truncated & p_key2_last_field_idx = field_idx
         then
PREPARE_TRUNCATED_FIELD:
	  do;
	     key1_field_value_length = truncated_field_descriptor.size;
	     key1_field_value_ptr = addr (key1_bit_array (field_table.field (field_idx).location));
	     key2_field_value_length = last_field_value_length;
	     key2_field_value_ptr = last_field_value_ptr;
	     field_descriptor_ptr = addr (truncated_field_descriptor);
	  end PREPARE_TRUNCATED_FIELD;
         else if field_table.varying_field_map (field_idx).varying_field_index = 0
         then
PREPARE_NONVARYING_FIELD:
	  do;
	     key1_field_value_length = -1;
	     key1_field_value_ptr = addr (key1_bit_array (field_table.field (field_idx).location));
	     key2_field_value_length = -1;
	     key2_field_value_ptr = addr (key2_bit_array (field_table.field (field_idx).location));
	     field_descriptor_ptr = addr (field_table.field (field_idx).descriptor);
	  end PREPARE_NONVARYING_FIELD;
         else
PREPARE_VARYING_FIELD:
	  do;
	     unspec (key1_field_value_length) =
		copy ("0"b, BITS_PER_WORD - field_table.field (field_idx).length_in_bits)
		||
		substr (p_key1_string, field_table.field (field_idx).location,
		field_table.field (field_idx).length_in_bits);
	     key1_field_value_offset = key1_location_of_first_varying_field;
	     unspec (key2_field_value_length) =
		copy ("0"b, BITS_PER_WORD - field_table.field (field_idx).length_in_bits)
		||
		substr (p_key2_string, field_table.field (field_idx).location,
		field_table.field (field_idx).length_in_bits);
	     key2_field_value_offset = key2_location_of_first_varying_field;
SET_VARYING_FIELD_VALUE_OFFSET:
	     do varying_field_idx = 1 to field_table.varying_field_map (field_idx).varying_field_index - 1;
	        current_field_id = field_table.varying_field_map (varying_field_idx).field_id;
	        current_field_location = field_table.field (current_field_id).location;
	        current_field_variable_length = field_table.field (current_field_id).length_in_bits;

	        key1_field_value_offset =
		   key1_field_value_offset
		   + bin (substr (p_key1_string, current_field_location, current_field_variable_length), 24, 0);
	        key2_field_value_offset =
		   key2_field_value_offset
		   + bin (substr (p_key2_string, current_field_location, current_field_variable_length), 24, 0);
	     end SET_VARYING_FIELD_VALUE_OFFSET;

	     key1_field_value_ptr = addr (key1_bit_array (key1_field_value_offset));
	     key2_field_value_ptr = addr (key2_bit_array (key2_field_value_offset));
	     field_descriptor_ptr = addr (field_table.field (field_idx).descriptor);
	  end PREPARE_VARYING_FIELD;

         call dmu_compare_values$field_to_field (field_descriptor_ptr, key1_field_value_ptr, key1_field_value_length,
	    key2_field_value_ptr, key2_field_value_length, p_key1_equal_to_key2, p_key1_less_than_key2, p_code);


      end FIELD_LOOP;

      p_first_inequal_field_id = field_idx - bin (^p_key1_equal_to_key2);

      return;
%page;
CHECK_VERSION_CHAR:
   proc (p_expected_version, p_received_version, p_structure_name);
      dcl	    (p_expected_version, p_received_version, p_structure_name)
			       char (*) aligned parameter;
      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION_CHAR;
%page;
%include sub_err_flags;
%page;
%include dm_field_table;
%page;
%include vu_typed_vector;
%page;
%include arg_descriptor;
%page;
%include std_descriptor_types;
   end dmu_compare_strings;




		    dmu_compare_values.pl1          10/24/88  1636.9r w 10/24/88  1400.2       52920



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
dmu_compare_values:
   proc (p_descriptor_ptr, p_vector_value_ptr, p_field_value_ptr, p_field_value_length, p_vector_equal_to_key,
      p_vector_less_than_key, p_code);

/* DESCRIPTION:
          This module compares two values and returns information about
     whether the first is less than, equal to, or greater than, the second.
     Both values must be of the same data-type, however the storage
     conventions for varying string data for the second value are slightly
     different from the Multics standard format.  This difference consists
     solely in that the length of the varying string is not stored as the
     initial piece of information in the string.  The length of varying
     string values in fields is passed in as a parameter.  
          The first value is referred to as the "vector" value, since it
     usually is the value of a dimension of a typed_vector.  The second value
     is referred to  as the "field" value, since it is usually the value of a
     field of a key.
     
          All work is actually done in the internal subroutine
     COMPARE_VALUES.  This routine is part of the include file
     dm_comp_values_proc.incl.pl1.  It is in an include file so that
     other modules may access it without the expense of an external call
     and argument list preparation.
     
          No parameters are passed to from this module to the internal 
     subroutine.  All data flow is done using global variables. The names of
     the global variables are prefixed with "cv_p_".
*/

/* HISTORY:
Written by Lindsey Spratt, 03/30/82.
Modified:
04/24/82 by Lindsey Spratt: Added the field_to_field entry and the
	  vector_value_is_in_field_format protocol.  Also, changed to use
	  unaligned (as opposed to aligned) based overlays for numeric
	  "field" format data.
06/03/82 by Lindsey Spratt: Changed the handling of unaligned numeric data
	  types to use the full word (or double word), they were using one
	  too few bits.  Also, introduced the consistent use of named
	  constants instead of literals.
01/10/83 by Lindsey Spratt: Fixed to include the sign character in the length
	  of decimal data.
01/14/83 by Lindsey Spratt: Added data types 43 (real fixed decimal leading
	  sign 4-bit byte aligned) and 44 (real float decimal 4-bit byte
	  aligned).  Also added unimplemented data type check.
01/17/83 by Lindsey Spratt: Fixed float decimal to include exponent in size.
01/18/83 by Lindsey Spratt: Fixed float binary to correctly copy packed data
	  into the local float binary variable.
03/02/83 by Lindsey Spratt: Added a check to ensure that the provided
	  descriptor type is between 1 and HIGHEST_SUPPORTED_DATA_TYPE.
03/15/83 by Lindsey Spratt: Added the 4 complex binary data types, 5 through 8.
03/17/83 by Lindsey Spratt:  Added the 4 complex decimal data types, 11, 12,
	  45 and 46.
03/28/83 by Lindsey Spratt:  Changed all references to im_* to dmu_*.
06/08/83 by Matthew Pierret: Changed references to dmu_compare_dec* modules
            to correctly be dmu_compare_decimal_values$dmu_compare_dec*.
04/19/84 by Matthew Pierret: Extracted code into the include file
            dm_comp_values_proc.incl.pl1, which is written as two internal
            subroutines: COMPARE_FIELD_VALUES (replaces $field_to_field)
            and COMPARE_VALUES (replaces $dmu_compare_values).
*/
/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_descriptor_ptr       ptr;
      dcl	    p_vector_value_ptr     ptr;
      dcl	    p_field_value_ptr      ptr;
      dcl	    p_field_value_length   fixed bin (35);
      dcl	    p_vector_equal_to_key  bit (1) aligned;
      dcl	    p_vector_less_than_key bit (1) aligned;
      dcl	    p_code	       fixed bin (35);

      dcl	    p_vector_value_length  fixed bin (35);

/* Automatic */

      dcl	    cv_p_descriptor_ptr    ptr;
      dcl	    cv_p_vector_value_ptr  ptr;
      dcl	    cv_p_vector_value_length
			       fixed bin (35);
      dcl	    cv_p_field_value_ptr   ptr;
      dcl	    cv_p_field_value_length
			       fixed bin (35);
      dcl	    cv_p_vector_equal_to_key
			       bit (1) aligned;
      dcl	    cv_p_vector_less_than_key
			       bit (1) aligned;
      dcl	    cv_p_code	       fixed bin (35);

      dcl	    vector_value_is_in_field_format
			       bit (1) aligned;

/* Based */
/* Builtin */
/* Constant */

      dcl	    myname	       init ("dmu_compare_values") char (32) varying internal static options (constant);

/* Entry */
/* External */

/* END OF DECLARATIONS */

      vector_value_is_in_field_format = "0"b;
      cv_p_vector_value_length = -1;

      goto CVS_JOIN;


field_to_field:
   entry (p_descriptor_ptr, p_vector_value_ptr, p_vector_value_length, p_field_value_ptr, p_field_value_length,
      p_vector_equal_to_key, p_vector_less_than_key, p_code);

      vector_value_is_in_field_format = "1"b;
      cv_p_vector_value_length = p_vector_value_length;

CVS_JOIN:						/* Copy parameters into variables COMPARE_VALUES expects. */
      cv_p_descriptor_ptr = p_descriptor_ptr;
      cv_p_vector_value_ptr = p_vector_value_ptr;
      cv_p_field_value_ptr = p_field_value_ptr;
      cv_p_field_value_length = p_field_value_length;

      call COMPARE_VALUES (vector_value_is_in_field_format);

/* Copy output values into parameters to return to caller. */

      p_vector_equal_to_key = cv_p_vector_equal_to_key;
      p_vector_less_than_key = cv_p_vector_less_than_key;
      p_code = cv_p_code;

      return;
%page;
%include dm_comp_values_proc;

   end dmu_compare_values;




		    dmu_compare_vector_to_str.pl1   10/24/88  1636.9r w 10/24/88  1359.2       62280



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* format: style2,ind3 */

dmu_compare_vector_to_str:
   proc (p_field_table_ptr, p_simple_typed_vector_ptr, p_key_string_ptr, p_key_string_length, p_last_field_idx,
      p_first_inequal_field_id, p_vector_equal_to_key, p_vector_less_than_key, p_code);

/* DESCRIPTION:  
          This program compares the value of a simple_typed_vector and a key.
     It is responsible for "parsing" the key bit string into its constituent
     fields, using the information provided by the field_table.  Dimension I
     of the simple_typed_vector is assumed to be the same field as field I of
     the key.
          The comparison is done a-field-at-a-time, starting with field 1 and
     continuing with field 2, field 3, etc. until either an inequality is
     found or all of the fields have been compared.  
     
          All of the code is in the internal procedure
     COMPARE_VECTOR_TO_STRING, which is in the include file 
     dm_comp_vec_str_proc.incl.pl1.  This is so that other procedures can
     get the same functionality this module provides without the expense of
     an external call.
     
          COMPARE_VECTOR_TO_STRING takes no arguments.  It assumes that
     the main procedure has declared and set a set of global variables which
     COMPARE_VECTOR_TO_STRING will use as if they were parameters.  These
     variables are described in the Parameters section of 
     COMPARE_VECTOR_TO_STRING.
*/

/* HISTORY:

Written by Lindsey Spratt, 03/30/82.
Modified:
04/22/82 by Lindsey Spratt:  Added the maximum_field_idx to allow for
	  comparisons against branch keys which are less than full length.
	  Extended the calling sequence to allow for the last_field_idx, as
	  well.
05/17/82 by Lindsey Spratt:  Changed to use the
	  field_table.varying_field_map.varying_field_index to determine if
	  a field is a varying string.
06/30/82 by Lindsey Spratt:  Changed to accept simple_typed_vectors which are
	  less than full length.  The "maximum_field_idx" is set to the
	  minimum of the number of dimensions in the simple_typed_vector and
	  either the p_last_field_idx (if greater than 0) or the number of
	  the fields in the field table.
08/02/82 by Lindsey Spratt:  Changed to set the p_first_inequal_field_id.
09/01/82 by Lindsey Spratt:  Changed to use simple_typed_vectors which have
	  packed value ptrs.
10/27/82 by Lindsey Spratt:  Changed to return the "true"
	  first_inequal_field_id.  It is possible for this value to be one
	  greater than the maximum_field_idx, which in turn may mean that it
	  is one greater than the number of fields in the key.
11/04/82 by Lindsey Spratt:  Fixed comparison for the last field to not return
	  "equal" if the last field is truncated to a value which
	  is shorter than the vector value.
11/22/82 by Matthew Pierret: Changed an if-then statement to an if-then if-then
            statement.  One of the components of the if-clause contains a
            pointer that is not set if the other components are not true.
            This test is the one that determines if vector and key are not 
            equal based on differing lengths.
12/08/82 by Lindsey Spratt:  Fixed code which looks at varying field lengths
	  to cope with any size field length variable (currently 9, 18 and
	  36 bit length variables are possible).
01/12/83 by Lindsey Spratt:  Fixed the offset calculation for varying length
	  fields to take into account whether the length value is in bits or
	  characters.  Streamlined this code to make use of the previous
	  calculation for the previous varying length field, rather than add
	  up the lengths of all varying length fields prior to the field
	  being looked at.
06/29/83 by Lindsey L. Spratt:  Fixed to set the
            location_of_first_varying_field correctly when p_last_field_idx >
            0 but field_table.field(p_last_field_idx) is not a truncated
            field.
11/16/83 by Lindsey L. Spratt:  Fixed to always set the
            last_field_is_truncated flag correctly.
04/10/84 by Matthew Pierret:  Changed to use local copies of parameters for
            enhanced performance.  Also changed to set pointers to locatins
            in the key_string using the addbitno builtin instead of
            addr(key_bit_array,...). Changed to test the descriptor type for
            varying_char_dtype or varying_bit_dtype instead of looking in the
            varying_field_map to determine if a field is varying.
04/20/84 by Matthew Pierret:  Moved code into the internal subroutine
            COMPARE_VECTOR_TO_STRING which is contained in the include file
            dm_comp_vec_str_proc.incl.pl1.
05/03/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_field_table_ptr      ptr;
      dcl	    p_simple_typed_vector_ptr
			       ptr;
      dcl	    p_key_string_ptr       ptr;
      dcl	    p_key_string_length    fixed bin (24);
      dcl	    p_last_field_idx       fixed bin (17) unaligned;
      dcl	    p_first_inequal_field_id
			       fixed bin (17) parameter;
      dcl	    p_vector_equal_to_key  bit (1) aligned;
      dcl	    p_vector_less_than_key bit (1) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    cvs_p_field_table_ptr  ptr;
      dcl	    cvs_p_simple_typed_vector_ptr
			       ptr;
      dcl	    cvs_p_key_string_ptr   ptr;
      dcl	    cvs_p_key_string_length
			       fixed bin (35);
      dcl	    cvs_p_last_field_idx   fixed bin (17);
      dcl	    cvs_p_first_inequal_field_id
			       fixed bin (17);
      dcl	    cvs_p_vector_equal_to_key
			       bit (1) aligned;
      dcl	    cvs_p_vector_less_than_key
			       bit (1) aligned;
      dcl	    cvs_p_code	       fixed bin (35);

/* Based */
/* Builtin */
/* Controlled */
/* Constant */

      dcl	    myname	       init ("dmu_compare_vector_to_str") char (32) varying internal static
			       options (constant);
      ;

/* Entry */
/* External */

/* END OF DECLARATIONS */

      cvs_p_field_table_ptr = p_field_table_ptr;
      cvs_p_simple_typed_vector_ptr = p_simple_typed_vector_ptr;
      cvs_p_key_string_ptr = p_key_string_ptr;
      cvs_p_key_string_length = p_key_string_length;
      cvs_p_last_field_idx = p_last_field_idx;

      call COMPARE_VECTOR_TO_STRING ();

      p_first_inequal_field_id = cvs_p_first_inequal_field_id;
      p_vector_equal_to_key = cvs_p_vector_equal_to_key;
      p_vector_less_than_key = cvs_p_vector_less_than_key;
      p_code = cvs_p_code;

      return;
%page;
%include dm_comp_vec_str_proc;

   end dmu_compare_vector_to_str;




		    dmu_cv_string_to_vector.pl1     03/06/85  0750.4re  03/05/85  0755.1      178443



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:
          Converts data in the form of a non-varying bit string, formatted
     according to the supplied field_table, to a simple typed vector
     structure.  The new typed_vector is allocated in the caller-supplied
     area.  The caller may supply a list of fields to be converted, in which
     case the fields are converted to vector "values" and ordered in the
     returned vector in the same order as they appear in the caller-supplied
     id_list structure.  If the id_list_ptr is null, then a simple
     typed_vector containing all of the fields in the field_table is returned.
*/

/* HISTORY:
Written by Lindsey Spratt, 04/20/82, from dmu_cv_vector_to_string.
Modified:
05/17/82 by Lindsey Spratt: Changed to use (varying_field_idx > 0) to
	  determine if the field under consideration is a varying string or
	  not.  Also, converted from the field_id_list structure to the
	  id_list structure.
10/19/82 by Lindsey Spratt:  Fixed cv_field to use a parameter to  specify
	  which dimension of the simple_typed_vector is to be used as the
	  target of the conversion.
12/09/82 by Lindsey Spratt:  Fixed handling of varying character strings to
	  interpret the length variable value correctly.
02/04/83 by Lindsey Spratt:  Fixed to deal with varying strings correctly when
	  given an id_list.
02/08/83 by Lindsey Spratt:  Added a new entry point, called "new" which sets
	  the value of simple_typed_vector_ptr to p_simple_typed_vector_ptr
	  rather than always making it null.  Changed the rest of the module
	  to use the passed in simple_typed_vector if there is one.  A new
	  entry point was added so that modules could be converted over to
	  use the new approach (which relies on the caller being very
	  careful about the INPUT value of p_simple_typed_vector_ptr) in a
	  gradual fashion.
03/22/83 by Lindsey Spratt:  Changed to use version 2 field_table.  Changed to
	  check version numbers in the field_table and id_lsit structures.
04/03/83 by Lindsey L. Spratt:  Fixed vs_length to be declared fixed bin (35)
            instead of fixed bin (17).
04/03/83 by Lindsey L. Spratt:  Made version check of the id_list structure
            conditional on whether the id_list_ptr is null or not.
04/04/83 by Lindsey L. Spratt:  Fixed the re-use of the
            current_varying_field_bit_index in the non-null id_list case.
06/14/83 by Matthew Pierret:  Changed to leave an empty
            simple_typed_vector.value_ptr entry for each non-positive id in
            the given id_list.  Added a cleanup handler to free an allocated
            simple_typed_vector.  This is incomplete, as the values are not
            also freed.  Added copyright notice.
02/22/84 by Matthew Pierret:  Changed cv_field to two separate routines,
            CV_VARYING_FIELD and CV_NONVARYING_FIELD.  Changed the way fields
            are converted, from using a substr approach to usign an overlay 
            approach, in hopes of enhancing efficiency.  Added a check to
            see if all of the given id_list actually contains all fields in
            the order defined in in field_table.  If so, pretend that no
            id_list was supplied as the conversion of the all fields is
            faster than selected fields.
02/24/84 by Matthew Pierret:  Fixed improper use of addbitno builtin. The 
            number addbitno takes is an offset, but was being used as an index.
05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.
05/03/84 by Matthew Pierret:  Changed to use dm_error_$bad_vector_type instead
            of vd_error_$bad_vector_structure_type.
10/13/84 by Lindsey L. Spratt:  Fixed to set p_code to 0 on entry.  Deleted
            unused variables and changed to pass id_list.version by reference
            in call to CHECK_VERSION, in response to audit comments.
02/04/85 by Lindsey L. Spratt:  Added area condition handler and the
            ERROR_RETURN proc.
*/

/* format: style2,ind3 */

dmu_cv_string_to_vector:
   proc;
      call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	 "^/An invalid entry (dmu_cv_string_to_vector$dmu_cv_string_to_vector) was
invoked.");


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_field_table_ptr      ptr;
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_id_list_ptr	       ptr;
      dcl	    p_typed_vector_ptr     ptr;
      dcl	    p_string_length	       fixed bin (35);
      dcl	    p_string_ptr	       ptr;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    input_string_ptr       ptr;

      dcl	    id_list_idx	       fixed bin;

      dcl	    old_varying_field_idx  fixed bin (35) init (0);
      dcl	    current_varying_field_idx
			       fixed bin (35) init (0);
      dcl	    field_idx	       fixed bin (17);
      dcl	    current_varying_field_bit_index
			       fixed bin (35);
      dcl	    work_area_ptr	       ptr;

/* Based */

      dcl	    work_area	       area (sys_info$max_seg_size) based (work_area_ptr);

/* Builtin */

      dcl	    (addbitno, bin, null)  builtin;

/* Condition */

      dcl	    (area, cleanup)	       condition;

/* Constant */

      dcl	    myname	       init ("dmu_cv_string_to_vector") char (32) varying internal static
			       options (constant);

      dcl	    BITS_PER_BYTE	       init (9) fixed bin (17) int static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    error_table_$area_too_small,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;
      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;
      dcl	    (dm_error_$programming_error)
			       fixed bin (35) ext;
      dcl	    dm_error_$bad_vector_type
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

old:
   entry (p_field_table_ptr, p_work_area_ptr, p_string_ptr, p_string_length, p_id_list_ptr, p_typed_vector_ptr, p_code);
      simple_typed_vector_ptr = null;
      goto JOIN;

new:
   entry (p_field_table_ptr, p_work_area_ptr, p_string_ptr, p_string_length, p_id_list_ptr, p_typed_vector_ptr, p_code);
      simple_typed_vector_ptr = p_typed_vector_ptr;

JOIN:
      p_code = 0;
      input_string_ptr = p_string_ptr;

      field_table_ptr = p_field_table_ptr;
      call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      id_list_ptr = p_id_list_ptr;
      work_area_ptr = p_work_area_ptr;

      current_varying_field_bit_index = field_table.location_of_first_varying_field;

      on area call ERROR_RETURN (error_table_$area_too_small);

      if id_list_ptr ^= null
      then
         do;
	  call CHECK_VERSION (id_list.version, (ID_LIST_VERSION_1), "id_list");

/* See if the id_list actually contains all fields */

	  if id_list.number_of_ids = field_table.number_of_fields
	  then
	     do;
	        do id_list_idx = 1 to id_list.number_of_ids while (id_list_idx = id_list.id (id_list_idx));
	        end;
	        if id_list_idx > id_list.number_of_ids	/* contains all fields in order */
	        then id_list_ptr = null;
	     end;
         end;

      if id_list_ptr = null
      then
         do;
	  if simple_typed_vector_ptr = null
	  then
	     do;
	        on cleanup call FINISH;

	        stv_number_of_dimensions = field_table.number_of_fields;
	        alloc simple_typed_vector in (work_area);
	        simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
	        simple_typed_vector.dimension.value_ptr = null;
	     end;
	  else if simple_typed_vector.type ^= SIMPLE_TYPED_VECTOR_TYPE
	  then call sub_err_ (dm_error_$bad_vector_type, myname, ACTION_CANT_RESTART, null, 0,
		  "^/Expected a ""simple"" typed_vector (type = ^d).
Received instead a typed_vector with type = ^d.", SIMPLE_TYPED_VECTOR_TYPE, simple_typed_vector.type);
	  else if simple_typed_vector.number_of_dimensions < field_table.number_of_fields
	  then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		  "^/The provided ""simple"" typed_vector has only ^d dimensions, while the 
number of dimensions requested is ^d.", simple_typed_vector.number_of_dimensions, field_table.number_of_fields);


	  do field_idx = 1 to field_table.number_of_fields;
	     if field_table.varying_field_map (field_idx).varying_field_index <= 0
	     then call CV_NONVARYING_FIELD (field_idx, field_idx);
	     else call CV_VARYING_FIELD (field_idx, field_idx, current_varying_field_bit_index);
	  end;
         end;
      else
         do;
	  if simple_typed_vector_ptr = null
	  then
	     do;
	        on cleanup call FINISH;

	        stv_number_of_dimensions = id_list.number_of_ids;
	        alloc simple_typed_vector in (work_area);
	        simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
	        simple_typed_vector.dimension.value_ptr = null;
	     end;
	  else if simple_typed_vector.type ^= SIMPLE_TYPED_VECTOR_TYPE
	  then call sub_err_ (dm_error_$bad_vector_type, myname, ACTION_CANT_RESTART, null, 0,
		  "^/Expected a ""simple"" typed_vector (type = ^d).
Received instead a typed_vector with type = ^d.", SIMPLE_TYPED_VECTOR_TYPE, simple_typed_vector.type);
	  else if simple_typed_vector.number_of_dimensions < id_list.number_of_ids
	  then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		  "^/The provided ""simple"" typed_vector has only ^d dimensions, while the 
number of dimensions requested is ^d.", simple_typed_vector.number_of_dimensions, id_list.number_of_ids);


	  do id_list_idx = 1 to id_list.number_of_ids;

	     field_idx = id_list.id (id_list_idx);

	     if field_idx >= 1			/* If field_idx < 1, ignore it. */
	     then
	        do;
		 current_varying_field_idx = field_table.varying_field_map (field_idx).varying_field_index;

		 if current_varying_field_idx <= 0
		 then call CV_NONVARYING_FIELD (id_list_idx, field_idx);
		 else
		    do;				/* Current field is varying */
		       if current_varying_field_idx ^= old_varying_field_idx + 1
						/* The current_varying_field_bit_index is not valid for the current field. */
		       then current_varying_field_bit_index = -1;
		       old_varying_field_idx = current_varying_field_idx;

		       call CV_VARYING_FIELD (id_list_idx, field_idx, current_varying_field_bit_index);
		    end;
	        end;
	  end;
         end;


      if p_typed_vector_ptr ^= simple_typed_vector_ptr
      then p_typed_vector_ptr = simple_typed_vector_ptr;

MAIN_RETURN:
      return;
%page;
FINISH:
   proc ();


      if simple_typed_vector_ptr ^= null & simple_typed_vector_ptr ^= p_typed_vector_ptr
      then free simple_typed_vector in (work_area);

/**** Also need to free dimension values. */

   end FINISH;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parm;
      p_code = er_p_code;
      call FINISH ();
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CV_VARYING_FIELD:
   proc (cvf_p_dimension_idx, cvf_p_field_idx, cvf_p_current_varying_field_bit_index);

/* This routine copies the value of a varying field in the input string to
   a stand-alone varying dimension string. The location of the varying field
   in the input string is determined by adding up the lengths of all prior
   varying fields in the input string and the location of the first varying
   field. */

/* Global variables:

   input_string_ptr - points to the input string
   simple_typed_vector - the simple_typed_vector which holds the dimension
                         values to be returned.
   field_table - the field_table describing the fields in the input string.
   work_area - the area in which this program allocates things.
*/

      dcl	    cvf_p_dimension_idx    fixed bin;
      dcl	    cvf_p_field_idx	       fixed bin;
      dcl	    cvf_p_current_varying_field_bit_index
			       fixed bin (35);

      dcl	    cvf_field_idx	       fixed bin;
      dcl	    cvf_current_varying_field_bit_index
			       fixed bin (35);

      dcl	    cvf_varying_field_idx  fixed bin init (0);	/* index into field_table.varying_field_map for each prior varying field */
      dcl	    cvf_temp_field_idx     fixed bin init (0);	/* index into field_table.field for each prior varying field */
      dcl	    cvf_temp_varying_field_length
			       fixed bin (35) init (0);
						/* length of each prior varying field */

      dcl	    cvf_dimension_value_string
			       bit (cvf_dimension_value_length) varying based (cvf_dimension_value_ptr);
						/* Varying bit string which holds converted field value */
      dcl	    cvf_dimension_value_length
			       fixed bin (35) init (0);
      dcl	    cvf_dimension_value_ptr
			       ptr init (null);

      dcl	    cvf_dimension_value_length_overlay
			       fixed bin (35) based (cvf_dimension_value_ptr);
						/* Overlays the length word of the varying dimension_value_string */
						/* This is used to change the length from bit- to character-length*/
      dcl	    cvf_dimension_value_length_in_characters
			       fixed bin (35) init (0);
						/* Saved length of the dimension in characters. */

      dcl	    cvf_field_value_string bit (cvf_dimension_value_length) based (cvf_field_value_ptr);
						/* Non-varying bit string overlay of field in input string */
      dcl	    cvf_field_value_ptr    ptr init (null);

      dcl	    cvf_length_field_string
			       bit (cvf_length_field_length) based (cvf_length_field_ptr);
						/* Bit string overlay of varying field length in input string */
      dcl	    cvf_length_field_length
			       fixed bin (35) init (0);
      dcl	    cvf_length_field_ptr   ptr init (null);

      dcl	    cvf_field_length_is_in_characters
			       bit (1) aligned init ("0"b);



      cvf_field_idx = cvf_p_field_idx;			/* for efficiency */
      cvf_current_varying_field_bit_index = cvf_p_current_varying_field_bit_index;


      if cvf_current_varying_field_bit_index = -1
      then /* Find location of varying field */
         do;
	  cvf_current_varying_field_bit_index = field_table.location_of_first_varying_field;

CVF_LOOP_THROUGH_VARYING_FIELDS:
	  do cvf_varying_field_idx = 1 to field_table.varying_field_map (cvf_field_idx).varying_field_index - 1;

	     cvf_temp_field_idx = field_table.varying_field_map (cvf_varying_field_idx).field_id;
	     cvf_length_field_length = field_table.field (cvf_temp_field_idx).length_in_bits;
	     cvf_length_field_ptr = addbitno (input_string_ptr, field_table.field (cvf_temp_field_idx).location - 1);
	     cvf_temp_varying_field_length = bin (cvf_length_field_string, 35, 0);

	     if field_table.field (cvf_temp_field_idx).flags.length_is_in_characters
	     then cvf_temp_varying_field_length = cvf_temp_varying_field_length * BITS_PER_BYTE;

	     cvf_current_varying_field_bit_index = cvf_current_varying_field_bit_index + cvf_temp_varying_field_length;

	  end CVF_LOOP_THROUGH_VARYING_FIELDS;

         end;


/* Set the length of the dimension */

      cvf_length_field_length = field_table.field (cvf_field_idx).length_in_bits;
      cvf_length_field_ptr = addbitno (input_string_ptr, field_table.field (cvf_field_idx).location - 1);
      cvf_dimension_value_length = bin (cvf_length_field_string, 35, 0);

      cvf_field_length_is_in_characters = field_table.field (cvf_field_idx).flags.length_is_in_characters;
      if cvf_field_length_is_in_characters		/* Change character length to bit length */
      then
         do;
	  cvf_dimension_value_length_in_characters = cvf_dimension_value_length;
	  cvf_dimension_value_length = cvf_dimension_value_length * BITS_PER_BYTE;
         end;

/* Set the pointer to the dimension to return */

      cvf_dimension_value_ptr = simple_typed_vector.dimension (cvf_p_dimension_idx).value_ptr;
      if cvf_dimension_value_ptr = null
      then
         do;
	  alloc cvf_dimension_value_string in (work_area);
	  simple_typed_vector.dimension (cvf_p_dimension_idx).value_ptr = cvf_dimension_value_ptr;
         end;

      cvf_field_value_ptr = addbitno (input_string_ptr, cvf_current_varying_field_bit_index - 1);

      cvf_dimension_value_string = cvf_field_value_string;	/* Copy the value */

      if cvf_field_length_is_in_characters
      then cvf_dimension_value_length_overlay = cvf_dimension_value_length_in_characters;

      cvf_p_current_varying_field_bit_index = cvf_current_varying_field_bit_index + cvf_dimension_value_length;
						/* Set return value */

      return;

   end CV_VARYING_FIELD;
%page;
CV_NONVARYING_FIELD:
   proc (cnf_p_dimension_idx, cnf_p_field_idx);

/* This routine copies the value of the cnf_p_field_idx'th field in the
   string into a stand-alone, nonvarying dimension value. */

      dcl	    cnf_p_dimension_idx    fixed bin;
      dcl	    cnf_p_field_idx	       fixed bin;

      dcl	    cnf_field_idx	       fixed bin;		/* Local copy for efficiency */
      dcl	    cnf_field_value_ptr    ptr;
      dcl	    cnf_dimension_value_ptr
			       ptr;
      dcl	    cnf_dimension_value_length
			       fixed bin;		/* Length of dimension value in bits */
      dcl	    cnf_dimension_value_string
			       bit (cnf_dimension_value_length) based (cnf_dimension_value_ptr);

/* Global variables:

   input_string_ptr - points to the input string
   simple_typed_vector - the simple_typed_vector which holds the dimension
                         values to be returned.
   field_table - the field_table describing the fields in the input string.
   work_area - the area in which this program allocates things.
*/

      cnf_field_idx = cnf_p_field_idx;

      cnf_dimension_value_length = field_table.field (cnf_field_idx).length_in_bits;
      cnf_dimension_value_ptr = simple_typed_vector.dimension (cnf_p_dimension_idx).value_ptr;
      if cnf_dimension_value_ptr = null
      then
         do;
	  alloc cnf_dimension_value_string in (work_area);
	  simple_typed_vector.dimension (cnf_p_dimension_idx).value_ptr = cnf_dimension_value_ptr;
         end;

      cnf_field_value_ptr = addbitno (input_string_ptr, field_table.field (cnf_field_idx).location - 1);

      cnf_dimension_value_string = cnf_field_value_ptr -> cnf_dimension_value_string;

      return;

   end CV_NONVARYING_FIELD;
%page;
CHECK_VERSION_CHAR:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (8) aligned parameter;
      dcl	    p_expected_version     char (8) aligned parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure. Received version ^a.", p_expected_version, p_structure_name,
	      p_received_version);

   end CHECK_VERSION_CHAR;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35) parameter;
      dcl	    p_expected_version     fixed bin (35) parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure. Received version ^d.", p_expected_version, p_structure_name,
	      p_received_version);

   end CHECK_VERSION;
%page;
%include vu_typed_vector;
%page;
%include dm_field_table;
%page;
%include dm_id_list;
%page;
%include sub_err_flags;
   end dmu_cv_string_to_vector;




		    dmu_cv_table_to_typed_array.pl1 01/04/85  0947.4re  01/03/85  1149.9       69957



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:
        Given a pointer to a field_table and a list of field ids, this module
   builds a typed_vector_array, allocated in the provided area, by converting 
   field descriptions in the field_table into dimension descriptions in the
   dimension_table.
*/

/* HISTORY:
Written by Matthew Pierret 04/05/82.
Modified:
04/14/82 by Lindsey Spratt: Changed the field_table location to be 1-originned
	  instead of 0-originned.  ft_maximum_field_name_length is no longer
	  calculated but is simply set to
	  typed_vector_array.maximum_dimension_name_length.  Also, the
	  descriptor_string based variable was changed from unaligned to
	  aligned.
06/28/82 by Lindsey Spratt: Declared a local automatic variable
	  "number_of_fields".  field_table.number_of_fields was being set to
	   the number of field ids being passed in as an argument.
08/19/82 by Matthew Pierret:  Changed p_ids to p_id_list_ptr, which
            points to id_list structure.
10/14/82 by Matthew Pierret:  Added p_number_of_vector_slots.
03/22/83 by Lindsey Spratt:  Changed to use version 2 of the field_table
	  structure.  Added the CHECK_VERSION_CHAR internal procedure.
06/14/83 by Matthew Pierret:  Changed to leave a blank dimension_table entry
            if a non-positive id is specified in p_id_list.
            Added FINISH routine as cleanup handler and enabled cleanup
            condition.  Added copyright notice.
05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.  Removed some
            un-used variables.
11/27/84 by Lindsey L. Spratt:  Changed to use dm_vector_util_ instead of
            vector_util_.
12/07/84 by M. Sharpe: to clean up format and dcls; to correct calls to
	  CHECK_VERSION* to pass parameters by reference where possible.
*/
/* format: style2,ind3 */

dmu_cv_table_to_typed_array:
cv_table_to_typed_array:
   proc (p_field_table_ptr, p_id_list_ptr, p_area_ptr, p_number_of_vector_slots, p_typed_vector_array_ptr, p_code);


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_area_ptr	       ptr;
      dcl	    p_typed_vector_array_ptr
			       ptr;
      dcl	    p_field_table_ptr      ptr;
      dcl	    p_id_list_ptr	       ptr;
      dcl	    p_number_of_vector_slots
			       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    process_all_fields     bit (1) aligned;
      dcl	    number_of_fields       fixed bin;
      dcl	    dimension_idx	       fixed bin;
      dcl	    field_id	       fixed bin (17);
      dcl	    area_ptr	       ptr;
      dcl	    descriptor_string_ptr  ptr;

/* Based */

      dcl	    area		       area (sys_info$max_seg_size) based (area_ptr);
      dcl	    descriptor_string      aligned bit (36) based (descriptor_string_ptr);

/* Builtin */

      dcl	    (hbound, max, null, substr)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("dmu_cv_table_to_typed_array") char (32) varying int static options (constant);

/* Entry */

      dcl	    sub_err_	       entry options (variable);
      dcl	    dm_vector_util_$init_typed_vector_array
			       entry options (variable);
      dcl	    dm_vector_util_$free_typed_vector_array
			       entry (ptr, ptr, fixed bin (35));

/* External */

      dcl	    error_table_$fatal_error
			       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);
      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code = 0;
      area_ptr = p_area_ptr;
      field_table_ptr = p_field_table_ptr;

      call CHECK_VERSION_CHAR ((field_table.version), (FIELD_TABLE_VERSION_3), "field_table");

      if p_id_list_ptr = null
      then
         do;

	  number_of_fields = hbound (field_table.field, 1);
	  process_all_fields = "1"b;

         end;
      else
         do;

	  id_list_ptr = p_id_list_ptr;
	  call CHECK_VERSION (id_list.version, (ID_LIST_VERSION_1), "id_list");

	  process_all_fields = "0"b;
	  number_of_fields = id_list.number_of_ids;

         end;

      tva_maximum_dimension_name_length = 0;
      do dimension_idx = 1 to number_of_fields;
         if process_all_fields
         then field_id = dimension_idx;
         else field_id = id_list.id (dimension_idx);
         if field_id >= 1
         then tva_maximum_dimension_name_length =
	         max (tva_maximum_dimension_name_length, field_table.field (field_id).length_of_name);
      end;

      typed_vector_array_ptr = null;

      on cleanup call FINISH ();

      call dm_vector_util_$init_typed_vector_array (area_ptr, p_number_of_vector_slots, number_of_fields,
	 tva_maximum_dimension_name_length, typed_vector_array_ptr, p_code);
      if p_code ^= 0
      then return;
      call CHECK_VERSION (typed_vector_array.version, TYPED_VECTOR_ARRAY_VERSION_2, "typed_vector_array");


      dimension_idx = 0;
SET_NAME_AND_DESCRIPTOR:
      do dimension_idx = 1 to number_of_fields;

         if process_all_fields
         then field_id = dimension_idx;
         else field_id = id_list.id (dimension_idx);

         if field_id >= 1				/* If field_id<1, leave dimension_table entry empty */
         then
	  do;
	     typed_vector_array.dimension_table (dimension_idx).name =
		substr (field_table.field_names, field_table.field (field_id).location_of_name,
		field_table.field (field_id).length_of_name);
	     if field_table.field (field_id).flags.descriptor_is_varying
	     then call sub_err_ (error_table_$fatal_error, myname, "s", null, 0,
		     "^/The capability to handle varying length descriptors is not yet supported.");

	     alloc descriptor_string in (area);
	     descriptor_string = field_table.field (field_id).descriptor;

	     typed_vector_array.dimension_table (dimension_idx).descriptor_ptr = descriptor_string_ptr;
	  end;
      end SET_NAME_AND_DESCRIPTOR;

      p_typed_vector_array_ptr = typed_vector_array_ptr;

      return;
%page;
FINISH:
   proc ();

      if typed_vector_array_ptr ^= null
      then call dm_vector_util_$free_typed_vector_array (area_ptr, typed_vector_array_ptr, (0));

   end FINISH;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
CHECK_VERSION_CHAR:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (*) parameter;
      dcl	    p_expected_version     char (*) parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION_CHAR;
%page;
%include vu_typed_vector_array;
%page;
%include dm_field_table;
%page;
%include dm_id_list;
%page;
%include sub_err_flags;
   end dmu_cv_table_to_typed_array;




		    dmu_cv_typed_array_to_table.pl1 01/04/85  0947.4re  01/03/85  1150.0       96894



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:
        Given a pointer to a typed vector array, this module builds a
   field_table, allocated in the provided area, by converting the dimension
   descriptions in the dimension_table into field descriptions in the
   field_table.  
   
        A field_table describes how fields are layed out in a record
   string or key string, generically known as data strings.  A data
   string is divided into two parts, the fixed part and the varying
   part.  There is a fixed-size field for each field of the
   record/key in the fixed part, whether the field is varying or
   nonvarying.  These fixed-sized fields are in the order specified
   in typed_vector_array.dimension_table.  These fixed-sized fields
   are aligned according to their data types.
   
        Nonvarying fields are kept in their entirety in their
   corresponding fixed-sized field in the fixed part.  Varying fields
   have the lengths of the varying fields kept in their corresponding
   fixed-sized fileds in the fixed part.  The contents of the varying
   fields are kept in the varying part.
*/

/* HISTORY:
Written by Matthew Pierret 04/05/82.
Modified:
04/14/82 by Lindsey Spratt: Changed the field_table location to be 1-originned
	  instead of 0-originned.  ft_maximum_field_name_length is no longer
	  calculated but is simply set to
	  typed_vector_array.maximum_dimension_name_length.  Also, the
	  descriptor_string based variable was changed from unaligned to
	  aligned.
05/19/82 by Lindsey Spratt: Changed to always set the
	  location_of_first_varying_field to reflect the length of the fixed
	  portion of the data string, whether or not there are any varying
	  fields.
03/22/83 by Lindsey Spratt:  Changed to use version 2 of the field_table 
	  structure.
05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3, which includes
            laying out the field names in a single string at the end of the
            structure (field_names).  Also changed to align fields within the
            data string.
09/12/84 by Matthew C. Pierret:  Changed the SET_FIELD_LOCATIONS loop to set
            the location after calculating what the location should be,
            instead of before.  Upper-cased the internal subroutine names and
            added a prefix before each variable local to an internal
            subroutine.  Changed the format style from style2,ind3, so
            reformat before comparing with the old version.
*/

/* format: style2,ind3 */
/* format: ll79,comcol50,indcomtxt,^indnoniterdo,indnoniterend */

dmu_cv_typed_array_to_table:
   proc (p_typed_vector_array_ptr, p_area_ptr, p_field_table_ptr,
        p_maximum_record_length, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_area_ptr	       ptr;
      dcl	    p_typed_vector_array_ptr
			       ptr;
      dcl	    p_field_table_ptr      ptr;
      dcl	    p_maximum_record_length
			       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    alignment	       fixed bin;
      dcl	    bits_past_alignment_boundary
			       fixed bin;
      dcl	    dimension_idx	       fixed bin;
      dcl	    field_idx	       fixed bin;
      dcl	    location_of_next_field fixed bin (35);
      dcl	    varying_field_portion_length
			       fixed bin (35);
      dcl	    field_length_in_bits   fixed bin (35);
      dcl	    position_in_varying_fields
			       fixed bin;
      dcl	    area_ptr	       ptr;

/* Based */

      dcl	    area		       area (sys_info$max_seg_size)
			       based (area_ptr);
      dcl	    descriptor_string      aligned bit (36) based;

/* Builtin */

      dcl	    (hbound, null, length, string, addr)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("dmu_cv_typed_array_to_table")
			       char (32) varying int static
			       options (constant);
      dcl	    MAXIMUM_LENGTH_HELD_IN_ONE_BYTE
			       fixed bin (35) int static
			       options (constant)
			       init (511 /* 2 ** 9 - 1 */);
      dcl	    MAXIMUM_LENGTH_HELD_IN_TWO_BYTES
			       fixed bin (35) int static
			       options (constant)
			       init (262143511 /* 2 ** 18 - 1 */);
      dcl	    ONE_BYTE	       fixed bin int static
			       options (constant) init (9);
      dcl	    TWO_BYTES	       fixed bin int static
			       options (constant) init (18);
      dcl	    FOUR_BYTES	       fixed bin int static
			       options (constant) init (36);

/* Entry */

      dcl	    sub_err_	       entry options (variable);
      dcl	    dmu_get_data_bit_length$alignment
			       entry (bit (36) aligned, fixed bin (35),
			       fixed bin (17), fixed bin (35));

/* External */

      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);
      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* END OF DECLARATIONS */

      typed_vector_array_ptr = p_typed_vector_array_ptr;
      area_ptr = p_area_ptr;
      p_code = 0;

      if typed_vector_array.version ^= TYPED_VECTOR_ARRAY_VERSION_2
      then call sub_err_ (error_table_$unimplemented_version, myname,
	      ACTION_CANT_RESTART, null, 0,
	      "^/Expecting version ^d of the typed_vector_array structure, received version ^d."
	      , TYPED_VECTOR_ARRAY_VERSION_2, typed_vector_array.version);

      ft_number_of_fields = typed_vector_array.number_of_dimensions;
      ft_length_of_field_names = 0;
SET_LENGTH_OF_FIELD_NAMES:
      do field_idx = 1 to ft_number_of_fields;
         ft_length_of_field_names =
	    ft_length_of_field_names
	    +
	    length (
	    rtrim (typed_vector_array.dimension_table (field_idx).name));
      end SET_LENGTH_OF_FIELD_NAMES;

      alloc field_table in (area);
      field_table.field_names = "";

SET_NAME_AND_DESCRIPTOR:
      do field_idx = 1 to field_table.number_of_fields;
         field_table.field (field_idx).location_of_name =
	    length (rtrim (field_table.field_names)) + 1;
         field_table.field (field_idx).length_of_name =
	    length (
	    rtrim (typed_vector_array.dimension_table (field_idx).name));
         field_table.field_names =
	    rtrim (field_table.field_names)
	    || rtrim (typed_vector_array.dimension_table (field_idx).name);

         field_table.field (field_idx).descriptor =
	    typed_vector_array.dimension_table (field_idx).descriptor_ptr
	    -> descriptor_string;
         string (field_table.field (field_idx).flags) = "0"b;
      end SET_NAME_AND_DESCRIPTOR;

      position_in_varying_fields = 0;
SETUP_VARYING_FIELD_MAP:
      do field_idx = 1 to hbound (field_table.field, 1);
         if FIELD_IS_VARYING (field_table.field (field_idx).descriptor)
         then
	  do;
	  field_table.field (field_idx).flags.length_is_in_characters =
	       FIELD_IS_CHARACTER_VARYING (field_table.field (field_idx)
	       .descriptor);
	  position_in_varying_fields = position_in_varying_fields + 1;
	  field_table.varying_field_map (position_in_varying_fields)
	       .field_id = field_idx;
	  field_table.varying_field_map (field_idx).varying_field_index =
	       position_in_varying_fields;
	  end;
      end SETUP_VARYING_FIELD_MAP;

      location_of_next_field = 1;
      varying_field_portion_length = 0;
SET_FIELD_LOCATIONS:
      do field_idx = 1 to hbound (field_table.field, 1);
         call dmu_get_data_bit_length$alignment (field_table.field (field_idx)
	    .descriptor, field_length_in_bits, alignment, code);
         if code ^= 0
         then call sub_err_ (code, myname, ACTION_CANT_RESTART, null, 0,
	         "^/Could not get bit-length of filed with descriptor ^3bo.",
	         field_table.field (field_idx).descriptor);

         bits_past_alignment_boundary =
	    mod (location_of_next_field - 1, alignment);
         if bits_past_alignment_boundary > 0
         then location_of_next_field =
	         location_of_next_field + alignment
	         - bits_past_alignment_boundary;

         if field_table.varying_field_map (field_idx).varying_field_index = 0
         then field_table.field (field_idx).length_in_bits =
	         field_length_in_bits;
         else
	  do;
	  if field_length_in_bits < MAXIMUM_LENGTH_HELD_IN_ONE_BYTE
	  then field_table.field (field_idx).length_in_bits = ONE_BYTE;
	  else if field_length_in_bits < MAXIMUM_LENGTH_HELD_IN_TWO_BYTES
	  then field_table.field (field_idx).length_in_bits = TWO_BYTES;
	  else field_table.field (field_idx).length_in_bits = FOUR_BYTES;

	  varying_field_portion_length =
	       varying_field_portion_length + field_length_in_bits;
	  end;
         field_table.field (field_idx).location = location_of_next_field;
         location_of_next_field =
	    location_of_next_field
	    + field_table.field (field_idx).length_in_bits;

      end SET_FIELD_LOCATIONS;
      field_table.location_of_first_varying_field = location_of_next_field;

      p_field_table_ptr = field_table_ptr;
      p_maximum_record_length =
	 location_of_next_field + varying_field_portion_length;

      return;
%page;
FIELD_IS_VARYING:
   proc (fiv_p_descriptor_string) returns (bit (1) aligned);

      dcl	    fiv_p_descriptor_string
			       bit (36) aligned;
      dcl	    1 fiv_descriptor_type  unal
			       based (addr (fiv_p_descriptor_string)),
	      2 unused1	       bit (1) unal,
	      2 type	       fixed bin (6) unsigned unal,
	      2 unused2	       bit (29) unal;
      dcl	    BIT_VARYING	       fixed bin (6) unsigned init (20);
      dcl	    CHAR_VARYING	       fixed bin (6) init (22);

      if fiv_descriptor_type.type = BIT_VARYING
	 | fiv_descriptor_type.type = CHAR_VARYING
      then return ("1"b);
      else return ("0"b);

   end FIELD_IS_VARYING;
%page;
FIELD_IS_CHARACTER_VARYING:
   proc (ficv_p_descriptor_string) returns (bit (1) aligned);

      dcl	    ficv_p_descriptor_string
			       bit (36) aligned;
      dcl	    1 ficv_descriptor_type unal
			       based (addr (ficv_p_descriptor_string)),
	      2 unused1	       bit (1) unal,
	      2 type	       fixed bin (6) unsigned unal,
	      2 unused2	       bit (29) unal;
      dcl	    BIT_VARYING	       fixed bin (6) unsigned init (20);
      dcl	    CHAR_VARYING	       fixed bin (6) init (22);

      if ficv_descriptor_type.type = CHAR_VARYING
      then return ("1"b);
      else return ("0"b);

   end FIELD_IS_CHARACTER_VARYING;
%page;
%include vu_typed_vector_array;
%page;
%include dm_field_table;
%page;
%include sub_err_flags;
   end dmu_cv_typed_array_to_table;




		    dmu_cv_vector_to_string.pl1     10/24/88  1636.9r w 10/24/88  1400.2       97875



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:
          Converts data in the form of a typed vector into a varying bit 
     string, formatted according to the supplied field_table.  The bit string 
     is placed in the caller supplied string_buffer if it will fit.  If it
     doesn't fit, then the bit string is allocated in the caller-supplied
     work_area.  If it doesn't fit there (or no work_area was supplied), then
     and error is returned.
*/

/* HISTORY:
Written by Lindsey Spratt, 04/02/82.
Modified:
04/14/82 by Lindsey Spratt: Changed to set the length word of the "p_string"
	  returned to the caller.  A new variable, p_string_length, is
	  defined which is based on the first word of the storage pointed at
	  by p_string_ptr.  Also, varying size length value for varying
	  strings are now handled.  The old technology was to assume that
	  all length values for varying character strings were one word (36
	  bits).  Now, the "length_in_bits" of the field_table is used to
	  get the size of the length value.
05/17/82 by Lindsey Spratt: Changed to use
	  field_table.varying_field_map.varying_field_index to determine if
	  a field is a varying string.  Was (incorrectly) using the
	  descriptor_is_varying bit.
12/22/82 by Lindsey Spratt:  Extended to support allocating new buffers at
	  need.  Added the p_return_string_buffer_length parameter.
01/03/83 by Lindsey Spratt:  Corrected setting of the buffer_string.length
	  value.  Was being set to buffer_string_length regardless of actual
	  string length, in some cases.
01/06/83 by Lindsey Spratt:  Fixed varying case to not use the p_string_ptr ->
	  based_varying_bit_string construct, but rather
	  buffer_string.contents.
03/23/83 by Lindsey Spratt:  Fixed to use version 2 field_table structure,
	  and changed to check the version of the field_table structure and
	  the type of the simple_typed_vector.
05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.
11/08/84 by Lindsey L. Spratt:  Changed to use ERROR_RETURN technique.  Minor
            format changes.  Corrected arguments for an error message.
            Changed CHECK_VERSION_CHAR to have char(8) aligned parameters for
            the versions.
*/

/* format: style2,ind3 */
dmu_cv_vector_to_string:
cv_vector_to_string:
   proc (p_field_table_ptr, p_typed_vector_ptr, p_string_buffer_ptr, p_string_buffer_length, p_work_area_ptr,
        p_string_ptr, p_return_string_buffer_length, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_field_table_ptr      ptr;
      dcl	    p_typed_vector_ptr     ptr;
      dcl	    p_string_buffer_ptr    ptr;
      dcl	    p_string_buffer_length fixed bin (35);
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_string_ptr	       ptr;
      dcl	    p_return_string_buffer_length
			       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    (buffer_string_ptr, new_buffer_string_ptr, old_buffer_string_ptr)
			       ptr init (null);
      dcl	    (buffer_string_length, new_buffer_string_length, old_buffer_string_length)
			       fixed bin (35) init (0);
      dcl	    work_area_ptr	       ptr init (null);

      dcl	    current_length_in_bits fixed bin (35);
      dcl	    data_type	       fixed bin (17);
      dcl	    field_idx	       fixed bin (17);
      dcl	    current_varying_field_bit_offset
			       fixed bin (35);
      dcl	    local_real_fix_bin_1a  fixed bin (35) aligned;

/* Based */

      dcl	    based_real_fix_bin_1u  fixed bin (35) unaligned based;
      dcl	    based_bit_string       bit (sys_info$max_seg_size * 36) based;
      dcl	    p_string_length	       fixed bin (35) based (p_string_ptr) unaligned;
      dcl	    1 buffer_string	       based (buffer_string_ptr) unaligned,
	      2 length	       fixed bin (35),
	      2 contents	       bit (buffer_string_length refer (buffer_string.length));
      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    (null, addr, length, copy)
			       builtin;

/* Condition */

      dcl	    (cleanup, area)	       condition;

/* Constant */

      dcl	    (
	    BITS_PER_WORD	       init (36),
	    BITS_PER_BYTE	       init (9)
	    )		       fixed bin (17) int static options (constant);
      dcl	    myname	       init ("dmu_cv_vector_to_string") char (32) varying internal static
			       options (constant);

/* Entry */

      dcl	    decode_descriptor_     entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;
      dcl	    (
	    dm_error_$short_buffer,
	    error_table_$bad_arg,
	    error_table_$unimplemented_version,
	    dm_error_$bad_vector_type
	    )		       fixed bin (35) ext;


/* END OF DECLARATIONS */

      p_code = 0;
      p_string_ptr = null;
      p_return_string_buffer_length = p_string_buffer_length;
      field_table_ptr = p_field_table_ptr;
      call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      simple_typed_vector_ptr = p_typed_vector_ptr;
      if simple_typed_vector.type ^= SIMPLE_TYPED_VECTOR_TYPE
      then call sub_err_ (dm_error_$bad_vector_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected a simple_typed_vector type structure (type ^d).
Received a structure with type ^d instead.", SIMPLE_TYPED_VECTOR_TYPE, simple_typed_vector.type);

      work_area_ptr = p_work_area_ptr;

      if p_string_buffer_length <= 0
      then call sub_err_ (error_table_$bad_arg, myname, "h", null, 0,
	      "^/The length of the string_buffer must be greater than 0.  The length
provided was ^d.", p_string_buffer_length);

      on cleanup call FINISH;

      on area call ERROR_RETURN (dm_error_$short_buffer);

      buffer_string_ptr = p_string_buffer_ptr;
      current_varying_field_bit_offset = field_table.location_of_first_varying_field;
      buffer_string_length = p_string_buffer_length - BITS_PER_WORD;
      buffer_string.length = field_table.location_of_first_varying_field - 1;

/* If the fixed length of the string is going to be larger than the entire
buffer, then either return the short buffer error or allocate a new,
sufficiently large buffer.
*/

      if buffer_string.length > buffer_string_length
      then if work_area_ptr = null
	 then call ERROR_RETURN (dm_error_$short_buffer);
	 else
	    do;
	       old_buffer_string_ptr = buffer_string_ptr;
	       old_buffer_string_length = buffer_string_length;
	       buffer_string_length = max (2 * buffer_string_length, buffer_string.length);
	       alloc buffer_string in (work_area);
	       buffer_string.length = old_buffer_string_ptr -> buffer_string.length;
	    end;

FIELD_LOOP:
      do field_idx = 1 to field_table.number_of_fields;
         if field_table.varying_field_map (field_idx).varying_field_index > 0
         then
VARYING_FIELD:
	  do;
	     substr (buffer_string.contents, field_table.field (field_idx).location,
		field_table.field (field_idx).length_in_bits) =
		substr (simple_typed_vector.dimension (field_idx).value_ptr -> based_bit_string,
		BITS_PER_WORD - field_table.field (field_idx).length_in_bits + 1,
		field_table.field (field_idx).length_in_bits);

	     if field_table.field (field_idx).length_is_in_characters
	     then current_length_in_bits =
		     simple_typed_vector.dimension (field_idx).value_ptr -> based_real_fix_bin_1u * BITS_PER_BYTE;
	     else current_length_in_bits = simple_typed_vector.dimension (field_idx).value_ptr -> based_real_fix_bin_1u;

	     buffer_string.length = buffer_string.length + current_length_in_bits;

	     if buffer_string.length > buffer_string_length
	     then if work_area_ptr = null
		then call ERROR_RETURN (dm_error_$short_buffer);
		else
		   do;
		      new_buffer_string_length = max (2 * buffer_string_length, buffer_string.length);
		      buffer_string.length = buffer_string.length - current_length_in_bits;
		      old_buffer_string_length = buffer_string_length;
		      old_buffer_string_ptr = buffer_string_ptr;
		      buffer_string_length = new_buffer_string_length;
		      alloc buffer_string in (work_area);
		      buffer_string = old_buffer_string_ptr -> buffer_string;
		      buffer_string.length = buffer_string.length + current_length_in_bits;
		      old_buffer_string_ptr -> buffer_string.length = old_buffer_string_length;
		      if old_buffer_string_ptr ^= p_string_buffer_ptr
		      then free old_buffer_string_ptr -> buffer_string in (work_area);
		   end;

	     substr (buffer_string.contents, current_varying_field_bit_offset, current_length_in_bits) =
		substr (simple_typed_vector.dimension (field_idx).value_ptr -> based_bit_string, 37,
		current_length_in_bits);
	     current_varying_field_bit_offset = current_varying_field_bit_offset + current_length_in_bits;
	  end VARYING_FIELD;
         else
	  do;
	     substr (buffer_string.contents, field_table.field (field_idx).location,
		field_table.field (field_idx).length_in_bits) =
		substr (simple_typed_vector.dimension (field_idx).value_ptr -> based_bit_string, 1,
		field_table.field (field_idx).length_in_bits);
	  end;
      end FIELD_LOOP;
      p_string_ptr = buffer_string_ptr;
      buffer_string_ptr = null;
      p_return_string_buffer_length = buffer_string_length + BITS_PER_WORD;

      call FINISH;

MAIN_RETURN:
      return;
%page;
FINISH:
   proc;
      if buffer_string_ptr ^= p_string_buffer_ptr & buffer_string_ptr ^= null
      then
         do;
	  buffer_string.length = buffer_string_length;
	  free buffer_string in (work_area);
         end;
   end FINISH;

ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;
      call FINISH ();
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CHECK_VERSION_CHAR:
   proc (p_expected_version, p_received_version, p_structure_name);
      dcl	    (p_expected_version, p_received_version)
			       char (8) aligned parameter;
      dcl	    p_structure_name       char (*) parameter;
      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION_CHAR;
%page;
%include sub_err_flags;
%page;
%include std_descriptor_types;
%page;
%include vu_typed_vector;
%page;
%include dm_field_table;
   end dmu_cv_vector_to_string;




		    dmu_display_string.pl1          01/04/85  0947.4re  01/03/85  1150.0       55962



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
dmu_display_string:
   proc (p_field_table_ptr, p_string_ptr, p_string_length, p_code);

/* DESCRIPTION:

         This  program  takes  as input a field_table and a "data string" and
     displays the data string interpreted according to the field_table.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 05/08/83.
Modified:
05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_field_table_ptr      ptr;		/*is a pointer to field_table which is
                                      used to control the display of the data
                                      string.*/
      dcl	    p_string_ptr	       ptr;		/*is a pointer to the data string to be
                                      displayed.*/
      dcl	    p_string_length	       fixed bin (35);	/*is the length of the data string
                                      pointed at by string_ptr.*/
      dcl	    p_code	       fixed bin (35);	/*is a standard system error code.*/

/* Automatic */

      dcl	    field_idx	       fixed bin;
      dcl	    current_varying_field_bit_index
			       fixed bin (35) init (0);

/* Based */
/* Builtin */

      dcl	    (null, substr)	       builtin;

/* Constant */

      dcl	    myname	       init ("dmu_display_string") char (32) varying internal static options (constant);
      dcl	    (
	    BITS_PER_WORD	       init (36),
	    BITS_PER_BYTE	       init (9)
	    )		       fixed bin internal static options (constant);

/* Entry */

      dcl	    ioa_		       entry () options (variable);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;
      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;

/* END OF DECLARATIONS */

      field_table_ptr = p_field_table_ptr;
      call CHECK_VERSION ((field_table.version), (FIELD_TABLE_VERSION_3), "field_table");

      current_varying_field_bit_index = field_table.location_of_first_varying_field;

      call ioa_ ("Id^10tName^/^2xLocation^12tValue");
FIELD_LOOP:
      do field_idx = 1 to field_table.number_of_fields;
         call DISPLAY_FIELD (field_idx, current_varying_field_bit_index);
      end FIELD_LOOP;

      return;
%page;
DISPLAY_FIELD:
   proc (p_field_idx, p_current_varying_field_bit_index);
      dcl	    p_field_idx	       fixed bin;
      dcl	    p_current_varying_field_bit_index
			       fixed bin (35);
      dcl	    vs_length	       fixed bin (35);
      dcl	    (varying_field_idx, temp_field_idx, temp_varying_field_length)
			       fixed bin (35);
      dcl	    based_bit_string       bit (sys_info$max_seg_size * BITS_PER_WORD) based;


      if field_table.varying_field_map (p_field_idx).varying_field_index > 0
      then
VARYING_FIELD:
         do;
	  unspec (vs_length) =
	     copy ("0"b, BITS_PER_WORD - field_table.field (p_field_idx).length_in_bits)
	     ||
	     substr (p_string_ptr -> based_bit_string, field_table.field (p_field_idx).location,
	     field_table.field (p_field_idx).length_in_bits);
	  if field_table.field (p_field_idx).length_is_in_characters
	  then vs_length = vs_length * BITS_PER_BYTE;

	  if p_current_varying_field_bit_index = -1
	  then
	     do;
	        p_current_varying_field_bit_index = field_table.location_of_first_varying_field;
	        do varying_field_idx = 1 to field_table.varying_field_map (p_field_idx).varying_field_index - 1;
		 temp_field_idx = field_table.varying_field_map (varying_field_idx).field_id;
		 unspec (temp_varying_field_length) =
		    copy ("0"b, BITS_PER_WORD - field_table.field (temp_field_idx).length_in_bits)
		    ||
		    substr (p_string_ptr -> based_bit_string, field_table.field (temp_field_idx).location,
		    field_table.field (temp_field_idx).length_in_bits);

		 if field_table.field (temp_field_idx).flags.length_is_in_characters
		 then temp_varying_field_length = temp_varying_field_length * BITS_PER_BYTE;

		 p_current_varying_field_bit_index = p_current_varying_field_bit_index + temp_varying_field_length;
	        end;

	     end;
	  call
	     ioa_ ("(^d)^10t^a^/^2x^d^12t^.3b^/^2x^d^12t^.3b", p_field_idx,
	     substr (field_table.field_names, field_table.field (p_field_idx).location_of_name,
	     field_table.field (p_field_idx).length_of_name), field_table.field (p_field_idx).location,
	     bin (
	     substr (p_string_ptr -> based_bit_string, field_table.field (p_field_idx).location,
	     field_table.field (p_field_idx).length_in_bits)), p_current_varying_field_bit_index,
	     substr (p_string_ptr -> based_bit_string, p_current_varying_field_bit_index, vs_length));

	  p_current_varying_field_bit_index = p_current_varying_field_bit_index + vs_length;
         end VARYING_FIELD;
      else
         do;
	  call
	     ioa_ ("(^d)^10t^a^/^2x^d^12t^.3b", p_field_idx,
	     substr (field_table.field_names, field_table.field (p_field_idx).location_of_name,
	     field_table.field (p_field_idx).length_of_name), field_table.field (p_field_idx).location,
	     bin (
	     substr (p_string_ptr -> based_bit_string, field_table.field (p_field_idx).location,
	     field_table.field (p_field_idx).length_in_bits)));

         end;

   end DISPLAY_FIELD;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (*);
      dcl	    p_expected_version     char (*);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
%include sub_err_flags;
%page;
%include dm_field_table;
   end dmu_display_string;




		    dmu_general_modify_string.pl1   10/24/88  1636.9r w 10/24/88  1400.2      135729



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:
          Modifies data in a bit string formatted according to the
     supplied field_table.  Fields to be modified are specified by a
     general_typed_vector and those field values are converted from the
     general_typed_vector to a bit string representation.  Un-modified
     field values are copied from the input bit string.  If only fixed fields
     are modified the modification is done in place, i.e., p_output_string_ptr
     and p_input_string_ptr are the same.  Otherwise, the output bit string is
     placed in the caller supplied string_buffer if it will fit.  If it doesn't
     fit, then the bit string is allocated in the caller-supplied work_area.
     If it doesn't fit there (or no work_area was supplied), then and an error
     is returned.
*/

/* HISTORY:
Written by Matthew Pierret, 10/04/82.
  (Mostly copied from dmu_cv_vector_to_string, written by 
   Lindsey Spratt, 04/02/82.)
Modified:
12/09/82 by Lindsey Spratt:  Changed to always use dim_idx when  referring to
	  the general_typed_vector.
12/13/82 by Lindsey Spratt:   Fixed to copy old varying fields correctly.
	  Changed setting of current_length_in_bits from old string to pick
	  to use unspec and copy instead of bin.
01/04/83 by Lindsey Spratt:  Changed to support arbitrarily long strings.
03/03/83 by Lindsey Spratt:  Fixed to only set p_output_buffer_length > 0 when
	  a new buffer is allocated, otherwise it's = 0.
03/14/83 by Lindsey Spratt:  Fixed to initialize p_output_string_length to the
	  fixed portion's length for the varying case, then to initialize
	  the output_string to "0"b, if the p_output_string_length is <= the
	  output_buffer_length.  This initialization to "0"b may be
	  superfluous.
05/12/83 by Lindsey L. Spratt:  Fixed to set the initial new-buffer allocation
            (done when the input buffer is too small) to be as much as twice
            as large as the length of the fixed portion of the data string.
            Removed the code which initialized the value of the buffer, since
            all of the buffer should be explicitly set in the course of the
            modify.
05/03/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3 and to use
            dm_error_$bad_vector_type.
11/08/84 by Lindsey L. Spratt:  Made minor format fixes.  Changed
            CHECK_VERSION_CHAR to have char(8) aligned version parameters.
            Removed unused/dcl'ed variables, added dcls for
            referenced/undcl'ed tokens.
*/

/* format: style2,ind3 */
dmu_general_modify_string:
general_modify_string:
   proc (p_field_table_ptr, p_typed_vector_ptr, p_input_string_ptr, p_input_string_length, p_string_buffer_ptr,
        p_string_buffer_length, p_work_area_ptr, p_output_string_ptr, p_output_string_length, p_output_buffer_length,
        p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_field_table_ptr      ptr;
      dcl	    p_typed_vector_ptr     ptr;
      dcl	    p_string_buffer_ptr    ptr;
      dcl	    p_string_buffer_length fixed bin (35);
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_input_string_ptr     ptr;
      dcl	    p_input_string_length  fixed bin (35);
      dcl	    p_output_string_ptr    ptr;
      dcl	    p_output_string_length fixed bin (35);
      dcl	    p_output_buffer_length fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    current_length_in_bits fixed bin (35);
      dcl	    current_varying_field_bit_offset
			       fixed bin (35);
      dcl	    dim_idx	       fixed bin (17);
      dcl	    field_idx	       fixed bin (17);
      dcl	    old_length_in_bits     fixed bin (35);
      dcl	    old_current_varying_field_bit_offset
			       fixed bin (35);
      dcl	    (output_buffer_ptr, old_output_buffer_ptr)
			       ptr init (null);
      dcl	    (output_buffer_length, old_output_buffer_length)
			       fixed bin (35) init (0);
      dcl	    work_area_ptr	       ptr init (null);

/* Based */

      dcl	    based_real_fix_bin_1u  fixed bin (35) unaligned based;
      dcl	    based_bit_string       bit (sys_info$max_seg_size * 36) based;
      dcl	    output_buffer	       based (output_buffer_ptr) bit (output_buffer_length);
      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    (bin, copy, hbound, min, null, substr, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    (
	    BITS_PER_WORD	       init (36),
	    BITS_PER_BYTE	       init (9),
	    MAXIMUM_BUFFER_LENGTH_IN_BITS
			       init (36 /* number of bits per word */
			       *
			       261084
			       /* (number of pages per segment (255) */
			       /* * number of words per page(1024)) */
			       /* -  number of words of area-package overhead (36) */)
	    )		       fixed bin (35) int static options (constant);
      dcl	    myname	       init ("dmu_general_modify_string") char (32) varying int static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;

      dcl	    (
	    error_table_$bad_arg,
	    error_table_$unimplemented_version,
	    dm_error_$bad_vector_type,
	    dm_error_$short_buffer,
	    dm_error_$programming_error
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      field_table_ptr = p_field_table_ptr;
      call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      general_typed_vector_ptr = p_typed_vector_ptr;

      if general_typed_vector.type ^= GENERAL_TYPED_VECTOR_TYPE
      then call sub_err_ (dm_error_$bad_vector_type, myname, "h", null, 0,
	      "Only typed_vector structures of type ^d are accepted by this routine.^/          Received type ^d.",
	      GENERAL_TYPED_VECTOR_TYPE, general_typed_vector.type);

      work_area_ptr = p_work_area_ptr;

      if p_string_buffer_length <= 0 & p_string_buffer_ptr ^= null
      then call sub_err_ (error_table_$bad_arg, myname, "h", null, 0,
	      "^/The length of the string_buffer must be greater than 0.  The length
provided was ^d.", p_string_buffer_length);

      current_varying_field_bit_offset, old_current_varying_field_bit_offset =
	 field_table.location_of_first_varying_field;

      p_output_buffer_length = 0;

      if ELEMENT_IS_FIXED ()
      then
         do;
	  p_output_string_ptr, output_buffer_ptr = p_input_string_ptr;
	  p_output_string_length, output_buffer_length = p_input_string_length;
         end;
      else
         do;
	  output_buffer_ptr, p_output_string_ptr = p_string_buffer_ptr;
	  output_buffer_length = p_string_buffer_length;
	  p_output_string_length = field_table.location_of_first_varying_field - 1;
         end;

      if p_output_string_length > output_buffer_length
      then if work_area_ptr = null
	 then
	    do;
	       p_code = dm_error_$short_buffer;
	       return;
	    end;
	 else
	    do;
	       old_output_buffer_length = output_buffer_length;
	       old_output_buffer_ptr = output_buffer_ptr;

	       output_buffer_length, p_output_buffer_length =
		  min (2 * p_output_string_length, MAXIMUM_BUFFER_LENGTH_IN_BITS);
	       alloc output_buffer in (work_area);
	       p_output_string_ptr = output_buffer_ptr;
	    end;

      if p_output_string_ptr = p_input_string_ptr
      then
MODIFY_FIXED_ELEMENT_IN_PLACE:
         do;

	  do dim_idx = 1 to hbound (general_typed_vector.dimension, 1);

	     substr (p_output_string_ptr -> based_bit_string,
		field_table.field (general_typed_vector.dimension (dim_idx).identifier).location,
		field_table.field (general_typed_vector.dimension (dim_idx).identifier).length_in_bits) =
		substr (general_typed_vector.dimension (dim_idx).value_ptr -> based_bit_string, 1,
		field_table.field (general_typed_vector.dimension (dim_idx).identifier).length_in_bits);

	  end;

	  p_output_string_length = p_input_string_length;

         end MODIFY_FIXED_ELEMENT_IN_PLACE;

      else
MERGE_OLD_STRING_AND_VECTOR_VALUES:
         do;
FIELD_LOOP:
	  do field_idx = 1 to hbound (field_table.field, 1);

	     do dim_idx = 1 to hbound (general_typed_vector.dimension, 1)
		while (general_typed_vector.dimension (dim_idx).identifier ^= field_idx);
	     end;
	     if dim_idx <= hbound (general_typed_vector.dimension, 1)
	     then
CV_NEW_FIELD:
	        do;

		 if field_table.varying_field_map (field_idx).varying_field_index > 0
		 then
VARYING_FIELD:
		    do;

		       substr (p_output_string_ptr -> based_bit_string, field_table.field (field_idx).location,
			  field_table.field (field_idx).length_in_bits) =
			  substr (general_typed_vector.dimension (dim_idx).value_ptr -> based_bit_string,
			  BITS_PER_WORD - field_table.field (field_idx).length_in_bits + 1,
			  field_table.field (field_idx).length_in_bits);

		       if field_table.field (field_idx).length_is_in_characters
		       then
			do;
			   current_length_in_bits =
			        general_typed_vector.dimension (dim_idx).value_ptr -> based_real_fix_bin_1u
			        * BITS_PER_BYTE;

			   old_length_in_bits =
			        bin (
			        substr (p_input_string_ptr -> based_bit_string,
			        field_table.field (field_idx).location,
			        field_table.field (field_idx).length_in_bits)) * BITS_PER_BYTE;
			end;
		       else
			do;

			   current_length_in_bits =
			        general_typed_vector.dimension (dim_idx).value_ptr -> based_real_fix_bin_1u;
			   old_length_in_bits =
			        bin (
			        substr (p_input_string_ptr -> based_bit_string,
			        field_table.field (field_idx).location,
			        field_table.field (field_idx).length_in_bits));
			end;

		       if current_varying_field_bit_offset + current_length_in_bits - 1 > output_buffer_length
		       then if work_area_ptr = null
			  then
			     do;
			        p_code = dm_error_$short_buffer;
			        return;
			     end;
			  else
			     do;
			        old_output_buffer_length = output_buffer_length;
			        old_output_buffer_ptr = output_buffer_ptr;

			        output_buffer_length, p_output_buffer_length = 2 * output_buffer_length;
			        alloc output_buffer in (work_area);
			        p_output_string_ptr = output_buffer_ptr;

			        substr (output_buffer, 1, current_varying_field_bit_offset) =
				   substr (old_output_buffer_ptr -> output_buffer, 1,
				   current_varying_field_bit_offset);

			        if old_output_buffer_ptr ^= p_string_buffer_ptr & old_output_buffer_ptr ^= null
			        then
				 do;
				    output_buffer_length = old_output_buffer_length;
				    free old_output_buffer_ptr -> output_buffer in (work_area);
				    output_buffer_length = p_output_buffer_length;
				 end;

			     end;

		       substr (p_output_string_ptr -> based_bit_string, current_varying_field_bit_offset,
			  current_length_in_bits) =
			  substr (general_typed_vector.dimension (dim_idx).value_ptr -> based_bit_string,
			  BITS_PER_WORD + 1, current_length_in_bits);

		       current_varying_field_bit_offset = current_varying_field_bit_offset + current_length_in_bits;
		       old_current_varying_field_bit_offset =
			  old_current_varying_field_bit_offset + old_length_in_bits;

		    end VARYING_FIELD;
		 else
		    do;
		       substr (p_output_string_ptr -> based_bit_string, field_table.field (field_idx).location,
			  field_table.field (field_idx).length_in_bits) =
			  substr (general_typed_vector.dimension (dim_idx).value_ptr -> based_bit_string, 1,
			  field_table.field (field_idx).length_in_bits);
		    end;
	        end CV_NEW_FIELD;
	     else
COPY_OLD_FIELD:
	        do;

		 substr (p_output_string_ptr -> based_bit_string, field_table.field (field_idx).location,
		      field_table.field (field_idx).length_in_bits) =
		      substr (p_input_string_ptr -> based_bit_string, field_table.field (field_idx).location,
		      field_table.field (field_idx).length_in_bits);

		 if field_table.varying_field_map (field_idx).varying_field_index > 0
		 then
		    do;

		       unspec (current_length_in_bits) =
			  copy ("0"b, BITS_PER_WORD - field_table.field (field_idx).length_in_bits)
			  ||
			  substr (p_output_string_ptr -> based_bit_string, field_table.field (field_idx).location,
			  field_table.field (field_idx).length_in_bits);

		       if field_table.field (field_idx).length_is_in_characters
		       then current_length_in_bits = current_length_in_bits * BITS_PER_BYTE;

		       if current_length_in_bits + current_varying_field_bit_offset - 1 > p_string_buffer_length
		       then
			do;
			   p_code = dm_error_$short_buffer;
			   return;
			end;

		       substr (p_output_string_ptr -> based_bit_string, current_varying_field_bit_offset,
			  current_length_in_bits) =
			  substr (p_input_string_ptr -> based_bit_string, old_current_varying_field_bit_offset,
			  current_length_in_bits);

		       current_varying_field_bit_offset = current_varying_field_bit_offset + current_length_in_bits;
		       old_current_varying_field_bit_offset =
			  old_current_varying_field_bit_offset + current_length_in_bits;

		    end;
	        end COPY_OLD_FIELD;
	  end FIELD_LOOP;

	  p_output_string_length = current_varying_field_bit_offset - 1;

         end MERGE_OLD_STRING_AND_VECTOR_VALUES;

      if p_output_buffer_length > 0
	 & (p_output_string_ptr = p_string_buffer_ptr | p_output_string_ptr = p_input_string_ptr)
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	      "^/There is an inconsistency in the return values of this module with respect 
to the output string buffer.");

      return;
%page;
ELEMENT_IS_FIXED:
   proc () returns (bit (1) aligned);

      dcl	    eif_dim_idx	       fixed bin;

      do eif_dim_idx = 1 to hbound (general_typed_vector.dimension, 1)
	 while (field_table.varying_field_map (general_typed_vector.dimension (eif_dim_idx).identifier)
	 .varying_field_index <= 0);
      end;

      if eif_dim_idx > hbound (general_typed_vector.dimension, 1)
      then return ("1"b);
      else return ("0"b);

   end ELEMENT_IS_FIXED;
%page;
CHECK_VERSION_CHAR:
   proc (p_expected_version, p_received_version, p_structure_name);
      dcl	    (p_expected_version, p_received_version)
			       char (8) aligned parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION_CHAR;
%page;
%include std_descriptor_types;
%page;
%include vu_typed_vector;
%page;
%include dm_field_table;
%page;
%include sub_err_flags;
   end dmu_general_modify_string;




		    dmu_get_data_bit_length.pl1     01/04/85  0947.4re  01/03/85  1150.0      152604



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
dmu_get_data_bit_length:
   proc (p_descriptor, p_bit_length, p_code);

/* DESCRIPTION:

     Given an aligned 36-bit multics pl1 argument descriptor this routine
     determines the number of bits of storage that the data type,
     alignment, and precision or size requires when residing in memory,
     not counting words skipped to obtain even word boundaries.  The
     descriptor is assumed to be valid, with correct values for scale,
     precision, size, etc.  For that data type, since this is to be an
     efficient run-time routine having had error checks made elsewhere.
     Also, the data is assumed to be scalar, i.e.  that there are no array
     bounds, as this will be expanded elsewhere. Decimal 4-bit non-byte 
     aligned are treated as byte aligned data.
*/

/* HISTORY:
Written by Matthew Pierret, 04/05/82.
Modified:
01/07/83 by Lindsey Spratt:  Fixed data-types 9 through 12 to always set the
	  bit_length.  It wasn't being set when the packed flag was off.
05/03/84 by Matthew Pierret:  Added the alignment entry, which returns the
            required alignment in addition to the bit length.  Made
            descriptor_string aligned.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_descriptor	       bit (36) aligned;
      dcl	    p_bit_length	       fixed bin (35);
      dcl	    p_alignment	       fixed bin (17);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    get_alignment	       bit (1) aligned init ("0"b);
      dcl	    alignment	       fixed bin (17);
      dcl	    descriptor_string      bit (36) aligned;
      dcl	    bit_length	       fixed bin (35);	/* returned storage length */

/* Based */

      dcl	    1 descriptor	       based (addr (descriptor_string)) unal,
	      2 flag	       bit (1) unal,
	      2 type	       unsigned fixed bin (6) unal,
	      2 packed	       bit (1) unal,
	      2 ndims	       unsigned fixed bin (4) unal,
	      2 size	       unsigned fixed bin (24) unal;

      dcl	    1 precision_descriptor based (addr (descriptor_string)) unal,
	      2 unused1	       bit (24) unal,
	      2 precision	       unsigned fixed bin (12) unal;

/* Builtin */

      dcl	    (mod, addr, null, floor)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    SIGN_AND_PAD	       fixed bin init (2) int static options (constant);
						/* sign digit + 1/2 byte padding */
      dcl	    SIGN_EXPONENT_AND_PAD  fixed bin init (4) int static options (constant);
						/* sign digit, exp byte, + 1/2 byte pad */
      dcl	    PAD		       fixed bin init (1) int static options (constant);
						/* 1/2 byte padding */
      dcl	    PER_BYTE_FACTOR	       fixed bin init (2) int static options (constant);
						/* number of digits per byte */
      dcl	    SIGN_AND_EXPONENT      fixed bin init (2) int static options (constant);
						/* float decimal exp and sign char space */
      dcl	    DOUBLE	       fixed bin init (2) int static options (constant);
						/* multiplier for complex numbers */
      dcl	    SIGN		       fixed bin init (1) int static options (constant);
						/* space for sign */
      dcl	    ONE_WORD	       fixed bin init (36) int static options (constant);
						/* bit length of a word */
      dcl	    TWO_WORD	       fixed bin init (72) int static options (constant);
						/* bit length of two words */
      dcl	    FOUR_WORD	       fixed bin init (144) int static options (constant);
						/* bit length of four words */
      dcl	    ONE_BYTE	       fixed bin init (9) int static options (constant);
						/* bit length of a byte (character) */
      dcl	    BIT_ALIGNED	       fixed bin (17) init (1) int static options (constant);
						/* data type is aligned at the bit level (not aligned) */
      dcl	    BYTE_ALIGNED	       fixed bin (17) init (9) int static options (constant);
						/* data type is aligned at the byte level */
      dcl	    WORD_ALIGNED	       fixed bin (17) init (36) int static options (constant);
						/* data type is aligned at the word level */
      dcl	    EVEN_WORD_ALIGNED      fixed bin (17) init (72) int static options (constant);
						/* data type is aligned at the even word level */

/* Entry */
/* External */

      dcl	    dm_error_$unimplemented_data_type
			       fixed bin (35) ext;
      dcl	    dm_error_$invalid_alignment
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      go to JOIN;

alignment:
   entry (p_descriptor, p_bit_length, p_alignment, p_code);

      get_alignment = "1"b;
      alignment = BIT_ALIGNED;			/* Default alignment is bit-aligned, or not aligned. */

JOIN:
      descriptor_string = p_descriptor;
      p_code = 0;

/* CASE STRUCTURE BASED ON THE DATA TYPE */

      goto DATA_TYPE (descriptor.type);

/* REAL FIXED BINARY SHORT */
DATA_TYPE (1):
      if descriptor.packed
      then bit_length = precision_descriptor.precision + SIGN;
      else
         do;
	  alignment = WORD_ALIGNED;
	  bit_length = ONE_WORD;
         end;
      goto END_CASE;

/* READ FIXED BINARY LONG */
DATA_TYPE (2):
      if descriptor.packed
      then bit_length = precision_descriptor.precision + SIGN;
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = TWO_WORD;
         end;
      goto END_CASE;

/* REAL FLOATING BINARY SHORT */
DATA_TYPE (3):
      if descriptor.packed
      then bit_length = precision_descriptor.precision + ONE_BYTE;
      else
         do;
	  alignment = WORD_ALIGNED;
	  bit_length = ONE_WORD;
         end;
      goto END_CASE;

/*  REAL FLOATING BINARY LONG */
DATA_TYPE (4):
      if descriptor.packed
      then bit_length = precision_descriptor.precision + ONE_BYTE;
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = TWO_WORD;
         end;
      goto END_CASE;

%page;
/* COMPLEX FIXED BINARY SHORT */
DATA_TYPE (5):
      if descriptor.packed
      then bit_length = DOUBLE * (precision_descriptor.precision + SIGN);
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = TWO_WORD;
         end;
      goto END_CASE;

/* COMPLEX FIXED BINARY LONG */
DATA_TYPE (6):
      if descriptor.packed
      then bit_length = DOUBLE * (precision_descriptor.precision + SIGN);
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = FOUR_WORD;
         end;
      goto END_CASE;

/* COMPLEX FLOATING BINARY SHORT */
DATA_TYPE (7):
      if descriptor.packed
      then bit_length = DOUBLE * (precision_descriptor.precision + ONE_BYTE);
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = TWO_WORD;
         end;
      goto END_CASE;

/* COMPLEX FLOATING BINARY LONG */
DATA_TYPE (8):
      if descriptor.packed
      then bit_length = DOUBLE * (precision_descriptor.precision + ONE_BYTE);
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = FOUR_WORD;
         end;
      goto END_CASE;

%page;
/* REAL FIXED DECIMAL */
DATA_TYPE (9):
      bit_length = ONE_BYTE * (precision_descriptor.precision + SIGN);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* REAL FLOATING DECIMAL */
DATA_TYPE (10):
      bit_length = ONE_BYTE * (precision_descriptor.precision + SIGN_AND_EXPONENT);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* COMPLEX FIXED DECIMAL */
DATA_TYPE (11):
      bit_length = DOUBLE * ONE_BYTE * (precision_descriptor.precision + SIGN);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* COMPLEX FLOATING DECIMAL */
DATA_TYPE (12):
      bit_length = DOUBLE * ONE_BYTE * (precision_descriptor.precision + SIGN_AND_EXPONENT);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

%page;
/* POINTER */
DATA_TYPE (13):
      if descriptor.packed
      then bit_length = ONE_WORD;
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = TWO_WORD;
         end;
      goto END_CASE;

/* OFFSET */
DATA_TYPE (14):
      if descriptor.packed
      then p_code = dm_error_$invalid_alignment;
      else
         do;
	  alignment = WORD_ALIGNED;
	  bit_length = ONE_WORD;
         end;
      goto END_CASE;

/* LABEL */
DATA_TYPE (15):
      if descriptor.packed
      then p_code = dm_error_$invalid_alignment;
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = FOUR_WORD;
         end;
      goto END_CASE;

/* ENTRY */
DATA_TYPE (16):
      if descriptor.packed
      then p_code = dm_error_$invalid_alignment;
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = FOUR_WORD;
         end;
      goto END_CASE;

/* NOTE: this length is correct for structures declared
   without arrays only. (i.e. only scalar elements) */

/* STRUCTURE */
DATA_TYPE (17):
      if ^descriptor.packed
      then alignment = WORD_ALIGNED;
      bit_length = ONE_WORD * descriptor.size;
      goto END_CASE;

/* AREA */
DATA_TYPE (18):
      alignment = EVEN_WORD_ALIGNED;
      bit_length = ONE_WORD * descriptor.size;
      goto END_CASE;

%page;
/* BIT STRING */
DATA_TYPE (19):
      bit_length = descriptor.size;
      if ^descriptor.packed
      then
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* Note: varying strings are stored in a special fashion which makes them,
   act as though they were bit-aligned. */

/* VARYING BIT STRING */
DATA_TYPE (20):
      bit_length = descriptor.size + ONE_WORD;
      if ^descriptor.packed
      then call pad_to_word_boundary ();
      goto END_CASE;

/* CHARACTER STRING */
DATA_TYPE (21):
      bit_length = ONE_BYTE * descriptor.size;
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* Note: varying strings are stored in a special fashion which makes them,
   act as though they were bit-aligned. */

/* VARYING CHARACTER STRING */
DATA_TYPE (22):
      bit_length = (ONE_BYTE * descriptor.size) + ONE_WORD;
      if ^descriptor.packed
      then call pad_to_word_boundary ();
      goto END_CASE;

%page;
/* FILE */
DATA_TYPE (23):
      alignment = EVEN_WORD_ALIGNED;
      bit_length = FOUR_WORD;
      goto END_CASE;

/* REAL FIXED DECIMAL LEADING OVERPUNCHED SIGN 9-BIT */
DATA_TYPE (29):
      bit_length = ONE_BYTE * precision_descriptor.precision;
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* REAL FIXED DECIMAL TRAILING OVERPUNCHED SIGN 9-BIT */
DATA_TYPE (30):
      bit_length = ONE_BYTE * precision_descriptor.precision;
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* REAL FIXED BINARY SHORT UNSIGNED */
DATA_TYPE (33):
      if descriptor.packed
      then bit_length = precision_descriptor.precision;
      else
         do;
	  alignment = WORD_ALIGNED;
	  bit_length = ONE_WORD;
         end;
      goto END_CASE;

/* REAL FIXED BINARY LONG UNSIGNED */
DATA_TYPE (34):
      if descriptor.packed
      then bit_length = precision_descriptor.precision;
      else
         do;
	  alignment = EVEN_WORD_ALIGNED;
	  bit_length = TWO_WORD;
         end;
      goto END_CASE;

%page;
/* REAL FIXED DECIMAL UNSIGNED 9-BIT */
DATA_TYPE (35):
      bit_length = ONE_BYTE * precision_descriptor.precision;
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* REAL FIXED DECIMAL TRAILING SIGN 9-BIT */
DATA_TYPE (36):
      bit_length = ONE_BYTE * (precision_descriptor.precision + SIGN);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* NOTE: non-byte-aligned decimal 4-bit requires knowledge of
   physical 1/2 byte alignment to determine actual bit length,
   thus it is unsupported by pl1, and MRDS, and the returned
   bit length will be the same as if it were the corresponding
   byte aligned decimal 4-bit data type. */

/* REAL FIXED DECIMAL UNSIGNED 4-BIT */
DATA_TYPE (38):
      bit_length = ONE_BYTE * floor ((precision_descriptor.precision + PAD) / PER_BYTE_FACTOR);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* REAL FIXED DECIMAL TRAILING SIGN 4-BIT */
DATA_TYPE (39):
      bit_length = ONE_BYTE * floor ((precision_descriptor.precision + SIGN_AND_PAD) / PER_BYTE_FACTOR);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* REAL FIXED DECIMAL LEADING SIGN 4-BIT */
DATA_TYPE (41):
      bit_length = ONE_BYTE * floor ((precision_descriptor.precision + SIGN_AND_PAD) / PER_BYTE_FACTOR);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* REAL FLOATING DECIMAL 4-BIT */
DATA_TYPE (42):
      bit_length = ONE_BYTE * floor ((precision_descriptor.precision + SIGN_EXPONENT_AND_PAD) / PER_BYTE_FACTOR);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

%page;
/* REAL FIXED DECIMAL LEADING SIGN 4-BIT BYTE-ALIGNED */
DATA_TYPE (43):
      bit_length = ONE_BYTE * floor ((precision_descriptor.precision + SIGN_AND_PAD) / PER_BYTE_FACTOR);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* REAL FLOATING DECIMAL 4-BIT BYTE-ALIGNED */
DATA_TYPE (44):
      bit_length = ONE_BYTE * floor ((precision_descriptor.precision + SIGN_EXPONENT_AND_PAD) / PER_BYTE_FACTOR);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* COMPLEX FIXED DECIMAL LEADING SIGN 4-BIT BYTE-ALIGNED */
DATA_TYPE (45):
      bit_length = DOUBLE * ONE_BYTE * floor ((precision_descriptor.precision + SIGN_AND_PAD) / PER_BYTE_FACTOR);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* COMPLEX FLOATING DECIMAL 4-BIT BYTE-ALIGNED */
DATA_TYPE (46):
      bit_length = DOUBLE * ONE_BYTE * floor ((precision_descriptor.precision + SIGN_EXPONENT_AND_PAD) / PER_BYTE_FACTOR);
      if descriptor.packed
      then alignment = BYTE_ALIGNED;
      else
         do;
	  alignment = WORD_ALIGNED;
	  call pad_to_word_boundary ();
         end;
      goto END_CASE;

/* UNUSED */
DATA_TYPE (0):
DATA_TYPE (24):
DATA_TYPE (25):
DATA_TYPE (26):
DATA_TYPE (27):
DATA_TYPE (28):
DATA_TYPE (31):
DATA_TYPE (32):
DATA_TYPE (37):
DATA_TYPE (40):
DATA_TYPE (47):
DATA_TYPE (48):
DATA_TYPE (49):
DATA_TYPE (50):
DATA_TYPE (51):
DATA_TYPE (52):
DATA_TYPE (53):
DATA_TYPE (54):
DATA_TYPE (55):
DATA_TYPE (56):
DATA_TYPE (57):
DATA_TYPE (58):
DATA_TYPE (59):
DATA_TYPE (60):
DATA_TYPE (61):
DATA_TYPE (62):
DATA_TYPE (63):
      p_code = dm_error_$unimplemented_data_type;
      goto END_CASE;

/* END OF DESCRIPTOR TYPE CASE STATEMENT */
END_CASE:
      p_bit_length = bit_length;
      if get_alignment
      then p_alignment = alignment;

      return;

%page;
pad_to_word_boundary:
   procedure ();

/* fill out the bit length to reflect a word boundary aligned,
   integral number of words storage space */

      if mod (bit_length, ONE_WORD) = 0
      then ;
      else bit_length = bit_length + (ONE_WORD - mod (bit_length, ONE_WORD));

   end;


   end dmu_get_data_bit_length;




		    om_free_opening.pl1             01/04/85  0947.4re  01/03/85  1150.0       42048



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

         Removes  an opening info structure from the opening table.  An error
     is returned if the table does not exist or if the supplied openin id does
     not correspond to an existing opening.
*/

/* HISTORY:

Written by Matthew Pierret, 07/27/82.
Modified:
08/11/82 by Matthew Pierret:  Changed ot.number_of_entries to ot.upper_bound.
04/12/83 by Matthew Pierret:  Changed to use OPENING_TABLE_VERSION_2.  This
            version is 0-originned because hash_index_ can return a value of
            0.  The "free" statement was changed to include the area from
            which to free.  Changed to use get_dm_free_area_.
09/01/83 by Lindsey L. Spratt:  Changed to use the om_get_opening$hash_index
            entry instead of calling hash_index_.
11/08/84 by Stanford S. Cox:  CV: Updated sub_err_ call.
12/05/84 by Stanford S. Cox:  MAIN: Chg to signal sub_err_ if open table
   	  appears damaged.
*/

/* format: style2,ind3 */
om_free_opening:
   proc (p_table_ptr, p_id, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_table_ptr	       ptr parameter;
      dcl	    p_id		       bit (72) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    bound_idx	       fixed bin (17);
      dcl	    hash_index	       fixed bin (35);
      dcl	    opening_id	       bit (72) aligned;
      dcl	    previous_hash_bead_ptr ptr;

/* Based */

      dcl	    dm_area	       area (sys_info$max_seg_size) based (static_dm_area_ptr);

/* Builtin */

      dcl	    (null)	       builtin;

/* Constant */

      dcl	    myname	       char (32) varying init ("om_free_opening") int static options (constant);

/* Entry */

      dcl	    om_get_opening$hash_index
			       entry (bit (72) aligned, fixed bin (35)) returns (fixed bin);
      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$no_opening   ext fixed bin (35);
      dcl	    dm_error_$open_table_damaged
			       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);
      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* Static */

      dcl	    static_dm_area_ptr     ptr internal static init (null);

/* END OF DECLARATIONS */

      p_code = 0;
      opening_table_ptr = p_table_ptr;
      opening_id = p_id;

      call CHECK_VERSION ("opening_table", opening_table.version, OPENING_TABLE_VERSION_2);

      hash_index = om_get_opening$hash_index (opening_id, opening_table.upper_bound);

      hash_bead_ptr = opening_table.hash_entry_ptr (hash_index);
      if hash_bead_ptr = null
      then p_code = dm_error_$no_opening;
      else
         do;
	  previous_hash_bead_ptr = null;

	  do bound_idx = 1 to HASH_UPPER_BOUND while (hash_bead.next_ptr ^= null & hash_bead.key ^= opening_id);
	     previous_hash_bead_ptr = hash_bead_ptr;
	     hash_bead_ptr = hash_bead.next_ptr;
	  end;

	  if bound_idx > HASH_UPPER_BOUND
	  then call sub_err_ (dm_error_$open_table_damaged, myname, ACTION_CANT_RESTART, null (), 0,
		  "^/Searching for opening id ^.3b.", opening_id);
	  else if hash_bead.key ^= opening_id
	  then p_code = dm_error_$no_opening;
	  else
	     do;
	        if previous_hash_bead_ptr = null
	        then opening_table.hash_entry_ptr (hash_index) = hash_bead.next_ptr;
	        else previous_hash_bead_ptr -> hash_bead.next_ptr = hash_bead.next_ptr;

	        if static_dm_area_ptr = null
	        then static_dm_area_ptr = get_dm_free_area_ ();

	        free hash_bead in (dm_area);
	     end;
         end;

      return;

CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", cv_p_correct_version,
	      cv_p_structure_name, cv_p_given_version);

      return;

   end CHECK_VERSION;
%page;
%include dm_om_table;
%page;
%include dm_om_hash_bead;
%page;
%include sub_err_flags;

   end om_free_opening;





		    om_get_opening.pl1              01/04/85  0947.4re  01/03/85  1150.0       37512



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

         Finds and returns a pointer to the opening associated with the given
     opening  identifier.  A hash is used to keep track of pointers to opening
     info structures.  The id is bit (72) aligned.    The  p_table_ptr  should
     point to a table set up by opening_manager_$init.
*/

/* HISTORY:

Written by Matthew Pierret, 07/26/82.
Modified:
08/10/82 by Matthew Pierret:  Changed p_code to fixed bin (35) from (17).
            Also changed ot.number_of_entries to ot.upper_bound.
04/12/83 by Matthew Pierret:  Changed to use OPENING_TABLE_VERSION_2.  This 
            represents no real change. The version was changed because
            other modules used a different structure with the same version.
11/08/84 by Stanford S. Cox:  MAIN: Moved CV inline,  updated sub_err_ call.
12/05/84 by Stanford S. Cox:  MAIN: Chg to signal sub_err_ if open table
   	  appears damaged.
*/

/* format: style2,ind3 */
om_get_opening:
   proc (p_table_ptr, p_id, p_info_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_table_ptr	       ptr parameter;
      dcl	    p_id		       bit (72) aligned parameter;
      dcl	    p_info_ptr	       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    bound_idx	       fixed bin (17);
      dcl	    hash_index	       fixed bin (35);
      dcl	    opening_id	       bit (72) aligned;

/* Based */
/* Builtin */

      dcl	    (bin, mod, null)       builtin;

/* Constant */

      dcl	    myname	       char (32) varying init ("om_get_opening") int static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$no_opening   ext fixed bin (35);
      dcl	    dm_error_$open_table_damaged
			       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code = 0;
      p_info_ptr = null;
      opening_table_ptr = p_table_ptr;
      opening_id = p_id;

      if opening_table.version ^= OPENING_TABLE_VERSION_2
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", OPENING_TABLE_VERSION_2, "opening_table",
	      opening_table.version);

      /***  hash_index = hash_index_ (addr (opening_id), OPENING_ID_LENGTH, OT_HASH_BIAS, opening_table.upper_bound); */

      hash_index = HASH_INDEX (opening_id, opening_table.upper_bound);

      hash_bead_ptr = opening_table.hash_entry_ptr (hash_index);
      if hash_bead_ptr = null
      then p_code = dm_error_$no_opening;
      else
         do;
	  do bound_idx = 1 to HASH_UPPER_BOUND while (hash_bead.next_ptr ^= null & hash_bead.key ^= opening_id);
	     hash_bead_ptr = hash_bead.next_ptr;
	  end;

	  if bound_idx > HASH_UPPER_BOUND
	  then call sub_err_ (dm_error_$open_table_damaged, myname, ACTION_CANT_RESTART, null (), 0,
		  "^/Searching for opening id ^.3b.", opening_id);
	  else if hash_bead.key = opening_id
	  then p_info_ptr = hash_bead.info_ptr;
	  else p_code = dm_error_$no_opening;

         end;

      return;



hash_index:
   entry (p_hash_opening_id, p_hash_upper_bound) returns (fixed bin (17));
      dcl	    p_hash_opening_id      bit (72) aligned;
      dcl	    p_hash_upper_bound     fixed bin (35);
      return (HASH_INDEX (p_hash_opening_id, p_hash_upper_bound));

HASH_INDEX:
   proc (hi_p_opening_id, hi_p_upper_bound) returns (fixed bin (17));
      dcl	    hi_p_opening_id	       bit (72) aligned;
      dcl	    hi_p_upper_bound       fixed bin (35);
      return (mod (bin (hi_p_opening_id, 71), hi_p_upper_bound));
   end HASH_INDEX;
%page;
%include dm_om_table;
%page;
%include dm_om_hash_bead;
%page;
%include sub_err_flags;

   end om_get_opening;




		    om_init.pl1                     01/04/85  0947.4re  01/03/85  1150.0       18036



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
om_init:
   proc (p_number_of_entries, p_table_ptr, p_code);

/* DESCRIPTION:

         Sets  up an empty table of pointers to opening info structures.  The
     table is allocated in the area pointed to  by  dm_data_$opening_area_ptr.
     The table is set up as a hash of p_number_of_entries buckets.
*/

/* HISTORY:

Written by Matthew Pierret, 07/26/82.
Modified:
08/11/82 by Matthew Pierret:  Changed opening_table to be 0-originned.
04/12/83 by Matthew Pierret:  Changed to use OPENING_TABLE_VERSION_2, which is
            0-originned.  This is necessary because hash_index can return a
            value of 0.
11/14/84 by Stanford S. Cox:  MAIN:  Chg to init opening_table.version.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_number_of_entries    fixed bin (17) parameter;
      dcl	    p_table_ptr	       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    work_area_ptr	       ptr;

/* Based */

      dcl	    work_area	       area (sys_info$max_seg_size) based (work_area_ptr);

/* Builtin */

      dcl	    null		       builtin;

/* Constant */
/* Entry */

      dcl	    get_dm_free_area_      entry () returns (ptr);

/* External */

      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code = 0;

      work_area_ptr = get_dm_free_area_ ();

      ot_upper_bound = p_number_of_entries - 1;

      alloc opening_table in (work_area);

      opening_table.hash_entry_ptr = null;

      p_table_ptr = opening_table_ptr;
      opening_table.version = OPENING_TABLE_VERSION_2;

      return;
%page;
%include dm_om_table;


   end om_init;




		    om_put_opening.pl1              01/04/85  0947.4re  01/03/85  1150.1       37341



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

         Puts  an  opening in a table of pointers to opening info structures.
     The info structure should have already been allocated by the callerin the
     area pointed to  by  get_dm_free_area_.    The  argument  p_table_ptr
     should point to a table set up previously by opening_manager_$init.
*/

/* HISTORY:

Written by Matthew Pierret, 07/26/82.
Modified:
08/10/82 by Matthew Pierret:  Changed p_code to fixed bin (35) from (17).
08/11/82 by Matthew Pierret:  Changed to allow "put"-ing an opening that already
            exists.
04/12/83 by Matthew Pierret:  Changed to use OPENING_TABLE_VERSION_2.  This
            version is 0-originned becaused hash_index_ can return a value of
            0.  Also changed to use get_dm_free_area_ to get the pointer to an
            area.
09/01/83 by Lindsey L. Spratt:  Changed to call om_get_opening$hash_index
            instead of hash_index_.
11/07/84 by Stanford S. Cox:  MAIN: Chg to thread bead at top, chg to not modify
            bead if it exists, moved ALLOCATE_HASH_BEAD inline.
*/

/* format: style2,ind3 */
om_put_opening:
   proc (p_table_ptr, p_id, p_info_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_table_ptr	       ptr parameter;
      dcl	    p_id		       bit (72) aligned parameter;
      dcl	    p_info_ptr	       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    hash_index	       fixed bin (35);
      dcl	    opening_info_ptr       ptr;
      dcl	    opening_id	       bit (72) aligned;
      dcl	    previous_hash_bead_ptr ptr;

/* Based */

      dcl	    dm_area	       area (sys_info$max_seg_size) based (dm_area_ptr);

/* Static */

      dcl	    dm_area_ptr	       ptr int static;

/* Builtin */

      dcl	    (null)	       builtin;

/* Constant */

      dcl	    myname	       char (32) varying init ("om_put_opening") int static options (constant);

/* Entry */

      dcl	    om_get_opening$hash_index
			       entry (bit (72) aligned, fixed bin (35)) returns (fixed bin);
      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    sys_info$max_seg_size  ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code = 0;
      opening_id = p_id;
      opening_info_ptr = p_info_ptr;
      opening_table_ptr = p_table_ptr;
      if dm_area_ptr = null ()
      then dm_area_ptr = get_dm_free_area_ ();
      call CHECK_VERSION ("opening_table", opening_table.version, OPENING_TABLE_VERSION_2);

      hash_index = om_get_opening$hash_index (opening_id, opening_table.upper_bound);

      hash_bead_ptr = opening_table.hash_entry_ptr (hash_index);
      previous_hash_bead_ptr = hash_bead_ptr;

      alloc hash_bead in (dm_area);

      hash_bead.key = opening_id;
      hash_bead.info_ptr = opening_info_ptr;
      hash_bead.next_ptr = null ();

      hash_bead.next_ptr = previous_hash_bead_ptr;
      opening_table.hash_entry_ptr (hash_index) = hash_bead_ptr;

      return;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", cv_p_correct_version,
	      cv_p_structure_name, cv_p_given_version);

      return;

   end CHECK_VERSION;
%page;
%include dm_om_table;
%page;
%include dm_om_hash_bead;
%page;
%include sub_err_flags;

   end om_put_opening;




		    opening_manager_.alm            01/04/85  0947.4re  01/03/85  1150.1        6174



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
	name	opening_manager_

" Modified:
"
" Macro to generate a call to an external entrypoint in the manager

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

	ext_transfer init,om_init$om_init
	ext_transfer get_opening,om_get_opening$om_get_opening
	ext_transfer put_opening,om_put_opening$om_put_opening
	ext_transfer free_opening,om_free_opening$om_free_opening

	end



*/
                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems 
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved

*/
