



		    fm_attribute_fref_.pl1          04/04/85  1119.5re  04/04/85  0826.6      156672



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

/* DESCRIPTION:

          This module and the module fm_attribute_ together contain
     all operations which deal with Data Management files as file system
     objects.  These operations are the eventual targets of entries in
     fs_util_, the file system utility for handling file system objects
     and extended objects. fm_attribute_fref_ contains those operations
     which require the process to be using Data Management - per-process
     initialization will be executed if it has not already been executed.
     fm_attribute_ contains those operations which do not
     require the process to be using Data Management.
*/

/* HISTORY:

Written by Matthew Pierret, 11/13/84.
Modified:
12/19/84 by Matthew Pierret:  Implemented set_ring_brackets and get_switch.
            Changed all entries to call INIT_FOR_FINISH to initialize variables
            which are tested in the FINISH procedure.
01/03/85 by Matthew Pierret:  Changed to check for benign error code
            dm_error_$file_already_open.
01/04/85 by Matthew C. Pierret:  Changed to set file_pathname in
            set_ring_brackets via the pathname_ function.
03/07/85 by Matthew C. Pierret:  In response to audit comments, added a call
            to ERROR_RETURN following the call to hcs_$chname_file if the
            returned code is non-zero; added declaration of sum and unspec;
            removed declartions of un-used variables.  Also, added use of
            ERROR_RETURN in other parts of the chname_file entry.
*/

/* format: style2,ind3 */

fm_attribute_fref_$get_switch:
   procedure (p_dirname, p_ename, p_switch_name, p_switch_value, p_code);


/* START OF DECLARATIONS */

/* Parameter */

      dcl	    p_dirname	       char (*) parameter;	/* directory containing the DM file */
      dcl	    p_ename	       char (*) parameter;	/* name of the DM file */
      dcl	    p_code	       fixed bin (35) parameter;

      dcl	    p_old_name	       char (*) parameter;	/* name to be deleted */
      dcl	    p_new_name	       char (*) parameter;	/* name to be added */

      dcl	    p_ring_brackets	       (2) fixed bin (3) parameter;
						/* new ring brackets */
      dcl	    p_switch_name	       char (*) parameter;
      dcl	    p_switch_value	       bit (1) parameter;

/* Automatic */

      dcl	    dirname	       char (256);
      dcl	    file_pathname	       char (256);
      dcl	    ename		       char (32);
      dcl	    old_name	       char (32);
      dcl	    new_name	       char (32);
      dcl	    switch_name	       char (64);
      dcl	    component_name	       char (32);

      dcl	    callers_validation_level
			       init (-1) fixed bin;
      dcl	    code		       fixed bin (35);
      dcl	    entry_idx	       fixed bin;
      dcl	    file_uid	       bit (36) aligned;
      dcl	    fs_ring_brackets       (3) fixed bin (3);
      dcl	    my_file_oid	       aligned bit (36) init (""b);
      dcl	    number_of_opens	       fixed bin;
      dcl	    ring_brackets	       (2) fixed bin (3);
      dcl	    ring_brackets_bc       fixed bin (24);
      dcl	    sys_pn_tbl_idx	       fixed bin;

      dcl	    local_msf_ptr	       ptr;

      dcl	    1 my_file_attributes   aligned like file_attributes;

/* Based */

/* Builtins */

      dcl	    (addr, hbound, lbound, null, sum, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    (
	    LOCK_WAIT_TIME	       init (1000000000) fixed bin (71),
	    STAR_BRANCHES_ONLY     init (2) fixed bin (2)
	    )		       internal static options (constant);

/* Entry */

      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    cu_$level_set	       entry (fixed bin);
      dcl	    file_manager_$close    entry (bit (36) aligned, fixed bin (35));
      dcl	    file_manager_$open     entry (char (*), char (*), bit (36) aligned, fixed bin (35));
      dcl	    fm_get_$internal_get   entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    fm_put_$internal_put   entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    fm_sys_pn_tbl_util_$opens
			       entry (bit (36) aligned, fixed bin, fixed bin);
      dcl	    fm_validate_$check_write_ring_bracket
			       entry (char (*), char (*), fixed bin (35));
      dcl	    get_ring_	       entry returns (fixed bin);
      dcl	    get_system_free_area_  entry () returns (ptr);
      dcl	    hcs_$chname_file       entry (char (*), char (*), char (*), char (*), fixed bin (35));
      dcl	    hcs_$set_bc	       entry (char (*), char (*), fixed bin (24), fixed bin (35));
      dcl	    hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
      dcl	    hcs_$star_	       entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
      dcl	    lock_manager_$lock     entry (bit (36) aligned, fixed bin (27), fixed bin, fixed bin (71), fixed bin,
			       fixed bin (35));
      dcl	    msf_manager_$close     entry (ptr);
      dcl	    msf_manager_$open      entry (char (*), char (*), ptr, fixed bin (35));
      dcl	    pathname_	       entry (char (*), char (*)) returns (char (168));

/* External */

      dcl	    dm_error_$bad_file_atrs_ver
			       fixed bin (35) ext;
      dcl	    dm_error_$file_already_open
			       fixed bin (35) ext;
      dcl	    dm_error_$file_in_use  fixed bin (35) ext;
      dcl	    dm_error_$file_not_dm_type
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_cant_remove_name
			       fixed bin (35) ext;
      dcl	    error_table_$argerr    fixed bin (35) ext;
      dcl	    error_table_$invalid_ring_brackets
			       fixed bin (35) ext;
      dcl	    error_table_$not_seg_type
			       fixed bin (35) ext;

%page;
/* The actual entry is the main procedure statement. 
   It is repeated here for clarity.

get_switch:
   entry (p_dirname, p_ename, p_switch_name, p_switch_value, p_code);
*/

      dirname = p_dirname;
      ename = p_ename;
      switch_name = p_switch_name;
      p_switch_value = ""b;
      p_code, code = 0;

      call INIT_FOR_FINISH ();

      if switch_name = "prot"
      then switch_name = "protection";
      else if switch_name = "conc"
      then switch_name = "concurrency";
      else if switch_name = "rlb"
      then switch_name = "rollback";
      if switch_name ^= "protection" & switch_name ^= "concurrency" & switch_name ^= "rollback"
      then call ERROR_RETURN (error_table_$argerr);	/* This is the code returned the get_switch entry of other managers */

      call cu_$level_get (callers_validation_level);
      on cleanup call FINISH ();

      call file_manager_$open (dirname, ename, my_file_oid, code);
      if code = dm_error_$file_already_open
      then code = 0;
      if code ^= 0
      then call ERROR_RETURN (code);

      call cu_$level_set (get_ring_ ());

      call GET_FILE_ATTRIBUTES (my_file_oid, addr (my_file_attributes));

      if switch_name = "protection"
      then p_switch_value = my_file_attributes.flags.protected;
      else if switch_name = "concurrency"
      then p_switch_value = my_file_attributes.flags.protected & ^my_file_attributes.flags.no_concurrency;
      else if switch_name = "rollback"
      then p_switch_value = my_file_attributes.flags.protected & ^my_file_attributes.flags.no_rollback;

      call cu_$level_set (callers_validation_level);

      call file_manager_$close (my_file_oid, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call RETURN ();


%page;
/* Changes the names on a DM file.  Renames are not supported. */

chname_file:
   entry (p_dirname, p_ename, p_old_name, p_new_name, p_code);

      dirname = p_dirname;
      ename = p_ename;
      old_name = p_old_name;
      new_name = p_new_name;
      p_code, code = 0;

      call INIT_FOR_FINISH ();

      if old_name ^= ""
      then call ERROR_RETURN (dm_error_$fm_cant_remove_name);
						/* mustn't delete name */

      call fm_validate_$check_write_ring_bracket (dirname, ename, code);
      if code ^= 0
      then if code = error_table_$not_seg_type
	 then call ERROR_RETURN (dm_error_$file_not_dm_type);
	 else call ERROR_RETURN (code);

      call cu_$level_get (callers_validation_level);
      on cleanup call FINISH ();
      call cu_$level_set (get_ring_ ());

      call hcs_$chname_file (dirname, ename, old_name, new_name, code);

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

      call cu_$level_set (callers_validation_level);
      call RETURN ();
%page;
/* DESCRIPTION OF set_ring_brackets:

        This entry sets the extended ring brackets of a DM file. Because 
   there exists no faulting mechanism as for hardware ring brackets, the
   ring brackets can not be made more restrictive and still have all
   current users of the file honor the new ring brackets.  For this reason,
   this entry only allows one to change ring brackets to a higher level,
   e.g., 4,4 to 4,5.
   */

set_ring_brackets:
   entry (p_dirname, p_ename, p_ring_brackets, p_code);

      dirname = p_dirname;
      ename = p_ename;
      ring_brackets (*) = p_ring_brackets (*);
      code = 0;
      unspec (my_file_attributes) = ""b;
      call INIT_FOR_FINISH ();
      on cleanup call FINISH ();

      call cu_$level_get (callers_validation_level);

      call file_manager_$open (dirname, ename, my_file_oid, code);
      if code = dm_error_$file_already_open
      then code = 0;
      if code ^= 0
      then call ERROR_RETURN (code);

      /*** Make sure that no one else is using this file. Do so by 
      locking the file exclusively, preventing any new openings.  
      Then check the system pathname table to see if
      our opening is the only current opening for this file.  
      If not, we have to give up. */

      file_uid = file_access_table.e (addr (my_file_oid) -> file_oid.file_access_table_idx).uid;
      sys_pn_tbl_idx = file_access_table.e (addr (my_file_oid) -> file_oid.file_access_table_idx).pn_tbl_idx;

      call lock_manager_$lock (file_uid, LOCK_ENTIRE_FILE, LOCK_MODE_X, 1e9, (0), code);
      if code ^= 0
      then call ERROR_RETURN (code);
      call fm_sys_pn_tbl_util_$opens (file_uid, sys_pn_tbl_idx, number_of_opens);
      if number_of_opens > 1
      then call ERROR_RETURN (dm_error_$file_in_use);

      /*** Get the current ring brackets from the file_attributes. */

      call cu_$level_set (get_ring_ ());

      call GET_FILE_ATTRIBUTES (my_file_oid, addr (my_file_attributes));

/* Verify that the given ring brackets are acceptable. */

      if ring_brackets (1) > ring_brackets (2) | get_ring_ () > ring_brackets (1)
	 | callers_validation_level > ring_brackets (1)
      then call ERROR_RETURN (error_table_$invalid_ring_brackets);

      /*** Set the new ring brackets in the file's file_attributes. */

      my_file_attributes.ring_brackets.write = ring_brackets (1);
      my_file_attributes.ring_brackets.read = ring_brackets (2);

      call PUT_FILE_ATTRIBUTES (my_file_oid, addr (my_file_attributes));

      /*** Set the actual file system ring brackets on the components
      to conform to the new DM file ring brackets.  This means leaving
      the write bracket alone and setting the read bracket to the
      level of the DM file read bracket. */

      fs_ring_brackets (1) = get_ring_ ();
      fs_ring_brackets (2) = ring_brackets (2);
      fs_ring_brackets (3) = ring_brackets (2);

      file_pathname = pathname_ (dirname, ename);

      call hcs_$star_ (file_pathname, "*", STAR_BRANCHES_ONLY, get_system_free_area_ (), star_entry_count, star_entry_ptr,
	 star_names_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);
      do entry_idx = lbound (star_entries, 1) to hbound (star_entries, 1);
         component_name = star_names (star_entries (entry_idx).nindex);
         call hcs_$set_ring_brackets (file_pathname, component_name, fs_ring_brackets, code);
         if code ^= 0
         then call ERROR_RETURN (code);
      end;

      /*** Now re-open the file MSF to reset fcb.rbs */

      local_msf_ptr = file_access_table.e (addr (my_file_oid) -> file_oid.file_access_table_idx).msf_ptr;
      file_access_table.e (addr (my_file_oid) -> file_oid.file_access_table_idx).msf_ptr = null;
      call msf_manager_$close (local_msf_ptr);
      call msf_manager_$open (dirname, ename, local_msf_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);
      file_access_table.e (addr (my_file_oid) -> file_oid.file_access_table_idx).msf_ptr = local_msf_ptr;

      /*** Store an encoded version of the ring brackets in the
      bit count of the first component. */

      ring_brackets_bc = 8 * ring_brackets (1) + ring_brackets (2);
      call hcs_$set_bc (file_pathname, "0", ring_brackets_bc, code);
      if code ^= 0
      then call ERROR_RETURN (code);

/* Now finish up and return. */

      call cu_$level_set (callers_validation_level);

      call file_manager_$close (my_file_oid, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call RETURN ();

%page;
MAIN_RETURN:
      return;

RETURN:
   proc ();

      call FINISH ();
      go to MAIN_RETURN;

   end RETURN;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35) parameter;

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

   end ERROR_RETURN;

FINISH:
   proc ();

      if local_msf_ptr = null ()
      then
         do;
	  call msf_manager_$open (dirname, ename, local_msf_ptr, (0));
	  file_access_table.e (addr (my_file_oid) -> file_oid.file_access_table_idx).msf_ptr = local_msf_ptr;
         end;

      if star_names_ptr ^= null
      then free star_names;
      if star_entry_ptr ^= null
      then free star_entries;

      if my_file_oid ^= ""b
      then call file_manager_$close (my_file_oid, (0));

      if callers_validation_level > 0
      then call cu_$level_set (callers_validation_level);

   end FINISH;

INIT_FOR_FINISH:
   proc ();

      star_names_ptr = null ();
      star_entry_ptr = null ();
      my_file_oid = ""b;
      local_msf_ptr = addr (local_msf_ptr);		/* Must be non-null for FINISH */
      callers_validation_level = 0;

   end INIT_FOR_FINISH;
%page;
GET_FILE_ATTRIBUTES:
   proc (gfa_p_file_oid, gfa_p_file_attributes_ptr);

/* DESCRIPTION of GET_FILE_ATTRIBUTES:

        Get the file_attributes structure of file indicated by gfa_p_file_oid,
   putting it at gfa_p_file_attributes_ptr.  The location in the file of the 
   file_attributes structure is between the end of the addressable portion
   of control interval 0 and the trailer of that control interval.
*/

      dcl	    gfa_p_file_attributes_ptr
			       ptr parameter;
      dcl	    gfa_p_file_oid	       bit (36) aligned parameter;
      dcl	    gfa_code	       fixed bin (35);
      dcl	    1 gfa_ci_parts	       aligned,
	      2 number_of_parts    fixed bin init (1),
	      2 mbz	       fixed bin init (0),
	      2 part	       (1) like ci_parts.part;

      gfa_ci_parts.part (1).offset_in_bytes = CI_0_ADDRESSABLE_LENGTH;
      gfa_ci_parts.part (1).length_in_bytes = CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH;
      gfa_ci_parts.part (1).local_ptr = gfa_p_file_attributes_ptr;

      call fm_get_$internal_get (gfa_p_file_oid, 0, addr (gfa_ci_parts), gfa_code);
      if gfa_code ^= 0
      then call ERROR_RETURN (gfa_code);

      if gfa_p_file_attributes_ptr -> file_attributes.version ^= FILE_ATTRIBUTES_VERSION_2
      then call ERROR_RETURN (dm_error_$bad_file_atrs_ver);

      return;

   end GET_FILE_ATTRIBUTES;
%page;
PUT_FILE_ATTRIBUTES:
   proc (pfa_p_file_oid, pfa_p_file_attributes_ptr);

/* DESCRIPTION of PUT_FILE_ATTRIBUTES:

        Put the file_attributes structure pointed to by 
   pfs_p_file_attributes_ptr in the appropriate location in the file
   indicated by pfa_p_file_oid.  The location in the file of the 
   file_attributes structure is between the end of the addressable portion
   of control interval 0 and the trailer of that control interval.
*/

      dcl	    pfa_p_file_attributes_ptr
			       ptr parameter;
      dcl	    pfa_p_file_oid	       bit (36) aligned parameter;
      dcl	    pfa_code	       fixed bin (35);
      dcl	    1 pfa_ci_parts	       aligned,
	      2 number_of_parts    fixed bin init (1),
	      2 mbz	       fixed bin init (0),
	      2 part	       (1) like ci_parts.part;

      pfa_ci_parts.part (1).offset_in_bytes = CI_0_ADDRESSABLE_LENGTH;
      pfa_ci_parts.part (1).length_in_bytes = CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH;
      pfa_ci_parts.part (1).local_ptr = pfa_p_file_attributes_ptr;

      call fm_put_$internal_put (pfa_p_file_oid, 0, addr (pfa_ci_parts), pfa_code);
      if pfa_code ^= 0
      then call ERROR_RETURN (pfa_code);

      return;

   end PUT_FILE_ATTRIBUTES;
%page;
%include dm_fm_file_access_tbl;
%page;
%include dm_fm_file_access_info;
%page;
%include dm_fm_file_attributes;
%page;
%include dm_fm_file_oid;
%page;
%include dm_ci_parts;
%page;
%include dm_ci_lengths;
%page;
%include star_structures;
%page;
%include dm_lock_modes;

   end fm_attribute_fref_$get_switch;




		    fm_combos_.pl1                  04/09/85  1450.9r w 04/08/85  1127.9       53415



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

/* DESCRIPTION:

          This module contains the create and delete operations, each of
     which is a number of calls to entries in fm_create_open_ and 
     fm_delete_close_ to do the actual work.
*/

/* HISTORY:

Designed by Andre' Bensoussan, 01/01/82.
Written by Jeffrey D. Ives, 10/01/82.
Modified:
05/31/83 by Lindsey L. Spratt:  Fixed the $delete entry to force the access if
            possible, when necessary.
01/06/84 by Matthew Pierret:  Changed $delete to force "rw" access to the file
            by calling file_manager_$add_acl_entries.  Forcing access should
            really be moved to fm_open_ some day.
06/07/84 by Lee Baldwin:  Renamed dm_error_$fm_sys_pn_tbl_ver_bad to
            $fm_bad_sys_pn_tbl_ver.
08/02/84 by Matthew Pierret:  Changed name of fm_open_ to fm_create_open_
            and fm_delete_close, as appropriate.
11/12/84 by Matthew Pierret:  Moved open_by_uid, open_by_uid_after_crash
            find_old_uid_pn_table and end_of_crash_recovery entries to
            fm_open_by_uid_. Renamed several variables.  Moved include files
            and external declarations out of internal procedures.
12/26/84 by Matthew Pierret:  Changed to use modern calling sequence of
            file_manager_$add_acl_entries, which only accepts a general_acl.
*/


/* format: style2,ind3,ll79,^indnoniterdo,indnoniterend */
fm_combos_$create:
   proc (p_dir_path, p_entry_name, p_file_create_info_ptr, p_code);

/* START OF DECLARATIONS */

/* Parameters */

      dcl	    p_code	       fixed bin (35) parm;
      dcl	    p_dir_path	       char (*) parm;
      dcl	    p_entry_name	       char (*) parm;
      dcl	    p_file_create_info_ptr ptr parm;

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    dir_path	       char (168);
      dcl	    entry_name	       char (32);
      dcl	    file_create_info_ptr   ptr;
      dcl	    my_oid	       bit (36) aligned;

/* Static */

/* Conditions */

      dcl	    cleanup	       condition;

/* Based */

/* Builtin */

      dcl	    addr		       builtin;

/* External Variables */

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

/* External Entries */

      dcl	    file_manager_$add_acl_entries
			       entry (char (*), char (*), ptr,
			       fixed bin (35));
      dcl	    get_group_id_$tag_star entry () returns (char (32));
      dcl	    fm_create_open_$create_open
			       entry (char (*), char (*), ptr,
			       bit (36) aligned, fixed bin (35));
      dcl	    fm_delete_close_$delete_close
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    fm_create_open_$open   entry (char (*), char (*),
			       bit (36) aligned, fixed bin (35));
      dcl	    fm_delete_close_$close entry (bit (36) aligned, fixed bin (35));

/* END OF DECLARATIONS */
%page;
/* The actual entry is the main procedure statement.  It is repeated here for 
   clarity.

create:
  entry (p_dir_path, p_entry_name, p_file_create_info_ptr, p_code);
*/

      dir_path = p_dir_path;
      entry_name = p_entry_name;
      file_create_info_ptr = p_file_create_info_ptr;
      p_code, code = 0;
      my_oid = ""b;

      on cleanup call FINISH ();

      call fm_create_open_$create_open (dir_path, entry_name,
	 file_create_info_ptr, my_oid, code);
      if my_oid = ""b
      then call ERROR_RETURN (code);
      else if code ^= 0
      then if code = dm_error_$file_already_open
	 then call ERROR_RETURN (dm_error_$file_already_exists);
	 else call ERROR_RETURN (code);

      call fm_delete_close_$close (my_oid, code);
      if code ^= 0
      then call ERROR_RETURN (code);

MAIN_RETURN:
      return;
%page;


delete:
   entry (p_dir_path, p_entry_name, p_code);

      dir_path = p_dir_path;
      entry_name = p_entry_name;
      p_code, code = 0;
      my_oid = ""b;

      call SET_RW_ACCESS (dir_path, entry_name);

      on cleanup call FINISH;

      call fm_create_open_$open (dir_path, entry_name, my_oid, code);
      if my_oid = ""b
      then call ERROR_RETURN (code);
      else code = 0;

      call fm_delete_close_$delete_close (my_oid, code);
      if code ^= 0
      then call ERROR_RETURN (code);
      else go to MAIN_RETURN;
%page;
ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35) parameter;

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

   end ERROR_RETURN;

FINISH:
   proc ();

      if my_oid ^= ""b
      then call fm_delete_close_$close (my_oid, (0));

   end FINISH;
%page;
SET_RW_ACCESS:
   proc (sra_p_dir_name, sra_p_entry_name);

/* This routine sets "read" and "write" access to the components of 
   the file to ensure no access problems while opening or deleting
   the file. */

      dcl	    (sra_p_dir_name, sra_p_entry_name)
			       char (*);
      dcl	    sra_code	       fixed bin (35);
      dcl	    1 sra_general_acl      aligned,
	      2 version	       char (8) aligned
			       init (GENERAL_ACL_VERSION_1),
	      2 count	       fixed bin init (1),
	      2 entries	       (1) like general_acl_entry;

      sra_code = 0;
      sra_general_acl.entries (1).access_name = get_group_id_$tag_star ();
      sra_general_acl.entries (1).mode = RW_ACCESS;
      sra_general_acl.entries (1).status_code = 0;

      call file_manager_$add_acl_entries (sra_p_dir_name, sra_p_entry_name,
	 addr (sra_general_acl), sra_code);
      if sra_code ^= 0
      then call ERROR_RETURN (sra_code);

   end SET_RW_ACCESS;
%page;
%include access_mode_values;
%page;
%include acl_structures;

   end fm_combos_$create;




		    fm_create_open_.pl1             12/09/86  1248.4rew 12/09/86  1236.6      522018



/****^  ***********************************************************
        *                                                         *
        * 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 to not log a message when attempting to open a file which does not
     exist.
  2) change(86-04-22,Pierret), approve(86-04-22,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Removed NO, YES, NO_OID_NEEDED as they were not used.  Added ltrim, string
     builtins as they were used but not declared.  Changed all occurences fo
     dir>entry to pathname (dir, entry).  Removed the unnecessary rtrim in
     pathname_(rtrim(dir),entry).
  3) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-11-26,Dupuis),
     install(86-12-09,MR12.0-1237):
     Set the file access blocking_factor to the file_attributes value that was
     used to create the file rather than the hard-coded value of 255.  This
     ensures that our process access table is consistent with the relation
     header value.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION: 

          This module handles the creation and opening of DM files.  Two entry
     points exist: create_open and open.
     
     create_open:  This entry creates a DM file, then opens it.
     
     open:  This entry opens a DM file.     
*/

/* HISTORY: 
Written by Jeffrey D. Ives, 10/xx/82.
           (Designed in January 1982 by Andre Bensoussan.)
Modified:
04/13/83 by JDI: Add protection_enabled, locking_enabled,
            & before_journalization_enabled.
06/01/83 by BIM: Changed lock_manager_ to take fb 27 ci's.
08/05/83 by Lee A. Newcomb: Removed obsolete status codes from
            per_system_ calls.
10/17/83 by JDI: Cleared flush list before calling msf_manager_$close.
12/14/83 by Lee Baldwin:  Moved ACL primitives to fm_attribute_.  Added
            CREATE_MSF & DONT_CREATE_MSF constants.  Changed file creation to
            place a special add-name on component zero.  This identifies the
            MSF as a DM file, and is used by fm_validate_ to validate files.
            Changed the open operation to call fm_validate_ to validate a file,
            removing the explicit CHECK_RING_BRACKETS code.  Also removed 
            explicit setting of 's' to *.*.* on the MSF directory, as 
            msf_manager_ has been changed to do that automatically.
            Changed the history section to the canonical format.
12/22/83 by Matthew Pierret: Added $acl_add back, which is used by bj_mgr_.
02/13/84 by Matthew Pierret:  Changed to reset the ring brackets on component
            0 to <validation level>,5,5 after creating a file.  This required
            closing and then opening the msf so that the file-control-block
            reflects the correct ring brackets (fcb.rbs).
02/14/84 by Matthew Pierret:  Changed to also reset the dir ring brackets
            on the DM file dir (MSF dir) to <DM ring>,<validation level>.
03/16/84 by Matthew Pierret:  Changed to translate error_table_$not_seg_type
            into dm_error_$file_not_dm_type upon return from fm_validate_
            instead of translating all non-zero error codes.
06/07/84 by Lee Baldwin:  Renamed a bunch of dm_error_ codes.
06/21/84 by Matthew Pierret: Changed to set the MSF dir ring brackets to
            <current validation level>,<current validation level> and the 
            component ring brackets to <current validation level>,
            <caller validation level>,<caller validation level>.
            Changed to use FILE_ATTRIBUTES_VERSION_2, moving the 
            file_attributes structure from the main procedure to the include
            file dm_fm_file_attributes.incl.pl1.  This version supports
            extended ring brackets.  Changed the create code to set the
            extended ring brackets to 
            <caller validation level>,<caller validation level>.  The 
            extended ring brackets are not checked anywhere, but are set so 
            that there will be no imcompatible change necessary when they 
            are fully supported.  Also changed to set the bit count on
            component 0 to be an encoded value representing the extended
            ring brackets.
            Also, changed the limit on the full file pathname to 168 chars
            (from 163).  Removed the un-used $acl_add.
            Made protected the default for create.
06/28/84 by Matthew Pierret:  Moved the entry per_process_init to its own
            module, fm_per_process_init. Moved delete_close, close, 
            post_commit and post_txn to fm_delete_close.
            Added extended ring brackets.
            Removed prepare_to_copy, and with it GET_PATH_NAME and 
            GET_LAST_CI_NUM.  They all live now in fm_prepare_to_copy_.
            Changed to use fm_error_util_.
            Changed name of module from fm_open_ to fm_create_open_.
08/27/84 by Matthew Pierret:  Changed the error code returned when
            my_file_access_info.opens > 1 from dm_error_$file_not_dm_type
            to dm_error_$file_already_open.
09/12/84 by Matthew C. Pierret:  Moved the call to
            fm_validate_$get_ring_brackets to the common code so that both
            create_open and open execute it.  create_open needs the ring
            brackets in the case where the file already exists, as the
            contract of create_open is to open the file if it already exists.
10/09/84 by Matthew Pierret:  Added the LEVEL_NOT_SET constant, to which
            (current saved)_validation_level are initialized.  The FINISH
            procedure checks that saved_validation_level is not equal to 
            LEVEL_NOT_SET before reseting the validation level.  This means 
            that the level had not yet been set, so should not be reset.
10/25/84 by Matthew Pierret:  To answer audit comments, in particular:
            Changed to use acl_structures.incl.pl1 and dm_ci_parts.incl.pl1,
            liking local structures to structures in those include files
            instead of imitating their declarations. Removed all use of 
            fm_data_. Made check of input ring brackets more exhaustive.
            Increased limit on number of openings from 255 to the max that
            can be held in fixed bin (17), and changed the case of exceeding
            that limit to be an error. Changed to use LOG_SV in 
            dm_log_sv_modes.icl.pl1.  Changed 
            GIVE_DAEMON_ACESS_TO_CONTAINING_DIR to use parameter and variable
            naming conventions.
10/29/84 by Matthew Pierret:  Added protection of file creation.  Moved
            many descriptive comments from in-line to a description section
            at the beginning of the create_open entry.
12/06/84 by Matthew Pierret:  Changed to explicitly set acl term for creator
            to avoid an msf_manager_ bug.  msf_manager_ should be fixed for
            MR11, so this can be removed once it is fixed.  Also changed
            to log fact that ring brackets have been resynched.
12/07/84 by Matthew Pierret:  Added must_be_zero field to my_attr_ci_parts.
12/17/84 by Matthew Pierret:  Changed to return error_table_$namedup if we are
            creating and there already exists a non-DM file object with the
            same name (instead of error_table_$not_seg_type).  Changed the
            file_access_info structure to have entry_state and file_state
            components.  Changed to pass the file_oid to the bjm_
            write_fm_rollback_handler entry, and so to move code which sets
            my_file_oid to before that bjm_ call.
            Changed to reset the entry_state to NOT_IN_USE if an error occurs.
            Changed to dm_error_$no_current_tranasction instead of 
            dm_error_$fm_no_current_txn.
02/28/85 by Steve Herbst:  Replace nonexistent error code
	  dm_error_$bad_file_cr_ring_brackets with
	  error_table_$invalid_ring_brackets.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/08/85 by S. Cox: Added TRANSACTION_BJ_FULL_HANDLER. 
03/21/85 by S. Cox: TRANSACTION_BJ_FULL_HANDLER: Add revert of txn_bj_full_
04/18/85 by Lindsey L. Spratt:  Fixed to check the iacl terms applied at
            creation (by the msf_manager_), and to "adjust" them to not have
            the "e" bit on (if any do).  This removes the only known source of
            invalid ACL entries for DM files.  Thsi is accomplished by the
            ADJUST_IACL proc.
05/03/85 by Matthew C. Pierret:  Changed to not log a message when attempting
            to open a file which does not exist.
*/

/* format: style2,ind3 */
/* format: ll79,comcol50,indnoniterend,^indnoniterdo,^indprocbody */
%page;
fm_create_open_$create_open:
   procedure (p_dir_path, p_entry_name, p_file_create_info_ptr,
        p_output_file_oid, p_code);


/* START OF DECLARATIONS */

/* Parameters */

   dcl	 p_code		    fixed bin (35) parm;
   dcl	 p_dir_path	    char (*) parm;
   dcl	 p_entry_name	    char (*) parm;
   dcl	 p_output_file_oid	    bit (36) aligned parm;
   dcl	 p_file_create_info_ptr ptr parm;

/* Automatic */

   dcl	 code		    fixed bin (35) init (0);
   dcl	 create_sw	    bit aligned init ("0"b);
   dcl	 current_validation_level
			    fixed bin init (LEVEL_NOT_SET);
   dcl	 dir_path		    char (168) unal init ("");
   dcl	 dir_ring_brackets	    (2) fixed bin (3);
   dcl	 encoded_ring_brackets  fixed bin (24) init (0);
   dcl	 entry_name	    char (32);
   dcl	 extended_ring_brackets (2) fixed bin (3) init (-1, -1);
   dcl	 file_access_table_idx  fixed bin init (0);
   dcl	 file_already_exists    bit aligned init ("0"b);
   dcl	 file_pathname	    char (168);
   dcl	 idx		    fixed bin init (0);
   dcl	 lowest_ring_bracket    fixed bin (3) init (7);
   dcl	 msf_acl_list_idx	    fixed bin init (0);
   dcl	 msf_fcb_ptr	    ptr init (null ());
				         /* cleanup */
   dcl	 number_of_msf_acl_terms
			    fixed bin init (0);
   dcl	 ring_brackets	    (3) fixed bin (3);
   dcl	 saved_validation_level fixed bin init (LEVEL_NOT_SET);
   dcl	 seg_0_ptr	    ptr init (null ());
   dcl	 seg_0_uid	    bit (36) aligned init (""b);
   dcl	 sys_pn_tbl_index	    fixed bin init (-1);
   dcl	 time_stamp	    fixed bin (71);/* dummy variable */

   dcl	 1 my_create_info	    like file_create_info aligned;

   dcl	 1 my_create_rollback_info
			    aligned like create_rollback_info;

   dcl	 1 my_ci_header	    like ci_header aligned;

   dcl	 1 my_file_oid	    aligned like file_oid;

   dcl	 1 my_msf_acl_list	    (2) aligned like general_extended_acl_entry;

   dcl	 1 my_attr_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_file_access_info  aligned like file_access_info;

   dcl	 1 my_file_attributes   aligned like file_attributes;
   dcl	 1 my_signal_structure  aligned like condition_info_header;

/* Builtin */

   dcl	 (addr, baseno, char, clock, dim, hbound, lbound, ltrim, max, null,
	 rtrim, size, string, substr, unspec)
			    builtin;

/* Conditions */

   dcl	 cleanup		    condition;
   dcl	 fm_sub_error_	    condition;
   dcl	 transaction_bj_full_   condition;

/* Constants */

   dcl	 MYNAME		    init ("fm_create_open_") char (32)
			    varying internal static options (constant);
   dcl	 (
	 BYTES_PER_WORD	    init (4) fixed bin,
	 CREATE_MSF	    init ("1"b) bit (1),
	 DONT_CREATE_MSF	    init ("0"b) bit (1),
	 FIRST_COMPONENT_NAME   init ("0") char (1),
	 LEVEL_NOT_SET	    init (-1) fixed bin,
	 DEFAULT_CI_SIZE_IN_BYTES
			    init (4096) fixed bin,
	 MAXIMUM_NUMBER_OF_FILE_OPENINGS
			    init (131071) fixed bin (17),
	 NO_CI_HELD	    init (0) fixed bin (27),
	 WITH_NO_ERRORS	    init (0) fixed bin (35)
	 )		    internal static options (constant);

/* Based */

   dcl	 dm_area		    area based (dm_data_$area_ptr);

/* External Variables */


   dcl	 dm_data_$current_txn_id
			    bit (36) aligned ext;
   dcl	 dm_data_$area_ptr	    ptr ext;

   dcl	 dm_system_data_$initializer_name
			    char (32) ext;

   dcl	 dm_error_$bad_file_atrs_length
			    fixed bin (35) ext;
   dcl	 dm_error_$bad_file_atrs_uid
			    fixed bin (35) ext;
   dcl	 dm_error_$bad_file_atrs_ver
			    fixed bin (35) ext;
   dcl	 dm_error_$bad_file_cr_blocking_factor
			    fixed bin (35) ext;
   dcl	 dm_error_$bad_file_cr_ci_size
			    fixed bin (35) ext;
   dcl	 dm_error_$bad_file_cr_info_ver
			    fixed bin (35) ext;
   dcl	 dm_error_$bj_journal_full
			    fixed bin (35) ext;
   dcl	 dm_error_$file_already_exists
			    fixed bin (35) ext;
   dcl	 dm_error_$file_already_open
			    fixed bin (35) ext;
   dcl	 dm_error_$file_not_dm_type
			    fixed bin (35) ext;
   dcl	 dm_error_$file_cr_info_mbz_nz
			    fixed bin (35) ext;
   dcl	 dm_error_$no_current_transaction
			    fixed bin (35) ext;
   dcl	 dm_error_$fm_proc_tbl_full
			    fixed bin (35) ext;
   dcl	 dm_error_$fm_too_many_openings
			    fixed bin (35) ext;
   dcl	 dm_error_$fm_xring_brackets_mismatch
			    fixed bin (35) ext;
   dcl	 dm_error_$programming_error
			    fixed bin (35) ext;
   dcl	 error_table_$bigarg    fixed bin (35) ext;
   dcl	 error_table_$invalid_ring_brackets
			    fixed bin (35) ext;
   dcl	 error_table_$namedup   fixed bin (35) ext;
   dcl	 error_table_$noentry   fixed bin (35) ext;
   dcl	 error_table_$not_dm_ring
			    fixed bin (35) ext;
   dcl	 error_table_$not_seg_type
			    fixed bin (35) ext;
   dcl	 error_table_$no_r_permission
			    fixed bin (35) ext;

   dcl	 sys_info$data_management_ringno
			    fixed bin ext;


/* External Entries */

   dcl	 before_journal_manager_$write_fm_rollback_handler
			    entry (bit (36) aligned, bit (36) aligned,
			    ptr, fixed bin, fixed bin (27),
			    fixed bin (71), fixed bin (35));
   dcl	 cu_$level_get	    entry (fixed bin);
   dcl	 cu_$level_set	    entry (fixed bin);
   dcl	 dm_misc_util_$log	    entry options (variable);
   dcl	 expand_pathname_	    entry (char (*), char (*), char (*),
			    fixed bin (35));
   dcl	 fm_error_util_$signal  entry options (variable);
   dcl	 fm_error_util_$get_code
			    entry () returns (fixed bin (35));
   dcl	 fm_get_$internal_get   entry (bit (36) aligned, uns fixed bin (24),
			    ptr, fixed bin (35));
   dcl	 fm_put_$internal_put   entry (bit (36) aligned, uns fixed bin (24),
			    ptr, fixed bin (35));
   dcl	 fm_sys_pn_tbl_util_$insert
			    entry (bit (36) aligned, char (*), ptr,
			    fixed bin (17));
   dcl	 fm_validate_$get_ring_brackets
			    entry (char (*), char (*), (2) fixed bin (3),
			    fixed bin (35));
   dcl	 get_group_id_$tag_star entry () returns (char (32));
   dcl	 get_ring_	    entry () returns (fixed bin (3));
   dcl	 hcs_$add_dir_acl_entries
			    entry (char (*), char (*), ptr, fixed bin,
			    fixed bin (35));
   dcl	 hcs_$chname_seg	    entry (ptr, char (*), char (*),
			    fixed bin (35));
   dcl	 hcs_$get_uid_seg	    entry (ptr, bit (36) aligned, fixed bin (35))
			    ;
   dcl	 hcs_$list_inacl	    entry (char (*), char (*), ptr, ptr, ptr,
			    fixed bin, fixed bin (3), fixed bin (35));
   dcl	 hcs_$set_bc	    entry (char (*), char (*), fixed bin (24),
			    fixed bin (35));
   dcl	 hcs_$set_bc_seg	    entry (ptr, fixed bin (24), fixed bin (35));
   dcl	 hcs_$set_dir_ring_brackets
			    entry (char (*), char (*), (2) fixed bin (3),
			    fixed bin (35));
   dcl	 hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (3),
			    fixed bin (35));
   dcl	 hcs_$set_safety_sw	    entry (char (*), char (*), bit (1),
			    fixed bin (35));
   dcl	 hcs_$set_synchronized_sw
			    entry (char (*), char (*), bit aligned,
			    fixed bin (35));
   dcl	 ioa_$rsnnl	    entry () options (variable);
   dcl	 lock_manager_$lock	    entry (bit (36) aligned, fixed bin (27),
			    fixed bin, fixed bin (71), fixed bin,
			    fixed bin (35));
   dcl	 msf_manager_$acl_add   entry (ptr, ptr, fixed bin, fixed bin (35));
   dcl	 msf_manager_$acl_delete
			    entry (ptr, ptr, fixed bin, fixed bin (35));
   dcl	 msf_manager_$close	    entry (ptr);
   dcl	 msf_manager_$msf_get_ptr
			    entry (ptr, fixed bin, bit (1), ptr,
			    fixed bin (24), fixed bin (35));
   dcl	 msf_manager_$open	    entry (char (*), char (*), ptr,
			    fixed bin (35));
   dcl	 pathname_	    entry (char (*), char (*))
			    returns (char (168));
   dcl	 signal_		    entry () options (variable);
   dcl	 transaction_manager_$abort_txn
			    entry (bit (36) aligned, fixed bin (35));

/* END OF DECLARATIONS */
%page;
/* DESCRIPTION OF fm_create_open_$create_open:

        This entry creates a Data Management file and opens that file,
   returing the opening id of the file to the caller.  The file is
   identified by pathname, p_dir_path and p_entry_name.  Attributes of
   the file are specified in the file_create_info structure, pointed to
   by the p_file_create_info_ptr parameter.  This parameter may be null,
   in which case a series of default values are used.
      
        Data Management files are MSFs with special values for two storage
   system attributes: an add-name on component 0 and the bit count on
   component 0.  The add-name on component has the canonical value held in the
   constant DM_FILE_VALIDATION_NAME.  This is used to validate that an
   apparent MSF is in reality a DM file without having to access the file or
   invoke any code which would cause Data Management to be initialized in the
   process.  The bit count on component has a value which is the encoded
   representation of the extended ring brackets of the file.  The bit count is
   used for the same reasons as the add-name.  The extended ring brackets are
   also stored in the file attributes for verification, and always takes
   precedence over the encoded ring brackets, should they differ. The
   encoding function is contained in the internal subroutine 
   ENCODE_RING_BRACKETS.  The encoded ring brackets in the bit count are
   preserved as long as msf_manager_$adjust is not called to adjust the
   file MSF, and the Data Management system does not do so. The extended
   ring brackets must satisfy the constraints:
    max(DM-ring, caller-validation-level) <= write bracket <= read bracket
   
        The actual ring brackets recognized by the file system are set so
   that only code in the DM ring can manipulate the contents of a file.
   The file's MSF directory ring brackets are both set to the DM ring, which
   is also the current ring of execution.  In this module, the DM ring, the
   ring fo excution and the current validation level (CVL) are all the same.
   So the file's MSF directory has ring brackets CVL, CVL.  The ring brackets
   on component 0 of the file's MSF are CVL, RB, RB, where RB is the specified
   or default extended read bracket.  This is to allow processes to directly
   read the contents of a file rather than obtaining local copies of file data.
   The ring brackets on component 0 are propogated to all components.

        Data Management files are uniquely indentified by the file system
   unique id of component 0 of the file's MSF.
   
        If the file is to be protected (the default case), some special 
   conditions exist.  First, a transaction must be in progress. If not, 
   dm_error_$no_current_transaction is returned.  Second, rw access to the
   file is granted to Data_Management.Daemon.  This allows the daemon to
   rollback modifications to the file if a transaction does not complete
   successfully.  Third, the creation of the file is also protected.

*/
/*
create_open:
   entry (p_dir_path, p_entry_name, p_file_create_info_ptr, p_output_file_oid, p_code);
*/

   call INIT;
   create_sw = "1"b;

   go to CREATE_OPEN_JOIN;
%page;
/* DESCRIPTION OF fm_create_open_$open:

          This entry opens a DM file, returning an opening id for the file.
     The file is identified by pathname, p_dir_path and p_entry_name.  The
     opening id is in p_output_file_oid.  Opening a file consists of inserting
     its pathname in the sys_pn_tbl so that, if necessary, a different process
     can find it during a rollback, and setting up a file_access_info
     structure as an entry in the file_access_table.  This is per-process
     information, the information for it retrieved from the file_attributes
     stored in control interval 0 of the file.  
*/

open:
   entry (p_dir_path, p_entry_name, p_output_file_oid, p_code);

   call INIT;
   create_sw = "0"b;

   go to CREATE_OPEN_JOIN;
%page;
CREATE_OPEN_JOIN:
   unspec (my_file_oid) = ""b;	         /* set for FINISH */

   on fm_sub_error_ call RETURN (fm_error_util_$get_code ());

   p_output_file_oid = ""b;
   dir_path = p_dir_path;
   entry_name = rtrim (p_entry_name);
   if entry_name ^= p_entry_name
   then call ERROR_RETURN (error_table_$bigarg,
	   "  The entry name argument is longer than 32 characters.  ^a^s",
	   p_entry_name, "");	         /* Subroutines will check the length of file_pathname */
   file_pathname = pathname_ (dir_path, entry_name);

   unspec (my_file_access_info) = ""b;
   my_file_access_info.msf_ptr = null ();

/* Validate the file and get its extended ring brackets.  If we are      */
/* are creating the file we expect to get the code error_table_$noentry. */
/* However, if the file already exists, (code = 0), do not abort as we   */
/* still have to open the file.  The extended ring brackets are those    */
/* that are encoded in the bit count of the first component of the file. */
/* We get them so that we can verify their correctness later when we get */
/* the file attributes. The call is made now because fm_validate_ expects*/
/* the validation level to be the caller's validation level.  The        */
/* validation level will be changed to the data management ring shortly. */

   call fm_validate_$get_ring_brackets (dir_path, entry_name,
        extended_ring_brackets, code);
   if create_sw
   then if code ^= 0
        then
	 do;
	 if code = error_table_$noentry
	 then code = 0;
	 else if code = error_table_$not_seg_type
	 then call ERROR_RETURN (error_table_$namedup, " ^a^s",
		 file_pathname, "");
	 else call ERROR_RETURN (code, "  ^a^s.", file_pathname, "");
	 end;
        else /* code already equal to 0 */
	   ;
   else if code ^= 0
   then if code = error_table_$noentry
        then call RETURN (code);
        else call ERROR_RETURN (code, "  ^a^s.", file_pathname, "");
   else /* code = 0 */
        ;

/* Save the caller's validation level.  It will be needed later to restore */
/* the validation level to the caller's.  Set the validation level to the  */
/* current ring of execution, i.e., the data management ring, so that      */
/* the process is in an appropriately priviledged state.                   */

   call cu_$level_get (saved_validation_level);
   on cleanup call FINISH ();
   current_validation_level = get_ring_ ();
   call cu_$level_set (current_validation_level);

   call msf_manager_$open (dir_path, entry_name, msf_fcb_ptr, code);
   if msf_fcb_ptr = null ()
   then call ERROR_RETURN (code, "  Returned by msf_manager_$open (^a).",
	   pathname_ (dir_path, entry_name), "");

%page;

   if create_sw & code = error_table_$noentry
   then
CREATE:
      do;
      file_already_exists = "0"b;

/* Set up and verify the local my_file_create_info. A local copy is  */
/* used for efficiency.  If the caller supplied a file_create_info   */
/* it is copied; otherwise a default my_create_info is used.  The    */
/* non-zero default value is the protected flag, which defaults to   */
/* on. */

      if p_file_create_info_ptr ^= null ()
      then my_create_info = p_file_create_info_ptr -> file_create_info;
      else
         do;
         unspec (my_create_info) = ""b;
         my_create_info.version = FILE_CREATE_INFO_VERSION_2;
         my_create_info.protected = "1"b;
         end;

      if my_create_info.version ^= FILE_CREATE_INFO_VERSION_2
      then call ERROR_RETURN (dm_error_$bad_file_cr_info_ver,
	      "  Supplied version was ^a.  It should have been ^a.",
	      (my_create_info.version), (FILE_CREATE_INFO_VERSION_2));

      if my_create_info.mbz_1 ^= ""b | unspec (my_create_info.mbz_2) ^= ""b
	 | unspec (my_create_info.mbz_3) ^= ""b
      then call ERROR_RETURN (dm_error_$file_cr_info_mbz_nz, "", "", "");

      if my_create_info.ci_size_in_bytes = 0
      then my_create_info.ci_size_in_bytes = DEFAULT_CI_SIZE_IN_BYTES;

      if my_create_info.ci_size_in_bytes ^= DEFAULT_CI_SIZE_IN_BYTES
      then call ERROR_RETURN (dm_error_$bad_file_cr_ci_size,
	      "  File_create_info.ci_size_in_bytes was ^a.  It should have been ^a.",
	      char (my_create_info.ci_size_in_bytes),
	      char (DEFAULT_CI_SIZE_IN_BYTES));

      if my_create_info.blocking_factor = 0
      then my_create_info.blocking_factor = 255;

      if my_create_info.blocking_factor ^= 64
	 & my_create_info.blocking_factor ^= 255
      then call ERROR_RETURN (dm_error_$bad_file_cr_blocking_factor,
	      "  Supplied blocking_factor was ^a.  It should have been 64 or 255.",
	      char (my_create_info.blocking_factor), "");

      if my_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX) = 0
      then my_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX) =
	      max (current_validation_level, saved_validation_level);
      if my_create_info.ring_brackets (FCI_READ_BRACKET_IDX) = 0
      then my_create_info.ring_brackets (FCI_READ_BRACKET_IDX) =
	      max (current_validation_level, saved_validation_level);
      lowest_ring_bracket =
	 max (current_validation_level, saved_validation_level);
      if my_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX)
	 < lowest_ring_bracket
	 | my_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX) > 7
	 | my_create_info.ring_brackets (FCI_READ_BRACKET_IDX)
	 < lowest_ring_bracket
	 | my_create_info.ring_brackets (FCI_READ_BRACKET_IDX) > 7
	 | my_create_info.ring_brackets (FCI_READ_BRACKET_IDX)
	 < my_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX)
      then call ERROR_RETURN (error_table_$invalid_ring_brackets,
	      "  The supplied ring_brackets were ^a,^a.",
	      char (my_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX)),
	      char (my_create_info.ring_brackets (FCI_READ_BRACKET_IDX)));

/* Now set the values in file_attributes from those in my_create_info.  */

      file_attributes_ptr = addr (my_file_attributes);
      unspec (file_attributes) = ""b;
      file_attributes.version = FILE_ATTRIBUTES_VERSION_2;
      file_attributes.ci_size_in_bytes = my_create_info.ci_size_in_bytes;
      file_attributes.blocking_factor = my_create_info.blocking_factor;
      file_attributes.flags.protected = my_create_info.protected;
      if my_create_info.protected
      then
         do;
         file_attributes.no_concurrency = my_create_info.no_concurrency;
         file_attributes.no_rollback = my_create_info.no_rollback;
         end;
      file_attributes.ring_brackets.write =
	 my_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX);
      file_attributes.ring_brackets.read =
	 my_create_info.ring_brackets (FCI_READ_BRACKET_IDX);


/* If the file is to be protected, verify that a transaction is in progress. */
/* Also, give Data_Management.Daemon access to the containing directory if   */
/* the containing directory is not the process directory.                    */

      if file_attributes.flags.protected
      then
         do;
         if dm_data_$current_txn_id = ""b
         then call RETURN (dm_error_$no_current_transaction);

         if substr (dir_path, 1, 4) ^= ">pdd"
	    & substr (dir_path, 1, 16) ^= ">process_dir_dir"
         then call GIVE_DAEMON_ACCESS_TO_CONTAINING_DIR (dir_path);
         end;

/* Now create the MSF by getting a pointer to the first component. */

      call msf_manager_$msf_get_ptr (msf_fcb_ptr, 0, CREATE_MSF, seg_0_ptr,
	 (0), code);
      if seg_0_ptr = null ()
      then call ERROR_RETURN (code,
	      "  Returned by msf_manager_$msf_get_ptr for component 0 of ^a.",
	      pathname_ (dir_path, entry_name), "");

/* Get the uid of the file, the same as the uid of the first component. */

      call hcs_$get_uid_seg (seg_0_ptr, seg_0_uid, code);
      if code ^= 0
      then call ERROR_RETURN (code,
	      "  Unable to get the Multics file system uid of ^a.",
	      pathname_ (pathname_ (dir_path, entry_name), "0"), "");

      file_attributes.unique_id = seg_0_uid;
      my_file_access_info.uid = seg_0_uid;

/* Reserve an entry in the file_access_table. */

      my_file_access_info.state.entry_state = FILE_ACCESS_INFO_IN_USE;
      my_file_access_info.state.file_state = FILE_EXISTS;

      call ADD_FILE_ACCESS_TABLE_ENTRY ();       /* This sets my_file_oid */

/* Setup for possible rollback of the file creation. */
/* The rollback handler requires the unique id of the file, its pathame and */
/* index in the sys_pn_tbl and its opening id. */

      if file_attributes.flags.protected & ^file_attributes.flags.no_rollback
      then
         do;
         on transaction_bj_full_ goto TRANSACTION_BJ_FULL_HANDLER;
         call fm_sys_pn_tbl_util_$insert (seg_0_uid, file_pathname, seg_0_ptr,
	    sys_pn_tbl_index);
         my_create_rollback_info.header.version = ROLLBACK_INFO_VERSION_1;
         my_create_rollback_info.header.operation = CREATE_ROLLBACK_OPERATION;
         my_create_rollback_info.sys_pn_tbl_index = sys_pn_tbl_index;
         my_create_rollback_info.dir_path = dir_path;
         my_create_rollback_info.file_name = entry_name;
         call before_journal_manager_$write_fm_rollback_handler (seg_0_uid,
	    unspec (my_file_oid), addr (my_create_rollback_info),
	    size (my_create_rollback_info) * BYTES_PER_WORD, NO_CI_HELD,
	    time_stamp, code);
         if code ^= 0
         then call ERROR_RETURN (code,
	         " Unable to write rollback handler while creating ^a.",
	         pathname_ (dir_path, entry_name), "");
         end;

/* Convert MSF into a Data Management file */

/* Add a canonical name to the first component of the MSF to indicate */
/* that this is a Data Management file.                               */

      call hcs_$chname_seg (seg_0_ptr, "" /* don't remove a name */,
	 DM_FILE_VALIDATION_NAME, code);
      if code ^= 0
      then call ERROR_RETURN (code, " Unable to add ^a to ^a.",
	      DM_FILE_VALIDATION_NAME, pathname_ (file_pathname, "0"));

/* Set the extended ring brackets on the file.  This is done by encoding the */
/* specified ring brackets into one value, and setting the bit count of the  */
/* first component to that value. */

      encoded_ring_brackets =
	 ENCODE_RING_BRACKETS ((file_attributes.ring_brackets.write),
	 (file_attributes.ring_brackets.read));

      call hcs_$set_bc_seg (seg_0_ptr, encoded_ring_brackets, code);
      if code ^= 0
      then call ERROR_RETURN (code, "  Could not set the bit count on ^a.",
	      pathname_ (file_pathname, "0"), "");

/* Set the actual ring brackets on the MSF directory and first MSF component.*/

      dir_ring_brackets (1) = current_validation_level;
      dir_ring_brackets (2) = current_validation_level;

      call hcs_$set_dir_ring_brackets (dir_path, entry_name, dir_ring_brackets,
	 code);
      if code ^= 0
      then call ERROR_RETURN (code, " Attempting to set ring brackets on ^a.",
	      pathname_ (dir_path, entry_name), "");

      ring_brackets (1) = current_validation_level;
      ring_brackets (2) = file_attributes.ring_brackets.read;
      ring_brackets (3) = file_attributes.ring_brackets.read;

      call hcs_$set_ring_brackets (file_pathname, FIRST_COMPONENT_NAME,
	 ring_brackets, code);
      if code ^= 0
      then call ERROR_RETURN (code, " Attempting to set ring brackets on ^a.",
	      pathname_ (file_pathname, FIRST_COMPONENT_NAME), "");

/* Ensure that future components' ring brackets will be set correctly by     */
/* closing and re-opening the MSF.  This resets fcb.rbs to the new values.   */

      call msf_manager_$close (msf_fcb_ptr);     /* Reset fcb.rbs */
      call msf_manager_$open (dir_path, entry_name, msf_fcb_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code,
	      " Unable to re-open ^a after setting ring_brackets.",
	      pathname_ (dir_path, entry_name), "");
      seg_0_ptr = null;		         /* Reset the seg_0_ptr - it was terminated by msf_manager_$close */
      call msf_manager_$msf_get_ptr (msf_fcb_ptr, 0, DONT_CREATE_MSF,
	 seg_0_ptr, (0), code);
      if seg_0_ptr = null ()
      then call ERROR_RETURN (code,
	      "  Unable to get pointer for component 0 of ^a.",
	      pathname_ (dir_path, entry_name), "");

/* Set the safety switch on the file (MSF directory). */

      call hcs_$set_safety_sw (dir_path, entry_name, "1"b, code);
      if code ^= 0
      then call ERROR_RETURN (code,
	      "  Unable to turn on the safety switch of ^a.",
	      pathname_ (dir_path, entry_name), "");

      call ADJUST_IACL (dir_path, entry_name, (current_validation_level),
	 (file_attributes.ring_brackets.write), msf_fcb_ptr);

/* Because of a bug in the msf_manager_, we must explicitly add an ACL     */
/* term for the creator in order to carry the term to new components. Also,*/
/* if the protected attribute is in force, add the Data Management daemon  */
/* to the access control list such that it is able to access the file for  */
/* rollback.                                                               */

      unspec (my_msf_acl_list) = ""b;
      number_of_msf_acl_terms = 1;
      my_msf_acl_list (1).access_name = get_group_id_$tag_star ();
      my_msf_acl_list (1).mode = RW_ACCESS;
      if file_attributes.flags.protected
      then
         do;
         number_of_msf_acl_terms = 2;
         my_msf_acl_list (2).access_name = dm_system_data_$initializer_name;
         my_msf_acl_list (2).mode = RW_ACCESS;
         end;
      call msf_manager_$acl_add (msf_fcb_ptr, addr (my_msf_acl_list),
	 number_of_msf_acl_terms, code);
      if code ^= 0
      then
         do msf_acl_list_idx = 1 to number_of_msf_acl_terms;
	  if my_msf_acl_list (msf_acl_list_idx).status_code ^= 0
	  then code = my_msf_acl_list (msf_acl_list_idx).status_code;
	  call ERROR_RETURN (code,
	       "  Unable to add 'rw' acl term to ^a for ^a.", file_pathname,
	       (my_msf_acl_list (msf_acl_list_idx).access_name));
         end;


/* Fill in the file_access_info entry for this file for this process and add */
/* it to the file_access_table. The file_access_info is roughly similar      */
/* to opening information or an MSF fcb.                                     */

      my_file_access_info.seg_0_num = baseno (seg_0_ptr);
      my_file_access_info.blocking_factor = file_attributes.blocking_factor;
      my_file_access_info.msf_ptr = msf_fcb_ptr;
      msf_fcb_ptr = null ();
      my_file_access_info.ring_brackets.write =
	 file_attributes.ring_brackets.write;
      my_file_access_info.ring_brackets.read =
	 file_attributes.ring_brackets.read;

      do file_access_table_idx = lbound (file_access_table.e, 1)
	 to file_access_table.h.last_entry;
         if file_access_table.e (file_access_table_idx).seg_0_num
	    = my_file_access_info.seg_0_num
	    & file_access_table.e (file_access_table_idx).state.entry_state
	    ^= 0
         then
	  do;			         /* unexpected dl */
	  unspec (file_access_table.e (file_access_table_idx).seg_0_num) =
	       ""b;
	  file_access_table.e (file_access_table_idx).msf_ptr = null ();
	  do idx = lbound (my_file_access_info.seg_nums, 1)
	       to hbound (my_file_access_info.seg_nums, 1);
	     unspec (file_access_table.e (file_access_table_idx)
		.seg_nums (idx)) = ""b;
	  end;
	  end;
      end;

      my_file_access_info.integrity_switches.record_time_modified = "1"b;
      my_file_access_info.integrity_switches.transaction =
	 file_attributes.flags.protected;
      my_file_access_info.integrity_switches.lock =
	 my_file_access_info.integrity_switches.transaction
	 & ^file_attributes.flags.no_concurrency;
      my_file_access_info.integrity_switches.bj =
	 my_file_access_info.integrity_switches.transaction
	 & ^file_attributes.flags.no_rollback;

      if my_file_access_info.integrity_switches.lock
      then
         do;
         call lock_manager_$lock (my_file_access_info.uid, LOCK_ENTIRE_FILE,
	    LOCK_MODE_X, 1e9, (0), code);
         if code ^= 0
         then call ERROR_RETURN (code,
	         "  Unable to lock file ^a, with file uid ^a, exclusively.",
	         file_pathname, char (my_file_access_info.uid));
         end;

      if my_file_access_info.integrity_switches.bj
      then
         do;
         call hcs_$set_synchronized_sw (file_pathname, "0", "1"b, code);
         if code ^= 0
         then
	  do;
	  if code = error_table_$not_dm_ring
	       & sys_info$data_management_ringno ^= get_ring_ ()
	  then code = 0;
	  else call ERROR_RETURN (code,
		  "  Unable to turn on the synchronized switch of ^a.",
		  pathname_ (pathname_ (dir_path, entry_name), "0"), "");
	  end;
         end;

      file_attributes.date_time_created = clock ();
      file_attributes.length_of_attributes = 4 * size (file_attributes) - 2;

      call INIT_ATTR_CI_PARTS (addr (my_attr_ci_parts), file_attributes_ptr);

      if my_attr_ci_parts.part (1).length_in_bytes
	 ^= file_attributes.length_of_attributes + 2
      then call ERROR_RETURN (dm_error_$programming_error,
	      "  The length of the file attributes, ^a, and the length of the ci_part, ^a, used to store the attributes differ.",
	      char (file_attributes.length_of_attributes + 2),
	      char (my_attr_ci_parts.part (1).length_in_bytes));

      my_file_access_info.pn_tbl_idx = sys_pn_tbl_index;
      my_file_access_info.opens = 1;

      file_access_table.e (my_file_oid.file_access_table_idx) =
	 my_file_access_info;

      call fm_put_$internal_put (unspec (my_file_oid), 0,
	 addr (my_attr_ci_parts), code);
      if code ^= 0
      then call RETURN (code);

      p_output_file_oid = unspec (my_file_oid);
      unspec (my_file_oid) = ""b;	         /* must be set for FINISH */

      call RETURN (WITH_NO_ERRORS);

      end CREATE;
%page;
/* if create_sw & code = error_table_$noentry */
/* then CREATE: ...                           */

   else if code ^= 0
   then call ERROR_RETURN (code, "  ^a^s.", file_pathname, "");
   else
OPEN:
      do;
      if create_sw
      then file_already_exists = "1"b;
      else file_already_exists = "0"b;

      call msf_manager_$msf_get_ptr (msf_fcb_ptr, 0, DONT_CREATE_MSF,
	 seg_0_ptr, (0), code);
      if seg_0_ptr = null ()
      then call ERROR_RETURN (code, "  Unable to get pointer to ^a.^s",
	      pathname_ (file_pathname, "0"), "");

/* Make sure that CI zero looks reasonable. */

      my_ci_header = seg_0_ptr -> ci_header;

      if my_ci_header.stamp.version ^= CI_HEADER_STAMP_VERSION_1
	 | unspec (my_ci_header.id.size_code) ^= CI_SIZE_CODE_1024_WORDS
	 | my_ci_header.id.num ^= 0 | my_ci_header.id.uid = ""b
      then call RETURN (dm_error_$file_not_dm_type);

      my_file_access_info.blocking_factor = 255;
      my_file_access_info.uid = my_ci_header.id.uid;
      my_file_access_info.seg_0_num = baseno (seg_0_ptr);

/* SEE IF IT IS ALREADY IN THE PROCESS TABLE */

      do file_access_table_idx = lbound (file_access_table.e, 1)
	 to file_access_table.h.last_entry
	 while (file_access_table.e (file_access_table_idx).seg_0_num
	 ^= my_file_access_info.seg_0_num
	 | file_access_table.e (file_access_table_idx).state.entry_state = 0)
	 ;
      end;

      if file_access_table_idx <= file_access_table.h.last_entry
      then
         do;
         if file_access_table.e (file_access_table_idx).uid
	    ^= my_file_access_info.uid
         then
	  do;			         /* unexpected dl */
	  unspec (file_access_table.e (file_access_table_idx).seg_0_num) =
	       ""b;
	  file_access_table.e (file_access_table_idx).msf_ptr = null ();
	  do idx = lbound (my_file_access_info.seg_nums, 1)
	       to hbound (my_file_access_info.seg_nums, 1);
	     unspec (file_access_table.e (file_access_table_idx)
		.seg_nums (idx)) = ""b;
	  end;
	  end;
         else
	  do;
	  call msf_manager_$close (msf_fcb_ptr);
	  msf_fcb_ptr = null ();

	  my_file_access_info = file_access_table.e (file_access_table_idx);

	  if my_file_access_info.opens >= MAXIMUM_NUMBER_OF_FILE_OPENINGS
	  then call ERROR_RETURN (dm_error_$fm_too_many_openings,
		  "For ^a^s.", file_pathname, "");
	  else my_file_access_info.opens = my_file_access_info.opens + 1;

	  file_access_table.e (file_access_table_idx) = my_file_access_info;

	  my_file_oid.file_access_table_idx = file_access_table_idx;
	  my_file_oid.uid_tail = substr (my_file_access_info.uid, 19, 18);

	  p_output_file_oid = unspec (my_file_oid);
	  unspec (my_file_oid) = ""b;	         /* must be set for FINISH */

	  if my_file_access_info.opens > 1
	  then call RETURN (dm_error_$file_already_open);

	  call RETURN (WITH_NO_ERRORS);
	  end;
         end;

      my_file_access_info.msf_ptr = msf_fcb_ptr;
      msf_fcb_ptr = null ();		         /* don't cleanup */

/* We will soon get the file_attributes by calling fm_get_$internal_get,   */
/* which relies on the information in file_access_info.  All of the info   */
/* upon which it relies has already been set with the exception of the     */
/* read ring bracket, the value of which is not yet known.  So that we can */
/* get the file_attributes, set the read ring bracket to the current ring  */
/* of execution.  Afterward, we will be able to set the ring bracket in    */
/* file_access_info to its true value.                                     */

      my_file_access_info.ring_brackets.read = get_ring_ ();

/* Insert the file access info in the file_access_table, where it can be   */
/* found by fm_get_$internal_get.  The entry in which the file access info */
/* is placed is recorded in file_oid.file_access_table_idx.                */

      my_file_access_info.state.entry_state = FILE_ACCESS_INFO_IN_USE;
      my_file_access_info.state.file_state = FILE_EXISTS;
      call ADD_FILE_ACCESS_TABLE_ENTRY ();

/* Now, actually get the file_attributes from control interval 0. */

      unspec (my_file_attributes) = ""b;
      file_attributes_ptr = addr (my_file_attributes);

      call INIT_ATTR_CI_PARTS (addr (my_attr_ci_parts), file_attributes_ptr);

      call fm_get_$internal_get (unspec (my_file_oid), 0,
	 addr (my_attr_ci_parts), code);
      if code ^= 0
      then call RETURN (code);

/* Verify the consistency of the values in the file_attributes structure. */

      if file_attributes.length_of_attributes
	 ^= CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH - 2
      then call ERROR_RETURN (dm_error_$bad_file_atrs_length,
	      "  The file_attributes length " || rtrim (file_pathname)
	      || " is ^a.  It should be ^a.",
	      char (file_attributes.length_of_attributes),
	      char (CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH - 2));

      if file_attributes.version ^= FILE_ATTRIBUTES_VERSION_2
      then call ERROR_RETURN (dm_error_$bad_file_atrs_ver,
	      "  The version of the file attributes is ^a.  It should be ^a.",
	      (file_attributes.version), (FILE_ATTRIBUTES_VERSION_2));

      if file_attributes.unique_id ^= my_file_access_info.uid
      then call ERROR_RETURN (dm_error_$bad_file_atrs_uid,
	      "  The unique identifier in the file attributes of "
	      || rtrim (file_pathname) || " is ^a.  The UID in CI 0 is ^a.",
	      char (file_attributes.unique_id),
	      char (my_file_access_info.uid));

      if file_attributes.ring_brackets.write
	 ^= extended_ring_brackets (FCI_WRITE_BRACKET_IDX)
	 | file_attributes.ring_brackets.read
	 ^= extended_ring_brackets (FCI_READ_BRACKET_IDX)
      then
         do;			         /* Stored and encoded ring brackets are out of synch.  Try to */
				         /* resynch them. If unsuccessful, it is safe to continue.     */
         call dm_misc_util_$log (LOG_SV, dm_error_$fm_xring_brackets_mismatch,
	    MYNAME,
	    "  The stored ring brackets for ^a are ^d,^d, the encoded are ^d,^d.",
	    file_pathname, file_attributes.ring_brackets.write,
	    file_attributes.ring_brackets.read,
	    extended_ring_brackets (FCI_WRITE_BRACKET_IDX),
	    extended_ring_brackets (FCI_READ_BRACKET_IDX));

         encoded_ring_brackets =
	    ENCODE_RING_BRACKETS ((file_attributes.ring_brackets.write),
	    (file_attributes.ring_brackets.read));
         call hcs_$set_bc (dir_path, entry_name, encoded_ring_brackets, code);
         if code ^= 0
         then call dm_misc_util_$log (LOG_SV, code, MYNAME,
	         "  Could not resynch extended ring brackets for ^a.",
	         file_pathname);
         else call dm_misc_util_$log (INFORM_SV, 0, MYNAME,
	         " Resynched ring brackets for ^a.", file_pathname);
         end;

      my_file_access_info.ring_brackets.write =
	 file_attributes.ring_brackets.write;
      my_file_access_info.ring_brackets.read =
	 file_attributes.ring_brackets.read;

      if my_file_access_info.ring_brackets.read < saved_validation_level
      then call RETURN (error_table_$no_r_permission);

      if file_attributes.flags.protected & ^file_attributes.flags.no_rollback
      then call fm_sys_pn_tbl_util_$insert (file_attributes.unique_id,
	      file_pathname, seg_0_ptr, sys_pn_tbl_index);

      my_file_access_info.blocking_factor = file_attributes.blocking_factor;
      my_file_access_info.integrity_switches.record_time_modified = "1"b;
      my_file_access_info.integrity_switches.transaction =
	 file_attributes.flags.protected;
      my_file_access_info.integrity_switches.lock =
	 my_file_access_info.integrity_switches.transaction
	 & ^file_attributes.flags.no_concurrency;
      my_file_access_info.integrity_switches.bj =
	 my_file_access_info.integrity_switches.transaction
	 & ^file_attributes.flags.no_rollback;
      my_file_access_info.pn_tbl_idx = sys_pn_tbl_index;
      my_file_access_info.opens = 1;

      file_access_table.e (file_access_table_idx) = my_file_access_info;

      p_output_file_oid = unspec (my_file_oid);
      unspec (my_file_oid) = ""b;	         /* must be set for FINISH */

      if file_already_exists
      then call RETURN (dm_error_$file_already_exists);
      else call RETURN (WITH_NO_ERRORS);

      end OPEN;

/* All returns from the main procedure go through this statement. */

MAIN_RETURN:
   return;
%skip;
TRANSACTION_BJ_FULL_HANDLER:
/**** Cannot call bj_report_err_ to do this since BJ cannot be called recursively. */
/**** See also fm_(delete_close put), which need to handle this condition. */
   revert transaction_bj_full_;
   my_signal_structure.length = size (my_signal_structure);
   my_signal_structure.version = 1;
   string (my_signal_structure.action_flags) = "0"b;
   call ioa_$rsnnl ("Creating DM file UID ^w ^a",
        my_signal_structure.info_string, (0), seg_0_uid,
        pathname_ (dir_path, entry_name));
   my_signal_structure.status_code = dm_error_$bj_journal_full;

   call transaction_manager_$abort_txn (dm_data_$current_txn_id, code);
   call signal_ ("transaction_bj_full_", null (), addr (my_signal_structure));
   call RETURN (dm_error_$bj_journal_full);      /* should never get here */
%page;
/* SUBROUTINES */

RETURN:
   proc (r_p_code);

/* DESCRIPTION of RETURN:
   This routine is called to exit the main procedure.  It is called in
   three cases: to return without errors, to return with a minor error
   which should not be logged, and to return from the fm_sub_error_
   condition handler.
*/

   dcl	 r_p_code		    fixed bin (35);

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

   end RETURN;


ERROR_RETURN:
   proc (er_p_code, er_p_error_message, er_p_error_message_argument_1,
        er_p_error_message_argument_2);

/* DESCRIPTION of ERROR_RETURN:
   This routine is called to exit the main procedure when a major error
   has occurred requiring logging.  It call fm_error_util_$signal,
   which logs the error message and signals fm_sub_error_.  The condition
   is caught by fm_create_open_'s fm_sub_error_ handler, which returns
   by calling RETURN.
*/

   dcl	 er_p_code	    fixed bin (35) parameter;
   dcl	 (er_p_error_message, er_p_error_message_argument_1,
	 er_p_error_message_argument_2)
			    char (*) parameter;

   call fm_error_util_$signal (er_p_code, MYNAME,
        (FM_ACTION_CANT_RESTART | FM_ACTION_LOG), LOG_SV, er_p_error_message,
        er_p_error_message_argument_1, er_p_error_message_argument_2);

   end ERROR_RETURN;


FINISH:
   proc;


   if msf_fcb_ptr ^= null ()
   then call msf_manager_$close (msf_fcb_ptr);
   if saved_validation_level ^= -1
   then call cu_$level_set (saved_validation_level);
   if my_file_oid.file_access_table_idx > 0
   then file_access_table.e (my_file_oid.file_access_table_idx).state
	   .entry_state = FILE_ACCESS_INFO_NOT_IN_USE;

   end FINISH;
%page;
INIT:
   proc;

/* THE LOGIC DOES NOT DEPEND ON THE INITIALIZATIONS BELOW */

   ci_header_ptr = null ();
   ci_trailer_ptr = null ();
   file_create_info_ptr = null ();

   unspec (my_ci_header) = ""b;
   unspec (my_create_info) = ""b;
   unspec (my_file_attributes) = ""b;

/* THE LOGIC DOES NOT DEPEND ON THE INITIALIZATIONS ABOVE */

   end INIT;

INIT_ATTR_CI_PARTS:
   proc (iacp_p_ci_parts_ptr, iacp_p_local_ptr);

/* DESCRIPTION of INIT_ATTR_CI_PARTS:
   Initializes the ci_parts structure pointed to by iacp_p_ci_parts_ptr
   such that it has the correct offset and length for accessing the 
   file_attributes in control interval 0. Sets the local_ptr in the
   ci_parts structure to iacp_p_local_ptr.  This can be used to 
   initialize the ci_parts structure for read or write.
*/

   dcl	 iacp_p_ci_parts_ptr    ptr parameter;
   dcl	 iacp_p_local_ptr	    ptr parameter;

   iacp_p_ci_parts_ptr -> ci_parts.number_of_parts = 1;
   iacp_p_ci_parts_ptr -> ci_parts.part (1).offset_in_bytes =
        CI_0_ADDRESSABLE_LENGTH;
   iacp_p_ci_parts_ptr -> ci_parts.part (1).length_in_bytes =
        CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH;
   iacp_p_ci_parts_ptr -> ci_parts.part (1).local_ptr = iacp_p_local_ptr;

   return;

   end INIT_ATTR_CI_PARTS;
%page;
ENCODE_RING_BRACKETS:
   proc (erb_p_write_bracket, erb_p_read_bracket) returns (fixed bin);

   dcl	 erb_p_write_bracket    fixed bin (3);
   dcl	 erb_p_read_bracket	    fixed bin (3);

   return ((8 * erb_p_write_bracket + erb_p_read_bracket));

   end ENCODE_RING_BRACKETS;
%page;
ADD_FILE_ACCESS_TABLE_ENTRY:
   proc ();


   do file_access_table_idx = lbound (file_access_table.e, 1)
        to file_access_table.h.last_entry
        while (file_access_table.e (file_access_table_idx).state.entry_state
        ^= 0);
   end;

   if file_access_table_idx > file_access_table.h.last_entry
   then
      do;
      if file_access_table.h.last_entry = hbound (file_access_table.e, 1)
      then call RETURN (dm_error_$fm_proc_tbl_full);
      file_access_table.h.last_entry = file_access_table_idx;
      end;

   file_access_table.e (file_access_table_idx) = my_file_access_info;

   my_file_oid.file_access_table_idx = file_access_table_idx;
   my_file_oid.uid_tail = substr (my_file_access_info.uid, 19, 18);

   end ADD_FILE_ACCESS_TABLE_ENTRY;
%page;
GIVE_DAEMON_ACCESS_TO_CONTAINING_DIR:
   proc (gda_p_path);

   dcl	 gda_p_path	    char (168) parm;

   dcl	 gda_dir_path	    char (168);
   dcl	 gda_effective_mode	    fixed bin (5);
   dcl	 gda_entry_name	    char (32);

   dcl	 1 gda_dir_acl_list	    (1) aligned like general_acl_entry;

   dcl	 hcs_$get_user_effmode  entry (char (*), char (*), char (*),
			    fixed bin, fixed bin (5), fixed bin (35));


   call expand_pathname_ (gda_p_path, gda_dir_path, gda_entry_name, code);
   if code ^= 0
   then call ERROR_RETURN (code, "  Unable to expand pathname ^a.^s.",
	   gda_p_path, "");

   call hcs_$get_user_effmode (gda_dir_path, gda_entry_name,
        dm_system_data_$initializer_name, get_ring_ (), gda_effective_mode,
        code);
   if code ^= 0
   then call ERROR_RETURN (code,
	   "  Unable to determine the access of ^a to ^a.",
	   dm_system_data_$initializer_name,
	   pathname_ (gda_dir_path, gda_entry_name));

   if gda_effective_mode ^= SMA_ACCESS_BIN
   then
      do;
      unspec (gda_dir_acl_list) = ""b;
      gda_dir_acl_list (1).access_name = dm_system_data_$initializer_name;
      gda_dir_acl_list (1).mode = SMA_ACCESS;

      call hcs_$add_dir_acl_entries (gda_dir_path, gda_entry_name,
	 addr (gda_dir_acl_list), dim (gda_dir_acl_list, 1), code);
      if code ^= 0
      then
         do;
         if gda_dir_acl_list (1).status_code ^= 0
         then code = gda_dir_acl_list (1).status_code;
         call ERROR_RETURN (code,
	    "  Unable to add 'sma' directory acl term to ^a for ^a.",
	    pathname_ (gda_dir_path, gda_entry_name),
	    (gda_dir_acl_list (1).access_name));
         end;
      end;

   return;


   end GIVE_DAEMON_ACCESS_TO_CONTAINING_DIR;
%page;
ADJUST_IACL:
   proc (ai_p_dir_path, ai_p_entry, ai_p_validation_level, ai_p_write_bracket,
        ai_p_msf_fcb_ptr);
   dcl	 ai_p_dir_path	    char (*) parm;
   dcl	 ai_p_entry	    char (*) parm;
   dcl	 ai_p_validation_level  fixed bin (3) parm;
   dcl	 ai_p_write_bracket	    fixed bin (3) parm;
   dcl	 ai_p_msf_fcb_ptr	    ptr parm;

   dcl	 ai_acl_idx	    fixed bin init (0);
   dcl	 ai_code		    fixed bin (35) init (0);
   dcl	 1 ai_delete_acl_array  (ai_delete_acl_count) aligned
			    based (ai_delete_acl_array_ptr)
			    like general_delete_acl_entry;
   dcl	 ai_delete_acl_count    fixed bin init (0);
   dcl	 ai_delete_acl_array_ptr
			    ptr init (null ());
   dcl	 ai_dir_dir	    char (168);
   dcl	 ai_dir_entry	    char (32);
   dcl	 ai_iacl_count	    fixed bin init (0);
   dcl	 1 ai_iacl_array	    (ai_iacl_count) aligned
			    based (ai_iacl_array_ptr)
			    like segment_acl_entry;
   dcl	 ai_iacl_array_ptr	    ptr init (null ());

   on cleanup call AI_FINISH ();

   call expand_pathname_ (ai_p_dir_path, ai_dir_dir, ai_dir_entry, ai_code);
   if ai_code ^= 0
   then call ERROR_RETURN (ai_code,
	   "^/Unable to expand the pathname of the directory, ^a, which is to contain the new DM file.",
	   ai_p_dir_path, "");


/* The IACLs applied by msf_manager_ at creation time are those for the ring
of the validation level.  However, the IACLs which should be applied are those
for the ring of the write_bracket.  Hence, it's necessary to delete the IACLs
for the validation level, then apply the (adjusted) IACLs for the
write_bracket ring.
*/

   call hcs_$list_inacl (ai_dir_dir, ai_dir_entry, dm_data_$area_ptr,
        ai_iacl_array_ptr, null (), ai_iacl_count, ai_p_validation_level,
        ai_code);
   if ai_code ^= 0
   then call ERROR_RETURN (ai_code,
	   "^/Unable to list the initial segment ACL for ^a for the validation level ^a.",
	   pathname_ (ai_dir_dir, ai_dir_entry),
	   ltrim (char (ai_p_validation_level)));
   if ai_iacl_count > 0
   then
      do;
      ai_delete_acl_count = ai_iacl_count;
      alloc ai_delete_acl_array in (dm_area);
      do ai_acl_idx = 1 to ai_delete_acl_count;
         ai_delete_acl_array (ai_acl_idx).access_name =
	    ai_iacl_array (ai_acl_idx).access_name;
         ai_delete_acl_array (ai_acl_idx).status_code = 0;
      end;

      free ai_iacl_array;
      ai_iacl_array_ptr = null ();

      call msf_manager_$acl_delete (ai_p_msf_fcb_ptr, ai_delete_acl_array_ptr,
	 ai_delete_acl_count, ai_code);
      if ai_code ^= 0
      then call ERROR_RETURN (ai_code,
	      "^/Unable to delete the IACLs for the validation level (^a) while creating ^a.",
	      ltrim (char (ai_p_validation_level)),
	      pathname_ (ai_p_dir_path, ai_p_entry));
      free ai_delete_acl_array;
      ai_delete_acl_array_ptr = null ();
      end;

/* Add the IACL for the write_bracket ring, after first turning off any use of the "e"
access bit.
*/

   call hcs_$list_inacl (ai_dir_dir, ai_dir_entry, dm_data_$area_ptr,
        ai_iacl_array_ptr, null (), ai_iacl_count, ai_p_write_bracket, ai_code)
        ;
   if ai_code ^= 0
   then call ERROR_RETURN (ai_code,
	   "^/Unable to list the initial segment ACL for ^a for the write_bracket ring ^a.",
	   pathname_ (ai_dir_dir, ai_dir_entry),
	   ltrim (char (ai_p_write_bracket)));

   do ai_acl_idx = 1 to ai_iacl_count;
      if (ai_iacl_array (ai_acl_idx).mode & E_ACCESS)
      then ai_iacl_array (ai_acl_idx).mode =
	      ai_iacl_array (ai_acl_idx).mode & RW_ACCESS;
   end;

   if ai_iacl_count > 0
   then
      do;
      call msf_manager_$acl_add (ai_p_msf_fcb_ptr, ai_iacl_array_ptr,
	 ai_iacl_count, ai_code);
      if ai_code ^= 0
      then call ERROR_RETURN (ai_code,
	      "^/Unable to add the ACL entries developed from the seg IACL with a set of those ACL terms with the ""e"" access removed while attempting to create ^a.",
	      pathname_ (ai_p_dir_path, ai_p_entry), "");
      end;

   call AI_FINISH ();
   return;

AI_FINISH:
   proc ();
   if ai_iacl_array_ptr ^= null ()
   then free ai_iacl_array;
   if ai_delete_acl_array_ptr ^= null ()
   then free ai_delete_acl_array;
   end AI_FINISH;
   end ADJUST_IACL;
%page;

/* ***************** START OF INCLUDE FILES ********************** */


%include access_mode_values;
%page;
%include acl_structures;
%page;
%include dm_ci_header;
%page;
%include dm_ci_lengths;


%include dm_ci_constants;
%page;
%include dm_ci_parts;
%page;
%include dm_lock_modes;
%page;
%include dm_file_create_info;
%page;
%include dm_file_validation_name;
%page;
%include dm_fm_file_attributes;
%page;
%include dm_fm_file_access_info;
%page;
%include dm_fm_file_access_tbl;
%page;
%include dm_fm_file_oid;
%page;
%include dm_fm_rollback_info;
%page;
%include dm_fm_sub_error_flags;
%page;
%include dm_log_sv_codes;
%page;
%include condition_info_header;

   end fm_create_open_$create_open;




		    fm_data_.alm                    03/06/85  0802.6re  03/05/85  0759.0       24417



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"    This is the external static data used by the Data Management File Manager.
"
"    Written in March 1983 by Jeffrey D. Ives
"    04/13/83 jdi Add protection_enabled, locking_enabled, & before_journalization_enabled.
"    830424 bim turned locking on.
"    07/12/84 by Matthew Pierret:  Changed proc_ad_tbl_ptr to 
"                file_access_table_ptr.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	fm_data_


	entry	sub_err_flag_set
sub_err_flag_set:
	epp2	pr0|2,*
	mlr	(pr),(pr)
	desc9a	pr2|0,1
	desc9a	pr4|sub_err_flag,1
	short_return


	entry	sub_err_flag_get
sub_err_flag_get:
	epp2	pr0|2,*
	mlr	(pr),(pr)
	desc9a	pr4|sub_err_flag,1
	desc9a	pr2|0,1
	short_return



" TEXT DATA  TEXT DATA  TEXT DATA  TEXT DATA  TEXT DATA  TEXT DATA  TEXT DATA

	segdef	me			" for calls to sub_err_
me:					" dcl fm_data_$me char (32) aligned ext;
	aci	/Data Management File/,32

	segdef	sys_pn_tbl_name		" name of uid/pathname table
sys_pn_tbl_name:				" dcl $sys_pn_tbl_name char (32) ext;
	aci	/fm_sys_pn_tbl/,32

	segdef	protection_enabled		" 1/0/ like protected = "0"b on all files.
protection_enabled:				" For development ONLY.
	vfd	1/1/			" Effective when file is first opened.

	segdef	locking_enabled		" 1/0/ no_concurrency = "1"b on all files.
locking_enabled:				" For development ONLY.
	vfd	1/1/			" Effective when file is first opened.

	segdef	before_journalization_enabled	" 1/0/ => no_rollback = "1"b on all files.
before_journalization_enabled:		" For development ONLY.
	vfd	1/1/			" Effective when file is first opened.
"
" LINKAGE DATA  LINKAGE DATA  LINKAGE DATA  LINKAGE DATA  LINKAGE DATA

	use	linkage_data

	even

	segdef	sys_pn_tbl_ptr		" -> pathname/pfuid table
sys_pn_tbl_ptr:				" dcl $sys_pn_tbl_ptr ptr ext;
	its	-1,1

	segdef	old_sys_pn_tbl_ptr		" used during recovery after crash
old_sys_pn_tbl_ptr:				" dcl $old_sys_pn_tbl_ptr ptr ext;
	its	-1,1

	segdef	proc_txn_tbl_ptr		" -> per-process per-transaction table
proc_txn_tbl_ptr:				" dcl $proc_txn_tbl_ptr ptr ext;
	its	-1,1

	segdef	file_access_table_ptr	" -> per-process access data table
file_access_table_ptr:			" dcl $file_access_table_ptr ptr ext;
	its	-1,1

" !!!!!!!!!!!!!!!!!! END OF DOUBLE WORD ALIGNMENT REGION !!!!!!!!!!!!!!!!!!!!!!


	segdef	sub_err_flag			" used in calls to sub_err_
sub_err_flag:					" dcl $sub_err_flag char aligned ext;
	aci	/q/


	join	/link/linkage_data

	end




		    fm_delete_close_.pl1            04/02/87  1316.2r w 04/02/87  1300.0      274005



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

/* DESCRIPTION: 

          This module deletes and closes files.  There are three entries
     delete_close, close and post_transaction.  The post_transaction
     entry is used to complete the close a file which was started during
     a transaction.
*/

/* HISTORY: 
Written by Matthew Pierret, 07/12/84.
           (Taken from fm_open_.pl1, written by Jeff Ives.)
           (Originally designed in January 1982 by Andre Bensoussan.)
Modified:
08/27/84 by Matthew Pierret:  Changed to set p_code to 0.
10/25/84 by Matthew Pierret:  Changed to answer audit comments, as follows:
            Moved setting of p_code up to the beginning of delete_close and
            close entries. Used dm_log_sv_codes.incl.pl1. Removed post_commit
            entry (it is being replaced by fm_do_$postcommit_do). Changed
            REALLY_CLOSE to use explicit qualifier references to
            file_access_info. Changed to use dm_error_$no_current_transaction.
            Changed to check for valid saved_validation_level before reseting
            it in FINISH. Moved dm_fm_file_oid to main procedure. Removed
            check for limit of openings (changes to fm_create_open_ make it
            unnecessary). Added documentation to explain the closing cases.
            Added error message when file_oid.uid_tail and
            file_access_info.uid don't match.
12/17/84 by Matthew Pierret:  Changed for new state variables in 
            file_access_info, substituting entry_state for thread and adding
            file_state. Made this routine set file_state to 
            FILE_LOGICALLY_DELETED if the file is logically deleted.
            Other routines will check file_state instead of relying on
            seg_0_num to be set to ""b for a logically deleted file, which is
            no longer true.
01/04/85 by Matthew C. Pierret:  In REALLY_CLOSE, consolidated the two test
            for seg_0_num not equal to zero into one test, as the then clause
            of the first test set seg_0_num to zero, causing the second to
            always fail. Also changed FINISH to understand to try to delete
            the system-pathname-table entry.
02/12/85 by Matthew C. Pierret:  Changed to set to zero the seg_0_num and
            seg_nums in the file_access_info just before deleting a file with
            no rollback protection.  This fixes a bug in which shuch a file
            could be deleted but, if directed, file_manager_ would attempt to
            reference through one of the segment numbers.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/08/85 by S. Cox: Added TRANSACTION_BJ_FULL_HANDLER. 
03/21/85 by S. Cox: TRANSACTION_BJ_FULL_HANDLER: Add revert of txn_bj_full_
04/25/85 by Matthew C. Pierret:  Changed post_transaction and REALLY_CLOSE to
            accept a file_state of FILE_DOES_NOT_EXIST as a trigger for
            really-really-closing.  Changed close to accept a file_state of
            FILE_LOGICALLY_DELETED as a trigger for really-closing or
            scheduling for a post-transaction close.  This means that deleting
            a file closes the file.
           Changed REALLY_CLOSE to call fm_sys_pn_tbl_util_$redelete_force
            instead of $delete if the file_state is FILE_DOES_NOT_EXIST.
*/

/* format: style2,ind3 */
%page;
fm_delete_close_$delete_close:
   proc (p_file_oid, p_code);

/* START OF DECLARATIONS */

/* Parameters */

      dcl	    p_code	       fixed bin (35) parm;
      dcl	    p_file_oid	       bit (36) aligned parm;

/* Automatic */

      dcl	    code		       fixed bin (35) init (0);
      dcl	    current_validation_level
			       fixed bin init (0);
      dcl	    dir_path	       char (168);
      dcl	    delete_name	       char (32);
      dcl	    entry_name	       char (32);
      dcl	    my_file_oid	       bit (36) aligned init (""b);
      dcl	    my_fsuid	       bit (36) aligned init (""b);
      dcl	    file_access_table_idx  fixed bin init (0);
      dcl	    sys_idx	       fixed bin init (0);
      dcl	    sys_pn_tbl_index       fixed bin init (0);
      dcl	    post_actions_thread_idx
			       fixed bin init (0);

      dcl	    saved_validation_level fixed bin init (-1);	/* for FINISH */
      dcl	    global_file_uid	       bit (36) aligned init (""b);
						/* for FINISH */
      dcl	    global_sys_pn_tbl_idx  fixed bin init (-1);	/* for FINISH */
      dcl	    global_msf_fcb_ptr     ptr init (null ());	/* for FINISH */

      dcl	    seg_ptr	       ptr init (null ());
      dcl	    seg_0_ptr	       ptr init (null ());

      dcl	    1 my_file_access_info  aligned like file_access_info;
      dcl	    1 my_signal_structure  aligned like condition_info_header;

/* Conditions */

      dcl	    cleanup	       condition;
      dcl	    fm_sub_error_	       condition;
      dcl	    transaction_bj_full_   condition;

/* Constants */

      dcl	    (
	    MYNAME	       init ("fm_delete_close_") char (32) varying,
	    BYTES_PER_WORD	       init (4) fixed bin,
	    MAX_CHARS_FOR_DELETE_NAME
			       init (16) fixed bin,
	    NO_CI_IS_HELD	       init (0) fixed bin (27),
	    NO_ERROR_MESSAGE       init ("") char (1),
	    NO_OID	       init (""b) bit (36) aligned,
	    NO_TRANSACTION_IN_PROGRESS
			       init (""b) bit (36) aligned
	    )		       internal static options (constant);

/* Based */

/* Builtin */

      dcl	    (addr, baseptr, char, decimal, lbound, length, min, null, rtrim, size, substr, unspec)
			       builtin;

/* External */

      dcl	    dm_data_$current_txn_id
			       bit (36) aligned ext;
      dcl	    dm_error_$bad_file_oid fixed bin (35) ext;
      dcl	    dm_error_$bj_journal_full
			       fixed bin (35) ext;
      dcl	    dm_error_$file_doesnt_exist
			       fixed bin (35) ext;
      dcl	    dm_error_$no_current_transaction
			       fixed bin (35) ext;
      dcl	    error_table_$insufficient_access
			       fixed bin (35);
      dcl	    error_table_$no_w_permission
			       fixed bin (35) ext;

/* Entry */

      dcl	    before_journal_manager_$write_fm_postcommit_handler
			       entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (21), fixed bin (35));
      dcl	    before_journal_manager_$write_fm_rollback_handler
			       entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (17), fixed bin (27),
			       fixed bin (71), fixed bin (35));
      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    cu_$level_set	       entry (fixed bin);
      dcl	    expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
      dcl	    fm_error_util_$get_code
			       entry () returns (fixed bin (35));
      dcl	    fm_put_$clear_flush_list
			       entry (fixed bin (35));
      dcl	    fm_sys_pn_tbl_util_$delete
			       entry (bit (36) aligned, fixed bin (17));
      dcl	    fm_sys_pn_tbl_util_$redelete_force
			       entry (bit (36) aligned, fixed bin (17));
      dcl	    fm_sys_pn_tbl_util_$rename
			       entry (bit (36) aligned, fixed bin (17), char (32));
      dcl	    get_ring_	       entry () returns (fixed bin (3));
      dcl	    hcs_$chname_file       entry (char (*), char (*), char (*), char (*), fixed bin (35));
      dcl	    hcs_$del_dir_tree      entry (char (*), char (*), fixed bin (35));
      dcl	    hcs_$delentry_file     entry (char (*), char (*), fixed bin (35));
      dcl	    hcs_$fs_get_path_name  entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
      dcl	    hcs_$get_user_effmode  entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
      dcl	    hcs_$set_safety_sw     entry (char (*), char (*), bit (1), fixed bin (35));
      dcl	    ioa_$rsnnl	       entry () options (variable);
      dcl	    lock_manager_$lock     entry (bit (36) aligned, fixed bin (27), fixed bin, fixed bin (71), fixed bin,
			       fixed bin (35));
      dcl	    msf_manager_$close     entry (ptr);
      dcl	    pathname_	       entry (char (*), char (*)) returns (char (168));
      dcl	    signal_	       entry () options (variable);
      dcl	    transaction_manager_$abort_txn
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    unique_bits_	       entry () returns (bit (70));
      dcl	    unique_chars_	       entry (bit (*)) returns (char (15));

/* END OF DECLARATIONS */
%page;
/* DESCRIPTION of fm_delete_close_$delete_close:
     
     delete_close deletes a file, then closes it.  The file must be open,
     as implied by the fact that an opening id is taken as input.  In the 
     near future, this entry should be changed to only logically delete
     files, and set up a post-commit handler to do the actual delete.
     This is part of the implementation of protected file deletion.

delete_close: entry (p_file_oid, p_code);

*/

      p_code = 0;
      my_file_oid = p_file_oid;

      call cu_$level_get (saved_validation_level);
      on cleanup call FINISH ();
      current_validation_level = get_ring_ ();
      call cu_$level_set (current_validation_level);

      call GET_ACCESS_INFO (my_file_oid, addr (my_file_access_info), file_access_table_idx);

      if my_file_access_info.seg_0_num = ""b
      then call ERROR_RETURN (dm_error_$file_doesnt_exist, NO_ERROR_MESSAGE);

      call GET_PATH (my_file_access_info.seg_0_num, dir_path, entry_name);

      sys_pn_tbl_index = my_file_access_info.pn_tbl_idx;

      call VERIFY_ACCESS_TO_DELETE_FILE (dir_path, entry_name, my_file_access_info.ring_brackets.write,
	 saved_validation_level);

      if my_file_access_info.integrity_switches.transaction
      then call VERIFY_TRANSACTION_STATE ();

      if my_file_access_info.integrity_switches.lock
      then call LOCK_FILE (my_file_access_info.uid);

      delete_name =
	 unique_chars_ (unique_bits_ ()) || "."
	 || substr (entry_name, 1, min (length (entry_name), MAX_CHARS_FOR_DELETE_NAME));

      if my_file_access_info.integrity_switches.bj
      then
         do;
	  on transaction_bj_full_ goto TRANSACTION_BJ_FULL_HANDLER;
	  call WRITE_ROLLBACK_HANDLER_FOR_DELETE (my_file_access_info.uid, my_file_oid, sys_pn_tbl_index, dir_path,
	       entry_name, delete_name);
         end;

      if my_file_access_info.integrity_switches.transaction
      then call FLUSH_MODIFIED_PAGES ();

      if my_file_access_info.integrity_switches.bj
      then
         do;
	  call WRITE_POSTCOMMIT_HANDLER_FOR_DELETE (my_file_access_info.uid, my_file_oid, sys_pn_tbl_index, dir_path,
	       delete_name);
	  my_file_access_info.state.file_state = FILE_LOGICALLY_DELETED;
	  file_access_table.e (file_access_table_idx) = my_file_access_info;
	  call LOGICAL_DELETE (my_file_access_info.uid, sys_pn_tbl_index, dir_path, entry_name, delete_name);
         end;
      else
         do;
	  my_file_access_info.seg_0_num = ""b;
	  my_file_access_info.seg_nums (*) = 0;
	  file_access_table.e (file_access_table_idx) = my_file_access_info;
	  call REALLY_DELETE (dir_path, entry_name);
         end;

      go to JOIN_CLOSE;
%page;
/* DESCRIPTION of fm_delete_close_$close:
     
     close logically closes a file.  It decrements the count of openings
     for this process for this file, and if the count reaches 0, the file
     is put on a list of files to be actually closed at the end of the
     transaction.  This post-transaction action is not to be confused with a 
     post-commit action, which only happens if a transaction commits.
*/

close:
   entry (p_file_oid, p_code);

      p_code = 0;
      my_file_oid = p_file_oid;

      call cu_$level_get (saved_validation_level);
      on cleanup call FINISH ();
      current_validation_level = get_ring_ ();
      call cu_$level_set (current_validation_level);

      call GET_ACCESS_INFO (my_file_oid, addr (my_file_access_info), file_access_table_idx);

JOIN_CLOSE:
      p_file_oid = ""b;

/* There are three cases which determine the behavior of the
   closing, as follows:
   
   1) This process has the file open more times than it has
   closed the file. This is the case if the opens component of
   my_file_access_info is greater than 0 after it has been
   decremented for this closing.  In this case, the file cannot
   be really closed, so just record the new opens count.
   
   2) The opens have reached 0, but a transaction is in progress
   and this file is a file whose opening is recorded in the
   sys_pn_tbl (for use if the before_journal_manager_ must open
   the file by its uid).  In this case the actual closing should
   be delayed until after the transaction has completed.  Put
   the file_access_table entry on the thread of entries which
   require post-transaction activity.
   
   3) The opens count is done to 0 and either there is not
   current transaction or the file is not in the sys_pn_tbl.  In
   this case there is no reason to delay the closing, so really
   close the file.
*/

      my_file_access_info.opens = my_file_access_info.opens - 1;

      if my_file_access_info.opens > 0 & my_file_access_info.state.file_state ^= FILE_LOGICALLY_DELETED
      then file_access_table.e (file_access_table_idx) = my_file_access_info;
      else if my_file_access_info.pn_tbl_idx > 0 & dm_data_$current_txn_id ^= ""b
      then
         do;
	  do post_actions_thread_idx = file_access_table.h.post_transaction_actions
	       repeat (file_access_table.e (post_actions_thread_idx).state.entry_state)
	       while (post_actions_thread_idx > 0 & post_actions_thread_idx ^= file_access_table_idx);
	  end;

	  if file_access_table_idx ^= post_actions_thread_idx
						/* If it is not already on the list,		*/
	  then
	     do;					/* then add it.				*/
	        my_file_access_info.state.entry_state = file_access_table.h.post_transaction_actions;
	        file_access_table.e (file_access_table_idx) = my_file_access_info;
	        file_access_table.h.post_transaction_actions = file_access_table_idx;
	     end;
         end;
      else
         do;
	  if my_file_access_info.integrity_switches.transaction & my_file_access_info.seg_0_num ^= ""b
	       & dm_data_$current_txn_id ^= ""b
	  then
	     do;
	        call fm_put_$clear_flush_list (code);
	        if code ^= 0
	        then call ERROR_RETURN (code, NO_ERROR_MESSAGE);
	     end;

	  call REALLY_CLOSE (addr (my_file_access_info), file_access_table_idx);
         end;

      call cu_$level_set (saved_validation_level);

MAIN_RETURN:					/* Only point from which control returns to the caller */
      return;
%skip;
TRANSACTION_BJ_FULL_HANDLER:
/**** Cannot call bj_report_err_ to do this since BJ cannot be called recursively. */
/**** See also fm_(create_open_ put), which need to handle this condition. */
      revert transaction_bj_full_;
      my_signal_structure.length = size (my_signal_structure);
      my_signal_structure.version = 1;
      string (my_signal_structure.action_flags) = "0"b;
      call ioa_$rsnnl ("Deleting DM file UID ^w OID ^w ^a>^a", my_signal_structure.info_string, (0),
	 my_file_access_info.uid, my_file_oid, dir_path, entry_name);
      my_signal_structure.status_code = dm_error_$bj_journal_full;

      call transaction_manager_$abort_txn (dm_data_$current_txn_id, code);
      call signal_ ("transaction_bj_full_", null (), addr (my_signal_structure));
      call ERROR_RETURN (dm_error_$bj_journal_full, "");	/* should never get here */
%page;
ERROR_RETURN:
   proc (er_p_code, er_p_message);

      dcl	    er_p_code	       fixed bin (35);
      dcl	    er_p_message	       char (*);

      dcl	    dm_misc_util_$log      entry () options (variable);

      if er_p_message ^= ""
      then call dm_misc_util_$log (LOG_SV, er_p_code, MYNAME, "^a", er_p_message);

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

   end ERROR_RETURN;


FINISH:
   proc ();

      if global_msf_fcb_ptr ^= null
      then call msf_manager_$close (global_msf_fcb_ptr);
      if global_sys_pn_tbl_idx ^= -1
      then
         do;
	  on fm_sub_error_
	     begin;
	        go to FINISH_IGNORE_THIS_ERROR;
	     end;
	  call fm_sys_pn_tbl_util_$delete (global_file_uid, global_sys_pn_tbl_idx);
FINISH_IGNORE_THIS_ERROR:
	  revert fm_sub_error_;
         end;
      if saved_validation_level ^= -1
      then call cu_$level_set (saved_validation_level);

   end FINISH;
%page;
/*                DESCRIPTION OF fm_delete_close_$post_transaction :
     
          This entry is used to execute actions which cannot be done until
     after the point at which a transaction is completed, whether committed or
     aborted.  It is by contract run after file_manager_$undo or 
     file_manager_$postcommit_do.  Currently it closes all files which were
     closed during the transaction.  The files are left open until this point
     in case the transaction is aborted - then the before journal manager will
     need to have the files open to efficiently roll back modifications.
*/

post_transaction:
   entry ();

      call cu_$level_get (saved_validation_level);
      current_validation_level = get_ring_ ();
      on cleanup call cu_$level_set (saved_validation_level);
      call cu_$level_set (current_validation_level);

      do file_access_table_idx = file_access_table.h.post_transaction_actions
	 repeat (my_file_access_info.state.entry_state) while (file_access_table_idx > 0);

         my_file_access_info = file_access_table.e (file_access_table_idx);

         if my_file_access_info.opens = 0 | my_file_access_info.state.file_state = FILE_DOES_NOT_EXIST
         then call REALLY_CLOSE (addr (my_file_access_info), file_access_table_idx);
      end;

      file_access_table.h.post_transaction_actions = -1;

      call cu_$level_set (saved_validation_level);

      return;
%page;
FLUSH_MODIFIED_PAGES:
   proc ();

      dcl	    fmp_code	       fixed bin (35);

      fmp_code = 0;
      call fm_put_$clear_flush_list (fmp_code);
      if fmp_code ^= 0
      then call ERROR_RETURN (code, NO_ERROR_MESSAGE);
      else return;

   end FLUSH_MODIFIED_PAGES;
%page;
GET_PATH:
   proc (gp_p_seg_0_num, gp_p_dir, gp_p_entry);

      dcl	    gp_p_seg_0_num	       bit (18) unal parm;
      dcl	    gp_p_dir	       char (168) parm;
      dcl	    gp_p_entry	       char (32) parm;

      dcl	    gp_seg_0_ptr	       ptr;
      dcl	    gp_full_path	       char (168);
      dcl	    gp_code	       fixed bin (35);

      gp_code = 0;
      gp_seg_0_ptr = baseptr (gp_p_seg_0_num);
      call hcs_$fs_get_path_name (gp_seg_0_ptr, gp_full_path, (0), gp_p_entry, gp_code);
      if gp_code ^= 0
      then call ERROR_RETURN (gp_code,
	      " Unable to get path name of file with whose first component has segment number "
	      || char (decimal (gp_p_seg_0_num)) || ".");
      call expand_pathname_ (gp_full_path, gp_p_dir, gp_p_entry, gp_code);
      if gp_code ^= 0
      then call ERROR_RETURN (gp_code, gp_full_path);

      return;

   end GET_PATH;
%page;
GET_ACCESS_INFO:
   proc (gai_p_file_oid, gai_p_file_access_info_ptr, gai_p_file_access_table_idx);

      dcl	    gai_p_file_oid	       bit (36) aligned;
      dcl	    gai_p_file_access_info_ptr
			       ptr;
      dcl	    gai_p_file_access_table_idx
			       fixed bin;

      dcl	    1 gai_file_oid	       aligned like file_oid;

      unspec (gai_file_oid) = gai_p_file_oid;
      gai_p_file_access_table_idx = gai_file_oid.file_access_table_idx;

      if gai_p_file_access_table_idx < lbound (file_access_table.e, 1)
	 | gai_p_file_access_table_idx > file_access_table.h.last_entry
      then call ERROR_RETURN (dm_error_$bad_file_oid, NO_ERROR_MESSAGE);

      gai_p_file_access_info_ptr -> file_access_info = file_access_table.e (gai_p_file_access_table_idx);

      if gai_p_file_access_info_ptr -> file_access_info.opens = 0
      then call ERROR_RETURN (dm_error_$bad_file_oid, NO_ERROR_MESSAGE);

      if gai_file_oid.uid_tail ^= substr (gai_p_file_access_info_ptr -> file_access_info.uid, 19, 18)
      then call ERROR_RETURN (dm_error_$bad_file_oid,
	      "Opening id contains uid tail " || char (gai_file_oid.uid_tail) || "; file access info contains uid "
	      || char (gai_p_file_access_info_ptr -> file_access_info.uid));

      return;

   end GET_ACCESS_INFO;
%page;
LOCK_FILE:
   proc (lf_p_file_uid);

      dcl	    lf_p_file_uid	       bit (36) aligned parm;
      dcl	    lf_code	       fixed bin (35);

      lf_code = 0;
      call lock_manager_$lock (lf_p_file_uid, LOCK_ENTIRE_FILE, LOCK_MODE_X, 1e9, (0), lf_code);
      if lf_code ^= 0
      then call ERROR_RETURN (lf_code, NO_ERROR_MESSAGE);

      return;

   end LOCK_FILE;
%page;
LOGICAL_DELETE:
   proc (ld_p_file_uid, ld_p_sys_pn_tbl_index, ld_p_dir, ld_p_entry_name, ld_p_delete_name);

/* DESCRIPTION of LOGICAL_DELETE:

   This routine logically deletes a file, as follows:

   1) Add the special "delete-name" to the file.
   2) Change the name of the file in the sys_pn_tbl to the delete-name.
   3) Remove the real name from the file.

   This method ensures that the entry in sys_pn_tbl will always have
   a name which corresponds to an actual file. 
*/

      dcl	    ld_p_file_uid	       bit (36) aligned parm;
      dcl	    ld_p_sys_pn_tbl_index  fixed bin parm;
      dcl	    ld_p_dir	       char (168) parm;
      dcl	    ld_p_entry_name	       char (32) parm;
      dcl	    ld_p_delete_name       char (32) parm;

      dcl	    ld_code	       fixed bin (35);

      ld_code = 0;
      call hcs_$chname_file (ld_p_dir, ld_p_entry_name, "", ld_p_delete_name, ld_code);
      if ld_code ^= 0
      then call ERROR_RETURN (ld_code, " Logically deleting " || pathname_ (rtrim (ld_p_dir), ld_p_entry_name));
      call fm_sys_pn_tbl_util_$rename (ld_p_file_uid, ld_p_sys_pn_tbl_index, ld_p_delete_name);
      call hcs_$chname_file (ld_p_dir, ld_p_entry_name, ld_p_entry_name, "", ld_code);
      if ld_code ^= 0
      then call ERROR_RETURN (ld_code, " Logically deleting " || pathname_ (rtrim (ld_p_dir), ld_p_entry_name));

      return;

   end LOGICAL_DELETE;
%page;
REALLY_CLOSE:
   proc (rc_p_file_access_info_ptr, rc_p_file_access_table_idx);


      dcl	    rc_p_file_access_info_ptr
			       ptr;
      dcl	    rc_p_file_access_table_idx
			       fixed bin;

      unspec (file_access_table.e (rc_p_file_access_table_idx)) = ""b;

      if rc_p_file_access_table_idx = file_access_table.h.last_entry
      then
         do;
	  do file_access_table.h.last_entry = file_access_table.h.last_entry by -1
	       to lbound (file_access_table.e, 1)
	       while (file_access_table.e (file_access_table.h.last_entry).state.entry_state
	       = FILE_ACCESS_INFO_NOT_IN_USE);
	  end;
         end;

      if rc_p_file_access_info_ptr -> file_access_info.seg_0_num ^= ""b
      then
         do;
	  global_msf_fcb_ptr = rc_p_file_access_info_ptr -> file_access_info.msf_ptr;
	  rc_p_file_access_info_ptr -> file_access_info.msf_ptr = null ();
	  rc_p_file_access_info_ptr -> file_access_info.seg_0_num = ""b;
	  unspec (rc_p_file_access_info_ptr -> file_access_info.seg_nums) = ""b;

	  if rc_p_file_access_info_ptr -> file_access_info.pn_tbl_idx > 0
	       | rc_p_file_access_info_ptr -> file_access_info.state.file_state = FILE_DOES_NOT_EXIST
	  then
	     do;
	        global_file_uid = rc_p_file_access_info_ptr -> file_access_info.uid;
	        global_sys_pn_tbl_idx = rc_p_file_access_info_ptr -> file_access_info.pn_tbl_idx;
	        rc_p_file_access_info_ptr -> file_access_info.pn_tbl_idx = -1;

	        if rc_p_file_access_info_ptr -> file_access_info.state.file_state = FILE_DOES_NOT_EXIST
	        then call fm_sys_pn_tbl_util_$redelete_force (global_file_uid, global_sys_pn_tbl_idx);
	        else call fm_sys_pn_tbl_util_$delete (global_file_uid, global_sys_pn_tbl_idx);
	        global_sys_pn_tbl_idx = -1;		/* mark as done */
	     end;

	  if global_msf_fcb_ptr ^= null
	  then
	     do;
	        call msf_manager_$close (global_msf_fcb_ptr);
	        global_msf_fcb_ptr = null ();		/* mark as done */
	     end;
         end;

      return;

   end REALLY_CLOSE;
%page;
REALLY_DELETE:
   proc (rd_p_dir_path, rd_p_entry_name);

/* DESCRIPTION fo REALLY_DELETE:
   Physically deletes a file from the Multics file system.  This
   entails first setting the safety switch to off, as files are
   created with the safety switch on, then deleting the contents of
   the file subtree (i.e., the components of the file), and finally
   deleting the file directory itself.  

   This routine is only called for files which do not have rollback
   protection.
   
   Variables declared in this subroutine are prefixed with rd_ to
   indicate that they are local to the subroutine.  Parameters ar
e   further prefixed with a p_, making the full prefix for parameters
   rd_p_.
*/

      dcl	    rd_p_dir_path	       char (168);
      dcl	    rd_p_entry_name	       char (32);

      call hcs_$set_safety_sw (rd_p_dir_path, rd_p_entry_name, "0"b, code);
      if code ^= 0
      then call ERROR_RETURN (code,
	      " Unable to set the safety switch to off for " || pathname_ (rtrim (rd_p_dir_path), rd_p_entry_name)
	      || ".");

      call hcs_$del_dir_tree (rd_p_dir_path, rd_p_entry_name, code);
      if code ^= 0
      then call ERROR_RETURN (code, pathname_ (rtrim (rd_p_dir_path), rd_p_entry_name));

      call hcs_$delentry_file (rd_p_dir_path, rd_p_entry_name, code);
      if code ^= 0
      then call ERROR_RETURN (code, pathname_ (rtrim (rd_p_dir_path), rd_p_entry_name));

      return;

   end REALLY_DELETE;
%page;
VERIFY_ACCESS_TO_DELETE_FILE:
   proc (va_p_dir, va_p_entry, va_p_write_bracket, va_p_validation_level);

      dcl	    va_p_dir	       char (168) parm;
      dcl	    va_p_entry	       char (32) parm;
      dcl	    va_p_write_bracket     fixed bin (3) uns unal parm;
      dcl	    va_p_validation_level  fixed bin parm;

      dcl	    va_code	       fixed bin (35);
      dcl	    va_containing_dir_dir  char (168);
      dcl	    va_containing_dir_entry
			       char (32);
      dcl	    va_modes	       fixed bin (5);

      if va_p_write_bracket < va_p_validation_level
      then call ERROR_RETURN (error_table_$no_w_permission, " Deleting " || pathname_ (rtrim (va_p_dir), va_p_entry));
      va_code = 0;
      call expand_pathname_ (va_p_dir, va_containing_dir_dir, va_containing_dir_entry, va_code);
      if va_code ^= 0
      then call ERROR_RETURN (va_code, va_p_dir);
      call hcs_$get_user_effmode (va_containing_dir_dir, va_containing_dir_entry, "", va_p_validation_level, va_modes,
	 va_code);
      if va_code ^= 0
      then call ERROR_RETURN (va_code, va_p_dir);
      if va_modes ^= SM_ACCESS_BIN & va_modes ^= SMA_ACCESS_BIN
      then call ERROR_RETURN (error_table_$insufficient_access, "Deleting " || pathname_ (rtrim (va_p_dir), va_p_entry));

      return;

   end VERIFY_ACCESS_TO_DELETE_FILE;


VERIFY_TRANSACTION_STATE:
   proc ();

      if dm_data_$current_txn_id = NO_TRANSACTION_IN_PROGRESS
      then call ERROR_RETURN (dm_error_$no_current_transaction, NO_ERROR_MESSAGE);

      return;

   end VERIFY_TRANSACTION_STATE;
%page;
WRITE_POSTCOMMIT_HANDLER_FOR_DELETE:
   proc (wp_p_file_uid, wp_p_file_oid, wp_p_sys_pn_tbl_index, wp_p_dir, wp_p_delete_name);

      dcl	    wp_p_file_uid	       bit (36) aligned parm;
      dcl	    wp_p_file_oid	       bit (36) aligned parm;
      dcl	    wp_p_sys_pn_tbl_index  fixed bin parm;
      dcl	    wp_p_dir	       char (168) parm;
      dcl	    wp_p_delete_name       char (32) parm;

      dcl	    1 wp_delete_postcommit_info
			       aligned like delete_postcommit_info;
      dcl	    wp_code	       fixed bin (35);

      wp_delete_postcommit_info.header.version = POSTCOMMIT_INFO_VERSION_1;
      wp_delete_postcommit_info.header.operation = DELETE_POSTCOMMIT_OPERATION;
      wp_delete_postcommit_info.sys_pn_tbl_index = wp_p_sys_pn_tbl_index;
      wp_delete_postcommit_info.dir_path = wp_p_dir;
      wp_delete_postcommit_info.file_name = wp_p_delete_name;
      wp_code = 0;
      call before_journal_manager_$write_fm_postcommit_handler (wp_p_file_uid, wp_p_file_oid,
	 addr (wp_delete_postcommit_info), size (wp_delete_postcommit_info) * BYTES_PER_WORD, wp_code);
      if wp_code ^= 0
      then call ERROR_RETURN (wp_code,
	      " Writing postcommit handler for " || pathname_ (rtrim (wp_p_dir), wp_p_delete_name));

      return;
   end WRITE_POSTCOMMIT_HANDLER_FOR_DELETE;
%page;
WRITE_ROLLBACK_HANDLER_FOR_DELETE:
   proc (wr_p_file_uid, wr_p_file_oid, wr_p_sys_pn_tbl_index, wr_p_dir, wr_p_entry_name, wr_p_delete_name);

      dcl	    wr_p_file_uid	       bit (36) aligned parm;
      dcl	    wr_p_file_oid	       bit (36) aligned parm;
      dcl	    wr_p_sys_pn_tbl_index  fixed bin parm;
      dcl	    wr_p_dir	       char (168) parm;
      dcl	    wr_p_entry_name	       char (32) parm;
      dcl	    wr_p_delete_name       char (32) parm;

      dcl	    wr_code	       fixed bin (35);
      dcl	    wr_time_stamp	       fixed bin (71);	/* dummy variable */
      dcl	    1 wr_delete_rollback_info
			       aligned like delete_rollback_info;

      wr_code = 0;
      wr_delete_rollback_info.header.version = ROLLBACK_INFO_VERSION_1;
      wr_delete_rollback_info.header.operation = DELETE_ROLLBACK_OPERATION;
      wr_delete_rollback_info.sys_pn_tbl_index = wr_p_sys_pn_tbl_index;
      wr_delete_rollback_info.dir_path = wr_p_dir;
      wr_delete_rollback_info.predelete_name = wr_p_entry_name;
      wr_delete_rollback_info.postdelete_name = wr_p_delete_name;

      call before_journal_manager_$write_fm_rollback_handler (wr_p_file_uid, wr_p_file_oid,
	 addr (wr_delete_rollback_info), size (delete_rollback_info) * BYTES_PER_WORD, NO_CI_IS_HELD, wr_time_stamp,
	 wr_code);
      if wr_code ^= 0
      then call ERROR_RETURN (wr_code,
	      " Writing delete rollback handler for " || pathname_ (rtrim (wr_p_dir), wr_p_entry_name));

      return;

   end WRITE_ROLLBACK_HANDLER_FOR_DELETE;
%page;
%include dm_fm_file_oid;
%page;
%include dm_fm_file_access_info;
%page;
%include dm_fm_file_access_tbl;
%page;
%include dm_fm_postcommit_info;
%page;
%include dm_fm_rollback_info;
%page;
%include dm_lock_modes;
%page;
%include dm_log_sv_codes;
%page;
%include access_mode_values;
%page;
%include condition_info_header;

   end fm_delete_close_$delete_close;




		    fm_do_.pl1                      04/02/87  1316.2rew 04/02/87  1258.8      271728



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



/****^  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, added code to check the version (not *another* structure
     version check!?!) of the key_count_array and make sure that we really
     have a key_count_array in case it has moved on us.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION:
   
        This procedure implements the "do" primitives of file_manager_:
   postcommit_do and undo.
   
   $undo: this entry rolls back an operation.  It implements
   file_manager_$undo, called by before_journal_manager_ while rolling
   back a transaction.  The information passed to this entry is that found
   in a rollback handler in a before journal.  One of two operations can
   be undone: file creation and file deletion.
   
   $postcommit_do: this entry completes an operation which
   started in a transaction and which, because of integrity constraints,
   cannot be completed until after the transaction commits.  This entry
   implements file_manager_$postcommit_do and is called by
   before_journal_manager_ while committing a transaction.  The
   information passed to this entry is that found in a postcommit handler
   in a before journal.  Only one operation needs to be completed after
   the transaction commits, file deletion.
*/

/* HISTORY:

Written by Matthew C. Pierret, 10/17/84.
Modified:
12/10/84 by Matthew Pierret:  Changed to set validation level.
12/17/84 by Matthew Pierret:  Changed to set the file state in the
            file_access_info.
01/10/85 by Matthew C. Pierret:  Changed UNDO_DELETE to not check for a match
            between the given file uid and the file system uid.  It is not
            necessarily incorrect for these two values to be different.
02/28/85 by Matthew C. Pierret:  Changed UNDO_CREATE and DO_DELETE to delete
            the file before removing the entry in sys_pn_tbl.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/11/85 by Matthew C. Pierret:  Added the increments postcommit handler.
03/11/85 by R. Michael Tague:  Completed implementation of the increments
	  postcommit handler.
04/22/85 by R. Michael Tague:  Changed to use $internal_get_ci_ptr instead of
	  $get_ci_ptr to get around the problem of updating increment info
	  on files that have been closed.  This returns a pointer even if the
	  file is closed.
04/25/85 by Matthew C. Pierret:  Changed UNDO_CREATE and DO_DELETE to not
            remove entries from sys_pn_tbl.  This guarantees that even if
            rollbacks are repeated, the file uid in each active before journal
            record can also be found in sys_pn_tbl.  The sys_pn_tbl entries
            are now deleted during the post-transaction phase of the
            commit/abort.  SET_ENTRY_STATE is used to be sure that the file is
            scheduled for post-transaction actions.
05/03/85 by Matthew Pierret:  Changed UNDO_CREATE and DO_DELETE to discard
            modified pages for the file to be deleted from the list of modified
            pages maintained for flushing.
*/

/* format: style2,ind3,ll79,comcol50,^indprocbody,^indnoniterdo,indnoniterend */
/* format: ^indblkcom,indcomtxt */

fm_do_$undo:
   proc (p_file_uid, p_file_oid, p_rollback_info_ptr, p_rollback_info_length,
        p_code);

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

   dcl	 p_file_uid	    bit (36) aligned;
				         /* Unique id of file. */
   dcl	 p_file_oid	    bit (36) aligned;
				         /* Opening id of file */
   dcl	 p_rollback_info_ptr    ptr;	         /* points to rollback info. */
   dcl	 p_rollback_info_length fixed bin;     /* byte length of rollback_info */
   dcl	 p_postcommit_info_ptr  ptr;	         /* points to postcommit info. */
   dcl	 p_postcommit_info_length
			    fixed bin;     /* byte length of postcommit_info */
   dcl	 p_code		    fixed bin (35);

/* Automatic */

   dcl	 my_file_oid	    bit (36) aligned init (""b);
   dcl	 my_file_uid	    bit (36) aligned init (""b);
   dcl	 saved_validation_level fixed bin init (0);

/* Based */
/* Builtin */

   dcl	 (addbitno, addr, lbound, null, rtrim, stacq, substr)
			    builtin;

/* Condition */

   dcl	 cleanup		    condition;

/* Constant */

   dcl	 myname		    init ("fm_do_") 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	 MAX_UPDATE_ATTEMPTS    fixed bin (35) init (10000) internal
			    static options (constant);
   dcl	 (
	 POSTCOMMIT_ACTION	    init ("complete"),
	 UNDO_ACTION	    init ("undo")
	 )		    char (8) internal static options (constant);

/* Entry */

   dcl	 cu_$level_get	    entry (fixed bin);
   dcl	 cu_$level_set	    entry (fixed bin);
   dcl	 dm_misc_util_$log	    entry options (variable);
   dcl	 get_ring_	    entry () returns (fixed bin (3));
   dcl	 fm_get_$internal_get_ci_ptr
			    entry (bit (36) aligned,
			    fixed bin (27) aligned, ptr, fixed bin (35));
   dcl	 fm_put_$discard_file_flush_list
			    entry (bit (36) aligned, fixed bin (35));
   dcl	 fm_sys_pn_tbl_util_$rename
			    entry (bit (36) aligned, fixed bin,
			    char (32));
   dcl	 fm_sys_pn_tbl_util_$redelete_force
			    entry (bit (36) aligned, fixed bin);
   dcl	 hcs_$chname_file	    entry (char (*), char (*), char (*),
			    char (*), fixed bin (35));
   dcl	 hcs_$del_dir_tree	    entry (char (*), char (*), fixed bin (35));
   dcl	 hcs_$delentry_file	    entry (char (*), char (*), fixed bin (35));
   dcl	 hcs_$set_safety_sw	    entry (char (*), char (*), bit (1),
			    fixed bin (35));
   dcl	 ioa_$rsnnl	    entry () options (variable);
   dcl	 pathname_	    entry (char (*), char (*))
			    returns (char (168));

/* External */

   dcl	 dm_error_$bad_file_oid fixed bin (35) ext;
   dcl	 dm_error_$fm_bad_postcommit_operation
			    fixed bin (35) ext;
   dcl	 dm_error_$fm_bad_undo_op
			    fixed bin (35) ext;
   dcl	 dm_error_$fm_word_increment_error
			    fixed bin (35) ext;
   dcl	 dm_error_$incr_array_not_found
			    fixed bin (35) ext;
   dcl	 error_table_$segnamedup
			    fixed bin (35) ext;
   dcl	 error_table_$noentry   fixed bin (35) ext;
   dcl	 error_table_$unimplemented_version
			    fixed bin (35) ext;

/* END OF DECLARATIONS */
%page;
/* undo: entry (p_file_uid, p_file_oid, p_rollback_info_ptr, p_rollback_info_length, p_code); */

/* DESCRIPTION:

   This entry implements file_manager_$undo.  It rolls back the
   creation and deletion of files.  The undo algorithm must be
   idempotent so that it can be interrupted and restarted without
   causing an error.  The algorithms used for each of creation
   and deletion are described in the subroutine which implements
   the algorithm (UNDO_CREATE and UNDO_DELETE).

   The create_rollback_info and delete_rollback_info are of fixed sizes,
   so p_rollback_info_length is presently not used.
*/

   p_code = 0;
   my_file_uid = p_file_uid;
   my_file_oid = p_file_oid;
   rollback_info_ptr = p_rollback_info_ptr;
   if rollback_info_header.version ^= ROLLBACK_INFO_VERSION_1
   then call ERROR_RETURN (error_table_$unimplemented_version,
	   VERSION_ERROR_MESSAGE (ROLLBACK_INFO_VERSION_1,
	   rollback_info_header.version, "rollback_info"));

   call cu_$level_get (saved_validation_level);
   on cleanup call RESET_LEVEL ();

   if rollback_info_header.operation = DELETE_ROLLBACK_OPERATION
   then call UNDO_DELETE (my_file_uid, my_file_oid, rollback_info_ptr);
   else if rollback_info_header.operation = CREATE_ROLLBACK_OPERATION
   then call UNDO_CREATE (my_file_uid, my_file_oid, rollback_info_ptr);
   else call ERROR_RETURN (dm_error_$fm_bad_undo_op,
	   rollback_info_header.operation);

   call RESET_LEVEL ();

   call RETURN ();
%page;
postcommit_do:
   entry (p_file_uid, p_file_oid, p_postcommit_info_ptr,
        p_postcommit_info_length, p_code);

/* DESCRIPTION:

   This entry implement file_manager_$postcommit_do.  It performs
   actions which cannot be done during a transaction, but must wait
   until the transaction has committed.  Currently there are two
   such sets of actions, those being for file deletion and for
   incrementing an array of words.  File deletion is delayed to
   save us from having to make a before image of each control interval
   in the file.  Incrementing an array of words is specifically for
   handling the index_mnager_'s key_count_array, which is too heavily hit
   to be exclusively locked.

   The algorithms used are described in the DO_DELETE and DO_INCREMENT
   subroutines.  The delete_postcommit_info is fixed size, so the
   p_postcommit_info_length is not used presently.
*/

   p_code = 0;
   my_file_uid = p_file_uid;
   my_file_oid = p_file_oid;
   postcommit_info_ptr = p_postcommit_info_ptr;
   if postcommit_info_header.version ^= POSTCOMMIT_INFO_VERSION_1
   then call ERROR_RETURN (error_table_$unimplemented_version,
	   VERSION_ERROR_MESSAGE (POSTCOMMIT_INFO_VERSION_1,
	   postcommit_info_header.version, "postcommit_info"));

   call cu_$level_get (saved_validation_level);
   on cleanup call RESET_LEVEL ();

   if postcommit_info_header.operation = DELETE_POSTCOMMIT_OPERATION
   then call DO_DELETE (my_file_uid, my_file_oid, postcommit_info_ptr);
   else if postcommit_info_header.operation = INCREMENT_POSTCOMMIT_OPERATION
   then call DO_INCREMENT (my_file_uid, my_file_oid, postcommit_info_ptr);
   else call ERROR_RETURN (dm_error_$fm_bad_postcommit_operation,
	   postcommit_info_header.operation);

   call RESET_LEVEL ();

   call RETURN ();
%page;
MAIN_RETURN:
   return;

RETURN:
   proc ();
   p_code = 0;
   go to MAIN_RETURN;
   end RETURN;

ERROR_RETURN:
   proc (er_p_code, er_p_message);

   dcl	 er_p_code	    fixed bin (35);
   dcl	 er_p_message	    char (*);

   p_code = er_p_code;
   call LOG_ERROR (er_p_code, er_p_message);
   call RESET_LEVEL ();
   go to MAIN_RETURN;
   end ERROR_RETURN;



LOG_ERROR:
   proc (le_p_code, le_p_message);

   dcl	 le_p_code	    fixed bin (35);
   dcl	 le_p_message	    char (*);

   call dm_misc_util_$log (LOG_SV, le_p_code, myname, le_p_message);
   return;
   end LOG_ERROR;

ACTION_ERROR_MESSAGE:
   proc (aem_p_action, aem_p_operation, aem_p_file) returns (char (*));

   dcl	 aem_p_action	    char (8);
   dcl	 aem_p_operation	    char (8);
   dcl	 aem_p_file	    char (168);
   dcl	 aem_return_string	    char (256);
   dcl	 aem_return_length	    fixed bin (21);

   call ioa_$rsnnl ("Unable to ^a the ^a of ^a.", aem_return_string,
        aem_return_length, aem_p_action, aem_p_operation, aem_p_file);
   return (substr (aem_return_string, 1, aem_return_length));

   end ACTION_ERROR_MESSAGE;

VERSION_ERROR_MESSAGE:
   proc (vem_p_expected_version, vem_p_given_version, vem_p_structure)
        returns (char (*));

   dcl	 vem_p_expected_version char (8);
   dcl	 vem_p_given_version    char (8);
   dcl	 vem_p_structure	    char (*);
   dcl	 vem_return_string	    char (256);
   dcl	 vem_return_length	    fixed bin (21);

   call ioa_$rsnnl ("Expected version ^a of ^a; received ^a.",
        vem_return_string, vem_return_length, vem_p_expected_version,
        vem_p_structure, vem_p_given_version);
   return (substr (vem_return_string, 1, vem_return_length));

   end VERSION_ERROR_MESSAGE;

RESET_LEVEL:
   proc ();

   if saved_validation_level > 0
   then call cu_$level_set (saved_validation_level);

   end RESET_LEVEL;
%page;
UNDO_CREATE:
   proc (uc_p_file_uid, uc_p_file_oid, uc_p_create_rollback_info_ptr);

/* DESCRIPTION of UNDO_CREATE:

   The algorithm to undo creation is:

   1) Discard entries for this file in the list of modified pages
   for this transaction.  We don't want the segment numbers in that list
   re-used while flushing.
   2) If uc_p_file_oid is non-null, meaning that the undo is being
   performed by the process which created the transaction, mark
   the per-process file access info to have a state of
   FILE_DOES_NOT_EXIST.
   3) Delete the file.
   4) If uc_p_file_oid is non-null, mark the file access info as
   requiring post-transaction actions.  In the post-transaction
   phase of the abort, the file's uid will be removed from the
   uid-pathname table (sys_pn_tbl).  This action is delayed so
   that if the abort is repeated, the uid will still be in sys_pn_tbl.
*/

   dcl	 uc_p_file_uid	    bit (36) aligned parameter;
   dcl	 uc_p_file_oid	    bit (36) aligned parameter;
   dcl	 uc_p_create_rollback_info_ptr
			    ptr parameter;
   dcl	 uc_sys_pn_tbl_index    fixed bin;
   dcl	 uc_dir_path	    char (168);
   dcl	 uc_file_name	    char (32);
   dcl	 uc_code		    fixed bin (35);

   uc_sys_pn_tbl_index =
        uc_p_create_rollback_info_ptr -> create_rollback_info.sys_pn_tbl_index;
   uc_dir_path =
        uc_p_create_rollback_info_ptr -> create_rollback_info.dir_path;
   uc_file_name =
        uc_p_create_rollback_info_ptr -> create_rollback_info.file_name;

   call cu_$level_set ((get_ring_ ()));


   call SET_FILE_STATE (uc_p_file_oid, FILE_DOES_NOT_EXIST);

   uc_code = 0;
   call fm_put_$discard_file_flush_list (uc_p_file_uid, uc_code);
   if uc_code ^= 0
   then call ERROR_RETURN (uc_code,
	   ACTION_ERROR_MESSAGE (UNDO_ACTION, CREATE_ROLLBACK_OPERATION,
	   pathname_ (rtrim (uc_dir_path), uc_file_name)));
   call hcs_$set_safety_sw (uc_dir_path, uc_file_name, "0"b, uc_code);
   if uc_code ^= 0 & uc_code ^= error_table_$noentry
   then call ERROR_RETURN (uc_code,
	   ACTION_ERROR_MESSAGE (UNDO_ACTION, CREATE_ROLLBACK_OPERATION,
	   pathname_ (rtrim (uc_dir_path), uc_file_name)));
   if uc_code ^= error_table_$noentry
   then
      do;
      call hcs_$del_dir_tree (uc_dir_path, uc_file_name, uc_code);
      if uc_code ^= 0
      then call ERROR_RETURN (uc_code,
	      ACTION_ERROR_MESSAGE (UNDO_ACTION, CREATE_ROLLBACK_OPERATION,
	      pathname_ (rtrim (uc_dir_path), uc_file_name)));
      call hcs_$delentry_file (uc_dir_path, uc_file_name, uc_code);
      if uc_code ^= 0
      then call ERROR_RETURN (uc_code,
	      ACTION_ERROR_MESSAGE (UNDO_ACTION, CREATE_ROLLBACK_OPERATION,
	      pathname_ (rtrim (uc_dir_path), uc_file_name)));
      end;

   call SET_ENTRY_STATE (uc_p_file_oid);

   return;

   end UNDO_CREATE;
%page;
UNDO_DELETE:
   proc (ud_p_file_uid, ud_p_file_oid, ud_p_delete_rollback_info_ptr);

/* DESCRIPTION of UNDO_DELETE:

   The algorithm to undo deletion is:

   0) The initial state should have a file with a delete-name
   and an entry in sys_pn_tbl with the delete-name, or any
   intermediate state during this algorithm.
   1) Add the predelete-name back to the file. If no error
   occurs, or an error occurs because then name is already on
   the entry or the entry does not exist, continue.
   Otherwise, a real error has occured.
   2) Change the file name in the sys_pn_tbl from the delete-name
   to the predelete-name.  Whether this step has been done once
   before or not, an entry must exist in the sys_pn_tbl, so
   a real error occurs if this step fails. fm_sys_pn_tbl_util_$rename
   does not return if an error occurs (it signals fm_sub_error_).
   3) Remove the delete-name from the file.  If the file is
   not found, assume we have already done this step.  Any other
   error is a real error.
*/

   dcl	 ud_p_file_uid	    bit (36) aligned parameter;
   dcl	 ud_p_file_oid	    bit (36) aligned parameter;
   dcl	 ud_p_delete_rollback_info_ptr
			    ptr parameter;
   dcl	 ud_sys_pn_tbl_index    fixed bin;
   dcl	 ud_dir_path	    char (168);
   dcl	 ud_predelete_name	    char (32);
   dcl	 ud_postdelete_name	    char (32);
   dcl	 ud_postdelete_path	    char (168);
   dcl	 ud_code		    fixed bin (35);

   ud_sys_pn_tbl_index =
        ud_p_delete_rollback_info_ptr -> delete_rollback_info.sys_pn_tbl_index;
   ud_dir_path =
        ud_p_delete_rollback_info_ptr -> delete_rollback_info.dir_path;
   ud_predelete_name =
        ud_p_delete_rollback_info_ptr -> delete_rollback_info.predelete_name;
   ud_postdelete_name =
        ud_p_delete_rollback_info_ptr -> delete_rollback_info.postdelete_name;

   call cu_$level_set ((get_ring_ ()));
   ud_postdelete_path = pathname_ (ud_dir_path, ud_postdelete_name);
   ud_code = 0;

   call hcs_$chname_file (ud_dir_path, ud_postdelete_name, "",
        ud_predelete_name, ud_code);
   if ud_code ^= 0 & ud_code ^= error_table_$noentry
        & ud_code ^= error_table_$segnamedup
   then call ERROR_RETURN (ud_code,
	   ACTION_ERROR_MESSAGE (UNDO_ACTION, DELETE_ROLLBACK_OPERATION,
	   pathname_ (rtrim (ud_dir_path), ud_postdelete_name)));

   call fm_sys_pn_tbl_util_$rename (ud_p_file_uid, ud_sys_pn_tbl_index,
        ud_predelete_name);

   call SET_FILE_STATE (ud_p_file_oid, FILE_EXISTS);

   call hcs_$chname_file (ud_dir_path, ud_postdelete_name, ud_postdelete_name,
        "", ud_code);
   if ud_code ^= 0 & ud_code ^= error_table_$noentry
   then call ERROR_RETURN (ud_code,
	   ACTION_ERROR_MESSAGE (UNDO_ACTION, DELETE_ROLLBACK_OPERATION,
	   pathname_ (rtrim (ud_dir_path), ud_postdelete_name)));

   return;

   end UNDO_DELETE;
%page;
DO_DELETE:
   proc (dd_p_file_uid, dd_p_file_oid, dd_p_delete_postcommit_info_ptr);

/* DESCRIPTION of DO_DELETE:

   This routine does the actual deletion of an already logically deleted file.
   The algorithm to actually delete a file is:

   0) Normally the file will have a unique name and will have an
   entry in the sys_pn_tbl with that name.
   1) Discard entries for this file in the list of modified pages
   for this transaction.  We don't want the segment numbers in that list
   re-used while flushing.
   2) Delete the file.
   3) If dd_p_file_oid is non-null, meaning that the process which
   created this transaction is performing this postcommit_do,
   mark the per-process file access info to state that the file is
   deleted.
   4) The file's entry is sys_pn_tbl must be removed, but cannot until
   after the transaction commits.  If dd_p_file_oid is non-null, then
   it was scheduled for such post-transaction actions when the file
   was logically deleted.  If dd_p_file_oid is null, then we can't
   schedule a post-transaction action.  The entry will stay in sys_pn_tbl
   until it is salvaged by fm_sys_pn_tbl_util_$insert.
*/

   dcl	 dd_p_file_uid	    bit (36) aligned parm;
   dcl	 dd_p_file_oid	    bit (36) aligned parm;
   dcl	 dd_p_delete_postcommit_info_ptr
			    ptr parameter;
   dcl	 dd_sys_pn_tbl_index    fixed bin;
   dcl	 dd_dir_path	    char (168);
   dcl	 dd_file_name	    char (32);
   dcl	 dd_code		    fixed bin (35);

   dd_sys_pn_tbl_index =
        dd_p_delete_postcommit_info_ptr
        -> delete_postcommit_info.sys_pn_tbl_index;
   dd_dir_path =
        dd_p_delete_postcommit_info_ptr -> delete_postcommit_info.dir_path;
   dd_file_name =
        dd_p_delete_postcommit_info_ptr -> delete_postcommit_info.file_name;

   call cu_$level_set ((get_ring_ ()));


   dd_code = 0;
   call fm_put_$discard_file_flush_list (dd_p_file_uid, dd_code);
   if dd_code ^= 0
   then call ERROR_RETURN (dd_code,
	   ACTION_ERROR_MESSAGE (POSTCOMMIT_ACTION,
	   DELETE_POSTCOMMIT_OPERATION,
	   pathname_ (dd_dir_path, dd_file_name)));
   call hcs_$set_safety_sw (dd_dir_path, dd_file_name, "0"b, dd_code);
   if dd_code ^= 0 & dd_code ^= error_table_$noentry
   then call ERROR_RETURN (dd_code,
	   ACTION_ERROR_MESSAGE (POSTCOMMIT_ACTION,
	   DELETE_POSTCOMMIT_OPERATION,
	   pathname_ (rtrim (dd_dir_path), dd_file_name)));
   if dd_code ^= error_table_$noentry
   then
      do;
      call hcs_$del_dir_tree (dd_dir_path, dd_file_name, dd_code);
      if dd_code ^= 0
      then call ERROR_RETURN (dd_code,
	      ACTION_ERROR_MESSAGE (POSTCOMMIT_ACTION,
	      DELETE_POSTCOMMIT_OPERATION,
	      pathname_ (rtrim (dd_dir_path), dd_file_name)));
      call hcs_$delentry_file (dd_dir_path, dd_file_name, dd_code);
      if dd_code ^= 0
      then call ERROR_RETURN (dd_code,
	      ACTION_ERROR_MESSAGE (POSTCOMMIT_ACTION,
	      DELETE_POSTCOMMIT_OPERATION,
	      pathname_ (rtrim (dd_dir_path), dd_file_name)));
      end;

   call SET_FILE_STATE (dd_p_file_oid, FILE_DOES_NOT_EXIST);

   call SET_ENTRY_STATE (dd_p_file_oid);

   return;

   end DO_DELETE;
%page;
DO_INCREMENT:
   proc (di_p_file_uid, di_p_file_oid, di_p_increment_postcommit_info_ptr);

/* DESCRIPTION of DO_INCREMENT

   This procedure updates an array of words with increment values pointed to by
   a pointer in the increment postcommit handler.  Since the increment values
   are stored per process, if this is not the process that wrote the postcommit
   handler then, we cannot update the file increments.

   The accurate updating of the file values is done using the stacq builtin.
   Up to MAX_UPDATE_ATTEMPTS attempts at updating the file value using stacq
   are made before we give up trying.  di_file_word is the word in the DM file
   to be updated, di_old_file_word is the local copy of this word,
   di_file_word_increment is the value to be added to the local copy, and
   di_new_file_word is the local variable containing the sum of the old value
   and the increment.  The stacq builtin replaces the value in the DM file with
   the new value if the file value has not changed since it was copied to the
   local old value.
*/

   dcl	 di_p_file_uid	    bit (36) aligned parameter;
   dcl	 di_p_file_oid	    bit (36) aligned parameter;
   dcl	 di_p_increment_postcommit_info_ptr
			    ptr parameter;

   dcl	 1 my_inc_postcommit_info
			    aligned like increment_postcommit_info;
   dcl	 di_increment_ptr	    ptr;
   dcl	 di_number_of_words	    fixed bin (35);
   dcl	 di_ci_number	    fixed bin (27);
   dcl	 di_offset_in_bytes	    fixed bin (35);

   dcl	 di_increment_index	    fixed bin (35);
   dcl	 di_update_attempts	    fixed bin (35);
   dcl	 di_increment_word_ptr  ptr;
   dcl	 di_file_word	    fixed bin (35) aligned
			    based (di_increment_word_ptr);
   dcl	 di_old_file_word	    fixed bin (35) aligned;
   dcl	 di_new_file_word	    fixed bin (35) aligned;
   dcl	 di_file_word_increment fixed bin (35) aligned
			    based (di_increment_ptr);

   dcl	 di_file_state	    fixed bin;
   dcl	 di_code		    fixed bin (35);

   if di_p_file_oid = ""b
   then return;

   call GET_FILE_STATE (di_p_file_oid, di_file_state);
   if di_file_state = FILE_DOES_NOT_EXIST
   then return;

   call cu_$level_set ((get_ring_ ()));

   unspec (my_inc_postcommit_info) =
        unspec (di_p_increment_postcommit_info_ptr
        -> increment_postcommit_info);
   di_increment_ptr = my_inc_postcommit_info.increments_ptr;
   di_number_of_words = my_inc_postcommit_info.number_of_words;
   di_ci_number = my_inc_postcommit_info.ci_number;
   di_offset_in_bytes = my_inc_postcommit_info.offset_in_bytes;

   call fm_get_$internal_get_ci_ptr (di_p_file_oid, di_ci_number,
        di_increment_word_ptr, di_code);
   if di_code ^= 0
   then call ERROR_RETURN (di_code,
	   " Cannot get CI pointer to update increment words.");

   di_increment_word_ptr =
        addbitno (di_increment_word_ptr, di_offset_in_bytes * BITS_PER_BYTE);

/* there should be a key_count_array here */
   key_count_array_ptr = addcharno(di_increment_word_ptr,-KEY_COUNT_OFFSET_IN_CHARACTERS);
   if key_count_array.version ^= KEY_COUNT_ARRAY_VERSION_2 then 
        call ERROR_RETURN (dm_error_$incr_array_not_found, "");

   do di_increment_index = 1 to di_number_of_words;	
      di_old_file_word = di_file_word;
      di_new_file_word = di_old_file_word + di_file_word_increment;
      do di_update_attempts = 1 to MAX_UPDATE_ATTEMPTS
	 while (
	 ^
	 stacq (unspec (di_file_word), unspec (di_new_file_word),
	 unspec (di_old_file_word)));
         di_old_file_word = di_file_word;
         di_new_file_word = di_old_file_word + di_file_word_increment;
      end;
      if di_update_attempts > MAX_UPDATE_ATTEMPTS
      then call ERROR_RETURN (dm_error_$fm_word_increment_error,
	      " Unable to increment DM file word after several tries.");
      di_increment_ptr = addbitno (di_increment_ptr, BITS_PER_WORD);
      di_increment_word_ptr = addbitno (di_increment_word_ptr, BITS_PER_WORD);
   end;
   return;

   end DO_INCREMENT;
%page;
GET_FILE_STATE:
   proc (gfs_p_file_oid, gfs_p_file_state);

/* DESCRIPTION of GET_FILE_STATE:

   This routine returns the file_state of the file from the process'
   file_access_info entry in the file_access_table.

*/

   dcl	 gfs_p_file_oid	    bit (36) aligned parameter;
   dcl	 gfs_p_file_state	    fixed bin parameter;

   dcl	 gfs_file_access_table_idx
			    fixed bin;
   dcl	 gfs_file_uid_tail	    bit (18);

   gfs_file_access_table_idx =
        addr (gfs_p_file_oid) -> file_oid.file_access_table_idx;
   gfs_file_uid_tail = addr (gfs_p_file_oid) -> file_oid.uid_tail;

   if gfs_file_access_table_idx < lbound (file_access_table.e, 1)
        | gfs_file_access_table_idx > file_access_table.h.last_entry
   then call ERROR_RETURN (dm_error_$bad_file_oid,
	   " File access table index out of range.");

   if gfs_file_uid_tail
        ^= substr (file_access_table.e (gfs_file_access_table_idx).uid, 19, 18)
   then call ERROR_RETURN (dm_error_$bad_file_oid,
	   " File access table entry uid does not match uid tail.");

   gfs_p_file_state =
        file_access_table.e (gfs_file_access_table_idx).state.file_state;

   return;

   end GET_FILE_STATE;
%page;
SET_FILE_STATE:
   proc (sfs_p_file_oid, sfs_p_file_state);

/* DESCRIPTION of SET_FILE_STATE:

   This routine sets the file_state of the file in the process'
   file_access_info entry in the file_access_table for this file.
   If sfs_p_file_oid is equal to ""b, this process is a process other
   than the one which wrote the postcommit/rollback handler which is
   now executing and does not need to have its file_access_info updated.
   By contract, before_journal_manager_ passes in a ""b sfs_p_file_oid in
   this case.

   If sfs_p_file_oid is not ""b, it is used to find the file_access_info
   entry.  The file_state is updated to the given value.

   file_access_table is based on the external pointer variable
   fm_data_$file_access_table_ptr, so is file_access_table is accessible
   merely because fm_data_$file_access_table_ptr is declared in the
   main procedure.

   If the sfs_p_file_oid and the file_access_info entry are not in synch,
   just return quietly.
*/

   dcl	 sfs_p_file_oid	    bit (36) aligned parameter;
   dcl	 sfs_p_file_state	    fixed bin parameter;

   dcl	 sfs_file_access_table_idx
			    fixed bin;
   dcl	 sfs_file_uid_tail	    bit (18);

   sfs_file_access_table_idx =
        addr (sfs_p_file_oid) -> file_oid.file_access_table_idx;
   sfs_file_uid_tail = addr (sfs_p_file_oid) -> file_oid.uid_tail;

   if sfs_file_access_table_idx < lbound (file_access_table.e, 1)
        | sfs_file_access_table_idx > file_access_table.h.last_entry
   then return;

   if sfs_file_uid_tail
        ^= substr (file_access_table.e (sfs_file_access_table_idx).uid, 19, 18)
   then return;

   file_access_table.e (sfs_file_access_table_idx).state.file_state =
        sfs_p_file_state;

   return;

   end SET_FILE_STATE;
%page;
SET_ENTRY_STATE:
   proc (ses_p_file_oid);

/* DESCRIPTION of SET_ENTRY_STATE:

   This routine sets the entry_state of the file in the process'
   file_access_info entry in the file_access_table for this file
   such that it is scheduled for post-transaction actions.

   If ses_p_file_oid is equal to ""b, this process is a process other
   than the one which wrote the postcommit/rollback handler which is
   now executing and does not need to have its file_access_info updated.
   By contract, before_journal_manager_ passes in a ""b ses_p_file_oid in
   this case.

   If ses_p_file_oid is not ""b, it is used to find the file_access_info
   entry.  The entry is added to the list of entries scheduled for
   post-transaction actions by setting entry_state to the value of
   the entry index of the last entry so scheduled.

   file_access_table is based on the external pointer variable
   fm_data_$file_access_table_ptr, so is file_access_table is accessible
   merely because fm_data_$file_access_table_ptr is declared in the
   main procedure.
*/

   dcl	 ses_p_file_oid	    bit (36) aligned parameter;

   dcl	 ses_file_access_table_idx
			    fixed bin;
   dcl	 ses_file_uid_tail	    bit (18);
   dcl	 ses_entry_idx	    fixed bin;

   ses_file_access_table_idx =
        addr (ses_p_file_oid) -> file_oid.file_access_table_idx;
   ses_file_uid_tail = addr (ses_p_file_oid) -> file_oid.uid_tail;

   if ses_file_access_table_idx < lbound (file_access_table.e, 1)
        | ses_file_access_table_idx > file_access_table.h.last_entry
   then return;

   if ses_file_uid_tail
        ^= substr (file_access_table.e (ses_file_access_table_idx).uid, 19, 18)
   then return;

   if file_access_table.e (ses_file_access_table_idx).pn_tbl_idx <= 0
   then return;

   do ses_entry_idx = file_access_table.h.post_transaction_actions
        repeat (file_access_table.e (ses_entry_idx).state.entry_state)
        while (ses_entry_idx > 0 & ses_entry_idx ^= ses_file_access_table_idx);
   end;
   if ses_entry_idx = ses_file_access_table_idx
   then return /* already on the list */;
   else
      do /* add to list */;
      file_access_table.e (ses_file_access_table_idx).state.entry_state =
	 file_access_table.h.post_transaction_actions;
      file_access_table.h.post_transaction_actions = ses_file_access_table_idx;
      end;

   return;

   end SET_ENTRY_STATE;
%page;
%include dm_key_count_array;
%page;
%include dm_fm_file_oid;
%page;
%include dm_fm_file_access_info;
%page;
%include dm_fm_file_access_tbl;
%page;
%include dm_fm_rollback_info;
%page;
%include dm_fm_postcommit_info;
%page;
%include dm_file_validation_name;
%page;
%include dm_log_sv_codes;

   end fm_do_$undo;




		    fm_error_util_.pl1              10/24/88  1640.8r w 10/24/88  1400.2      108702



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

/* DESCRIPTION:

          This modules is the file_manager_'s error handling facility.  It is
     based on the signalling mechanism, much as sub_err_ is, but never allows
     the signal to escape the control of the file_manager_.  Thus this is not
     for reporting errors to file_manager_'s caller, but for reporting errors
     between file_manager_ routines.
     
          There are three entries, as follows:
     
     $signal - is the entry called to report an error.  It has an entry
     options(variable) calling sequence similar to a simplified sub_err_.
     The usage is:
          call fm_error_util_$signal 
               (code, module_name, action_flags, severity, ioa_control_string
                {, ioa_string_arg_1 ... , ioa_string_arg_N}
     
     This routine builds logs a message in the dm_system_log_ if the
     action_flags indicate that it should, building the message from the
     arguments given.  It also builds an fm_sub_error_info condition structure
     and signals the fm_sub_error_ signal.
     
     $get_code - is called from an fm_sub_error_ condition handler to get the
     status code stored in fm_sub_error_info.
     
     $get_message - is called from an fm_sub_error_ condition handler to get
     the message stored in fm_sub_error_info.
*/

/* HISTORY:

Written by Matthew Pierret, 07/02/84.
Modified:
10/31/84 by Matthew Pierret:  Changed setting of p_module_name when a 
            varying character argument is provided to check the current
            length of the varying string instead of the length of the argument,
            which is always max-length.
            Answered audit comments by changing to use LOG_SV in
            dm_log_sv_codes.incl.pl1 instead of the local constant 
            DEFAULT_SEVERITY.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/

/* format: style2,ind3 */
%page;
fm_error_util_$signal:
   procedure ();


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

      dcl	    p_status_code	       fixed bin (35);	/* is a standard system error code. */
      dcl	    p_module_name	       char (32);		/* name of the calling module */
      dcl	    p_fm_error_flags_string
			       bit (36) aligned;	/* contains action flags */
      dcl	    p_severity	       fixed bin (17);	/* severity for call to dm_misc_util_$log */

/* Automatic */

      dcl	    arg_list_ptr	       ptr init (null);
      dcl	    arg_size	       fixed bin (24);
      dcl	    arg_packed	       bit (1) aligned;
      dcl	    (arg_count, arg_type, arg_ndims, arg_scale)
			       fixed bin;

      dcl	    code		       fixed bin (35) init (0);
      dcl	    char_varying_ptr       ptr init (null);
      dcl	    message_buffer_ptr     ptr init (null);
      dcl	    message_length	       fixed bin (21) init (-1);

      dcl	    (pad_sw, nl_sw)	       bit (1) aligned;

      dcl	    1 my_fm_sub_error_info aligned like fm_sub_error_info;

      dcl	    1 my_condition_info    aligned like condition_info;

/* Based */

      dcl	    char_varying	       char (1000000) varying based;
      dcl	    char_nonvarying	       char (1000000) based;
      dcl	    fixed_bin_17	       fixed bin (17) based;
      dcl	    fixed_bin_35	       fixed bin (35) based;
      dcl	    bit_36_aligned	       bit (36) aligned based;
      dcl	    message_buffer	       char (sys_info$max_seg_size * 4) based (message_buffer_ptr);
      dcl	    message	       char (message_length) based (message_buffer_ptr);

/* Builtin */

      dcl	    (addr, addwordno, length, max, min, null, size, string, substr, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("fm_error_util_") char (32) varying internal static options (constant);
      dcl	    (
	    CODE_ARGUMENT_IDX      init (1),
	    MODULE_NAME_ARGUMENT_IDX
			       init (2),
	    FM_ERROR_FLAGS_ARGUMENT_IDX
			       init (3),
	    SEVERITY_ARGUMENT_IDX  init (4),
	    FIRST_MESSAGE_ARGUMENT_IDX
			       init (5),
	    NUMBER_OF_REQUIRED_ARGUMENTS
			       init (4)
	    )		       fixed bin internal static options (constant);
      dcl	    NON_ACTION_FLAGS_MASK  init ((18)"1"b || (18)"0"b) bit (36) aligned internal static options (constant);

/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_count	       entry (fixed bin, fixed bin (35));
      dcl	    decode_descriptor_     entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin (24),
			       fixed bin);
      dcl	    find_condition_info_   entry (ptr, ptr, fixed bin (35));
      dcl	    get_temp_segment_      entry (char (*), 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	    dm_misc_util_$log       entry () options (variable);
      dcl	    release_temp_segment_  entry (char (*), ptr, fixed bin (35));
      dcl	    signal_	       entry () options (variable);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;
      dcl	    error_table_$badcall   fixed bin (35) ext;
      dcl	    sys_info$max_seg_size  fixed bin (35) ext;

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

/* This "entry point" is actually the main procedure statement above.

   signal:
   entry ();
*/

/**** Get pointer to this routine's arg_list */

      call cu_$arg_list_ptr (arg_list_ptr);
      call cu_$arg_count (arg_count, (0));

      if arg_count < NUMBER_OF_REQUIRED_ARGUMENTS
      then call sub_err_ (error_table_$badcall, myname, ACTION_CANT_RESTART, null, 0,
	      "^/^10xThis entry requires at least ^d arguments.^/^10xOnly ^d arguments were received.",
	      (NUMBER_OF_REQUIRED_ARGUMENTS), arg_count);

/**** Set the parameter values. */

      p_status_code = arg_list_ptr -> arg_list.arg_ptrs (CODE_ARGUMENT_IDX) -> fixed_bin_35;
      p_severity = arg_list_ptr -> arg_list.arg_ptrs (SEVERITY_ARGUMENT_IDX) -> fixed_bin_17;
      p_fm_error_flags_string = arg_list_ptr -> arg_list.arg_ptrs (FM_ERROR_FLAGS_ARGUMENT_IDX) -> bit_36_aligned;
      call decode_descriptor_ (arg_list_ptr, MODULE_NAME_ARGUMENT_IDX, arg_type, arg_packed, arg_ndims, arg_size,
	 arg_scale);
      if arg_type = char_dtype
      then p_module_name =
	      substr (arg_list_ptr -> arg_list.arg_ptrs (MODULE_NAME_ARGUMENT_IDX) -> char_nonvarying, 1,
	      min (32, arg_size));
      else if arg_type = varying_char_dtype
      then
         do;					/* arg_list.arg_ptrs points to data, not length word, */
						/* so must be backed up one word to use varying variable */
	  char_varying_ptr = addwordno (arg_list_ptr -> arg_list.arg_ptrs (MODULE_NAME_ARGUMENT_IDX), -1);
	  p_module_name =
	       substr (char_varying_ptr -> char_varying, 1, min (32, length (char_varying_ptr -> char_varying)));
         end;
      else call sub_err_ (error_table_$badcall, myname, ACTION_CANT_RESTART, null (), (0),
	      "^/Argument ^d is of type ^d.  Only char-varying and char-nonvarying are acceptable.",
	      MODULE_NAME_ARGUMENT_IDX, arg_type);


/**** Setup message buffer in a temporary segment. ****/

      on cleanup call FINISH ();

      call get_temp_segment_ ((myname), message_buffer_ptr, code);
      if code ^= 0
      then call sub_err_ (code, myname, ACTION_CANT_RESTART, null, 0,
	      "^/^10xAn attempt to acquire a temporary segment failed while^/^10xpreparing error message.");

      call ioa_$general_rs (arg_list_ptr, FIRST_MESSAGE_ARGUMENT_IDX, FIRST_MESSAGE_ARGUMENT_IDX + 1, message_buffer,
	 message_length, pad_sw, nl_sw);

      unspec (my_fm_sub_error_info) = ""b;
      fm_sub_error_info_ptr = addr (my_fm_sub_error_info);

      fm_sub_error_info.header.version = FM_SUB_ERROR_INFO_VERSION_200;
      fm_sub_error_info.header.length = size (fm_sub_error_info);
      fm_sub_error_info.header.status_code = p_status_code;
      string (fm_sub_error_info.header.action_flags) = p_fm_error_flags_string & NON_ACTION_FLAGS_MASK;
      fm_sub_error_info.header.action_flags.support_signal = "1"b;
      fm_sub_error_info.module_name = p_module_name;

      if message_length <= 256
      then
         do;
	  fm_sub_error_info.header.info_string = message;
	  fm_sub_error_info.message_length = message_length;
	  fm_sub_error_info.message_ptr = addr (fm_sub_error_info.header.info_string);
         end;
      else
         do;
	  fm_sub_error_info.header.info_string = "";
	  fm_sub_error_info.message_length = message_length;
	  fm_sub_error_info.message_ptr = message_buffer_ptr;
         end;


/**** Log message if requested. */

      if addr (p_fm_error_flags_string) -> fm_error_flags.log.system
      then call dm_misc_util_$log (max (LOG_SV, p_severity), fm_sub_error_info.header.status_code, fm_sub_error_info.module_name,
	      message);



/**** Signal fm_sub_error_ condition. */

      call signal_ ("fm_sub_error_", null, fm_sub_error_info_ptr, null);

      do while (fm_sub_error_info.header.action_flags.cant_restart);
						/* If user can't hack return */
         call signal_ ("illegal_return", null, fm_sub_error_info_ptr, null);
      end;

      call FINISH ();

      return;
%page;
FINISH:
   proc ();

      if message_buffer_ptr ^= null
      then call release_temp_segment_ ((myname), message_buffer_ptr, (0));

   end FINISH;
%page;
get_code:
   entry () returns (fixed bin (35));

      fm_sub_error_info_ptr = GET_ERROR_INFO_PTR ();

      return (fm_sub_error_info.header.status_code);




get_message:
   entry () returns (char (*));

      fm_sub_error_info_ptr = GET_ERROR_INFO_PTR ();

      message_length = fm_sub_error_info.message_length;
      message_buffer_ptr = fm_sub_error_info.message_ptr;

      return (message);


GET_ERROR_INFO_PTR:
   proc () returns (ptr);

      dcl	    geip_code	       fixed bin (35) init (0);

      condition_info_ptr = addr (my_condition_info);
      call find_condition_info_ ((null), condition_info_ptr, geip_code);
      if geip_code ^= 0
      then call sub_err_ (geip_code, myname, ACTION_CANT_RESTART, null, 0, "^/Attempt to find condition info failed.");
      if condition_info_ptr = null
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	      "^/^10xThis entry was invoked to handle a ^a condition,^/^10xbut no condition info exists.",
	      FM_SUB_ERROR_CONDITION_NAME);
      if condition_info.condition_name ^= FM_SUB_ERROR_CONDITION_NAME
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null (), 0,
	      "^/^10xThis entry was invoked to handle a ^a condition,^/^10xbut the current condition is ^a.",
	      FM_SUB_ERROR_CONDITION_NAME, condition_info.condition_name);
      if condition_info.info_ptr = null
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null (), 0,
	      "^/The condition_info.info_ptr variable is not set.");

      if condition_info.info_ptr -> fm_sub_error_info.header.version ^= FM_SUB_ERROR_INFO_VERSION_200
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the fm_sub_error_info structure; received ^d.", FM_SUB_ERROR_INFO_VERSION_200,
	      condition_info.info_ptr -> fm_sub_error_info.header.version);

      return (condition_info.info_ptr);


   end GET_ERROR_INFO_PTR;
%page;
%include dm_fm_sub_error_info;
%page;
%include dm_fm_sub_error_flags;
%page;
%include condition_info;
%page;
%include condition_info_header;
%page;
%include sub_err_flags;
%page;
%include std_descriptor_types;
%page;
%include dm_log_sv_codes;
%page;
%include arg_list;

   end fm_error_util_$signal;




		    fm_firstref_tv_.alm             04/04/85  1119.5re  04/04/85  0826.7       52830



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"  DESCRIPTION:
"
"          This is one of the two Data Management inner ring file manager 
"     transfer vectors.  This one, fm_firstref_tv_, is for each file manager
"     entry which requires Data Management per-process initialization to have 
"     been executed at some time before the file manager entry itself is
"     executed.  Since all such entries go through fm_firstref_tv_, a first
"     reference trap associated with fm_firstref_tv_ runs per-process
"     initialization the first time fm_firstref_tv_ is invoked.
"     
"          The other file manager transfer vector is fm_no_firstref_tv_ and is 
"     for those entries which do not require Data Management per-process
"     initialization.
"
" HISTORY:
"
" Written by Jeffrey D. Ives, 02/23/83.
" Modified:
" 08/02/83 by Lindsey Spratt: Added the read and write entries, to make the
"	    support of the binding easier.
" 12/22/83 by Matthew Pierret: Removed (commented out) the acl_delete,
"             acl_replace and acl_list entries.  The acl_add entry should be
"             deleted also when the before_journal_manager_ is taught to use
"             the standard file_manager_$add_acl_entries instead of $acl_add.
"             Removed fm_attribute_$validate. This has been replaced by 
"             fm_validate_, which is accessed directly through fm_gate_.
" 01/06/84 by Matthew Pierret:  Removed $delentry_file, which is obsolete.
" 02/01/84 by Matthew Pierret:  Added $get_ci_ptr and $terminate_ci_pt.
" 05/02/84 by Lee A. Newcomb:  Added $user_shutdown.
" 05/21/84 by R. Michael Tague:  Deleted $acl_delete, $acl_list, and
"	    $acl_replace.  They were commented out.  Deleted $fetch,
"	    $store, $read, and $write.  Added $simple_get, $simple_put,
"	    $get_stream, and $put_stream.
" 05/25/84 by R. Michael Tague:  Added $abandon entry point.
" 06/25/84 by Matthew Pierret:  Removed $acl_add entrypoint. 
" 07/10/84 by Matthew Pierret:  Changed fm_open_$per_process_init_ to
"             fm_per_process_init_$fm_per_process_init_.
"             Moved the delete_close, close, post_txn and post_commit
"             entries from fm_open_ to fm_delete_close_.
"             Moved the prepare_to_copy entry from fm_open_ to 
"             fm_prepare_to_copy_.
"             Moved status entry from fm_open_ to fm_status.
"             Changed module name of fm_open_ to fm_create_open_.
" 10/29/84 by Matthew Pierret:  Changed target of undo from fm_put_$undo
"             to fm_do_$undo.  Changed post_commit to postcommit_do with
"             a target of fm_do_$postcommit_do.
" 11/22/84 by Lee A. Newcomb:  Added $per_process_init entry and changed
"	    firstref trap to transaction_manager_$per_process_init.
" 11/13/84 by Matthew Pierret:  
"             Moved entries in fm_attribute_ which do not need the 
"             first-reference trap to fm_no_firstref_tv_.  Changed the target
"             of the remaining fm_attribute_ entries to fm_attribute_fref_.
"             Changed the target module of open_by_uid, open_by_uid_after_crash
"             find_old_pn_tabl and end_of_crash_recovery from fm_combos_
"             to fm_open_by_uid_. Added set_ring_brackets.
" 12/02/84 by Stanford S. Cox: Renamed fm_firstref_tv_
" 03/13/85 by R. Michael Tague:  Added postcommit_increment.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	fm_firstref_tv_

	firstref	transaction_manager_$per_process_init


	macro	transfer
	entry	&1
&1:
	tra	&2

	&end


	transfer	abandon,fm_put_$adopt
	transfer	adopt,fm_put_$adopt
	transfer	allocate,fm_put_$allocate
	transfer	chname_file,fm_attribute_fref_$chname_file
	transfer	close,fm_delete_close_$close
	transfer	create,fm_combos_$create
	transfer	create_open,fm_create_open_$create_open
	transfer	delete,fm_combos_$delete
	transfer	delete_close,fm_delete_close_$delete_close
	transfer	end_of_crash_recovery,fm_open_by_uid_$end_of_crash_recovery
	transfer	find_old_uid_pn_table,fm_open_by_uid_$find_old_uid_pn_table
	transfer	flush_consecutive_ci,fm_put_$flush_consecutive_ci
	transfer	flush_modified_ci,fm_put_$flush_modified_ci
	transfer	free,fm_put_$free
	transfer	get,fm_get_$get
	transfer	get_ci_header,fm_get_$get_ci_header
          transfer  get_ci_ptr,fm_get_$get_ci_ptr
	transfer	get_exclusive,fm_get_$get_exclusive
	transfer  get_stream,fm_stream_$get_stream
	transfer	get_switch,fm_attribute_fref_$get_switch
	transfer	lock_advice,fm_put_$lock_advice
	transfer	open,fm_create_open_$open
	transfer	open_by_uid,fm_open_by_uid_$open
	transfer	open_by_uid_after_crash,fm_open_by_uid_$open_after_crash
	transfer	per_process_init,fm_per_process_init_$fm_per_process_init_
	transfer  postcommit_do,fm_do_$postcommit_do
	transfer  postcommit_increment,fm_put_$postcommit_increment
          transfer  post_transaction,fm_delete_close_$post_transaction
	transfer	prepare_to_copy,fm_prepare_to_copy_$fm_prepare_to_copy_
	transfer	put,fm_put_$put
	transfer	put_journal,fm_put_$put_journal
	transfer  put_stream,fm_stream_$put_stream
	transfer	raw_get,fm_get_$raw_get
	transfer	raw_put,fm_put_$raw_put
          transfer  set_ring_brackets,fm_attribute_fref_$set_ring_brackets
	transfer  simple_get,fm_get_$simple_get
	transfer  simple_put,fm_put_$simple_put
	transfer	status,fm_status$fm_status
	transfer	sub_err_flag_get,fm_data_$sub_err_flag_get
	transfer	sub_err_flag_set,fm_data_$sub_err_flag_set
          transfer  terminate_ci_ptr,fm_get_$terminate_ci_ptr
	transfer	undo,fm_do_$undo
	transfer	unput,fm_put_$unput
	transfer	user_shutdown,fm_user_shutdown$fm_user_shutdown
	end




		    fm_get_.pl1                     05/10/85  0807.3re  05/08/85  1037.3      162693



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

/* DESCRIPTION

   This routine implements the file manager's read primitives.
*/

/* HISTORY:

Written by Bensoussan-Ives, 06/22/82.
   01/28/82 Andre Bensoussan, Specification and design.
   06/22/82 Jeffrey D. Ives, Design and coding.
Modified:
01/31/84 by Matthew Pierret:  Added the get_ci_ptr and terminate_ci_ptr
            entries.  The latter is currently a no-op.  get_ci_ptr returns
            a pointer to the addressable portion of a control interval, 
            allowing for faster retrievals overall many common retrieval
            patterns.  Also changed the format comment to simply style2.
03/16/84 by Matthew Pierret:  Changed $get_ci_ptr to return
            dm_error_$ci_not_allocated if the control interval has not been
            allocated instead of returning a pointer to a page of zeroes.
            If the control interval is part of a non-existent segment, there
            is no page to which to point.
05/21/84 by R. Michael Tague:  Created $simple_get, which is an entry for
	  getting from just one control interval without having to set
	  up a ci_parts structure.
06/07/84 by Lee Baldwin:  Renamed a bunch of dm_error_ codes.
07/27/84 by Matthew Pierret:  Changed to check read ring bracket.  Also added
            RETURN and ERROR_RETURN procedures, replacing the statements
            "go to GOOD_RETURN", "go to BAD_RETURN" and "go to <error>".
            Changed to use my_file_access_info instead of proc_ad.
11/12/84 by Matthew Pierret:  Made the proc statement be fm_get_$get so
            there are no useless entrypoints. Added get_ci_ptr_exclusive.
            Made several changes to the dm_ci* include files.
12/17/84 by Matthew Pierret:  Changed to use the new state variables in
            my_file_access_info, and to return dm_error_$bad_file_oid if
            entry_state is not IN_USE and dm_error_$file_doesnt_exist if
            file_state is not FIEL_EXISTS. Also, changed LOCK_WAIT_TIME to
            1e9 from 1e8. Changed to use dm_error_$no_current_transaction
            instead of dm_error_$fm_no_current_txn.
04/22/85 by R. Michael Tague:  Added $internal_get_ci_ptr that will return a
	  pointer even if the file is not open.
*/

/* format: style2 */

fm_get_$get:
     procedure (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code);

/* START OF DECLARATIONS */

/* Parameters */

	dcl     p_ci_num		 fixed bin (27) parm;
	dcl     p_ci_parts_ptr	 ptr parm;
	dcl     p_ci_ptr		 ptr parameter;
	dcl     p_single_part_length	 fixed bin (17) parm;
	dcl     p_single_part_offset	 fixed bin (17) parm;
	dcl     p_single_part_ptr	 ptr parm;
	dcl     p_code		 fixed bin (35) parm;
	dcl     p_file_oid		 bit (36) aligned parm;

	dcl     1 p_ci_header	 aligned parm,
		2 stamp		 bit (72),
		2 id		 bit (72);


/* Automatic */

	dcl     caller_validation_level
				 fixed bin init (0);/* for cleanup */
	dcl     ci_num		 fixed bin (27);
	dcl     code		 fixed bin (35) init (0);
	dcl     component_num	 fixed bin;
	dcl     just_get_ci_ptr	 bit (1) aligned;
	dcl     just_get_header	 bit aligned;
	dcl     lock_mode		 fixed bin;
	dcl     min_opens		 fixed bin;
	dcl     number_of_addressable_bytes
				 fixed bin;
	dcl     page_num		 fixed bin;
	dcl     part_idx		 fixed bin;
	dcl     part_length		 fixed bin;
	dcl     part_offset		 fixed bin;

	dcl     part_ptr		 ptr init (null ());
	dcl     my_ci_id		 fixed bin (71);
	dcl     my_ci_stamp		 fixed bin (71);
	dcl     1 my_file_oid	 aligned like file_oid;

	dcl     1 single_ci_part	 aligned,
		2 number_of_parts	 fixed bin (17) init (1),
		2 part		 (1) like ci_parts.part;

	dcl     1 effective_integrity_switches
				 aligned like file_access_info.integrity_switches;
	dcl     1 my_file_access_info	 aligned like file_access_info;

/* Constant */

	dcl     LOCK_WAIT_TIME	 init (1000000000) fixed bin (71) internal static options (constant);
	dcl     NULL_INTEGRITY_SWITCHES
				 init ((5)"0"b) bit (5) aligned static options (constant);
	dcl     GET_INTEGRITY_SWITCHES init ((5)"1"b) bit (5) aligned static options (constant);


/* Conditions */

	dcl     cleanup		 condition;

/* Based */

	dcl     part_buffer		 char (part_length) based (part_ptr);

	dcl     1 seg		 aligned based,
		2 pages		 (0:254),
		  3 double_words	 (512) fixed bin (71);

/* Builtin */

	dcl     (addr, baseno, baseptr, bin, divide, hbound, lbound, multiply, null, string, substr, unspec)
				 builtin;

/* External Variables */

	dcl     dm_data_$current_txn_id
				 bit (36) aligned ext;
	dcl     dm_error_$bad_file_oid fixed bin (35) ext;
	dcl     dm_error_$ci_bad_hdr_arg_ver
				 fixed bin (35) ext;
	dcl     dm_error_$ci_bad_hdr_id_num
				 fixed bin (35) ext;
	dcl     dm_error_$ci_bad_hdr_size_code
				 fixed bin (35) ext;
	dcl     dm_error_$ci_bad_hdr_uid
				 fixed bin (35) ext;
	dcl     dm_error_$ci_bad_stamp_ver
				 fixed bin (35) ext;
	dcl     dm_error_$ci_not_allocated
				 fixed bin (35) ext;
	dcl     dm_error_$ci_num_oob	 fixed bin (35) ext;
	dcl     dm_error_$ci_num_parts_neg
				 fixed bin (35) ext;
	dcl     dm_error_$ci_parts_oob fixed bin (35) ext;
	dcl     dm_error_$file_doesnt_exist
				 fixed bin (35) ext;
	dcl     dm_error_$no_current_transaction
				 fixed bin (35) ext;
	dcl     error_table_$noentry	 fixed bin (35) ext;
	dcl     error_table_$no_r_permission
				 fixed bin (35) ext;


/* External Entries */

	dcl     cu_$level_get	 entry (fixed bin);
	dcl     cu_$level_set	 entry (fixed bin);
	dcl     get_ring_		 entry () returns (fixed bin (3));
	dcl     lock_manager_$lock	 entry (bit (36) aligned, fixed bin (27), fixed bin, fixed bin (71), fixed bin,
				 fixed bin (35));
	dcl     msf_manager_$msf_get_ptr
				 entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));

/* END OF DECLARATIONS */
%page;
/* This entry is actually the main procedure statement and is repeated
   here for the reader's convenience

get: entry  (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code); */

	call INIT;

	just_get_header, just_get_ci_ptr = "0"b;
	min_opens = 1;
	string (effective_integrity_switches) = GET_INTEGRITY_SWITCHES;
	lock_mode = LOCK_MODE_S;

	ci_parts_ptr = p_ci_parts_ptr;
	ci_num = p_ci_num;

	if ci_num = 0
	then number_of_addressable_bytes = CI_0_ADDRESSABLE_LENGTH;
	else number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;

	go to JOIN;


get_ci_header:
     entry (p_file_oid, p_ci_num, p_ci_header, p_code);

	call INIT;

	just_get_header = "1"b;
	just_get_ci_ptr = "0"b;
	min_opens = 1;
	string (effective_integrity_switches) = GET_INTEGRITY_SWITCHES;
	lock_mode = LOCK_MODE_S;

	ci_num = p_ci_num;

	if addr (p_ci_header) -> ci_stamp.version ^= CI_STAMP_VERSION_1
	then call ERROR_RETURN (dm_error_$ci_bad_hdr_arg_ver);

	go to JOIN;
%page;
internal_get:
     entry (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code);

	call INIT;

	just_get_header, just_get_ci_ptr = "0"b;
	min_opens = 0;
	string (effective_integrity_switches) = GET_INTEGRITY_SWITCHES;
	lock_mode = LOCK_MODE_S;

	ci_parts_ptr = p_ci_parts_ptr;
	ci_num = p_ci_num;

	number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;

	go to JOIN;




get_exclusive:
     entry (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code);

	call INIT;

	just_get_header, just_get_ci_ptr = "0"b;
	min_opens = 1;
	string (effective_integrity_switches) = GET_INTEGRITY_SWITCHES;
	lock_mode = LOCK_MODE_X;

	ci_parts_ptr = p_ci_parts_ptr;
	ci_num = p_ci_num;

	if ci_num = 0
	then number_of_addressable_bytes = CI_0_ADDRESSABLE_LENGTH;
	else number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;

	go to JOIN;
%page;
raw_get:
     entry (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code);

	call INIT;

	just_get_header, just_get_ci_ptr = "0"b;
	min_opens = 1;
	string (effective_integrity_switches) = NULL_INTEGRITY_SWITCHES;
	lock_mode = LOCK_MODE_S;

	ci_parts_ptr = p_ci_parts_ptr;
	ci_num = p_ci_num;

	if ci_num = 0
	then number_of_addressable_bytes = CI_0_ADDRESSABLE_LENGTH;
	else number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;

	go to JOIN;


simple_get:
     entry (p_file_oid, p_ci_num, p_single_part_offset, p_single_part_ptr, p_single_part_length, p_code);

	call INIT;

	just_get_header = "0"b;
	just_get_ci_ptr = "0"b;
	min_opens = 1;
	string (effective_integrity_switches) = GET_INTEGRITY_SWITCHES;
	lock_mode = LOCK_MODE_S;
	ci_parts_ptr = addr (single_ci_part);
	ci_parts.part (1).offset_in_bytes = p_single_part_offset;
	ci_parts.part (1).length_in_bytes = p_single_part_length;
	ci_parts.part (1).local_ptr = p_single_part_ptr;
	ci_num = p_ci_num;
	if ci_num = 0
	then number_of_addressable_bytes = CI_0_ADDRESSABLE_LENGTH;
	else number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;
	go to JOIN;
%page;
get_ci_ptr:
     entry (p_file_oid, p_ci_num, p_ci_ptr, p_code);

/* This entry gets a pointer to the addressable portion of a ci.  The pointer
   is directly into the file ci, not a copy, so this pointer must not be 
   used to update the ci. */

	call INIT;
	p_ci_ptr = null;
	just_get_header = "0"b;
	just_get_ci_ptr = "1"b;
	min_opens = 1;
	string (effective_integrity_switches) = GET_INTEGRITY_SWITCHES;
	lock_mode = LOCK_MODE_S;
	ci_num = p_ci_num;

	go to JOIN;

%page;
internal_get_ci_ptr:
     entry (p_file_oid, p_ci_num, p_ci_ptr, p_code);

/* This entry gets a pointer to the addressable portion of a ci.  The pointer
   is directly into the file ci, not a copy, so this pointer must not be 
   used to update the ci.  This entry differs from get_ci_ptr in that the file
   need not be open.
 */

	call INIT;
	p_ci_ptr = null;
	just_get_header = "0"b;
	just_get_ci_ptr = "1"b;
	min_opens = 0;
	string (effective_integrity_switches) = GET_INTEGRITY_SWITCHES;
	lock_mode = LOCK_MODE_S;
	ci_num = p_ci_num;

	go to JOIN;

get_ci_ptr_exclusive:
     entry (p_file_oid, p_ci_num, p_ci_ptr, p_code);

/* This entry is the same as get_ci_ptr except that it acquires an
   exclusive lock on the control interval. */

	call INIT;
	p_ci_ptr = null;
	just_get_header = "0"b;
	just_get_ci_ptr = "1"b;
	min_opens = 1;
	string (effective_integrity_switches) = GET_INTEGRITY_SWITCHES;
	lock_mode = LOCK_MODE_X;
	ci_num = p_ci_num;
	go to JOIN;


terminate_ci_ptr:
     entry (p_file_oid, p_ci_num, p_ci_ptr, p_code);

/* This entry is currently not supported.  $get_ci_ptr should be changed
in the future to remember the ci pointers gotten, holding them until
terminate_ci_ptr releases the ci_ptr. */

	call RETURN ();
%page;
JOIN:
	if ci_num < 0 | ci_num > MAX_CI_NUM
	then call ERROR_RETURN (dm_error_$ci_num_oob);

	unspec (my_file_oid) = p_file_oid;

	if my_file_oid.file_access_table_idx < lbound (file_access_table.e, 1)
	     | my_file_oid.file_access_table_idx > file_access_table.h.last_entry
	then call ERROR_RETURN (dm_error_$bad_file_oid);

	my_file_access_info = file_access_table.e (my_file_oid.file_access_table_idx);

	if my_file_access_info.state.entry_state = FILE_ACCESS_INFO_NOT_IN_USE
	then call ERROR_RETURN (dm_error_$bad_file_oid);

	if my_file_access_info.state.file_state ^= FILE_EXISTS
	then call ERROR_RETURN (dm_error_$file_doesnt_exist);

	if my_file_access_info.opens < min_opens
	then call ERROR_RETURN (dm_error_$bad_file_oid);

	if my_file_oid.uid_tail ^= substr (my_file_access_info.uid, 19, 18)
	then call ERROR_RETURN (dm_error_$bad_file_oid);

	if my_file_access_info.seg_0_num = ""b
	then call ERROR_RETURN (dm_error_$file_doesnt_exist);

	call cu_$level_get (caller_validation_level);
	if caller_validation_level > my_file_access_info.ring_brackets.read
	then call ERROR_RETURN (error_table_$no_r_permission);

	effective_integrity_switches = effective_integrity_switches & my_file_access_info.integrity_switches;

	if effective_integrity_switches.transaction
	then do;
		if dm_data_$current_txn_id = ""b
		then call ERROR_RETURN (dm_error_$no_current_transaction);
	     end;

	if effective_integrity_switches.lock
	then do;
		if my_file_access_info.lock_advice = 0
		then do;
			call lock_manager_$lock (my_file_access_info.uid, ci_num, lock_mode, LOCK_WAIT_TIME, (0),
			     code);
			if code ^= 0
			then call ERROR_RETURN (code);
		     end;
		else do;
			if my_file_access_info.last_transaction_id ^= dm_data_$current_txn_id
			then do;
				my_file_access_info.last_transaction_id = dm_data_$current_txn_id;
				file_access_table.e (my_file_oid.file_access_table_idx) = my_file_access_info;

				call lock_manager_$lock (my_file_access_info.uid, LOCK_ENTIRE_FILE,
				     (my_file_access_info.lock_advice), LOCK_WAIT_TIME, (0), code);
				if code ^= 0
				then call ERROR_RETURN (code);
			     end;

			if my_file_access_info.lock_advice = LOCK_MODE_X
			then ;
			else if lock_mode = LOCK_MODE_S
			     & (my_file_access_info.lock_advice = LOCK_MODE_S
			     | my_file_access_info.lock_advice = LOCK_MODE_SIX)
			then ;
			else do;
				call lock_manager_$lock (my_file_access_info.uid, ci_num, lock_mode,
				     LOCK_WAIT_TIME, (0), code);
				if code ^= 0
				then call ERROR_RETURN (code);
			     end;
		     end;
	     end;

	component_num = divide (ci_num, my_file_access_info.blocking_factor, 27);

	if component_num = 0
	then do;
		ci_ptr = baseptr (my_file_access_info.seg_0_num);
		go to REAL_GET;
	     end;
	else if component_num <= hbound (my_file_access_info.seg_nums, 1)
	then do;
		if my_file_access_info.seg_nums (component_num) ^= 0
		then do;
			ci_ptr = baseptr (my_file_access_info.seg_nums (component_num));
			go to REAL_GET;
		     end;
	     end;

	on cleanup call cu_$level_set (caller_validation_level);
	call cu_$level_set (get_ring_ ());

	call msf_manager_$msf_get_ptr ((my_file_access_info.msf_ptr), component_num, "0"b, ci_ptr, (0), code);

	call cu_$level_set (caller_validation_level);

	if ci_ptr = null ()
	then do;
		if code = error_table_$noentry
		then go to FAKE_GET;

		call ERROR_RETURN (code);
	     end;

	if component_num <= hbound (my_file_access_info.seg_nums, 1)
	then do;
		my_file_access_info.seg_nums (component_num) = bin (baseno (ci_ptr), 18);
		file_access_table.e (my_file_oid.file_access_table_idx) = my_file_access_info;
	     end;

%page;
REAL_GET:
	page_num = ci_num - multiply (component_num, my_file_access_info.blocking_factor, 27);
	ci_ptr = addr (ci_ptr -> seg.pages (page_num));

	my_ci_stamp = ci.trailer.stamp;
	my_ci_id = ci.header.id;

	if my_ci_stamp = 0
	then go to FAKE_GET;

	if addr (my_ci_stamp) -> ci_stamp.version ^= CI_STAMP_VERSION_1
	then call ERROR_RETURN (dm_error_$ci_bad_stamp_ver);

	if addr (my_ci_id) -> ci_id.size_code ^= SIZE_CODE_1024_WORDS
	then call ERROR_RETURN (dm_error_$ci_bad_hdr_size_code);

	if addr (my_ci_id) -> ci_id.uid ^= my_file_access_info.uid
	then call ERROR_RETURN (dm_error_$ci_bad_hdr_uid);

	if addr (my_ci_id) -> ci_id.num ^= ci_num
	then call ERROR_RETURN (dm_error_$ci_bad_hdr_id_num);

	if just_get_ci_ptr
	then go to GET_CI_PTR;

	if just_get_header
	then go to REAL_GET_HEADER;

	cip_number_of_parts = ci_parts.number_of_parts;
	if cip_number_of_parts < 0
	then call ERROR_RETURN (dm_error_$ci_num_parts_neg);

	do part_idx = lbound (ci_parts.part, 1) to cip_number_of_parts;
	     part_length = ci_parts.part (part_idx).length_in_bytes;

	     if part_length ^= 0
	     then do;
		     part_offset = ci_parts.part (part_idx).offset_in_bytes;
		     part_ptr = ci_parts.part (part_idx).local_ptr;

		     if part_offset < 0 | part_length < 0 | part_offset + part_length > number_of_addressable_bytes
		     then call ERROR_RETURN (dm_error_$ci_parts_oob);

		     part_buffer = substr (ci.addressable_bytes, part_offset + 1, part_length);
		end;
	end;

	p_code = 0;
MAIN_RETURN:
	return;

RETURN:
     proc ();
	p_code = 0;
	go to MAIN_RETURN;
     end 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;
FAKE_GET:
	if just_get_ci_ptr
	then call ERROR_RETURN (dm_error_$ci_not_allocated);

	if just_get_header
	then go to FAKE_GET_HEADER;

	cip_number_of_parts = ci_parts.number_of_parts;
	if cip_number_of_parts < 0
	then call ERROR_RETURN (dm_error_$ci_num_parts_neg);

	do part_idx = lbound (ci_parts.part, 1) to cip_number_of_parts;
	     part_length = ci_parts.part (part_idx).length_in_bytes;

	     if part_length ^= 0
	     then do;
		     part_offset = ci_parts.part (part_idx).offset_in_bytes;
		     part_ptr = ci_parts.part (part_idx).local_ptr;

		     if part_offset < 0 | part_length < 0 | part_offset + part_length > number_of_addressable_bytes
		     then call ERROR_RETURN (dm_error_$ci_parts_oob);

		     unspec (part_buffer) = ""b;
		end;
	end;

	call RETURN ();





FAKE_GET_HEADER:
	my_ci_stamp = TEMPLATE_CI_STAMP_1;
	addr (my_ci_id) -> ci_id.uid = my_file_access_info.uid;
	addr (my_ci_id) -> ci_id.size_code = SIZE_CODE_1024_WORDS;
	addr (my_ci_id) -> ci_id.num = ci_num;

REAL_GET_HEADER:
	unspec (p_ci_header.stamp) = unspec (my_ci_stamp);
	unspec (p_ci_header.id) = unspec (my_ci_id);

	call RETURN ();


GET_CI_PTR:
	p_ci_ptr = addr (ci.addressable_bytes);
	call RETURN ();


/* THIS IS THE END OF THE MAIN LINE CODE */
%page;
INIT:
     proc;

/* THE LOGIC DOES NOT DEPEND ON THE INITIALIZATIONS BELOW */

	ci_ptr = null ();
	ci_parts_ptr = null ();
	part_ptr = null ();

	cip_number_of_parts = -1;
	code = -1;
	component_num = -1;
	lock_mode = -1;
	my_ci_id = -1;
	my_ci_stamp = -1;
	number_of_addressable_bytes = -1;
	page_num = -1;
	part_idx = -1;
	part_length = -1;
	part_offset = -1;

	unspec (my_file_oid) = ""b;

/* THE LOGIC DOES NOT DEPEND ON THE INITIALIZATIONS ABOVE */

     end INIT;
%page;
/* START OF INCLUDE FILES */

%include dm_ci;
%page;
%include dm_ci_header;
%page;
%include dm_ci_constants;

%include dm_ci_lengths;
%page;
%include dm_ci_parts;
%page;
%include dm_lock_modes;
%page;
%include dm_fm_file_oid;
%page;
%include dm_fm_file_access_info;
%page;
%include dm_fm_file_access_tbl;

     end fm_get_$get;




		    fm_get_last_ci_num.pl1          12/09/86  1248.4rew 12/09/86  1237.0       64917



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



/****^  HISTORY COMMENTS:
  1) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-11-26,Dupuis),
     install(86-12-09,MR12.0-1237):
     Correct the p_blocking_factor parameter to be aligned so we don't always
     get a value of zero from the top half of the word being passed in. This
     was causing the copying of dm files to fail and status to give erroneous
     results for the last-control interval.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION:

     This subroutine determines the number of the last control interval
     in a file.  It does so as follows:
     
     1) Find the component which has the highest name (component names are
     "0", "1", "2", ...).  This component, say with name "N", is the last
     component of the file and its last page is the last control interval
     of the file.
     
     2) Get the current length of "N", say M pages / control intervals.
     
     3) The number of components prior to "N" is N - 1 + 1, or N.  The -1
     is to exclude component "N" and the +1 is to include component "0".
     The number of control intervals prior to component "N" is
     N * <p_blocking_factor>. p_blocking_factor is the maximum number of
     control intervals per component.  So calculate the number of the last 
     control interval with the expression: N * <p_blocking_factor> + M.
     
     The reason why we don't just add up the lengths of all the components
     is that we are not calculating the number of control intervals in use.
     We are looking for the number of the last control interval in use.  It
     is very possible that control intervals and even components have been
     freed and are no longer in use, but that does not change the number of 
     the last control interval.
*/

/* HISTORY:
Written by Matthew Pierret, 08/01/84.
     (Extracted from fm_open_.pl1, written by Jeff Ives.)
Modified:
11/16/84 by Matthew Pierret:  Answered audit comments:  declared all builtins,
            used structures in star_structures.incl.pl1 instead of declaring
            them locally.
12/11/84 by Lindsey L. Spratt:  Fixed to set the validation level down to
            get_ring_().
*/

/* format: style2,ind3 */

fm_get_last_ci_num:
   proc (p_file_path_name, p_blocking_factor, p_last_ci_num);


/* START OF DECLARATIONS */

/* Parameter */

      dcl	    p_blocking_factor      fixed bin (17) parm;
      dcl	    p_file_path_name       char (168) parm;
      dcl	    p_last_ci_num	       fixed bin (27) parm;

/* Automatic */

      dcl	    code		       fixed bin (35) init (0);
      dcl	    component_nindex       fixed bin init (0);
      dcl	    component_num	       fixed bin init (0);
      dcl	    entry_idx	       fixed bin init (0);
      dcl	    file_path_name	       char (168);
      dcl	    highest_component_nindex
			       fixed bin init (0);
      dcl	    highest_component_num  fixed bin init (-1);

      dcl	    1 my_status_branch     aligned like status_branch;

      dcl	    saved_level	       fixed bin init (0);

/* Based */

/* Builtin */

      dcl	    (addr, bin, hbound, lbound, null, rtrim, sum, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("fm_get_last_ci_num") char (32) varying internal static options (constant);
      dcl	    NO_ARG	       init ("") char (1) internal static options (constant);
      dcl	    STAR_BRANCHES_ONLY     fixed bin (2) static options (constant) init (2);
      dcl	    CHASE_LINKS	       fixed bin (1) static options (constant) init (1);

/* Entry */

      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    cu_$level_set	       entry (fixed bin);
      dcl	    fm_error_util_$signal  entry options (variable);
      dcl	    get_ring_	       entry () returns (fixed bin (3));
      dcl	    get_system_free_area_  entry () returns (ptr);
      dcl	    hcs_$star_	       entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
      dcl	    hcs_$status_long       entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));

/* External */

      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;

/* END OF DECLARATIONS */
%page;
      file_path_name = p_file_path_name;

      star_names_ptr = null ();
      star_entry_ptr = null ();
      status_area_ptr = null ();
      status_ptr = null ();
      unspec (my_status_branch) = ""b;

      call cu_$level_get (saved_level);

      on cleanup call FINISH ();

      call cu_$level_set (get_ring_ ());

      call hcs_$star_ (file_path_name, "*", STAR_BRANCHES_ONLY, get_system_free_area_ (), star_entry_count,
	 star_entry_ptr, star_names_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code, " Unable to get names matching ^a>*.^s", file_path_name, "");

      do entry_idx = lbound (star_entries, 1) to hbound (star_entries, 1);
         component_nindex = star_entries (entry_idx).nindex;
         component_num = bin (rtrim (star_names (component_nindex)), 17);
         if component_num > highest_component_num
         then
	  do;
	     highest_component_num = component_num;
	     highest_component_nindex = component_nindex;
	  end;
      end;

      if highest_component_nindex = 0
      then call ERROR_RETURN (dm_error_$programming_error, "  No msf components found in ^a.", file_path_name, (NO_ARG));

      call hcs_$status_long (file_path_name, star_names (highest_component_nindex), CHASE_LINKS, addr (my_status_branch),
	 null (), code);
      if code ^= 0
      then call ERROR_RETURN (code, "  Unable to get status for ^a>^a.", file_path_name,
	      star_names (highest_component_nindex));

      if my_status_branch.short.type ^= Segment
      then call ERROR_RETURN (code, "  The branch ^a>^a is not a segment.", file_path_name,
	      star_names (highest_component_nindex));

      p_last_ci_num = highest_component_num * p_blocking_factor + my_status_branch.long.current_length - 1;

      call FINISH ();

      return;
%page;
ERROR_RETURN:
   proc (er_p_code, er_p_message, er_p_arg_1, er_p_arg_2);

      dcl	    er_p_code	       fixed bin (35) parm;
      dcl	    er_p_message	       char (*) parm;
      dcl	    er_p_arg_1	       char (*) parm;
      dcl	    er_p_arg_2	       char (*) parm;

      call fm_error_util_$signal (er_p_code, myname, (FM_ACTION_CANT_RESTART | FM_ACTION_LOG), -1, er_p_message,
	 er_p_arg_1, er_p_arg_2);

   end ERROR_RETURN;


FINISH:
   proc ();

      if saved_level > 0
      then call cu_$level_set (saved_level);
      if star_names_ptr ^= null ()
      then free star_names;
      if star_entry_ptr ^= null ()
      then free star_entries;

   end FINISH;

%page;
%include dm_fm_sub_error_flags;
%page;
%include status_structures;
%page;
%include star_structures;

   end fm_get_last_ci_num;




		    fm_open_by_uid_.pl1             05/06/86  1321.1rew 05/06/86  1257.6       97047



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



/****^  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 to not log a message when attempting to open a file which does not
     exist.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION:

        This module opens a file given a file uid.  The pathname of the
   file is obtained by searching the System Pathname Table (sys_pn_tbl)
   for an entry with the specified file uid.  That pathname is then used to
   open the file in the usual fashion by calling fm_create_open_$open.
   
        There are two entries to this module which differ slightly in the 
   manner they use the sys_pn_tbl.  fm_open_by_uid_$open locks the
   sys_pn_tbl while using it.  fm_open_by_uid$open_after_crash is executed
   in the Data_Management daemon process during crash recovery.  At this time
   no other process can access the sys_pn_tbl, so locking is unnecessary.

        There are also two entries which are used in setting up and 
   eliminating the sys_pn_tbl of a previous Data Management system.
   This is the table used by open_after_crash.
   find_old_uid_pn_table initiates the old sys_pn_tbl.
   end_of_crash_recovery terminates it.
*/

/* HISTORY:
Written by Matthew Pierret, 11/07/84.
  (Copied from fm_combos_, written by Jeffrey Ives.)
Modified:
12/10/84 by Matthew Pierret:  Added declaration of char builtin, corrected 
            initial value of TRUE, and changed to not read p_code in the
            ERROR_RETURN procedure.
01/11/85 by Matthew Pierret:  Corrected calling sequence of dm_log_ call
            in LOG_ERROR_RETURN.  Also made LOG_ERROR_RETURN options(variable)
            removing the need for the ERROR_MESSAGE function.
01/28/85 by Matthew Pierret:  Made LOG_ERROR_RETURN call ERROR_RETURN  so
            that it actually returns from the main procedure.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
05/03/85 by Matthew C. Pierret:  Changed to not log an error message if the
            file does not exist.
*/

/* format: style2,ind3,ll79,^indnoniterdo,indnoniterend */
%page;
fm_open_by_uid_$open:
   procedure (p_file_uid, p_file_oid, p_code);

/* START OF DECLARATIONS */

/* Parameter */

      dcl	    p_dir_path	       char (168) parameter;
      dcl	    p_file_uid	       bit (36) aligned parameter;
      dcl	    p_file_oid	       bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    dir_path	       char (168);
      dcl	    file_dir	       char (168);
      dcl	    file_name	       char (32);
      dcl	    file_path	       char (168);
      dcl	    file_uid	       bit (36) aligned;
      dcl	    must_lock_sys_pn_tbl   bit (1) aligned;
      dcl	    my_file_oid	       bit (36) aligned;
      dcl	    saved_validation_level fixed bin init (-1);
      dcl	    sys_pn_tbl_ptr	       ptr;

/* Based */

/* Builtin */

      dcl	    (addr, length, min, null, substr)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    (
	    MYNAME	       init ("fm_open_by_uid_") char (32)
			       varying,
	    FALSE		       init ("0"b) bit (1) aligned,
	    TRUE		       init ("1"b) bit (1) aligned,
	    NO_ERROR_ARG_1	       init (""b) bit (36) aligned,
	    NO_ERROR_ARG_2	       init ("") char (1),
	    NO_ERROR_ARG_3	       init (""b) bit (36) aligned,
	    NO_ERROR_ARG_4	       init ("") char (1)
	    )		       internal static options (constant);

/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21),
			       fixed bin (35), ptr);
      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    cu_$level_set	       entry (fixed bin);
      dcl	    dm_misc_util_$log      entry options (variable);
      dcl	    expand_pathname_       entry (char (*), char (*), char (*),
			       fixed bin (35));
      dcl	    fm_create_open_$open   entry (char (*), char (*),
			       bit (36) aligned, fixed bin (35));
      dcl	    fm_delete_close_$close entry (bit (36) aligned, fixed bin (35));
      dcl	    fm_sys_pn_tbl_util_$get_path
			       entry (ptr, bit (1) aligned,
			       bit (36) aligned, char (168));
      dcl	    get_ring_	       entry () returns (fixed bin (3));
      dcl	    hcs_$initiate	       entry (char (*), char (*), char (*),
			       fixed bin (1), fixed bin (2), ptr,
			       fixed bin (35));
      dcl	    hcs_$terminate_noname  entry (ptr, fixed bin (35));
      dcl	    ioa_$general_rs	       entry (ptr, fixed bin, fixed bin,
			       char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);

/* External */

      dcl	    fm_data_$old_sys_pn_tbl_ptr
			       ptr ext;
      dcl	    dm_error_$file_uid_arg_null
			       fixed bin (35) ext;
      dcl	    dm_error_$file_uid_not_found
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_old_uidpn_ptr_null
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_uid_fnd_wrong_file
			       fixed bin (35) ext;
      dcl	    error_table_$noentry   fixed bin (35) ext;

/* END OF DECLARATIONS */
%page;
/* open: entry (p_file_uid, p_file_oid, p_code); */

      must_lock_sys_pn_tbl = TRUE;
      sys_pn_tbl_ptr = fm_data_$sys_pn_tbl_ptr;

      go to JOIN;


open_after_crash:
   entry (p_file_uid, p_file_oid, p_code);

      must_lock_sys_pn_tbl = FALSE;
      sys_pn_tbl_ptr = fm_data_$old_sys_pn_tbl_ptr;

      if sys_pn_tbl_ptr = null
      then call LOG_ERROR_RETURN (dm_error_$fm_old_uidpn_ptr_null, "");

      go to JOIN;
%page;
JOIN:
      p_code, code = 0;
      p_file_oid, my_file_oid = ""b;
      file_uid = p_file_uid;

      if file_uid = ""b
      then call ERROR_RETURN (dm_error_$file_uid_arg_null);

      call fm_sys_pn_tbl_util_$get_path (sys_pn_tbl_ptr, must_lock_sys_pn_tbl,
	 file_uid, file_path);

      if file_path = ""
      then call LOG_ERROR_RETURN (dm_error_$file_uid_not_found,
	      " Could not open file with uid ^w.", file_uid);

      call expand_pathname_ (file_path, file_dir, file_name, code);
      if code ^= 0
      then call LOG_ERROR_RETURN (code,
	      " Could not expand pathname ^a, the path in ^a for file with uid ^w.",
	      file_path, fm_data_$sys_pn_tbl_name, file_uid);

      my_file_oid = ""b;

      on cleanup call FINISH ();

      call fm_create_open_$open (file_dir, file_name, my_file_oid, code);
      if my_file_oid = ""b
      then if code = error_table_$noentry
	 then call ERROR_RETURN (code);
	 else call LOG_ERROR_RETURN (code,
		 " Unable to open file ^a, found in ^a with uid ^w.",
		 file_path, fm_data_$sys_pn_tbl_name, file_uid);
      else p_code = code;

      if file_uid
	 ^= file_access_table
	 .e (addr (my_file_oid) -> file_oid.file_access_table_idx).uid
      then call LOG_ERROR_RETURN (dm_error_$fm_uid_fnd_wrong_file,
	      " The file with uid ^w is ^a, but it has a uid of ^w in ^a.",
	      file_access_table
	      .e (addr (my_file_oid) -> file_oid.file_access_table_idx).uid,
	      file_path, file_uid, fm_data_$sys_pn_tbl_name);

      p_file_oid = my_file_oid;

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

      dcl	    er_p_code	       fixed bin (35) parameter;

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

   end ERROR_RETURN;

LOG_ERROR_RETURN:
   proc options (variable);

      dcl	    ler_arg_list_ptr       ptr;
      dcl	    ler_code	       fixed bin (35) based (ler_code_ptr);
      dcl	    ler_code_ptr	       ptr;
      dcl	    ler_code_len	       fixed bin (21);
      dcl	    ler_message_len	       fixed bin (21);
      dcl	    ler_message_buffer     char (1024);
      dcl	    (DONT_PAD, NO_NEW_LINE)
			       init ("0"b) bit (1) aligned;

      call cu_$arg_list_ptr (ler_arg_list_ptr);
      call cu_$arg_ptr_rel (1, ler_code_ptr, ler_code_len, (0),
	 ler_arg_list_ptr);

      call ioa_$general_rs (ler_arg_list_ptr, 2, 3, ler_message_buffer,
	 ler_message_len, DONT_PAD, NO_NEW_LINE);
      call dm_misc_util_$log (LOG_SV, ler_code, MYNAME,
	 substr (ler_message_buffer, 1,
	 min (length (ler_message_buffer), ler_message_len)));
      call ERROR_RETURN (ler_code);

   end LOG_ERROR_RETURN;

FINISH:
   proc ();

      if my_file_oid ^= ""b
      then call fm_delete_close_$close (my_file_oid, (0));

   end FINISH;

%page;
/* DESCRIPTION OF find_old_uid_pn_table 

          This entry point is called at the beginning of crash recovery in 
     order to set a pointer to the old uid/pathname table so that 
     open_by_uid_after_crash can be called by rollback.
*/

find_old_uid_pn_table:
   entry (p_dir_path, p_code);

      dir_path = p_dir_path;
      my_file_oid = ""b;
      p_code, code = 0;

      call cu_$level_get (saved_validation_level);
      on cleanup call cu_$level_set (saved_validation_level);
      call cu_$level_set (get_ring_ ());

      call hcs_$initiate (dir_path, fm_data_$sys_pn_tbl_name, "", 0, 0,
	 fm_data_$old_sys_pn_tbl_ptr, code);

      call cu_$level_set (saved_validation_level);

      if fm_data_$old_sys_pn_tbl_ptr = null ()
      then call LOG_ERROR_RETURN (code, " Unable to initiate ^a>^a.", dir_path,
	      fm_data_$sys_pn_tbl_name);

      return;
%page;
/* DESCRIPTION OF end_of_crash_recovery :

          This entry point is called after all rollbacks are complete.  It 
     terminates the pointer to the old uid/pathname table so that it can be 
     deleted.
*/

end_of_crash_recovery:
   entry (p_code);

      p_code, code = 0;
      my_file_oid = ""b;

      if fm_data_$old_sys_pn_tbl_ptr = null ()
      then call LOG_ERROR_RETURN (dm_error_$fm_old_uidpn_ptr_null, "");

      call cu_$level_get (saved_validation_level);
      on cleanup call cu_$level_set (saved_validation_level);
      call cu_$level_set (get_ring_ ());

      call hcs_$terminate_noname (fm_data_$old_sys_pn_tbl_ptr, code);

      call cu_$level_set (saved_validation_level);

      if code ^= 0
      then call LOG_ERROR_RETURN (code,
	      " Unable to terminate ^a with pointer ^p.",
	      fm_data_$sys_pn_tbl_name, fm_data_$old_sys_pn_tbl_ptr);

      return;
%page;
%include dm_fm_file_oid;
%page;
%include dm_fm_file_access_info;
%page;
%include dm_fm_file_access_tbl;
%page;
%include dm_fm_sys_pn_tbl;
%page;
%include dm_log_sv_codes;

   end fm_open_by_uid_$open;




		    fm_per_process_init_.pl1        03/06/85  0802.6re  03/05/85  0759.2       28170



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

/* DESCRIPTION:

     This routine is called by the first reference trap on fm_inner_ring_tv_
     It initializes the values of fm_data_ upon which file_manager_ depends
     Most file_manager_ primitives cannot be executed validly until after this
     routine has run.
*/

/* HISTORY:

Written by Matthew, 06/25/84.
   (Moved from fm_open_.pl1.)
Modified:
11/16/84 by Matthew Pierret:  Answered audit comments: replaced fm_data_$me
            with MYNAME constant, removed useless rv variable.
11/22/84 by Lee A. Newcomb:  Removed obsolete dm_common_init_ references.
*/

/* format: style2,ind3 */
%page;
fm_per_process_init_:
   proc ();

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

      dcl	    code		       fixed bin (35) init (0);
      dcl	    saved_validation_level fixed bin init (8);

/* Based */
/* Builtin */

      dcl	    (null, unspec)	       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */


      dcl	    MYNAME	       init ("fm_per_process_init_") char (32) varying internal static options (constant);

/* Entry */

      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    cu_$level_set	       entry (fixed bin);
      dcl	    dm_per_system_$initiate
			       entry (char (*), char (*), ptr);
      dcl	    fm_put_$init_txn_tbl   entry (fixed bin (35));
      dcl	    get_ring_	       entry () returns (fixed bin (3));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$fm_bad_sys_pn_tbl_ver
			       fixed bin (35) ext;

/* END OF DECLARATIONS */
%page;
      call cu_$level_get (saved_validation_level);
      on cleanup call cu_$level_set (saved_validation_level);
      call cu_$level_set (get_ring_ ());

      call dm_per_system_$initiate (fm_data_$sys_pn_tbl_name, "", fm_data_$sys_pn_tbl_ptr);
						/* dm_per_system_ will return a non-null pointer */

      if sys_pn_tbl.h.version ^= SYS_PN_TBL_VERSION_1
      then call sub_err_ (dm_error_$fm_bad_sys_pn_tbl_ver, MYNAME, ACTION_CANT_RESTART, null (), (0),
	      "  The version number in ^a was ^w.  It should have been ^w.", fm_data_$sys_pn_tbl_name,
	      sys_pn_tbl.h.version, SYS_PN_TBL_VERSION_1);

      allocate file_access_table;

      unspec (file_access_table) = ""b;
      file_access_table.h.version = FILE_ACCESS_TABLE_VERSION_1;
      file_access_table.h.post_transaction_actions = -1;

      call fm_put_$init_txn_tbl (code);
      if code ^= 0
      then call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), (0), " returned by fm_put_$init_txn_tbl.");

      call cu_$level_set (saved_validation_level);

      return;
%page;
%include dm_fm_file_access_info;
%page;
%include dm_fm_file_access_tbl;
%page;
%include dm_fm_sys_pn_tbl;
%page;
%include sub_err_flags;
   end fm_per_process_init_;




		    fm_prepare_to_copy_.pl1         03/06/85  0802.6re  03/05/85  0759.2      111060



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

/* DESCRIPTION: 

          This procedure locks the specified file in preparation for
     copying the file and returns information to the caller needed
     to copy the file.  This information includes a file_create_info
     structure for creating the new copy of the file and the length
     of the file.  The file_create_info information is found in
     the file's file_attributes.

          Error handling for this procedure is of note.  There is one
     return statement in this procedure, preceded by the MAIN_RETURN label.
     If no error is encountered, this return statement is reached from
     the previous statement.  In all error cases, control is transferred
     from the ERROR_RETURN procedure to the MAIN_RETURN label to reach
     the return statement.  ERROR_RETURN is called by this procedure
     when an error is encountered which does not need to be logged in
     the dm_system_log.  Generally these are errors which are completely 
     described by the error code.  ERROR_RETURN is also called by the
     fm_sub_error_ on unit.  If the fm_sub_error_ on unit is invoked,
     the error has already been logged, so should not be logged again.
     Errors which have additional information are logged by calling
     LOG_ERROR_RETURN.  LOG_ERROR_RETURN and possibly fm_get_last_ci_num
     signal fm_sub_error_ after logging the error, causing the call to
     ERROR_RETURN via the on unit.
*/

/* HISTORY:
Written by Matthew Pierret, 08/01/84.
     (Extracted from fm_open_.pl1, written by Jeff Ives.)
Modified:
11/13/84 by Matthew Pierret:  Answered audit comments: Added check for 
            saved_validation_level>0 before resetting level.  Added call to
            FINISH in non-error case.  Made to make use of automatic
            file_create_info_ptr variable instead of always using the 
            parameter.  Changed ERROR_RETURN to LOG_ERROR_RETURN,
            RETURN to ERROR_RETURN.  Added description of error handling.
12/06/84 by Matthew Pierret:  Changed to use dm_error_$no_current_transaction 
            instead of dm_error_$fm_no_current_txn. Added must_be_zero
            component in my_ci_parts.
12/17/84 by Matthew Pierret:  Changed to use new file_access_info state 
            variables.
*/

/* format: style2,ind3 */

fm_prepare_to_copy_:
   procedure (p_file_oid, p_file_create_info_ptr, p_last_ci_num, p_code);

/* START OF DECLARATIONS */

/* Parameter */

      dcl	    p_file_oid	       bit (36) aligned parameter;
      dcl	    p_file_create_info_ptr ptr parameter;
      dcl	    p_last_ci_num	       fixed bin (27) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35) init (0);
      dcl	    dir_path	       char (168);
      dcl	    entry_name	       char (32);
      dcl	    full_path_name	       char (168);
      dcl	    saved_validation_level fixed bin init (0);
      dcl	    seg_0_ptr	       ptr init (null ());
      dcl	    1 my_create_info       aligned like file_create_info;
      dcl	    1 my_ci_part	       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_file_access_info  aligned like file_access_info;
      dcl	    1 my_file_attributes   aligned like file_attributes;
      dcl	    1 my_file_oid	       aligned like file_oid;

/* Based */

/* Builtin */

      dcl	    (addr, baseptr, char, fixed, lbound, null, rtrim, substr, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;
      dcl	    fm_sub_error_	       condition;

/* Constant */

      dcl	    MYNAME	       init ("fm_prepare_to_copy_") char (32) varying internal static options (constant);
      dcl	    LOCK_WAIT_TIME	       init (1e9) fixed bin (71) internal static options (constant);

/* Entry */

      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    cu_$level_set	       entry (fixed bin);
      dcl	    expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
      dcl	    fm_error_util_$get_code
			       entry () returns (fixed bin (35));
      dcl	    fm_error_util_$signal  entry options (variable);
      dcl	    fm_get_$internal_get   entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    fm_get_last_ci_num     entry (char (168), fixed bin, fixed bin (27));
      dcl	    get_ring_	       entry () returns (fixed bin (3));
      dcl	    hcs_$fs_get_path_name  entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
      dcl	    lock_manager_$lock     entry (bit (36) aligned, fixed bin (27), fixed bin, fixed bin (71), fixed bin,
			       fixed bin (35));

/* External */

      dcl	    dm_data_$current_txn_id
			       bit (36) aligned ext;

      dcl	    dm_error_$bad_file_atrs_length
			       fixed bin (35) ext;
      dcl	    dm_error_$bad_file_atrs_uid
			       fixed bin (35) ext;
      dcl	    dm_error_$bad_file_atrs_ver
			       fixed bin (35) ext;
      dcl	    dm_error_$bad_file_cr_info_ver
			       fixed bin (35) ext;
      dcl	    dm_error_$bad_file_oid fixed bin (35) ext;
      dcl	    dm_error_$file_doesnt_exist
			       fixed bin (35) ext;
      dcl	    dm_error_$no_current_transaction
			       fixed bin (35) ext;

/* END OF DECLARATIONS */
%page;
      on fm_sub_error_ call ERROR_RETURN (fm_error_util_$get_code ());

      unspec (my_file_oid) = p_file_oid;
      file_create_info_ptr = p_file_create_info_ptr;
      if file_create_info.version ^= FILE_CREATE_INFO_VERSION_2
      then call LOG_ERROR_RETURN (dm_error_$bad_file_cr_info_ver, "  Supplied version was ^a.  It should have been ^a.",
	      (file_create_info.version), (FILE_CREATE_INFO_VERSION_2));

/* Get file access info. */

      if my_file_oid.file_access_table_idx < lbound (file_access_table.e, 1)
	 | my_file_oid.file_access_table_idx > file_access_table.h.last_entry
      then call ERROR_RETURN (dm_error_$bad_file_oid);

      my_file_access_info = file_access_table.e (my_file_oid.file_access_table_idx);

      if my_file_access_info.state.entry_state = FILE_ACCESS_INFO_NOT_IN_USE
      then call ERROR_RETURN (dm_error_$bad_file_oid);

      if my_file_access_info.state.file_state ^= FILE_EXISTS
      then call ERROR_RETURN (dm_error_$file_doesnt_exist);

      if my_file_access_info.opens = 0
      then call ERROR_RETURN (dm_error_$bad_file_oid);

      if my_file_oid.uid_tail ^= substr (my_file_access_info.uid, 19, 18)
      then call ERROR_RETURN (dm_error_$bad_file_oid);

      if my_file_access_info.seg_0_num = ""b
      then call ERROR_RETURN (dm_error_$file_doesnt_exist);

      call cu_$level_get (saved_validation_level);
      on cleanup call FINISH;
      call cu_$level_set (get_ring_ ());

/* Get the path name of the file given the segment number of the first component */

      seg_0_ptr = baseptr (my_file_access_info.seg_0_num);

      call hcs_$fs_get_path_name (seg_0_ptr, full_path_name, (0), entry_name, code);
      if code ^= 0
      then call LOG_ERROR_RETURN (code, "^/Unable to get pathname of segment ^a.^s",
	      char (fixed (my_file_access_info.seg_0_num)), "");

      call expand_pathname_ (full_path_name, dir_path, entry_name, code);
      if code ^= 0
      then call ERROR_RETURN (code);


      if my_file_access_info.integrity_switches.transaction
      then
         do;
	  if dm_data_$current_txn_id = ""b
	  then call ERROR_RETURN (dm_error_$no_current_transaction);
         end;

      if my_file_access_info.integrity_switches.lock
      then
         do;
	  call lock_manager_$lock (my_file_access_info.uid, LOCK_ENTIRE_FILE, LOCK_MODE_X, LOCK_WAIT_TIME, (0), code);
	  if code ^= 0
	  then call LOG_ERROR_RETURN (code, "  Unable to lock file ^a, with uid ^a, exclusively.", full_path_name,
		  char (my_file_access_info.uid));
         end;

/* Get the attributes stored in the file. */

      unspec (my_file_attributes) = ""b;
      file_attributes_ptr = addr (my_file_attributes);
      my_ci_part.part (1).offset_in_bytes = CI_0_ADDRESSABLE_LENGTH;
      my_ci_part.part (1).length_in_bytes = CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH;
      my_ci_part.part (1).local_ptr = file_attributes_ptr;

      call fm_get_$internal_get (unspec (my_file_oid), 0, addr (my_ci_part), code);
      if code ^= 0
      then call ERROR_RETURN (code);

      if file_attributes.length_of_attributes ^= CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH - 2
      then call LOG_ERROR_RETURN (dm_error_$bad_file_atrs_length,
	      "  The file_attributes length " || rtrim (full_path_name) || " is ^a.  It should be ^a.",
	      char (file_attributes.length_of_attributes), char (CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH - 2));

      if file_attributes.version ^= FILE_ATTRIBUTES_VERSION_2
      then call LOG_ERROR_RETURN (dm_error_$bad_file_atrs_ver,
	      "  The version of the file attributes is ^a.  It should be ^a.", (file_attributes.version),
	      (FILE_ATTRIBUTES_VERSION_2));

      if file_attributes.unique_id ^= my_file_access_info.uid
      then call LOG_ERROR_RETURN (dm_error_$bad_file_atrs_uid,
	      "  The unique identifier in the file attributes of " || rtrim (full_path_name)
	      || " is ^a.  The UID in CI 0 is ^a.", char (file_attributes.unique_id), char (my_file_access_info.uid));

/* Copy the file attributes into my_create_info. */

      unspec (my_create_info) = ""b;
      my_create_info.version = FILE_CREATE_INFO_VERSION_2;
      my_create_info.ci_size_in_bytes = file_attributes.ci_size_in_bytes;
      my_create_info.blocking_factor = file_attributes.blocking_factor;
      my_create_info.protected = file_attributes.flags.protected;
      my_create_info.no_concurrency = file_attributes.flags.no_concurrency;
      my_create_info.no_rollback = file_attributes.flags.no_rollback;
      my_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX) = file_attributes.ring_brackets.write;
      my_create_info.ring_brackets (FCI_READ_BRACKET_IDX) = file_attributes.ring_brackets.read;

/* Notice that there is no check to see if the caller's validation level     */
/* is within the file_attributes.ring_bracket.read bracket.  This is because */
/* the caller must have been within the read bracket to open the file.  In   */
/* the future, if changable ring brackets are implemented, a check should be */
/* added here in case the ring brackets were lowered since the time of open. */

/* Copy the file_create_info from automatic storage to the caller's buffer. */

      file_create_info = my_create_info;

/* Determine the number of the last control interval. */

      call fm_get_last_ci_num (full_path_name, (my_file_access_info.blocking_factor), p_last_ci_num);

      p_code = 0;
      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 ();
      go to MAIN_RETURN;

   end ERROR_RETURN;


LOG_ERROR_RETURN:
   proc (ler_p_code, ler_p_error_message, ler_p_error_message_argument_1, ler_p_error_message_argument_2);

      dcl	    ler_p_code	       fixed bin (35) parameter;
      dcl	    (ler_p_error_message, ler_p_error_message_argument_1, ler_p_error_message_argument_2)
			       char (*) parameter;

      call fm_error_util_$signal (ler_p_code, MYNAME, (FM_ACTION_CANT_RESTART | FM_ACTION_LOG), LOG_SV,
	 ler_p_error_message, ler_p_error_message_argument_1, ler_p_error_message_argument_2);

   end LOG_ERROR_RETURN;


FINISH:
   proc ();

      if saved_validation_level > 0
      then call cu_$level_set (saved_validation_level);

   end FINISH;
%page;
%include dm_file_create_info;
%page;
%include dm_fm_file_oid;
%page;
%include dm_fm_file_access_info;
%page;
%include dm_fm_file_access_tbl;
%page;
%include dm_fm_file_attributes;
%page;
%include dm_fm_sub_error_flags;
%page;
%include dm_lock_modes;
%page;
%include dm_ci_lengths;
%page;
%include dm_ci_parts;
%page;
%include dm_log_sv_codes;

   end fm_prepare_to_copy_;




		    fm_put_.pl1                     04/02/87  1316.2rew 04/02/87  1258.7      501723



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

/* DESCRIPTION

   This module implements the control interval update operations of the
   file manager.


NON-FAILING AUDIT COMMENTS NOT YET ADDRESSED:
   
   This module should be re-written.
*/

/* HISTORY:

Written by Bensoussan-Ives, 06/22/82.
   01/28/82 by Andre Bensoussan: Specification and design.
   06/22/82 by Jeffery D. Ives: Design and coding.
Modified:
10/05/83 by Jeffrey D. Ives: Added initial implementation of lock advice.
01/25/84 by Jeffrey D. Ives: Fixed lock advice to make sure that, when the
	  advice is changed, the new advice is passed on to the lock manager.
05/23/84 by R. Michael Tague:  Added simple_put and fm_put_.
06/07/84 by Lee Baldwin:  Renamed a bunch of dm_error_ codes.
07/26/84 by Matthew Pierret:  Changed to check extended ring brackets.
            Also, as an aside, made extensive re-modularizations, name changes,
            added RETURN procedure instead of all of those go to statements.
11/01/84 by Matthew Pierret: Answered audit comments: removed unnecessary
            copy of p_file_oid after PUT_JOIN label; removed the un-used entry
            internal_get_uid ; removed "signal error" - the cases in which
            the signal was attempted were not possible ; changed to use
            dm_error_$no_current_transaction instead of $fm_no_current_txn ;
            moved external entry declarations two the main procedure ; liked
            my_ci_parts.part and single_ci_part.part to ci_parts.part.
            Removed the un-used undo entry. It is now in fm_do_$undo.
            Removed declared but un-used variables. Removed dm_fm_file_oid
            from GET_ACCESS_INFO, instead declaring gai_my_file_oid liked to
            the file_oid in dm_fm_file_oid.incl.pl1 in the main procedure.
            Made to use dm_ci_header.incl.pl1 and dm_ci_constants.incl.pl1.
12/06/84 by Matthew C. Pierret:  Added must_be_zero component to my_ci_parts
            and single_ci_part structures.  Fixed to not inadvertently re-read
            the p_file_oid parameter in the free entry.  Changed local
            flush_consec structure to fc_flush_consec, liked on flush_consec
            in the include file flush_structures.  Removed comment surrounding
            form-feed.
12/17/84 by Matthew C. Pierret:  Changed to use new file_access_info state
            variables. 
02/01/85 by Matthew C. Pierret:  Changed to return dm_error_$file_was_deleted
            instead of error_table_$invalidsegno if the latter is returned
            from one the hcs_$flush_* entries.
02/06/85 by S. Cox: Added transaction_bj_full_ handler for the put entries.
03/08/85 by S. Cox: Added TRANSACTION_BJ_FULL_HANDLER invoked by nonlocal goto.
03/14/85 by R. Michael Tague: Added $postcommit_increment.
03/21/85 by S. Cox: TRANSACTION_BJ_FULL_HANDLER: Add revert of txn_bj_full_
03/21/85 by R. Michael Tague: Added protected file check to
            $postcommit_increment.
04/11/85 by Lindsey L. Spratt:  Fixed to normally complete in FLUSH and
            FLUSH_MOD_PAGES (when error_table_$invalidsegno is encountered)
            before calling RETURN(dm_error_$file_was_deleted).
04/24/85 by Matthew Pierret:  Changed FLUSH_MOD_PAGES to not return
            dm_error_$file_was_deleted (or any error code) if the operation
            is an unput operation and error_table_$invalid_segno is
            encountered.
05/03/85 by Matthew Pierret:  Changed the proc_txn_tbl version to char (8) from
            bit(36)aligned with the value PROC_TXN_TBL_VERSION_2. Changed
            proc_txn to maintain parallel arrays of modified pages and file
            uids of the files to which the modified pages belong. Also changed
            to insertion algorithm to do a binary search, changing
            proc_txn.low_idx and proc_txn.high_idx to simply
            proc_txn.last_entry.
            Added fm_put_$discard_file_flush_list, which is to be called when
            deleting a file to "forget" modified pages in the file.  This
            should eliminate error_table_$invalidsegno and $dirseg errors.
*/


/****^  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, arranged to pass along the element_id of the
     key_count_array that we saved in cm_postcommit_increment so that we can
     use it at post_commit time if necessary. We save it in my_postcommit_info.
                                                   END HISTORY COMMENTS */



/* format: style2,ind3 */

fm_put_$init_txn_tbl:
   proc (p_code);

/* START OF DECLARATIONS */

/* Parameters */

      dcl	    p_ci_num	       fixed bin (27) parm;
      dcl	    p_ci_parts_ptr	       ptr parm;
      dcl	    p_single_part_length   fixed bin (17) parm;
      dcl	    p_single_part_offset   fixed bin (17) parm;
      dcl	    p_single_part_ptr      ptr parm;
      dcl	    p_code	       fixed bin (35) parm;
      dcl	    p_first_ci	       fixed bin (27) parm;
      dcl	    p_lock_mode	       fixed bin parm;
      dcl	    p_number_of_ci	       fixed bin (27) parm;
      dcl	    p_file_oid	       bit (36) aligned parm;
      dcl	    p_increment_info_ptr   ptr parm;
      dcl	    p_transaction_id       bit (36) aligned parm;
      dcl	    p_transaction_index    fixed bin parm;
      dcl	    p_file_uid	       bit (36) aligned parm;


/* Automatic */

      dcl	    ci_num	       fixed bin (27);
      dcl	    code		       fixed bin (35);
      dcl	    component_num	       fixed bin;
      dcl	    first_ci	       fixed bin (27);
      dcl	    last_ci	       fixed bin (28);
      dcl	    lock_mode	       fixed bin;
      dcl	    my_file_oid	       aligned bit (36);
      dcl	    my_part_idx	       fixed bin;
      dcl	    n_ci		       fixed bin (27);
      dcl	    number_of_addressable_bytes
			       fixed bin;
      dcl	    operation_is_unput     bit aligned init ("0"b);
      dcl	    page_num	       fixed bin (8);
      dcl	    part_idx	       fixed bin;
      dcl	    part_length	       fixed bin;
      dcl	    part_offset	       fixed bin;
      dcl	    some_ci_already_allocated
			       bit aligned;
      dcl	    some_ci_already_free   bit aligned;
      dcl	    transaction_id	       bit (36) aligned;
      dcl	    transaction_index      fixed bin;

      dcl	    dtcm		       fixed bin (71);
      dcl	    my_ci_id	       fixed bin (71);
      dcl	    my_ci_stamp	       fixed bin (71);
      dcl	    part_ptr	       ptr;


      dcl	    1 seg		       aligned based,
	      2 pages	       (0:254),
	        3 double_words     (512) fixed bin (71);

      dcl	    part_buffer	       char (part_length) based (part_ptr);

      dcl	    my_part_ptrs	       (8) ptr;

      dcl	    1 my_ci_parts	       aligned,
	      2 number_of_parts    fixed bin init (0),
	      2 must_be_zero       fixed bin init (0),
	      2 part	       (8) like ci_parts.part;

      dcl	    1 single_ci_part       aligned,
	      2 number_of_parts    fixed bin (17) init (1),
	      2 must_be_zero       fixed bin init (0),
	      2 part	       (1) like ci_parts.part;

      dcl	    1 effective_integrity_switches
			       aligned like file_access_info.integrity_switches;

      dcl	    1 my_postcommit_info   aligned like increment_postcommit_info;
      dcl	    1 my_file_access_info  aligned like file_access_info;
      dcl	    1 my_signal_structure  aligned like condition_info_header;

/* Based */
/* Builtin */

      dcl	    (addr, baseno, baseptr, bin, clock, divide, hbound, lbound, max, min, multiply, null, string, substr,
	    unspec)	       builtin;

/* Conditions */

      dcl	    (cleanup, transaction_bj_full_)
			       condition;

/* Constants */

      dcl	    BYTES_PER_WORD	       init (4) fixed bin internal static options (constant);
      dcl	    FOR_UNPUT	       init ("1"b) bit (1) aligned internal static options (constant);
      dcl	    NOT_FOR_UNPUT	       init ("0"b) bit (1) aligned internal static options (constant);
      dcl	    ERROR_FREE	       init (0) fixed bin (35) internal static options (constant);
      dcl	    NO_TRANSACTION	       init (""b) bit (36) aligned internal static options (constant);
      dcl	    (
	    NULL_INTEGRITY_SWITCHES
			       init (1),
	    VANILLA_WRITE_INTEGRITY_SWITCHES
			       init (2),
	    UNPUT_INTEGRITY_SWITCHES
			       init (3),
	    UNPROTECTED_INTEGRITY_SWITCHES
			       init (4)
	    )		       fixed bin internal static options (constant);
      dcl	    LOCK_WAIT_TIME	       init (1e9) fixed bin (71) internal static options (constant);

/* External Variables */

      dcl	    dm_data_$current_txn_id
			       bit (36) aligned ext;
      dcl	    dm_data_$current_txn_index
			       fixed bin ext;
      dcl	    sys_info$data_management_ringno
			       fixed bin ext;
      dcl	    error_table_$bad_subr_arg
			       fixed bin (35) ext;
      dcl	    error_table_$invalidsegno
			       fixed bin (35) ext;
      dcl	    error_table_$no_w_permission
			       fixed bin (35) ext;
      dcl	    error_table_$noentry   fixed bin (35) ext;
      dcl	    error_table_$not_dm_ring
			       fixed bin (35) ext;
      dcl	    dm_error_$bad_file_oid fixed bin (35) ext;
      dcl	    dm_error_$bj_journal_full
			       fixed bin (35) ext;
      dcl	    dm_error_$ci_already_allocated
			       fixed bin (35) ext;
      dcl	    dm_error_$ci_already_free
			       fixed bin (35) ext;
      dcl	    dm_error_$ci_bad_hdr_id_num
			       fixed bin (35) ext;
      dcl	    dm_error_$ci_bad_hdr_size_code
			       fixed bin (35) ext;
      dcl	    dm_error_$ci_bad_hdr_uid
			       fixed bin (35) ext;
      dcl	    dm_error_$ci_bad_stamp_ver
			       fixed bin (35) ext;
      dcl	    dm_error_$ci_num_oob   fixed bin (35) ext;
      dcl	    dm_error_$ci_num_parts_neg
			       fixed bin (35) ext;
      dcl	    dm_error_$ci_parts_oob fixed bin (35) ext;
      dcl	    dm_error_$file_doesnt_exist
			       fixed bin (35) ext;
      dcl	    dm_error_$file_must_be_protected
			       fixed bin (35) ext;
      dcl	    dm_error_$file_was_deleted
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_bad_inc_info_ver
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_bad_proc_txn_tbl_ver
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_cant_free_ci_0
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_first_ci_neg
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_num_ci_neg
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_old_txn_not_flushed
			       fixed bin (35) ext;
      dcl	    dm_error_$lock_invalid_mode
			       fixed bin (35) ext;
      dcl	    dm_error_$no_current_transaction
			       fixed bin (35) ext;



/* Entry */

      dcl	    continue_to_signal_    entry (fixed bin (35));
      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    cu_$level_set	       entry (fixed bin);
      dcl	    dm_hcs_$set_force_write_limit
			       entry (fixed bin, fixed bin (35));
      dcl	    get_ring_	       entry () returns (fixed bin (3));
      dcl	    hcs_$flush_consecutive_pages
			       entry (ptr, fixed bin (35));
      dcl	    hcs_$flush_pages       entry (ptr, fixed bin (35));

      dcl	    before_journal_manager_$flush_transaction
			       entry (bit (36) aligned, fixed bin, fixed bin (35));
      dcl	    before_journal_manager_$write_before_image
			       entry (bit (36) aligned, bit (36) aligned, fixed bin (27), ptr, fixed bin (71),
			       fixed bin (35));
      dcl	    before_journal_manager_$write_fm_postcommit_handler
			       entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (21), fixed bin (35));
      dcl	    hcs_$fs_get_path_name  entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
      dcl	    hcs_$set_synchronized_sw
			       entry (char (*), char (*), bit aligned, fixed bin (35));
      dcl	    ioa_$rsnnl	       entry () options (variable);
      dcl	    lock_manager_$lock     entry (bit (36) aligned, fixed bin (27), fixed bin, fixed bin (71), fixed bin,
			       fixed bin (35));
      dcl	    msf_manager_$msf_get_ptr
			       entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
      dcl	    signal_	       entry () options (variable);
      dcl	    transaction_manager_$abort_txn
			       entry (bit (36) aligned, fixed bin (35));

/* END OF DECLARATIONS */
%page;

/*
init_txn_tbl:
     entry (p_code);
*/

      call INIT;

      call TXN_INIT_PROC_DATA;

      call RETURN (ERROR_FREE);

/* Effective end of fm_put_$init_txn_tbl */


get_uid:
   entry (p_file_oid, p_file_uid, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);

      p_file_uid = file_access_info.uid;

      call RETURN (ERROR_FREE);

/* Effective end of fm_put_$get_uid */
%page;
allocate:
   entry (p_file_oid, p_first_ci, p_number_of_ci, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (VANILLA_WRITE_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);

      first_ci = p_first_ci;
      n_ci = p_number_of_ci;

      call CHECK_CI_RANGE (first_ci, n_ci, last_ci);

      if effective_integrity_switches.lock
      then
         do;
	  do ci_num = first_ci to last_ci;
	     call LOCK_EXCLUSIVELY (ci_num, transaction_id, addr (my_file_oid) -> file_oid.file_access_table_idx);
	  end;
         end;

      some_ci_already_allocated = "0"b;

      do ci_num = first_ci to last_ci;
         component_num = divide (ci_num, file_access_info.blocking_factor, 27);

         call MAKE_SEG_PTR (component_num, ci_ptr, addr (my_file_oid) -> file_oid.file_access_table_idx,
	    (effective_integrity_switches.bj));

         page_num = ci_num - multiply (component_num, file_access_info.blocking_factor, 27);
         ci_ptr = addr (ci_ptr -> pages (page_num));

         if ci.trailer.stamp ^= 0
         then some_ci_already_allocated = "1"b;
         else
	  do;
	     call BASIC_ALLOCATE;

	     if effective_integrity_switches.transaction
	     then call TXN_REMEMBER_MOD_PAGE;

	     if effective_integrity_switches.aj
	     then
	        do;
	        end;
	  end;
      end;

      if some_ci_already_allocated
      then call RETURN (dm_error_$ci_already_allocated);

      call RETURN (ERROR_FREE);


/* Effective end of fm_put_$allocate */
%page;
free:
   entry (p_file_oid, p_first_ci, p_number_of_ci, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (VANILLA_WRITE_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);

      first_ci = p_first_ci;
      n_ci = p_number_of_ci;

      if first_ci = 0
      then call RETURN (dm_error_$fm_cant_free_ci_0);

      call CHECK_CI_RANGE (first_ci, n_ci, last_ci);

      if effective_integrity_switches.lock
      then
         do;
	  do ci_num = first_ci to last_ci;
	     call LOCK_EXCLUSIVELY (ci_num, transaction_id, addr (my_file_oid) -> file_oid.file_access_table_idx);
	  end;
         end;

      if effective_integrity_switches.bj
      then
         do;
	  single_ci_part.part (1).offset_in_bytes = 0;
	  single_ci_part.part (1).length_in_bytes = CI_ADDRESSABLE_LENGTH;

	  do ci_num = last_ci to first_ci by -1;
	     component_num = divide (ci_num, file_access_info.blocking_factor, 27);

	     call GET_SEG_PTR (component_num, ci_ptr, addr (my_file_oid) -> file_oid.file_access_table_idx);

	     if ci_ptr ^= null ()
	     then
	        do;
		 page_num = ci_num - multiply (component_num, file_access_info.blocking_factor, 27);
		 ci_ptr = addr (ci_ptr -> seg.pages (page_num));

		 if ci.trailer.stamp ^= 0 & unspec (ci.addressable_bytes) ^= ""b
		 then
		    do;
		       on transaction_bj_full_ goto TRANSACTION_BJ_FULL_HANDLER;
		       single_ci_part.part (1).local_ptr = addr (ci.addressable_bytes);
		       call before_journal_manager_$write_before_image (file_access_info.uid, my_file_oid, ci_num,
			  addr (single_ci_part), dtcm, code);
		       if code ^= 0
		       then call RETURN (code);
		    end;
	        end;
	  end;

	  call before_journal_manager_$flush_transaction (transaction_id, transaction_index, code);
	  if code ^= 0
	  then call RETURN (code);
         end;

      some_ci_already_free = "0"b;

      do ci_num = last_ci to first_ci by -1;
         component_num = divide (ci_num, file_access_info.blocking_factor, 27);

         call GET_SEG_PTR (component_num, ci_ptr, addr (my_file_oid) -> file_oid.file_access_table_idx);

         if ci_ptr = null ()
         then some_ci_already_free = "1"b;
         else
	  do;
	     page_num = ci_num - multiply (component_num, file_access_info.blocking_factor, 27);
	     ci_ptr = addr (ci_ptr -> seg.pages (page_num));

	     if ci.trailer.stamp = 0
	     then some_ci_already_free = "1"b;

	     if unspec (ci) ^= ""b
	     then
	        do;
		 ci.trailer.stamp = 0;
		 unspec (ci) = ""b;

		 if effective_integrity_switches.transaction
		 then call TXN_REMEMBER_MOD_PAGE;

		 if effective_integrity_switches.aj
		 then
		    do;
		    end;
	        end;
	  end;
      end;

      if some_ci_already_free
      then call RETURN (dm_error_$ci_already_free);
      else call RETURN (ERROR_FREE);


/* Effective end of fm_put_$free */
%page;
internal_put:
   entry (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (VANILLA_WRITE_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      ci_parts_ptr = p_ci_parts_ptr;
      ci_num = p_ci_num;

      number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;

      go to PUT_JOIN;



unput:
   entry (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code);

      operation_is_unput = "1"b;

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (UNPUT_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      call TXN_DONT_FLUSH_BJ;

      ci_parts_ptr = p_ci_parts_ptr;
      ci_num = p_ci_num;

      number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;

      go to PUT_JOIN;



put_journal:
   entry (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (UNPROTECTED_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);

      ci_parts_ptr = p_ci_parts_ptr;
      ci_num = p_ci_num;

      if ci_num = 0
      then number_of_addressable_bytes = CI_0_ADDRESSABLE_LENGTH;
      else number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;

      go to PUT_JOIN;


raw_put:
   entry (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (NULL_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);

      ci_parts_ptr = p_ci_parts_ptr;
      ci_num = p_ci_num;

      if ci_num = 0
      then number_of_addressable_bytes = CI_0_ADDRESSABLE_LENGTH;
      else number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;

      go to PUT_JOIN;




put:
   entry (p_file_oid, p_ci_num, p_ci_parts_ptr, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (VANILLA_WRITE_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);

      ci_parts_ptr = p_ci_parts_ptr;
      ci_num = p_ci_num;

      if ci_num = 0
      then number_of_addressable_bytes = CI_0_ADDRESSABLE_LENGTH;
      else number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;

      go to PUT_JOIN;

simple_put:
   entry (p_file_oid, p_ci_num, p_single_part_offset, p_single_part_ptr, p_single_part_length, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (VANILLA_WRITE_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);
      ci_parts_ptr = addr (single_ci_part);
      ci_parts.part (1).offset_in_bytes = p_single_part_offset;
      ci_parts.part (1).length_in_bytes = p_single_part_length;
      ci_parts.part (1).local_ptr = p_single_part_ptr;
      ci_num = p_ci_num;
      if ci_num = 0
      then number_of_addressable_bytes = CI_0_ADDRESSABLE_LENGTH;
      else number_of_addressable_bytes = CI_ADDRESSABLE_LENGTH;
      go to PUT_JOIN;

%page;
PUT_JOIN:
      if ci_parts.number_of_parts < 0
      then call RETURN (dm_error_$ci_num_parts_neg);

      if ci_num < 0 | ci_num > MAX_CI_NUM
      then call RETURN (dm_error_$ci_num_oob);

      if effective_integrity_switches.lock
      then call LOCK_EXCLUSIVELY (ci_num, transaction_id, addr (my_file_oid) -> file_oid.file_access_table_idx);

      component_num = divide (ci_num, file_access_info.blocking_factor, 27);

      call MAKE_SEG_PTR (component_num, ci_ptr, addr (my_file_oid) -> file_oid.file_access_table_idx,
	 (effective_integrity_switches.bj));

      page_num = ci_num - multiply (component_num, file_access_info.blocking_factor, 27);
      ci_ptr = addr (ci_ptr -> seg.pages (page_num));

      my_ci_stamp = ci.trailer.stamp;
      my_ci_id = ci.header.id;

      if my_ci_stamp = 0
      then call BASIC_ALLOCATE;
      else
         do;
	  if addr (my_ci_stamp) -> ci_stamp.version ^= CI_STAMP_VERSION_1
	  then call RETURN (dm_error_$ci_bad_stamp_ver);

	  if addr (my_ci_id) -> ci_id.size_code ^= SIZE_CODE_1024_WORDS
	  then call RETURN (dm_error_$ci_bad_hdr_size_code);

	  if addr (my_ci_id) -> ci_id.uid ^= file_access_info.uid
	  then call RETURN (dm_error_$ci_bad_hdr_uid);

	  if addr (my_ci_id) -> ci_id.num ^= ci_num
	  then call RETURN (dm_error_$ci_bad_hdr_id_num);
         end;

      unspec (my_ci_parts) = ""b;
      my_part_ptrs (*) = null ();
      my_part_idx = 0;

      do part_idx = lbound (ci_parts.part, 1) to ci_parts.number_of_parts;
         part_length = ci_parts.part (part_idx).length_in_bytes;

         if part_length < 0
         then call RETURN (dm_error_$ci_parts_oob);

         if part_length > 0
         then
	  do;
	     part_offset = ci_parts.part (part_idx).offset_in_bytes;

	     if part_offset < 0 | part_offset + part_length > number_of_addressable_bytes
	     then call RETURN (dm_error_$ci_parts_oob);

	     my_part_idx = my_part_idx + 1;

	     my_ci_parts.part (my_part_idx).offset_in_bytes = part_offset;
	     my_ci_parts.part (my_part_idx).length_in_bytes = part_length;
	     my_ci_parts.part (my_part_idx).local_ptr = addr (substr (ci.addressable_bytes, part_offset + 1));

	     my_part_ptrs (my_part_idx) = ci_parts.part (part_idx).local_ptr;

	     if my_part_idx = hbound (my_ci_parts.part, 1)
	     then call PUT_MY_PARTS;
	  end;
      end;

      if my_part_idx > 0
      then call PUT_MY_PARTS;

      call RETURN (ERROR_FREE);


/* Effective end of all put entries */


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;

TRANSACTION_BJ_FULL_HANDLER:
/**** Cannot call bj_report_err_ to do this since BJ cannot be called recursively. */
/**** See also fm_(create_open delete_close), which need to handle this condition. */
      revert transaction_bj_full_;
      my_signal_structure.length = size (my_signal_structure);
      my_signal_structure.version = 1;
      string (my_signal_structure.action_flags) = "0"b;
      call ioa_$rsnnl ("Writing a before image for UID ^w OID ^w CI ^d", my_signal_structure.info_string, (0),
	 file_access_info.uid, my_file_oid, ci_num);
      my_signal_structure.status_code = dm_error_$bj_journal_full;

      call transaction_manager_$abort_txn (dm_data_$current_txn_id, code);
      call signal_ ("transaction_bj_full_", null (), addr (my_signal_structure));
      call RETURN (dm_error_$bj_journal_full);		/* should never get here */
%page;
PUT_MY_PARTS:
   proc;
      my_ci_parts.number_of_parts = my_part_idx;

      if effective_integrity_switches.bj
      then
         do;
	  on transaction_bj_full_ goto TRANSACTION_BJ_FULL_HANDLER;
	  call before_journal_manager_$write_before_image (file_access_info.uid, my_file_oid, ci_num,
	       addr (my_ci_parts), dtcm, code);
	  if code ^= 0
	  then call RETURN (code);

	  my_ci_stamp = TEMPLATE_CI_STAMP_1 + dtcm;
         end;
      else my_ci_stamp = TEMPLATE_CI_STAMP_1 + clock ();

      if effective_integrity_switches.record_time_modified
      then ci.header.stamp = my_ci_stamp;

      do my_part_idx = 1 to my_ci_parts.number_of_parts;
         part_length = my_ci_parts.part (my_part_idx).length_in_bytes;
         part_offset = my_ci_parts.part (my_part_idx).offset_in_bytes;
         part_ptr = my_part_ptrs (my_part_idx);

         substr (ci.addressable_bytes, part_offset + 1, part_length) = part_buffer;
      end;

      if effective_integrity_switches.record_time_modified
      then ci.trailer.stamp = my_ci_stamp;

      if effective_integrity_switches.transaction
      then call TXN_REMEMBER_MOD_PAGE;

      if effective_integrity_switches.aj
      then
         do;
         end;

      unspec (my_ci_parts) = ""b;
      my_part_ptrs (*) = null ();
      my_part_idx = 0;
   end PUT_MY_PARTS;
%page;
postcommit_increment:
   entry (p_file_oid, p_ci_num, p_increment_info_ptr, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      ci_num = p_ci_num;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (VANILLA_WRITE_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);

      if ci_num < 0 | ci_num > MAX_CI_NUM
      then call RETURN (dm_error_$ci_num_oob);

      if effective_integrity_switches.bj
      then
         do;
	  on transaction_bj_full_ goto TRANSACTION_BJ_FULL_HANDLER;
	  fm_increment_info_ptr = p_increment_info_ptr;
	  if fm_increment_info.version ^= FM_INCREMENT_INFO_VERSION_1
	  then call RETURN (dm_error_$fm_bad_inc_info_ver);
	  my_postcommit_info.header.version = POSTCOMMIT_INFO_VERSION_1;
	  my_postcommit_info.header.operation = INCREMENT_POSTCOMMIT_OPERATION;
	  my_postcommit_info.increments_ptr = fm_increment_info.increments_ptr;
	  my_postcommit_info.number_of_words = fm_increment_info.number_of_words;
	  my_postcommit_info.ci_number = p_ci_num;
	  my_postcommit_info.offset_in_bytes = fm_increment_info.offset_in_bytes;
	  my_postcommit_info.element_id = fm_increment_info.element_id;

	  code = 0;
	  call before_journal_manager_$write_fm_postcommit_handler (file_access_info.uid, my_file_oid,
	       addr (my_postcommit_info), size (my_postcommit_info) * BYTES_PER_WORD, code);
	  if code ^= 0
	  then call RETURN (code);
         end;
      else call RETURN (dm_error_$file_must_be_protected);

      call RETURN (ERROR_FREE);

/* Effective end of fm_put_$postcommit_increment */
%page;
lock_advice:
   entry (p_file_oid, p_lock_mode, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call GET_INTEGRITY_SWITCHES (NULL_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);

      lock_mode = p_lock_mode;

      if ^(lock_mode = 0 | lock_mode = LOCK_MODE_S | lock_mode = LOCK_MODE_X | lock_mode = LOCK_MODE_IS
	 | lock_mode = LOCK_MODE_IX | lock_mode = LOCK_MODE_SIX)
      then call RETURN (dm_error_$lock_invalid_mode);


      file_access_info.lock_advice = lock_mode;
      file_access_info.last_transaction_id = ""b;
      file_access_table.e (addr (my_file_oid) -> file_oid.file_access_table_idx) = file_access_info;

      call RETURN (ERROR_FREE);


/* Effective end of fm_put_$lock_advice */
%page;
flush_consecutive_ci:
   entry (p_file_oid, p_first_ci, p_number_of_ci, p_code);

      call INIT;
      my_file_oid = p_file_oid;
      file_access_info_ptr = addr (my_file_access_info);
      call GET_ACCESS_INFO (my_file_oid, NOT_FOR_UNPUT, file_access_info_ptr);
      call CHECK_RING_ACCESS ((file_access_info.ring_brackets.write));
      call GET_INTEGRITY_SWITCHES (NULL_INTEGRITY_SWITCHES, (file_access_info.integrity_switches),
	 effective_integrity_switches);
      call GET_TRANSACTION_INFO (effective_integrity_switches.transaction, transaction_id, transaction_index);

      if file_access_info.opens = 0
      then call RETURN (dm_error_$bad_file_oid);

      first_ci = p_first_ci;
      n_ci = p_number_of_ci;

      call CHECK_CI_RANGE (first_ci, n_ci, last_ci);

FLUSH_CONSECUTIVE:
      begin;

         dcl     1 fc_flush_consec	aligned,
	         2 version		fixed bin,
	         2 n_segs		fixed bin,
	         2 seg		(8) like flush_consec.seg;

         unspec (fc_flush_consec) = ""b;
         fc_flush_consec.version = 1;

         do ci_num = first_ci to last_ci by file_access_info.blocking_factor;
	  component_num = divide (ci_num, file_access_info.blocking_factor, 27);

	  call GET_SEG_PTR (component_num, ci_ptr, addr (my_file_oid) -> file_oid.file_access_table_idx);

	  if ci_ptr ^= null ()
	  then
	     do;
	        fc_flush_consec.n_segs = fc_flush_consec.n_segs + 1;

	        fc_flush_consec.seg (fc_flush_consec.n_segs).segno = bin (baseno (ci_ptr), 18);

	        fc_flush_consec.seg (fc_flush_consec.n_segs).first_page =
		   max (0, first_ci - multiply (component_num, file_access_info.blocking_factor, 27));

	        fc_flush_consec.seg (fc_flush_consec.n_segs).n_pages =
		   min (file_access_info.blocking_factor - 1,
		   last_ci - multiply (component_num, file_access_info.blocking_factor, 27))
		   - fc_flush_consec.seg (fc_flush_consec.n_segs).first_page + 1;

	        if fc_flush_consec.n_segs = hbound (fc_flush_consec.seg, 1)
	        then call FLUSH;
	     end;
         end;

         if fc_flush_consec.n_segs > 0
         then call FLUSH;



FLUSH:
   proc;

      dcl	    f_callers_validation_level
			       fixed bin;

      call cu_$level_get (f_callers_validation_level);
      on cleanup call cu_$level_set (f_callers_validation_level);
      call cu_$level_set (get_ring_ ());

      call hcs_$flush_consecutive_pages (addr (fc_flush_consec), code);
      if code ^= 0
      then if code = error_table_$invalidsegno
	 then code = dm_error_$file_was_deleted;
	 else call RETURN (code);

      call cu_$level_set (f_callers_validation_level);

      unspec (fc_flush_consec) = ""b;
      fc_flush_consec.version = 1;

      if code = dm_error_$file_was_deleted
      then call RETURN (code);

      return;

   end FLUSH;


      end FLUSH_CONSECUTIVE;

      call RETURN (ERROR_FREE);


/* Effective end of fm_put_$flush_consective_ci */
%page;
flush_modified_ci:
   entry (p_transaction_id, p_transaction_index, p_code);

      call INIT;

      transaction_id = p_transaction_id;
      transaction_index = p_transaction_index;

      call TXN_FLUSH_MOD_PAGES;

      call RETURN (ERROR_FREE);

/* Effective end of fm_put_$flush_modified_ci */


adopt:
   entry (p_transaction_id, p_transaction_index, p_code);

      call INIT;

      transaction_id = p_transaction_id;
      transaction_index = p_transaction_index;

      call TXN_DISCARD_FLUSH_LIST;

      call RETURN (ERROR_FREE);

/* Effective end of fm_put_$adopt */


clear_flush_list:
   entry (p_code);

      call INIT;

      transaction_id = dm_data_$current_txn_id;
      transaction_index = dm_data_$current_txn_index;

      call TXN_CLEAR_FLUSH_LIST;

      call RETURN (ERROR_FREE);

/* Effective end of fm_put_$clear_flush_list */

discard_file_flush_list:
   entry (p_file_uid, p_code);

      call INIT;

      transaction_id = dm_data_$current_txn_id;
      transaction_index = dm_data_$current_txn_index;

      call TXN_DISCARD_FILE_FLUSH_LIST (p_file_uid);

      call RETURN (ERROR_FREE);

/* Effective end of fm_put_$discard_file_flush_list */

/* THIS IS THE END OF THE MAIN LINE CODE */
%page;
/* SUBROUTINES */


INIT:
   proc;

/* THE LOGIC OF fm_put_ DOES NOT DEPEND ON THE INITIALIZATIONS BELOW */

      ci_parts_ptr = null ();
      ci_ptr = null ();
      part_ptr = null ();

      ci_num = -1;
      code = -1;
      component_num = -1;
      first_ci = -1;
      my_ci_id = -1;
      my_ci_stamp = -1;
      n_ci = -1;
      number_of_addressable_bytes = -1;
      page_num = -1;
      part_idx = -1;
      part_length = -1;
      part_offset = -1;
      transaction_id = ""b;
      transaction_index = -1;

/* THE LOGIC OF fm_put_ DOES NOT DEPEND ON THE INITIALIZATIONS ABOVE */

   end INIT;
%page;
CHECK_CI_RANGE:
   proc (ccr_p_first_ci, ccr_p_n_ci, ccr_p_last_ci);

      dcl	    ccr_p_first_ci	       fixed bin (27) parameter;
      dcl	    ccr_p_n_ci	       fixed bin (27) parameter;
      dcl	    ccr_p_last_ci	       fixed bin (28) parameter;

      if ccr_p_first_ci < 0
      then call RETURN (dm_error_$fm_first_ci_neg);

      if ccr_p_n_ci < 0
      then call RETURN (dm_error_$fm_num_ci_neg);

      ccr_p_last_ci = ccr_p_first_ci + ccr_p_n_ci - 1;

      if ccr_p_last_ci > MAX_CI_NUM
      then call RETURN (dm_error_$ci_num_oob);
      else return;

   end CHECK_CI_RANGE;


BASIC_ALLOCATE:
   proc;
      my_ci_stamp = TEMPLATE_CI_STAMP_1 + clock ();

      addr (my_ci_id) -> ci_id.uid = file_access_info.uid;
      addr (my_ci_id) -> ci_id.size_code = SIZE_CODE_1024_WORDS;
      addr (my_ci_id) -> ci_id.num = ci_num;

      ci.header.stamp = my_ci_stamp;
      ci.header.id = my_ci_id;
      ci.trailer.stamp = my_ci_stamp;
   end BASIC_ALLOCATE;
%page;
GET_ACCESS_INFO:
   proc (gai_p_file_oid, gai_p_for_unput_operation, gai_p_file_access_info_ptr);

      dcl	    gai_p_file_oid	       bit (36) aligned;
      dcl	    gai_p_for_unput_operation
			       bit (1) aligned;
      dcl	    gai_p_file_access_info_ptr
			       ptr;

      dcl	    1 gai_my_file_oid      aligned like file_oid;

      unspec (gai_my_file_oid) = gai_p_file_oid;

      if gai_my_file_oid.file_access_table_idx < lbound (file_access_table.e, 1)
	 | gai_my_file_oid.file_access_table_idx > file_access_table.h.last_entry
      then call RETURN (dm_error_$bad_file_oid);

      file_access_info_ptr = gai_p_file_access_info_ptr;
      file_access_info = file_access_table.e (gai_my_file_oid.file_access_table_idx);

      if file_access_info.state.entry_state = FILE_ACCESS_INFO_NOT_IN_USE
      then call RETURN (dm_error_$bad_file_oid);

      if file_access_info.state.file_state ^= FILE_EXISTS
      then
         do;
	  if file_access_info.state.file_state = FILE_LOGICALLY_DELETED
	  then if gai_p_for_unput_operation
	       then /* okay */
		  ;
	       else call RETURN (dm_error_$file_doesnt_exist);
	  else call RETURN (dm_error_$file_doesnt_exist);
         end;

      if gai_my_file_oid.uid_tail ^= substr (file_access_info.uid, 19, 18)
      then call RETURN (dm_error_$bad_file_oid);

      if file_access_info.seg_0_num = ""b
      then if gai_p_for_unput_operation
	 then call RETURN (ERROR_FREE);
	 else call RETURN (dm_error_$file_doesnt_exist);

      return;


   end GET_ACCESS_INFO;
%page;
GET_INTEGRITY_SWITCHES:
   proc (gis_p_type, gis_p_file_integrity_switches, gis_p_effective_integrity_switches);

/* This subroutine determines the effective integrity switches to be
   used by this operation.  Three sets of integrity switches are taken
   into account while determing the effective switches: the switches
   in the file's attributes, the switches that are to be forced
   (currently no switches are forced), and the switches permitted by
   the current operation.
*/

      dcl	    gis_p_type	       fixed bin parameter;	/* Type of operation */
      dcl	    1 gis_p_file_integrity_switches
			       aligned like file_access_info.integrity_switches parameter;
						/* the switches in the file attributes */
      dcl	    1 gis_p_effective_integrity_switches
			       aligned like file_access_info.integrity_switches parameter;
						/* the resulting effective integrity switches */

      dcl	    1 gis_permit_integrity_switches
			       aligned like file_access_info.integrity_switches;
						/* the switches permitted by this operation */
      dcl	    1 gis_force_integrity_switches
			       aligned like file_access_info.integrity_switches;
						/* the switches that are to be forced regardless of */
						/* attributes and operation                          */
      string (gis_permit_integrity_switches) = "0"b;
      string (gis_force_integrity_switches) = "0"b;

      go to GIS_TYPE (gis_p_type);

GIS_TYPE (1):					/* Null */
      go to GIS_RETURN;
GIS_TYPE (2):					/* Vanilla write */
      gis_permit_integrity_switches.record_time_modified = "1"b;
      gis_permit_integrity_switches.transaction = "1"b;
      gis_permit_integrity_switches.lock = "1"b;
      gis_permit_integrity_switches.bj = "1"b;
      gis_permit_integrity_switches.aj = "1"b;
      go to GIS_RETURN;
GIS_TYPE (3):					/* Unput */
      gis_permit_integrity_switches.transaction = "1"b;
      gis_permit_integrity_switches.aj = "1"b;
      go to GIS_RETURN;
GIS_TYPE (4):					/* Unprotected */
      gis_permit_integrity_switches.record_time_modified = "1"b;
      go to GIS_RETURN;

GIS_RETURN:
      gis_p_effective_integrity_switches =
	 (gis_p_file_integrity_switches & gis_permit_integrity_switches) | gis_force_integrity_switches;
      return;


   end GET_INTEGRITY_SWITCHES;
%page;
GET_TRANSACTION_INFO:
   proc (gti_p_requires_transaction, gti_p_transaction_id, gti_p_transaction_index);

      dcl	    gti_p_requires_transaction
			       bit (1) parameter;
      dcl	    gti_p_transaction_id   bit (36) aligned parameter;
      dcl	    gti_p_transaction_index
			       fixed bin (17) parameter;

      if gti_p_requires_transaction
      then
         do;
	  gti_p_transaction_index = dm_data_$current_txn_index;
	  gti_p_transaction_id = dm_data_$current_txn_id;
	  if gti_p_transaction_id = ""b
	  then call RETURN (dm_error_$no_current_transaction);
         end;
      else
         do;
	  gti_p_transaction_index = -1;
	  gti_p_transaction_id = ""b;
         end;

      return;

   end GET_TRANSACTION_INFO;



CHECK_RING_ACCESS:
   proc (cra_p_write_bracket);

      dcl	    cra_p_write_bracket    fixed bin (3) uns unal parameter;

      dcl	    cra_caller_validation_level
			       fixed bin;

      call cu_$level_get (cra_caller_validation_level);

      if cra_caller_validation_level > cra_p_write_bracket
      then call RETURN (error_table_$no_w_permission);
      else return;

   end CHECK_RING_ACCESS;
%page;
LOCK_EXCLUSIVELY:
   proc (le_p_ci_num, le_p_transaction_id, le_p_file_access_table_idx);

      dcl	    le_p_ci_num	       fixed bin (27) parameter;
      dcl	    le_p_transaction_id    bit (36) aligned parameter;
      dcl	    le_p_file_access_table_idx
			       fixed bin (17) unal;
      dcl	    le_code	       fixed bin (35) init (0);

      if file_access_info.lock_advice ^= 0
      then
         do;
	  if file_access_info.last_transaction_id ^= le_p_transaction_id
	  then
	     do;
	        file_access_info.last_transaction_id = le_p_transaction_id;
	        file_access_table.e (le_p_file_access_table_idx) = file_access_info;

	        call lock_manager_$lock (file_access_info.uid, LOCK_ENTIRE_FILE, (file_access_info.lock_advice),
		   LOCK_WAIT_TIME, (0), le_code);
	        if le_code ^= 0
	        then call RETURN (le_code);
	     end;
         end;

      if ^(file_access_info.lock_advice = LOCK_MODE_X)
      then
         do;
	  call lock_manager_$lock (file_access_info.uid, le_p_ci_num, LOCK_MODE_X, LOCK_WAIT_TIME, (0), le_code);
	  if le_code ^= 0
	  then call RETURN (le_code);
         end;

      return;

   end LOCK_EXCLUSIVELY;
%page;
TXN_FLUSH_MOD_PAGES:
   proc;

      if proc_txn_tbl.h.version ^= PROC_TXN_TBL_VERSION_2
      then call RETURN (dm_error_$fm_bad_proc_txn_tbl_ver);

      proc_txn_ptr = addr (proc_txn_tbl.e (1));

      if proc_txn.tid = ""b
      then return;

      if transaction_id ^= proc_txn.tid
      then call RETURN (dm_error_$fm_old_txn_not_flushed);

      proc_txn.flush_bj_first = "0"b;

      call FLUSH_MOD_PAGES;

      return;


TXN_CLEAR_FLUSH_LIST:
   entry;
      if proc_txn_tbl.h.version ^= PROC_TXN_TBL_VERSION_2
      then call RETURN (dm_error_$fm_bad_proc_txn_tbl_ver);

      proc_txn_ptr = addr (proc_txn_tbl.e (1));

      if proc_txn.tid = ""b
      then return;

      if transaction_id ^= proc_txn.tid
      then call RETURN (dm_error_$fm_old_txn_not_flushed);

      call FLUSH_MOD_PAGES;

      return;


TXN_DISCARD_FLUSH_LIST:
   entry;
      if proc_txn_tbl.h.version ^= PROC_TXN_TBL_VERSION_2
      then call RETURN (dm_error_$fm_bad_proc_txn_tbl_ver);

      proc_txn_ptr = addr (proc_txn_tbl.e (1));

      unspec (proc_txn) = ""b;

      return;

TXN_DISCARD_FILE_FLUSH_LIST:
   entry (txn_discard_file_uid);
      if proc_txn_tbl.h.version ^= PROC_TXN_TBL_VERSION_2
      then call RETURN (dm_error_$fm_bad_proc_txn_tbl_ver);

      proc_txn_ptr = addr (proc_txn_tbl.e (1));

      do txn_discard_idx = lbound (proc_txn.mod_pages, 1) to proc_txn.last_entry
	 while (proc_txn.file_uids (txn_discard_idx) ^= txn_discard_file_uid);
      end;
      txn_discard_delta = 0;
      do txn_discard_idx = txn_discard_idx to proc_txn.last_entry;
         if proc_txn.file_uids (txn_discard_idx) = txn_discard_file_uid
         then txn_discard_delta = txn_discard_delta + 1;
         else
	  do;
	     proc_txn.file_uids (txn_discard_idx - txn_discard_delta) = proc_txn.file_uids (txn_discard_idx);
	     proc_txn.mod_pages (txn_discard_idx - txn_discard_delta) = proc_txn.mod_pages (txn_discard_idx);
	  end;
      end;
      do txn_discard_idx = proc_txn.last_entry by -1 to proc_txn.last_entry - txn_discard_delta + 1;
         proc_txn.mod_pages (txn_discard_idx) = 0;
         proc_txn.file_uids (txn_discard_idx) = ""b;
      end;
      proc_txn.last_entry = proc_txn.last_entry - txn_discard_delta;

      return;

TXN_DONT_FLUSH_BJ:
   entry;

      proc_txn_ptr = addr (proc_txn_tbl.e (1));

      if proc_txn.tid = ""b
      then return;

      if transaction_id ^= proc_txn.tid
      then call RETURN (dm_error_$fm_old_txn_not_flushed);

      proc_txn.flush_bj_first = "0"b;

      return;



TXN_REMEMBER_MOD_PAGE:
   entry;

/*   DESCRIPTION of TXN_FLUSH_MOD_PAGES$TXN_REMEMBER_MOD_PAGE

          This entry in TXN_FLUSH_MOD_PAGES manages the insertion of a
     modified page in proc_txn.mod_pages, the list of pages modified by a
     transaction.  Before the transaction can commit or abort, these pages
     must be flushed to disk.  As a process can have only one transaction in
     progress, there is only one entry in proc_txn_tbl (per-process
     transaction table).

          Each entry in proc_txn.mod_pages is a segment number and page
     number, and has a corresponding file uid in proc_txn.file_uids.  mod_pages
     is kept as a sorted list and is searched via a binary search.  */


      proc_txn_ptr = addr (proc_txn_tbl.e (1));

      if proc_txn.tid = NO_TRANSACTION
      then
         do;
	  proc_txn.version = 1;
	  proc_txn.tid = transaction_id;
         end;
      else if transaction_id ^= proc_txn.tid
      then call RETURN (dm_error_$fm_old_txn_not_flushed);

      txn_remember_mod_page_breakout.segment_number = baseno (ci_ptr);
      txn_remember_mod_page_breakout.page_number = page_num;
      unspec (txn_remember_mod_page) = unspec (txn_remember_mod_page_breakout);

      txn_remember_low_idx = 0;
      txn_remember_high_idx = proc_txn.last_entry + 1;
      txn_remember_delta = txn_remember_high_idx - txn_remember_low_idx;
      if txn_remember_delta = 1
      then txn_remember_current_idx = txn_remember_high_idx;
      else
         do;
	  do while (txn_remember_delta > 1);
	     txn_remember_current_idx = divide (txn_remember_delta, 2, 17, 0) + txn_remember_low_idx;
	     if txn_remember_mod_page = proc_txn.mod_pages (txn_remember_current_idx)
	     then return /* already here, nothing to do */;
	     if txn_remember_mod_page < proc_txn.mod_pages (txn_remember_current_idx)
	     then txn_remember_high_idx = txn_remember_current_idx;
	     else txn_remember_low_idx = txn_remember_current_idx;
	     txn_remember_delta = txn_remember_high_idx - txn_remember_low_idx;
	  end;
	  txn_remember_current_idx = txn_remember_high_idx;
	  if proc_txn.last_entry >= hbound (proc_txn.mod_pages, 1)
	  then
	     do;
	        call FLUSH_MOD_PAGES ();		/* Resets proc_txn to ""b */
	        proc_txn.version = 1;
	        proc_txn.tid = transaction_id;
	        txn_remember_current_idx = 1;
	     end;
         end;
      do txn_remember_shift_idx = proc_txn.last_entry by -1 to txn_remember_current_idx;
         proc_txn.mod_pages (txn_remember_shift_idx + 1) = proc_txn.mod_pages (txn_remember_shift_idx);
         proc_txn.file_uids (txn_remember_shift_idx + 1) = proc_txn.file_uids (txn_remember_shift_idx);
      end;
      proc_txn.last_entry = proc_txn.last_entry + 1;
      proc_txn.mod_pages (txn_remember_current_idx) = txn_remember_mod_page;
      proc_txn.file_uids (txn_remember_current_idx) = file_access_info.uid;
      if effective_integrity_switches.bj
      then proc_txn.flush_bj_first = "1"b;

      return;

TXN_INIT_PROC_DATA:
   entry;

      allocate proc_txn_tbl;

      unspec (proc_txn_tbl) = ""b;
      proc_txn_tbl.h.version = PROC_TXN_TBL_VERSION_2;

      begin;
         call cu_$level_get (callers_validation_level);
         on cleanup call cu_$level_set (callers_validation_level);
         call cu_$level_set (get_ring_ ());

         code = 0;
         call dm_hcs_$set_force_write_limit (10, code);
         if code ^= 0
         then call RETURN (code);

         call cu_$level_set (callers_validation_level);

         dcl     callers_validation_level
				fixed bin;

      end;

      return;


FLUSH_MOD_PAGES:
   proc;

      proc_txn.n_pages = proc_txn.last_entry;

      if proc_txn.n_pages > 0
      then
         do;
	  if proc_txn.flush_bj_first
	  then
	     do;
	        call before_journal_manager_$flush_transaction (transaction_id, transaction_index, code);
	        if code ^= 0
	        then call RETURN (code);
	     end;

	  call cu_$level_get (callers_validation_level);
	  on cleanup call cu_$level_set (callers_validation_level);
	  call cu_$level_set (get_ring_ ());

	  call hcs_$flush_pages (addr (proc_txn.version), code);
	  if code ^= 0
	  then if code = error_table_$invalidsegno
	       then code = dm_error_$file_was_deleted;
	       else call RETURN (code);

	  call cu_$level_set (callers_validation_level);
         end;

      unspec (proc_txn) = ""b;

      if code = dm_error_$file_was_deleted
      then if operation_is_unput
	 then code = 0 /* For unput - deleted file is not unexpected */;
	 else call RETURN (code);

      return;

      dcl	    callers_validation_level
			       fixed bin;

   end FLUSH_MOD_PAGES;

/* Declarations for TXN_FLUSH_MOD_PAGES entries */

      dcl	    (
	    txn_discard_file_uid   bit (36) aligned,
	    txn_discard_delta      fixed bin,
	    txn_discard_idx	       fixed bin
	    );
      dcl	    (
	    txn_remember_low_idx   fixed bin,
	    txn_remember_high_idx  fixed bin,
	    txn_remember_current_idx
			       fixed bin,
	    txn_remember_delta     fixed bin,
	    txn_remember_shift_idx fixed bin,
	    txn_remember_mod_page  fixed bin (33)
	    );
      dcl	    1 txn_remember_mod_page_breakout
			       aligned,
	      2 segment_number     bit (18) unal,
	      2 page_number	       fixed bin unal;

      dcl	    proc_txn_ptr	       ptr;
      dcl	    1 proc_txn	       aligned based (proc_txn_ptr),
	      2 tid	       bit (36),
	      2 flush_bj_first     bit,
	      2 last_entry	       fixed bin,
	      2 mbz	       fixed bin,
	      2 version	       fixed bin,
	      2 n_pages	       fixed bin,
	      2 mod_pages	       (250) fixed bin (33),
	      2 file_uids	       (250) bit (36) aligned;

      dcl	    fm_data_$proc_txn_tbl_ptr
			       ptr ext;
      dcl	    1 proc_txn_tbl	       aligned based (fm_data_$proc_txn_tbl_ptr),
	      2 h,
	        3 version	       char (8) aligned,
	        3 mbz	       fixed bin (71),
	      2 e		       (1) like proc_txn;

      dcl	    PROC_TXN_TBL_VERSION_2 char (8) aligned static options (constant) init ("FM-PTT 2");


   end TXN_FLUSH_MOD_PAGES;
%page;
/* Make_seg means if you can't get a pointer, don't come back. */

MAKE_SEG_PTR:
   proc (msp_p_component_num, msp_p_ci_ptr, msp_p_file_access_table_idx, msp_p_bj_on);



      dcl	    msp_p_component_num    fixed bin parameter;
      dcl	    msp_p_ci_ptr	       ptr parameter;
      dcl	    msp_p_file_access_table_idx
			       fixed bin (17) unal parameter;
      dcl	    msp_p_bj_on	       bit (1) parameter;

      dcl	    msp_make_seg	       bit (1) aligned;
      dcl	    msp_code	       init (0) fixed bin (35);

      msp_make_seg = "1"b;
      go to MSP_JOIN;

GET_SEG_PTR:
   entry (msp_p_component_num, msp_p_ci_ptr, msp_p_file_access_table_idx);

      msp_make_seg = "0"b;
      go to MSP_JOIN;

MSP_JOIN:
      if msp_p_component_num = 0
      then
         do;
	  msp_p_ci_ptr = baseptr (file_access_info.seg_0_num);
	  return;
         end;
      else if msp_p_component_num <= hbound (file_access_info.seg_nums, 1)
      then
         do;
	  if file_access_info.seg_nums (msp_p_component_num) ^= 0
	  then
	     do;
	        msp_p_ci_ptr = baseptr (file_access_info.seg_nums (msp_p_component_num));
	        return;
	     end;
         end;

CALL_RING_0:
      begin;

         dcl     msp_dir_name		char (168);
         dcl     msp_entry_name	char (32);
         dcl     msp_callers_validation_level
				fixed bin;

         call cu_$level_get (msp_callers_validation_level);
         on cleanup call cu_$level_set (msp_callers_validation_level);
         call cu_$level_set (get_ring_ ());

         call msf_manager_$msf_get_ptr ((file_access_info.msf_ptr), msp_p_component_num, "0"b, msp_p_ci_ptr, (0),
	    msp_code);

         if msp_p_ci_ptr = null ()
         then
	  do;
	     if msp_code ^= error_table_$noentry
	     then call RETURN (msp_code);

	     if msp_make_seg
	     then
	        do;
		 call msf_manager_$msf_get_ptr ((file_access_info.msf_ptr), msp_p_component_num, "1"b, msp_p_ci_ptr,
		      (0), msp_code);
		 if msp_p_ci_ptr = null ()
		 then call RETURN (msp_code);

		 if msp_p_bj_on
		 then
		    do;
		       call hcs_$fs_get_path_name (msp_p_ci_ptr, msp_dir_name, (0), msp_entry_name, msp_code);
		       if msp_code ^= 0
		       then call RETURN (msp_code);

		       call hcs_$set_synchronized_sw (msp_dir_name, msp_entry_name, "1"b, msp_code);
		       if msp_code ^= 0
		       then
			do;
			   if msp_code = error_table_$not_dm_ring & sys_info$data_management_ringno ^= get_ring_ ()
			   then msp_code = 0;
			   else call RETURN (msp_code);
			end;
		    end;
	        end;
	  end;

         call cu_$level_set (msp_callers_validation_level);


      end CALL_RING_0;

      if msp_p_ci_ptr ^= null () & msp_p_component_num <= hbound (file_access_info.seg_nums, 1)
      then
         do;
	  file_access_info.seg_nums (msp_p_component_num) = bin (baseno (msp_p_ci_ptr), 18);
	  file_access_table.e (msp_p_file_access_table_idx) = file_access_info;
         end;

      return;

   end MAKE_SEG_PTR;
%page;
%include dm_ci;
%page;
%include dm_ci_header;
%page;
%include dm_ci_lengths;

%include dm_ci_constants;
%page;
%include dm_ci_parts;
%page;
%include dm_lock_modes;
%page;
%include dm_fm_file_oid;
%page;
%include dm_fm_file_access_info;
%page;
%include dm_fm_file_access_tbl;
%page;
%include dm_fm_increment_info;
%page;
%include dm_fm_postcommit_info;
%page;
%include flush_structures;
%page;
%include condition_info_header;

   end fm_put_$init_txn_tbl;




		    fm_status.pl1                   04/04/85  1119.5re  04/04/85  0826.8       76446



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

fm_status: proc (A_dirname, A_entryname, A_file_status_ptr, A_code);

/* DESCRIPTION:

   This  subroutine  returns status information about a DM file that is
   not returned by hcs_$status.  Information is returned  in  the  structure
   declared in dm_file_status.incl.pl1.
*/

/* HISTORY:

Written by Steve Herbst, 08/13/84.
Modified:
11/07/84 by Steve Herbst: Changed in response to audit comments:
	Removed cleanup windows, added ERROR_RETURN procedure, changed to
	call fm_get_last_ci_num and use fm_attributes.ci_size_in_bits.
11/27/84 by Steve Herbst: Changed further in response to audit comments:
	Changed to report CLEAN_UP errors on normal termination, and call
	sub_err_ with ACTION_CANT_RESTART.
12/17/84 by Steve Herbst: Changed again in response to audit comments:
	Fixed SUB_ERROR_CODE to return cond_info.status_code instead of
	sub_error_info.retval, compute effective mode using validation
	level instead of current ring, prevent CLEAN_UP from ever being
	called twice.
02/26/85 by Steve Herbst: Changed again in response to audit comments:
	Changed CLEAN_UP proc, not its caller, to turn on cleanup_called_sw.
*/

/* DECLARATIONS */

/* Parameters */

dcl  A_dirname char (*) parameter;
dcl  A_entryname char (*) parameter;
dcl  A_file_status_ptr ptr parameter;
dcl  A_code fixed bin (35) parameter;


/* Constants */

dcl ME char (32) int static options (constant) init ("fm_status");
dcl DONT_RETURN_CODE fixed bin int static options (constant) init (-1);

/* Based */

/* Static */

/* Automatic */

dcl 1 auto_ci_parts aligned,
   2 number_of_parts fixed bin init (1),
   2 pad fixed bin init (0),
   2 part (1) like ci_parts.part;

dcl 1 cond_info aligned like condition_info;

dcl 1 file_attributes_space aligned like file_attributes;

dcl dirname char (168);
dcl entryname char (32);
dcl opening_id bit (36);
dcl txn_id bit (36) aligned;
dcl cleanup_called_sw bit (1) aligned;
dcl callers_level fixed bin;
dcl (begin_code, code) fixed bin (35);

/* External */

dcl dm_error_$bad_file_atrs_ver fixed bin (35) ext;
dcl dm_error_$transaction_in_progress fixed bin (35) ext;
dcl error_table_$null_info_ptr fixed bin (35) ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl continue_to_signal_ entry (fixed bin (35));
dcl cu_$level_get entry (fixed bin);
dcl file_manager_$close entry (bit (36), fixed bin (35));
dcl file_manager_$get_user_access_modes entry (char (*), char (*), char (32), fixed bin,
	bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl file_manager_$open entry (char (*), char (*), bit (36), fixed bin (35));
dcl find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl fm_get_$internal_get entry (bit (36), fixed bin, ptr, fixed bin (35));
dcl fm_get_last_ci_num entry (char (*), fixed bin, fixed bin (27));
dcl get_group_id_ entry() returns(char(32));
dcl pathname_ entry (char(*), char(*)) returns(char(168));
dcl sub_err_ entry() options(variable);
dcl transaction_manager_$begin_txn entry (fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl transaction_manager_$commit_txn entry (bit (36) aligned, fixed bin (35));

/* Builtins */

dcl (addr, null, unspec) builtin;

/* Conditions */

dcl (cleanup, sub_error_) condition;

/* END OF DECLARATIONS */
%page;
	dirname = A_dirname;
	entryname = A_entryname;
	dm_file_status_ptr = A_file_status_ptr;
	A_code, begin_code = 0;
	cleanup_called_sw = "0"b;

	if dm_file_status_ptr = null then call ERROR_RETURN (error_table_$null_info_ptr);

	if dm_file_status.version ^= DM_FILE_STATUS_VERSION_1 then
	     call ERROR_RETURN (error_table_$unimplemented_version);

/* Open the DM file */

	opening_id = "0"b;
	on cleanup call CLEAN_UP (code);

	on sub_error_ begin;
	     code = SUB_ERROR_CODE ();
	     if code ^= DONT_RETURN_CODE then call ERROR_RETURN (code);
					/* DONT_RETURN_CODE => want to continue signalling sub_error_ */
	end;

	call file_manager_$open (dirname, entryname, opening_id, code);
	if opening_id = "0"b then call ERROR_RETURN (code);

	revert sub_error_;

/* Need a transaction to read the attributes in the file */

	call transaction_manager_$begin_txn (TM_NORMAL_MODE, "0"b, txn_id, begin_code);
	if txn_id = "0"b then call ERROR_RETURN (begin_code);

/* Get file attributes */

	unspec (file_attributes_space) = "0"b;
	file_attributes_ptr = addr (file_attributes_space);

	auto_ci_parts.part (1).local_ptr = file_attributes_ptr;
	auto_ci_parts.part (1).offset_in_bytes = CI_0_ADDRESSABLE_LENGTH;
	auto_ci_parts.part (1).length_in_bytes = CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH;

	call fm_get_$internal_get (opening_id, 0, addr (auto_ci_parts), code);
	if code ^= 0 then call ERROR_RETURN (code);

	if file_attributes.version ^= FILE_ATTRIBUTES_VERSION_2 then
						/* calls sub_err_ rather than just return a code since the
						   bad version is in file_attributes, not dm_file_status */
	     call sub_err_ (dm_error_$bad_file_atrs_ver, ME, ACTION_CANT_RESTART, null, 0,
		"File attributes version was ^a, should have been ^a",
		file_attributes.version, FILE_ATTRIBUTES_VERSION_2);

	dm_file_status.fm_unique_id = file_attributes.unique_id;
	dm_file_status.date_time_created = file_attributes.date_time_created;
	dm_file_status.ring_brackets (1) = file_attributes.ring_brackets.write;
	dm_file_status.ring_brackets (2) = file_attributes.ring_brackets.read;
	unspec (dm_file_status.switches) = "0"b;
	dm_file_status.protected_sw = file_attributes.protected;
	dm_file_status.no_concurrency_sw = file_attributes.no_concurrency;
	dm_file_status.no_rollback_sw = file_attributes.no_rollback;

/* Get other info */

	call cu_$level_get (callers_level);
	call file_manager_$get_user_access_modes (dirname, entryname, get_group_id_ (), callers_level,
	     dm_file_status.mode, "0"b, code);
	if code ^= 0 then dm_file_status.mode = "0"b;

	dm_file_status.ci_size = file_attributes.ci_size_in_bytes;

	call fm_get_last_ci_num
	     (pathname_ (dirname, entryname), (file_attributes.blocking_factor), dm_file_status.highest_ci);
	
RETURN:
	if ^cleanup_called_sw then do;
	     call CLEAN_UP (code);
	     if code ^= 0 & A_code = 0 then call ERROR_RETURN (code);
	end;
	
	return;
%page;
CLEAN_UP: proc (P_cleanup_code);

/* This procedure completes even if one of its calls returns an error.
   The intent is to restore the environment and the file to their original
   states as much as possible. It sets a parameter code instead of reporting
   its own errors, to leave the choice up to the caller: an error is reported
   at normal termination time, but not when "cleanup" is signalled. */

dcl (P_cleanup_code, code) fixed bin (35);

	code = 0;
	cleanup_called_sw = "1"b;

	if opening_id ^= "0"b then call file_manager_$close (opening_id, P_cleanup_code);
	if txn_id ^= "0"b then
	     if begin_code = dm_error_$transaction_in_progress then;
						/* Can't commit or abort the user's previous transaction */
	     else do;
		call transaction_manager_$commit_txn (txn_id, code);  /* could have aborted instead; doesn't
							    /* matter since no data has been changed */
		if code ^= 0 & P_cleanup_code = 0 then P_cleanup_code = code;
	     end;

end CLEAN_UP;
%page;
ERROR_RETURN: proc (P_code);

dcl P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

end ERROR_RETURN;
%page;
SUB_ERROR_CODE: proc () returns (fixed bin (35));

/* Returns the error code that sub_error_ was signalled with */

dcl code fixed bin (35);

	call find_condition_info_ (null, addr (cond_info), code);
	if code ^= 0 then return (code);

	if cond_info.info_ptr -> sub_error_info.default_restart then do;
						/* should only happen when testing tm_per_process_init_ */
	     call continue_to_signal_ (0);
	     return (DONT_RETURN_CODE);
	end;

	else return (cond_info.info_ptr -> sub_error_info.status_code);

end SUB_ERROR_CODE;
%page;
%include dm_ci_parts;
%page;
%include condition_info;
%page;
%include condition_info_header;
%page;
%include dm_ci_lengths;
%page;
%include dm_file_status;
%page;
%include dm_fm_file_attributes;
%page;
%include dm_tm_modes;
%page;
%include sub_err_flags;
%page;
%include sub_error_info;

end fm_status;




		    fm_stream_.pl1                  03/06/85  0802.6re  03/05/85  0759.4       39474



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

/* DESCRIPTION
These routines implement stream I/O for Data Management files.  They simplify
I/O for the simple stream case.  We decompose a single stream get/put into
seperate gets/puts on each control interval involved.
*/

/* HISTORY:
Written by Jeff Ives, 06/22/82.
Modified:
05/24/84 by R. Michael Tague:  Changed the name of the entries from
            $read and $write to $get_stream and $put_stream.
	  Changed the error handling to return a code instead of signaling
	  an error.
12/13/84 by R. Michael Tague:  Changed some variable names and generally fixed
            up due to auditing comments.
*/
%page;
/* format: style2 */

get_stream:
     proc (p_opening_id, p_file_offset_in_bytes, p_buffer_ptr, p_buffer_len_in_bytes, p_code);
	operation_kind = "get";
	go to JOIN;
%page;
/* START OF DECLARATIONS */

/* Parameters */

	dcl     p_opening_id	 bit (36) aligned parm;
	dcl     p_file_offset_in_bytes fixed bin (48) parm;
	dcl     p_buffer_ptr	 ptr parm;
	dcl     p_buffer_len_in_bytes	 fixed bin (21) parm;
	dcl     p_code		 fixed bin (35) parm;

/* Automatic */

	dcl     adjusted_file_first_byte
				 fixed bin (49) init (0);
	dcl     buffer_ptr		 ptr init (null ());
	dcl     chunk_ptr		 ptr init (null ());
	dcl     ci_first_byte	 fixed bin (17) init (0);
	dcl     ci_number_of_bytes	 fixed bin (17) init (0);
	dcl     ci_num		 fixed bin (27) init (0);
	dcl     code		 fixed bin (35) init (0);
	dcl     eof_byte		 fixed bin (49) init (0);
	dcl     file_chunk_first_byte	 fixed bin (49) init (0);
	dcl     file_first_byte	 fixed bin (48) init (0);
	dcl     number_of_bytes	 fixed bin (21) init (0);
	dcl     opening_id		 bit (36) aligned init (""b);
	dcl     operation_kind	 char (8) aligned;

/* Conditions */
/* Based */
/* Builtin */

	dcl     (addcharno, divide, min, mod, null)
				 builtin;

/* External Variables */
/* External Entries */

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

/* Static */

/* END OF DECLARATIONS */
%page;
put_stream:
     entry (p_opening_id, p_file_offset_in_bytes, p_buffer_ptr, p_buffer_len_in_bytes, p_code);
	operation_kind = "put";
	go to JOIN;
%page;
JOIN:
	opening_id = p_opening_id;
	file_first_byte = p_file_offset_in_bytes;
	buffer_ptr = p_buffer_ptr;
	number_of_bytes = p_buffer_len_in_bytes;

	if number_of_bytes = 0
	then /* Do nothing */
	     ;
	else do;
		eof_byte = file_first_byte + number_of_bytes;
		if file_first_byte < CI_0_ADDRESSABLE_LENGTH
		then do;
			ci_num = 0;
			ci_first_byte = file_first_byte;
			chunk_ptr = buffer_ptr;
			ci_number_of_bytes =
			     min (CI_0_ADDRESSABLE_LENGTH - ci_first_byte, eof_byte - file_first_byte);
		     end;
		else do;
			adjusted_file_first_byte =
			     file_first_byte + (CI_ADDRESSABLE_LENGTH - CI_0_ADDRESSABLE_LENGTH);
			ci_num = divide (adjusted_file_first_byte, CI_ADDRESSABLE_LENGTH, 49);
			ci_first_byte = mod (adjusted_file_first_byte, CI_ADDRESSABLE_LENGTH);
			chunk_ptr = buffer_ptr;
			ci_number_of_bytes =
			     min (CI_ADDRESSABLE_LENGTH - ci_first_byte, eof_byte - file_first_byte);
		     end;
		file_chunk_first_byte = file_first_byte;
		code = 0;
		do while (ci_number_of_bytes ^= 0 & code = 0);
		     if operation_kind = "get"
		     then call file_manager_$simple_get (opening_id, ci_num, ci_first_byte, chunk_ptr,
			     ci_number_of_bytes, code);
		     else call file_manager_$simple_put (opening_id, ci_num, ci_first_byte, chunk_ptr,
			     ci_number_of_bytes, code);
		     ci_num = ci_num + 1;
		     ci_first_byte = 0;
		     chunk_ptr = addcharno (chunk_ptr, ci_number_of_bytes);
		     file_chunk_first_byte = file_chunk_first_byte + ci_number_of_bytes;
		     ci_number_of_bytes = min (CI_ADDRESSABLE_LENGTH, eof_byte - file_chunk_first_byte);
		end;
	     end;

	p_code = code;
	return;
%page;
/* START OF INCLUDE FILES */
%include dm_ci_lengths;

     end get_stream;




		    fm_sys_pn_tbl_delete.pl1        04/04/85  1119.5re  04/04/85  0826.9       87885



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

/* DESCRIPTION:

         This  routine  removes  an  entry  from  the  file  manager's System
     Pathname  Table  (sys_pn_tbl).    This  routine  locks  and  unlocks  the
     sys_pn_tbl, so if the caller already has the sys_pn_tbl locked and wishes
     it  to  stay  locked,  they must  lock  the sys_pn_tbl after this routine
     returns.    The  caller  must  also  have  set   the   validation   level
     appropriately.
     
          There are two entries, as follows:

     fm_sys_pn_tbl_delete$fm_sys_pn_tbl_delete - 
          This entry is the target of fm_sys_on_tbl_util_$delete and
          is used by fm_delete_close_$post_transaction.
          It decrements the reference count of processes holding the
          file open.  If the reference count goes to 0, deletes the entry.
          It is not an error to attempt to close a file, and subsequently to
          try to delete its sys_pn_tbl entry, after the file has been deleted.
          For this reason, if the entry is not in use or is in use by another 
          fiel, this operation returns without error.

     fm_sys_pn_tbl_delete$redelete_force - 
          This entry is the target of fm_sys_pn_tbl_util_$redelete_force.
          It is used by undo and postcommit_do operations
          which must be able to force the deletion of the entry regardless
          of whether other processes have the file open.  These operations
          are the points at which protected files are actually deleted
          after the transaction has committed itself to doing the deletion
          (i.,e., the deletion will not be undone).  It is safe to delete
          the file's entry in the sys_pn_tbl, even if the file is open to 
          another process, if no other transaction has a before image against
          the file.  For this reason,
       ** this entry requires that the current transaction have an exclusive **
       ** lock on the file.                                                  **

   Error handling

     Possible errors are handled in one of two ways: the LOG routine
     or the ERROR_RETURN routine.  The LOG routine simply logs the event and 
     returns to the main procedure.  It is used if the sys_pn_tbl entry
     does not describe the specified file and if an error occurs in the
     cleanup handler (FINISH routine).  The ERROR_RETURN logs the event
     and calls fm_error_util_$signal, signalling the fm_sub_error_ condition.
     The ERROR_RETURN routine does not return and is used for errors which
     represent a real error.

*/

/* HISTORY:

Written by Matthew Pierret, 06/27/84.
Modified:
10/30/84 by Matthew Pierret:  Answered audit comments: removed sub_err_flags,
            fixed HISTORY section, fixed typo in DESCRIPTION section.
            Added the delete_force and redelete_force entries. Changed to use
            LOG_SV (in dm_log_sv_codes.incl.pl1).
01/10/85 by Matthew Pierret:  Changed to not signal error if not-in-use or
            if file uids don't match on the assumption that the file was
            deleted.
01/10/85 by Matthew C. Pierret:  Added ERROR_RETURN, LOG and MAKE_MESSAGE
            routines for better error handling.
02/28/85 by Matthew C. Pierret:  Changed to not log if the UIDs mis-match.
            That just means that the entry has already been deleted and
            re-used.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/14/85 by Matthew C. Pierret:  Changed to only unlock if the lock was
            successfully obtained and was not already locked by this process
            (it is invalid to lock the lock that a process already holds).
*/
/* format: style2,ind3 */
%page;
fm_sys_pn_tbl_delete:
   proc (p_file_uid, p_sys_pn_tbl_idx);

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

      dcl	    p_file_uid	       bit (36) aligned;	/*unique id of the DM file*/
      dcl	    p_sys_pn_tbl_idx       fixed bin (17);	/*index of entry in sys_pn_tbl*/

/* Automatic */

      dcl	    forced_delete	       bit (1) aligned;
      dcl	    code		       fixed bin (35);
      dcl	    file_uid	       bit (36) aligned;
      dcl	    lock_code	       fixed bin (35) init (LOCK_NOT_YET_ATTEMPTED);
      dcl	    sys_pn_tbl_idx	       fixed bin;
      dcl	    unlock_code	       fixed bin (35) init (UNLOCK_NOT_YET_ATTEMPTED);

/* Based */
/* Builtin */

      dcl	    (addr, lbound, length, min, substr, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    MYNAME	       init ("fm_sys_pn_tbl_delete") char (32) varying internal static options (constant);
      dcl	    LOCK_WAIT_TIME	       init (1e9) fixed bin (71) internal static options (constant);
      dcl	    (LOCK_NOT_YET_ATTEMPTED, UNLOCK_NOT_YET_ATTEMPTED)
			       init (-1) fixed bin (35) internal static options (constant);

/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
      dcl	    dm_misc_util_$log      entry options (variable);
      dcl	    fm_error_util_$signal  entry options (variable);
      dcl	    ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
      dcl	    lock_manager_$lock_fast
			       entry (ptr, fixed bin (71), fixed bin (35));
      dcl	    lock_manager_$unlock_fast
			       entry (ptr, fixed bin (35));

/* External */

      dcl	    (
	    dm_error_$fast_lock_invalid_reset,
	    dm_error_$file_uid_not_found
	    )		       ext fixed bin (35);

/* END OF DECLARATIONS */
%page;
      forced_delete = "0"b;
      go to JOIN;


redelete_force:
   entry (p_file_uid, p_sys_pn_tbl_idx);

      forced_delete = "1"b;
      go to JOIN;

JOIN:
      code = 0;
      file_uid = p_file_uid;
      sys_pn_tbl_idx = p_sys_pn_tbl_idx;

      on cleanup call FINISH ();

      call lock_manager_$lock_fast (addr (sys_pn_tbl.h.lock), LOCK_WAIT_TIME, lock_code);
      if lock_code ^= 0 & lock_code ^= dm_error_$fast_lock_invalid_reset
      then call ERROR_RETURN (lock_code, " Unable to lock ^a.", fm_data_$sys_pn_tbl_name);

      if sys_pn_tbl.e (sys_pn_tbl_idx).in_use = SPT_ENTRY_NOT_IN_USE
      then /* already been deleted - this is not unusual */
	 ;
      else if sys_pn_tbl.e (sys_pn_tbl_idx).file_uid ^= file_uid
      then /* again, already been deleted and replaced */
	 ;
      else
         do;
	  if forced_delete
	  then sys_pn_tbl.e (sys_pn_tbl_idx).open_count = 0;
	  else sys_pn_tbl.e (sys_pn_tbl_idx).open_count = sys_pn_tbl.e (sys_pn_tbl_idx).open_count - 1;

	  if sys_pn_tbl.e (sys_pn_tbl_idx).open_count = 0
	  then
	     do;
	        unspec (sys_pn_tbl.e (sys_pn_tbl_idx)) = ""b;
	        unspec (sys_pn_tbl.paths (sys_pn_tbl_idx)) = ""b;
	     end;

	  if sys_pn_tbl.h.last_entry = sys_pn_tbl_idx
	  then
	     do;
	        do sys_pn_tbl.h.last_entry = sys_pn_tbl_idx by -1 to lbound (sys_pn_tbl.e, 1)
		   while (sys_pn_tbl.e (sys_pn_tbl.h.last_entry).in_use = SPT_ENTRY_NOT_IN_USE);
	        end;
	     end;
         end;

      call lock_manager_$unlock_fast (addr (sys_pn_tbl.h.lock), unlock_code);
      if unlock_code ^= 0
      then call ERROR_RETURN (unlock_code, " Unable to unlock ^a.", fm_data_$sys_pn_tbl_name);


      return;
%page;
ERROR_RETURN:
   proc options (variable);


      dcl	    er_arg_list_ptr	       ptr;
      dcl	    er_code	       fixed bin (35) based (er_code_ptr);
      dcl	    er_code_ptr	       ptr;
      dcl	    er_code_len	       fixed bin (21);

      call cu_$arg_list_ptr (er_arg_list_ptr);
      call cu_$arg_ptr_rel (1, er_code_ptr, er_code_len, (0), er_arg_list_ptr);
      call fm_error_util_$signal (er_code, MYNAME, FM_ACTION_CANT_RESTART | FM_ACTION_LOG, LOG_SV,
	 MAKE_MESSAGE (er_arg_list_ptr));

/* fm_error_util_$signal never returns, however FINISH will be invoked when
   the stack is unwound. */

   end ERROR_RETURN;

LOG:
   proc options (variable);

      dcl	    l_arg_list_ptr	       ptr;
      dcl	    l_code	       fixed bin (35) based (l_code_ptr);
      dcl	    l_code_ptr	       ptr;
      dcl	    l_code_len	       fixed bin (21);

      call cu_$arg_list_ptr (l_arg_list_ptr);
      call cu_$arg_ptr_rel (1, l_code_ptr, l_code_len, (0), l_arg_list_ptr);
      call dm_misc_util_$log (LOG_SV, l_code, MYNAME, MAKE_MESSAGE (l_arg_list_ptr));

      return;

   end LOG;

MAKE_MESSAGE:
   proc (mm_p_arg_list_ptr) returns (char (*));

      dcl	    mm_p_arg_list_ptr      ptr;
      dcl	    mm_message_len	       fixed bin (21);
      dcl	    mm_message_buffer      char (1024);
      dcl	    (DONT_PAD, NO_NEW_LINE)
			       init ("0"b) bit (1) aligned;

      call ioa_$general_rs (mm_p_arg_list_ptr, 2, 3, mm_message_buffer, mm_message_len, DONT_PAD, NO_NEW_LINE);

      return (substr (mm_message_buffer, 1, min (length (mm_message_buffer), mm_message_len)));

   end MAKE_MESSAGE;

FINISH:
   proc ();


      if (lock_code = 0 | lock_code = dm_error_$fast_lock_invalid_reset) & unlock_code = UNLOCK_NOT_YET_ATTEMPTED
      then
         do;
	  call lock_manager_$unlock_fast (addr (sys_pn_tbl.h.lock), code);
	  if unlock_code ^= 0
	  then call LOG (unlock_code, " Failed to unlock ^a during cleanup.", fm_data_$sys_pn_tbl_name);

         end;

      return;

   end FINISH;
%page;
%include dm_fm_sub_error_flags;
%page;
%include dm_fm_sys_pn_tbl;
%page;
%include dm_log_sv_codes;

   end fm_sys_pn_tbl_delete;




		    fm_sys_pn_tbl_get_path.pl1      04/04/85  1119.5re  04/04/85  0826.9       62712



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


/* DESCRIPTION:

         This routine finds an entry in the System Pathname Table (sys_pn_tbl).
     returning the index of the entry. It is not assumed that the sys_pn_tbl is
     locked, and this routine will lock it while examining it.  It is assumed
     that the caller has set the validation level to the Data Management Ring.
*/

/* HISTORY:

Written by Matthew, 10/29/84.
Modified:
01/09/85 by Matthew Pierret:  Moved initialization of lock_is_locked to
            before the first potential call to FINISH (via LOG_ERROR_RETURN).
01/10/85 by Matthew C. Pierret:  Changed LOG_ERROR_RETURN to ERROR_RETURN,
            making ERROR_RETURN call fm_error_util_$signal.  Also removed the
            call to FINISH, relying on the cleanup on-unit to be invoked when
            the stack is unwound.  Removed knowledge of the now-obsolete
            SPT_ENTRY_IN_USE_BUT_DELETED state.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/14/85 by Matthew C. Pierret:  Changed to only attempt to unlock the lock if
            it has not yet attempted to do so and the lock was validly
            obtained.  In the case of the sys_pn_tbl.lock, it is invalid to
            obtain the lock if the process already has it locked.
*/

/* format: style2,ind3 */
%page;
fm_sys_pn_tbl_get_path:
   proc (p_sys_pn_tbl_ptr, p_lock_sys_pn_tbl, p_file_uid, p_file_path);

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

      dcl	    p_sys_pn_tbl_ptr       ptr;		/* points to the sys_pn_tbl */
      dcl	    p_lock_sys_pn_tbl      bit (1) aligned;	/* ON->lock the sys_pn_tbl */
      dcl	    p_file_uid	       bit (36) aligned;	/*unique id of the file*/
      dcl	    p_file_path	       char (168);		/*pathname of file */

/* Automatic */

      dcl	    code		       fixed bin (35) init (0);
      dcl	    file_uid	       bit (36) aligned init (""b);
      dcl	    lock_code	       fixed bin (35) init (LOCK_NOT_YET_ATTEMPTED);
      dcl	    sys_idx	       fixed bin init (-1);
      dcl	    sys_pn_tbl_ptr	       ptr;
      dcl	    unlock_code	       fixed bin (35) init (UNLOCK_NOT_YET_ATTEMPTED);

/* Based */
/* Builtin */

      dcl	    (addr, length, lbound, min, substr)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    MYNAME	       init ("fm_sys_pn_tbl_get_path") char (32) varying internal static options (constant);
      dcl	    LOCK_WAIT_TIME	       init (1000000000) fixed bin (71) internal static options (constant);
      dcl	    (LOCK_NOT_YET_ATTEMPTED, UNLOCK_NOT_YET_ATTEMPTED)
			       fixed bin (35) init (-1) internal static options (constant);

/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
      dcl	    dm_misc_util_$log      entry options (variable);
      dcl	    fm_error_util_$signal  entry options (variable);
      dcl	    ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
      dcl	    lock_manager_$lock_fast
			       entry (ptr, fixed bin (71), fixed bin (35));
      dcl	    lock_manager_$unlock_fast
			       entry (ptr, fixed bin (35));

/* External */

      dcl	    dm_error_$fast_lock_invalid_reset
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_bad_sys_pn_tbl_ver
			       fixed bin (35) ext;

/* END OF DECLARATIONS */
%page;

      on cleanup call FINISH ();

      file_uid = p_file_uid;
      sys_pn_tbl_ptr = p_sys_pn_tbl_ptr;
      if sys_pn_tbl_ptr -> sys_pn_tbl.h.version ^= SYS_PN_TBL_VERSION_1
      then call ERROR_RETURN (dm_error_$fm_bad_sys_pn_tbl_ver, "  Expected version ^w of ^a, received version ^w.",
	      SYS_PN_TBL_VERSION_1, fm_data_$sys_pn_tbl_name, sys_pn_tbl_ptr -> sys_pn_tbl.h.version);

      if p_lock_sys_pn_tbl
      then
         do;
	  call lock_manager_$lock_fast (addr (sys_pn_tbl_ptr -> sys_pn_tbl.h.lock), LOCK_WAIT_TIME, lock_code);
	  if lock_code ^= 0 & lock_code ^= dm_error_$fast_lock_invalid_reset
	  then call ERROR_RETURN (lock_code, "  Unable to lock ^a.", fm_data_$sys_pn_tbl_name);
         end;

      do sys_idx = lbound (sys_pn_tbl_ptr -> sys_pn_tbl.e, 1) to sys_pn_tbl_ptr -> sys_pn_tbl.h.last_entry
	 while (sys_pn_tbl_ptr -> sys_pn_tbl.e (sys_idx).file_uid ^= file_uid
	 | sys_pn_tbl_ptr -> sys_pn_tbl.e (sys_idx).in_use = SPT_ENTRY_NOT_IN_USE);
      end;

      if sys_idx > sys_pn_tbl_ptr -> sys_pn_tbl.h.last_entry
      then p_file_path = "";
      else p_file_path = sys_pn_tbl_ptr -> sys_pn_tbl.paths (sys_idx);

      if lock_code ^= LOCK_NOT_YET_ATTEMPTED
      then
         do;
	  call lock_manager_$unlock_fast (addr (sys_pn_tbl_ptr -> sys_pn_tbl.h.lock), unlock_code);
	  if unlock_code ^= 0
	  then call ERROR_RETURN (unlock_code, "  Unable to unlock ^a.^s", fm_data_$sys_pn_tbl_name);
         end;

      return;


ERROR_RETURN:
   proc options (variable);


      dcl	    er_arg_list_ptr	       ptr;
      dcl	    er_code	       fixed bin (35) based (er_code_ptr);
      dcl	    er_code_ptr	       ptr;
      dcl	    er_code_len	       fixed bin (21);

      call cu_$arg_list_ptr (er_arg_list_ptr);
      call cu_$arg_ptr_rel (1, er_code_ptr, er_code_len, (0), er_arg_list_ptr);
      call fm_error_util_$signal (er_code, MYNAME, FM_ACTION_CANT_RESTART | FM_ACTION_LOG, LOG_SV,
	 MAKE_MESSAGE (er_arg_list_ptr));

/* FINISH will be invoked to unlock the lock when the stack is unwound */
/* because of the "on cleanup call FIISH ();". */

   end ERROR_RETURN;

MAKE_MESSAGE:
   proc (mm_p_arg_list_ptr) returns (char (*));

      dcl	    mm_p_arg_list_ptr      ptr;
      dcl	    mm_message_len	       fixed bin (21);
      dcl	    mm_message_buffer      char (1024);
      dcl	    (DONT_PAD, NO_NEW_LINE)
			       init ("0"b) bit (1) aligned;

      call ioa_$general_rs (mm_p_arg_list_ptr, 2, 3, mm_message_buffer, mm_message_len, DONT_PAD, NO_NEW_LINE);

      return (substr (mm_message_buffer, 1, min (length (mm_message_buffer), mm_message_len)));

   end MAKE_MESSAGE;


FINISH:
   proc ();

      if (lock_code = 0 | lock_code = dm_error_$fast_lock_invalid_reset) & unlock_code = UNLOCK_NOT_YET_ATTEMPTED
      then
         do;
	  call lock_manager_$unlock_fast (addr (sys_pn_tbl_ptr -> sys_pn_tbl.h.lock), unlock_code);
	  if unlock_code ^= 0
	  then call dm_misc_util_$log (LOG_SV, unlock_code, MYNAME, "  Failed to unlock ^a during cleanup.",
		  fm_data_$sys_pn_tbl_name);
         end;

   end FINISH;

%page;
%include dm_fm_sys_pn_tbl;
%page;
%include dm_fm_sub_error_flags;
%page;
%include dm_log_sv_codes;

   end fm_sys_pn_tbl_get_path;




		    fm_sys_pn_tbl_insert.pl1        05/10/85  0807.3re  05/08/85  1037.4      168129



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


/* DESCRIPTION:

         This routine inserts a pathname/uid pair into an entry of the System
     Pathname  Table  (sys_pn_tbl).   It is assumed that the sys_pn_tbl is not
     locked, and this routine will lock it while examining it.  In fact, an
     error is signalled if the lock is already locked.  It is assumed
     that the caller has set the validation level to the Data Management Ring.

         Currently there is no mechanism for recovering from interuptions
     while inserting an entry.  Ideally there should be, but since an
     interuption immediately after this routine returns is really the same
     as one occurring during this routine, there is no pressing need.
     
         Error handling is managed by two routines: ERROR_RETURN and LOG,
     both of  which use the MAKE_MESSAGE function.  LOG simply logs an error
     and returns to the main procedure.  LOG is used when an inconsistency is
     found between the supplied and existing file_system_uid (a non-fatal 
     error) and when an error occurs in the FINISH procedure.  Both of these
     cases warrant reporting the unusual event while continuing to proceed.
     ERROR_RETURN is used in all other cases.  It logs a message then signals
     fm_sub_error_ via fm_error_util_$signal.  These errors are fatal errors.
     FINISH is not called by ERROR_RETURN as in many other modules.  It is
     invoked only by the cleanup handler when the stack is unwound.  
     A possible scenario in which FINISH is invoked is as follows:
       Invoke ERROR_RETURN, signal fm_sub_error_ via fm_error_util_signal,
       before signal escapes to outer ring stak is unwound, setting off
       cleanup on-unit, which calls FINISH.
*/

/* HISTORY:

Written by Matthew, 06/26/84.
Modified:
10/29/84 by Matthew Pierret:  Cleaned up error messages. Answered audit 
            comments. Added use of SPT_ENTRY_*_IN_USE constants.
01/10/85 by Matthew C. Pierret:  Added ERROR_RETURN, LOG and MAKE_MESSAGE
            routines for error handling.  Changed algorithm to not blow up if
            an entry is found but the file system uid's do not match, rather
            to log the event and continue looking for a suitable entry.  Also
            changed to only check for file system uid mismatch if the entry is
            not a new entry.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/14/85 by Matthew C. Pierret:  Changed to only flush once as the first flush
            does not really buy us anything.  Also changed to only unlock if
            the lock was obtained successfully and validly, where it is
            considered invalid to lock the table if the process already holds
            that lock.  More specifically, the codes
            dm_error_$invalid_lock_reset and 0 are valid codes returned from
            lock_manager_$lock_fast.
04/22/85 by Matthew C. Pierret:  Changed the loop which loops on sys_idx
            looking for a matching uid to start from sys_idx + 1 so that if
            the loop is executed again (happens if an entry has matching dm
            file uid but not file system uids) the same entry is not found a
            second time.
04/23/85 by Matthew C. Pierret:  Changed to attempt to find an orphan entry if
            the table is full.  An orphan entry is one which is in use but
            refers to a non-existent file.  Such entries are the result of a
            failure to run the post_transaction actions.  The sys_pn_tbl is
            locked and unlocked around each entry while looking for an ibly
            cause other transactions to timeout on the lock.
04/30/85 by Matthew C. Pierret:  Changed to salvage sys_pn_tbl if it is full,
            looking for an entry which describes a file which does not exist
            and is not in the process of being deleted.
*/

/* format: style2,ind3 */
%page;
fm_sys_pn_tbl_insert:
   proc (p_file_uid, p_file_path_name, p_component_0_seg_ptr, p_sys_pn_tbl_idx);

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

      dcl	    p_file_uid	       bit (36) aligned;	/*unique id of the file*/
      dcl	    p_file_path_name       char (*);		/*full pathname of the file*/
      dcl	    p_component_0_seg_ptr  ptr;		/*pointer to the first component of the file MSF*/
      dcl	    p_sys_pn_tbl_idx       fixed bin;		/*new index into sys_pn_tbl, meant to be stored in file_access_info.pn_tbl_idx */

/* Automatic */

      dcl	    code		       fixed bin (35) init (0);
      dcl	    component_0_seg_ptr    ptr init (null);
      dcl	    component_0_seg_uid    bit (36) aligned init (""b);
      dcl	    file_path_name	       char (168);
      dcl	    file_uid	       bit (36) aligned init (""b);
      dcl	    lock_code	       fixed bin (35) init (LOCK_OP_NOT_COMPLETE);
      dcl	    lock_state	       fixed bin init (LOCK_ATTEMPTED);
      dcl	    sys_idx	       fixed bin init (-1);
      dcl	    sys_pn_tbl_idx	       fixed bin init (-1);
      dcl	    unlock_code	       fixed bin (35) init (LOCK_OP_NOT_COMPLETE);

/* Based */
/* Builtin */

      dcl	    (addr, hbound, lbound, length, min, null, substr, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    MYNAME	       init ("fm_sys_pn_tbl_insert") char (32) varying internal static options (constant);
      dcl	    (
	    LOCK_WAIT_TIME	       init (1e9),
	    LOCK_DONT_WAIT	       init (0)
	    )		       fixed bin (71) internal static options (constant);
      dcl	    (
	    LOCK_ATTEMPTED	       init (1),
	    UNLOCK_ATTEMPTED       init (0)
	    )		       fixed bin internal static options (constant);
      dcl	    LOCK_OP_NOT_COMPLETE   init (-1) fixed bin (35) internal static options (constant);

/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
      dcl	    dm_misc_util_$log      entry options (variable);
      dcl	    expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
      dcl	    fm_error_util_$signal  entry options (variable);
      dcl	    fm_validate_$fm_validate_
			       entry (char (*), char (*), fixed bin (35));
      dcl	    hcs_$force_write       entry (ptr, bit (36), fixed bin (35));
      dcl	    hcs_$get_uid_seg       entry (ptr, bit (36) aligned, fixed bin (35));
      dcl	    ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
      dcl	    lock_manager_$lock     entry (bit (36) aligned, fixed bin (27), fixed bin, fixed bin (71), fixed bin,
			       fixed bin (35));
      dcl	    lock_manager_$lock_fast
			       entry (ptr, fixed bin (71), fixed bin (35));
      dcl	    lock_manager_$unlock_fast
			       entry (ptr, fixed bin (35));

/* External */

      dcl	    dm_error_$fast_lock_invalid_reset
			       fixed bin (35) ext;
      dcl	    dm_error_$file_duplication
			       fixed bin (35) ext;
      dcl	    dm_error_$fm_sys_pn_tbl_full
			       fixed bin (35) ext;
      dcl	    error_table_$noentry   fixed bin (35) ext;

/* END OF DECLARATIONS */
%page;
      p_sys_pn_tbl_idx = -1;

      code = 0;
      component_0_seg_ptr = p_component_0_seg_ptr;
      file_uid = p_file_uid;
      file_path_name = p_file_path_name;

      call hcs_$get_uid_seg (component_0_seg_ptr, component_0_seg_uid, code);
      if code ^= 0
      then call ERROR_RETURN (code, "  Trying to get the Multics file system uid of ^a>0 (^p).", file_path_name,
	      component_0_seg_ptr);

      on cleanup call FINISH ();

      call LOCK (lock_state, lock_code);

      sys_pn_tbl_idx = -1;
      sys_idx = lbound (sys_pn_tbl.e, 1) - 1;

FIND_ENTRY_LOOP:
      do while (sys_pn_tbl_idx = -1);

         do sys_idx = sys_idx + 1 to sys_pn_tbl.h.last_entry
	    while (sys_pn_tbl.e (sys_idx).file_uid ^= file_uid | sys_pn_tbl.e (sys_idx).in_use = SPT_ENTRY_NOT_IN_USE);
						/* This loop stops when it */
						/* finds matching uids in  */
						/* an entry currently used */
         end;

         if sys_idx <= sys_pn_tbl.h.last_entry
         then
VERIFY_EXISTING_ENTRY:
	  do;
	     if sys_pn_tbl.e (sys_idx).file_system_uid = component_0_seg_uid
	     then sys_pn_tbl_idx = sys_idx;
	     else call LOG (dm_error_$file_duplication,
		     "The new one is ^a.  The one already known in entry ^d is ^a.^/The new one will be put in another entry.",
		     file_path_name, sys_idx, sys_pn_tbl.paths (sys_idx));
	  end VERIFY_EXISTING_ENTRY;
         else
INSERT_NEW_ENTRY:
	  do;
	     do sys_idx = lbound (sys_pn_tbl.e, 1) to sys_pn_tbl.h.last_entry
		while (sys_pn_tbl.e (sys_idx).in_use ^= SPT_ENTRY_NOT_IN_USE);
	     end;

	     if sys_idx > sys_pn_tbl.h.last_entry & sys_pn_tbl.h.last_entry = hbound (sys_pn_tbl.e, 1)
	     then call SALVAGE_TABLE (sys_idx, lock_state, lock_code, unlock_code);

	     if sys_idx > sys_pn_tbl.h.last_entry
	     then sys_pn_tbl.h.last_entry = sys_idx;

	     unspec (sys_pn_tbl.e (sys_idx)) = ""b;
	     unspec (sys_pn_tbl.paths (sys_idx)) = ""b;

	     sys_pn_tbl.paths (sys_idx) = file_path_name;
	     sys_pn_tbl.e (sys_idx).file_uid = file_uid;
	     sys_pn_tbl.e (sys_idx).file_system_uid = component_0_seg_uid;
	     sys_pn_tbl.e (sys_idx).in_use = SPT_ENTRY_IN_USE;
	     sys_pn_tbl_idx = sys_idx;
	  end INSERT_NEW_ENTRY;
      end FIND_ENTRY_LOOP;

      sys_pn_tbl.e (sys_pn_tbl_idx).open_count = sys_pn_tbl.e (sys_pn_tbl_idx).open_count + 1;

      if sys_pn_tbl.e (sys_pn_tbl_idx).open_count = 1
      then
         do;
	  call hcs_$force_write (fm_data_$sys_pn_tbl_ptr, ""b, code);
	  if code ^= 0
	  then call ERROR_RETURN (code, "  Unable to force-write ^a (^p) after inserting file ^a in entry ^d.",
		  fm_data_$sys_pn_tbl_name, fm_data_$sys_pn_tbl_ptr, file_path_name, sys_pn_tbl_idx);
         end;

      p_sys_pn_tbl_idx = sys_pn_tbl_idx;

      call UNLOCK (lock_state, unlock_code);

      return;
%page;
ERROR_RETURN:
   proc options (variable);


      dcl	    er_arg_list_ptr	       ptr;
      dcl	    er_code	       fixed bin (35) based (er_code_ptr);
      dcl	    er_code_ptr	       ptr;
      dcl	    er_code_len	       fixed bin (21);

      call cu_$arg_list_ptr (er_arg_list_ptr);
      call cu_$arg_ptr_rel (1, er_code_ptr, er_code_len, (0), er_arg_list_ptr);
      call fm_error_util_$signal (er_code, MYNAME, FM_ACTION_CANT_RESTART | FM_ACTION_LOG, LOG_SV,
	 MAKE_MESSAGE (er_arg_list_ptr));

/* fm_error_util_$signal never returns, however FINISH will be invoked when
   the stack is unwound. */

   end ERROR_RETURN;

LOG:
   proc options (variable);

      dcl	    l_arg_list_ptr	       ptr;
      dcl	    l_code	       fixed bin (35) based (l_code_ptr);
      dcl	    l_code_ptr	       ptr;
      dcl	    l_code_len	       fixed bin (21);

      call cu_$arg_list_ptr (l_arg_list_ptr);
      call cu_$arg_ptr_rel (1, l_code_ptr, l_code_len, (0), l_arg_list_ptr);
      call dm_misc_util_$log (LOG_SV, l_code, MYNAME, MAKE_MESSAGE (l_arg_list_ptr));

      return;

   end LOG;

MAKE_MESSAGE:
   proc (mm_p_arg_list_ptr) returns (char (*));

      dcl	    mm_p_arg_list_ptr      ptr;
      dcl	    mm_message_len	       fixed bin (21);
      dcl	    mm_message_buffer      char (1024);
      dcl	    (DONT_PAD, NO_NEW_LINE)
			       init ("0"b) bit (1) aligned;

      call ioa_$general_rs (mm_p_arg_list_ptr, 2, 3, mm_message_buffer, mm_message_len, DONT_PAD, NO_NEW_LINE);

      return (substr (mm_message_buffer, 1, min (length (mm_message_buffer), mm_message_len)));

   end MAKE_MESSAGE;


FINISH:
   proc ();

      if (lock_state = LOCK_ATTEMPTED & (lock_code = 0 | lock_code = dm_error_$fast_lock_invalid_reset))
	 | (lock_state = UNLOCK_ATTEMPTED & unlock_code = -1)
      then call UNLOCK (lock_state, unlock_code);

   end FINISH;
%page;
LOCK:
   proc (lk_p_lock_state, lk_p_lock_code);

/* This routine locks the SPT.  Following a protocol used to always be
   able to determine if the SPT is locked, it:
     1) sets lk_p_lock_code to LOCK_OP_NOT_COMPLETE (-1)
     2) sets lk_p_lock_state to LOCK_ATTEMPTED
     3) calls lock_manager_$lock_fast with lk_p_lock_code as
        the error code.
   The parameters correspond with the global variables lock_code and
   lock_state. This protocol (and a simlar one for unlocking) means 
   that if lock_state is equal to LOCK_ATTEMPTED and lock_code is equal
   to either 0 or dm_error_$fast_lock_invalid_reset, we have the lock. */

      dcl	    lk_p_lock_state	       fixed bin parameter;
      dcl	    lk_p_lock_code	       fixed bin (35) parameter;

      lk_p_lock_code = LOCK_OP_NOT_COMPLETE;
      lk_p_lock_state = LOCK_ATTEMPTED;
      call lock_manager_$lock_fast (addr (sys_pn_tbl.h.lock), LOCK_WAIT_TIME, lk_p_lock_code);
      if lk_p_lock_code ^= 0 & lk_p_lock_code ^= dm_error_$fast_lock_invalid_reset
      then call ERROR_RETURN (lk_p_lock_code, " Unable to lock ^a.", fm_data_$sys_pn_tbl_name);
      else return;

   end LOCK;
%skip (4);
UNLOCK:
   proc (u_p_lock_state, u_p_unlock_code);

/* This routine unlocks the SPT.  Following a protocol used to always be
   able to determine if the SPT is locked, it:
     1) sets u_p_unlock_code to LOCK_OP_NOT_COMPLETE (-1)
     2) sets u_p_lock_state to UNLOCK_ATTEMPTED
     3) calls lock_manager_$unlock_fast with u_p_unlock_code as
        the error code.
   The parameters correspond with the global variables unlock_code and
   lock_state. This protocol (and a simlar one for locking) means 
   that if lock_state is equal to UNLOCK_ATTEMPTED and unlock_code is equal
   to 0, we've unlocked the lock. */

      dcl	    u_p_lock_state	       fixed bin parameter;
      dcl	    u_p_unlock_code	       fixed bin (35) parameter;

      u_p_unlock_code = LOCK_OP_NOT_COMPLETE;
      u_p_lock_state = UNLOCK_ATTEMPTED;
      call lock_manager_$unlock_fast (addr (sys_pn_tbl.h.lock), u_p_unlock_code);
      if u_p_unlock_code ^= 0
      then call ERROR_RETURN (u_p_unlock_code, " Unable to unlock ^a.", fm_data_$sys_pn_tbl_name);
      else return;

   end UNLOCK;
%page;
SALVAGE_TABLE:
   proc (st_p_sys_idx, st_p_lock_state, st_p_lock_code, st_p_unlock_code);

/* SALVAGE_TABLE walks through sys_pn_tbl verifying that each entry describes
   a file which exists or one which is in the process of being deleted.  If
   an entry fails verification, i.e., the file does not exist and no other
   transaction has the file locked, the entry is claimed for use by this
   transaction.  As SALVAGE_TABLE is called only when sys_pn_tbl is full,
   if no salvagable entry is found, the table is really full. 

   So as not to hold the sys_pn_tbl lock for too long, after looking at each
   entry it is unlocked and locked again between entries. */

      dcl	    (
	    st_p_sys_idx	       fixed bin,
	    st_p_lock_state	       fixed bin,
	    st_p_lock_code	       fixed bin (35),
	    st_p_unlock_code       fixed bin (35)
	    )		       parameter;

      dcl	    st_sys_idx	       fixed bin;

      call LOG (dm_error_$fm_sys_pn_tbl_full, "Beginning salvage of ^a.", fm_data_$sys_pn_tbl_name);

      st_p_sys_idx = -1;
      st_sys_idx = lbound (sys_pn_tbl.e, 1);

      call VALIDATE_ENTRY (st_sys_idx, st_p_lock_state, st_p_lock_code, st_p_unlock_code, st_p_sys_idx);

      do st_sys_idx = st_sys_idx + 1 to sys_pn_tbl.h.last_entry while (st_p_sys_idx = -1);
         call UNLOCK (st_p_lock_state, st_p_unlock_code);
         call LOCK (st_p_lock_state, st_p_lock_code);
         call VALIDATE_ENTRY (st_sys_idx, st_p_lock_state, st_p_lock_code, st_p_unlock_code, st_p_sys_idx);
      end;

      if st_p_sys_idx = -1
      then
         do;
	  call UNLOCK (st_p_lock_state, st_p_unlock_code);
	  call ERROR_RETURN (dm_error_$fm_sys_pn_tbl_full, "  No salvagable entries were found.");
         end;
      else return;

   end SALVAGE_TABLE;
%page;
VALIDATE_ENTRY:
   proc (ve_p_sys_idx, ve_p_lock_state, ve_p_lock_code, ve_p_unlock_code, ve_p_invalid_entry_idx);

/* VALIDATE_ENTRY checks an entry in sys_pn_tbl to see if it contains an 
   active file, one that either exists or is in the process of being deleted.
   The validation is as follows:
     1) If the pathname is invalid, the entry is invalid.
     2) If the file exists, the entry is valid.
     3) If the file does not exist, attempt to lock the file.
        3.1) If the file is locked by another transaction, assume that
             that transaction is in the process of deleting it, so
             the entry is valid.
        3.2) If the file is not locked, then no transaction is in the
             process of deleting it, so the entry is invalid.  
   An entry is indicated as valid by setting ve_p_invalid_entry_idx to -1,
   as invalid by setting ve_p_invalid_entry_idx to ve_p_sys_idx.
*/

      dcl	    (
	    ve_p_sys_idx	       fixed bin,
	    ve_p_lock_state	       fixed bin,
	    ve_p_lock_code	       fixed bin (35),
	    ve_p_unlock_code       fixed bin (35),
	    ve_p_invalid_entry_idx fixed bin
	    )		       parameter;
      dcl	    ve_code	       fixed bin (35) init (0);
      dcl	    ve_dir	       char (168);
      dcl	    ve_file	       char (32);

      call expand_pathname_ ((sys_pn_tbl.paths (ve_p_sys_idx)), ve_dir, ve_file, ve_code);
      if ve_code ^= 0
      then
         do;
	  ve_p_invalid_entry_idx = ve_p_sys_idx;
	  call LOG (0, "Salvaged ^a entry ^d with file ^a. The path is invalid.", fm_data_$sys_pn_tbl_name,
	       ve_p_invalid_entry_idx, sys_pn_tbl.paths (ve_p_invalid_entry_idx));
         end;
      else
         do;
	  call fm_validate_$fm_validate_ (ve_dir, ve_file, ve_code);
	  if ve_code ^= error_table_$noentry
	  then ve_p_invalid_entry_idx = -1;
	  else
	     do;
	        call lock_manager_$lock (sys_pn_tbl.e (ve_p_sys_idx).file_uid, LOCK_ENTIRE_FILE, LOCK_MODE_X,
		   LOCK_DONT_WAIT, (0), ve_code);
	        if ve_code = 0
	        then
		 do;
		    ve_p_invalid_entry_idx = ve_p_sys_idx;
		    call LOG (0, "Salvaged ^a entry ^d with file ^a. The file does not exist.",
		         fm_data_$sys_pn_tbl_name, ve_p_invalid_entry_idx, sys_pn_tbl.paths (ve_p_invalid_entry_idx));
		 end;
	        else ve_p_invalid_entry_idx = -1;
	     end;
         end;
   end VALIDATE_ENTRY;
%page;
%include dm_fm_sys_pn_tbl;
%page;
%include dm_fm_sub_error_flags;
%page;
%include dm_lock_modes;
%page;
%include dm_log_sv_codes;

   end fm_sys_pn_tbl_insert;




		    fm_sys_pn_tbl_opens.pl1         04/04/85  1119.5re  04/04/85  0827.2       35505



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

/* DESCRIPTION:

         This  routine returns the number of opens for a file in the System
     Pathname  Table  (sys_pn_tbl).    This  routine  locks  and  unlocks  the
     sys_pn_tbl, so if the caller already has the sys_pn_tbl locked and wishes
     it  to  stay  locked,  it must  lock  the sys_pn_tbl  after  this routine
     returns.    The  caller  must  also  have  set   the   validation   level
     appropriately.
*/

/* HISTORY:

Written by Matthew Pierret, 12/20/84.
Modified:
02/27/85 by Lee A. Newcomb:  Removed unused variables and corrected a name in
            the history section.
*/
/* format: style2,ind3 */
%page;
fm_sys_pn_tbl_opens:
   proc (p_file_uid, p_sys_pn_tbl_idx, p_opens, p_code);

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

      dcl	    p_file_uid	       bit (36) aligned;	/*unique id of the DM file*/
      dcl	    p_sys_pn_tbl_idx       fixed bin (17);	/*index of entry in sys_pn_tbl*/
      dcl	    p_opens	       fixed bin (17);	/* number of processes that have file open*/
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    try_to_unlock_lock     bit (1) aligned;
      dcl	    code		       fixed bin (35) init (0);
      dcl	    file_uid	       bit (36) aligned init (""b);
      dcl	    sys_pn_tbl_idx	       fixed bin init (-1);

/* Based */
/* Builtin */

      dcl	    addr		       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("fm_sys_pn_tbl_opens") char (32) varying internal static options (constant);
      dcl	    LOCK_WAIT_TIME	       init (1e9) fixed bin (71) internal static options (constant);

/* Entry */

      dcl	    fm_error_util_$signal  entry options (variable);
      dcl	    lock_manager_$lock_fast
			       entry (ptr, fixed bin (71), fixed bin (35));
      dcl	    lock_manager_$unlock_fast
			       entry (ptr, fixed bin (35));

/* External */

      dcl	    (
	    dm_error_$fast_lock_invalid_reset,
	    dm_error_$fm_sys_pne_clobbered
	    )		       ext fixed bin (35);

/* END OF DECLARATIONS */
%page;
      p_code, code = 0;
      file_uid = p_file_uid;
      sys_pn_tbl_idx = p_sys_pn_tbl_idx;
      try_to_unlock_lock = "1"b;

      on cleanup call FINISH ();

      call lock_manager_$lock_fast (addr (sys_pn_tbl.h.lock), LOCK_WAIT_TIME, code);
      if code ^= 0 & code ^= dm_error_$fast_lock_invalid_reset
      then call ERROR_RETURN (code);

      if sys_pn_tbl.e (sys_pn_tbl_idx).file_uid ^= file_uid
      then call ERROR_RETURN (dm_error_$fm_sys_pne_clobbered);

      if sys_pn_tbl.e (sys_pn_tbl_idx).in_use = 0
      then call ERROR_RETURN (dm_error_$fm_sys_pne_clobbered);

      p_opens = sys_pn_tbl.e (sys_pn_tbl_idx).open_count;

      call lock_manager_$unlock_fast (addr (sys_pn_tbl.h.lock), code);
      try_to_unlock_lock = "0"b;
      if code ^= 0
      then call ERROR_RETURN (code);

MAIN_RETURN:
      return;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35) parameter;

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

   end ERROR_RETURN;

FINISH:
   proc ();


      if try_to_unlock_lock
      then
         do;
	  call lock_manager_$unlock_fast (addr (sys_pn_tbl.h.lock), code);
	  try_to_unlock_lock = "0"b;
	  if code ^= 0
	  then call fm_error_util_$signal (code, myname, FM_ACTION_QUIET_RESTART | FM_ACTION_LOG, LOG_SV,
		  "  Unable to unlock ^a.", fm_data_$sys_pn_tbl_name);
         end;

      return;

   end FINISH;
%page;
%include dm_fm_sub_error_flags;
%page;
%include dm_fm_sys_pn_tbl;
%page;
%include dm_log_sv_codes;

   end fm_sys_pn_tbl_opens;




		    fm_sys_pn_tbl_rename.pl1        05/10/85  0807.3re  05/08/85  1037.4       75942



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

/* DESCRIPTION:

         This  routine  renames a pathname in the file_manager_'s System
     Pathname  Table  (sys_pn_tbl).    This  routine  locks  and  unlocks  the
     sys_pn_tbl, so if the caller already has the sys_pn_tbl locked and wishes
     it  to  stay  locked,  the  must  lock  the sys_pn_tbl after this routine
     returns.    The  caller  must  also  have  set   the   validation   level
     appropriately.

         The current transaction must have obtained an exclusive (X) lock on 
     the file being renamed.  This guarantees that there are no outstanding
     before images against the file other than those held by the current
     transaction (actually, a share (S) lock might be sufficient).

         If we are unable to find the file in the sys_pn_tbl at the
     p_sys_pn_tbl_idx location, we search the sys_pn_tbl for the file uid to
     get the index.  If the file's uid is not in the table, it is a fatal
     error.
*/

/* HISTORY:

Written by Matthew, 10/29/84.
Modified:
01/10/85 by Matthew C. Pierret:  Changed myname to MYNAME.  Added ERROR_RETURN
            and MAKE_MESSAGE routines.  Made to call fm_error_util_$signal via
            ERROR_RETURN if the call to lock_manager_$unlock_fast in the
            normal execution path fails, but to only log and continue if in
            FINISH (the cleanup on-unit handler).
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/14/85 by Matthew C. Pierret:  Changed to only try to unlock the sys_pn_tbl
            lock once and only if the lock was validly obtained.  In this
            context, valid means the lock was previously not held (lock_code
            is 0) or the lock was held by a dead process (lock_code is
            dm_error_$fast_lock_invalid_reset).  It is invalid if the lock was
            previously held by this process.
05/02/85 by Lee A. Newcomb:  Changed to search the sys_pn_tbl by uid if the
            entry located by p_sys_pn_tbl_idx is not the file we expected;
            this is required for recovery to work correctly.
*/
/* format: style2,ind3 */
%page;
fm_sys_pn_tbl_rename:
   proc (p_file_uid, p_sys_pn_tbl_idx, p_new_name);

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

      dcl	    p_file_uid	       bit (36) aligned;	/*unique id of the DM file*/
      dcl	    p_sys_pn_tbl_idx       fixed bin (17);	/*index of entry in sys_pn_tbl*/
      dcl	    p_new_name	       char (32);		/*new entry name of file*/

/* Automatic */

      dcl	    absolute_path	       char (168);
      dcl	    dir_path	       char (168);
      dcl	    entry_name	       char (32);
      dcl	    code		       fixed bin (35) init (0);
      dcl	    file_uid	       bit (36) aligned init (""b);
      dcl	    lock_code	       fixed bin (35) init (LOCK_NOT_YET_ATTEMPTED);
      dcl	    sys_pn_tbl_idx	       fixed bin init (-1);
      dcl	    unlock_code	       fixed bin (35) init (UNLOCK_NOT_YET_ATTEMPTED);

/* Based */
/* Builtin */

      dcl	    (addr, length, min, substr)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    MYNAME	       init ("fm_sys_pn_tbl_rename") char (32) varying internal static options (constant);
      dcl	    LOCK_WAIT_TIME	       init (1e9) fixed bin (71) internal static options (constant);
      dcl	    (LOCK_NOT_YET_ATTEMPTED, UNLOCK_NOT_YET_ATTEMPTED)
			       fixed bin (35) init (-1) internal static options (constant);

/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
      dcl	    dm_misc_util_$log      entry options (variable);
      dcl	    expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
      dcl	    fm_error_util_$signal  entry options (variable);
      dcl	    hcs_$force_write       entry (ptr, bit (36), fixed bin (35));
      dcl	    ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
      dcl	    lock_manager_$lock_fast
			       entry (ptr, fixed bin (71), fixed bin (35));
      dcl	    lock_manager_$unlock_fast
			       entry (ptr, fixed bin (35));
      dcl	    pathname_	       entry (char (*), char (*)) returns (char (168));

/* External */

      dcl	    (
	    dm_error_$fast_lock_invalid_reset,
	    dm_error_$file_uid_not_found,
	    dm_error_$fm_sys_pne_clobbered
	    )		       ext fixed bin (35);

/* END OF DECLARATIONS */
%page;

      file_uid = p_file_uid;
      sys_pn_tbl_idx = p_sys_pn_tbl_idx;

      on cleanup call FINISH ();

      call lock_manager_$lock_fast (addr (sys_pn_tbl.h.lock), LOCK_WAIT_TIME, lock_code);
      if lock_code ^= 0 & lock_code ^= dm_error_$fast_lock_invalid_reset
      then call ERROR_RETURN (lock_code, "  Unable to lock ^a.", fm_data_$sys_pn_tbl_name);

      if sys_pn_tbl.e (sys_pn_tbl_idx).in_use = 0 | sys_pn_tbl.e (sys_pn_tbl_idx).file_uid ^= file_uid
      then
GET_SYS_PN_TBL_INDEX:
         do;

/* following loop stops when the UID is found in active entry. */
/* This is based on the UID search loop in fm_sys_pn_tbl_insert. */
	  do sys_pn_tbl_idx = lbound (sys_pn_tbl.e, 1) to sys_pn_tbl.h.last_entry
	       while (sys_pn_tbl.e (sys_pn_tbl_idx).file_uid ^= file_uid
	       | sys_pn_tbl.e (sys_pn_tbl_idx).in_use = SPT_ENTRY_NOT_IN_USE);
	  end;
	  if sys_pn_tbl_idx > sys_pn_tbl.h.last_entry
	  then call ERROR_RETURN (dm_error_$file_uid_not_found, "Unable to re-name file with unique id ^w.", file_uid);
         end GET_SYS_PN_TBL_INDEX;

      absolute_path = sys_pn_tbl.paths (sys_pn_tbl_idx);
      call expand_pathname_ (absolute_path, dir_path, entry_name, code);
      if code ^= 0
      then call ERROR_RETURN (code, "  Unable to expand ^a entry ^d: ^a.", fm_data_$sys_pn_tbl_name, sys_pn_tbl_idx,
	      sys_pn_tbl.paths (sys_pn_tbl_idx));

      sys_pn_tbl.paths (sys_pn_tbl_idx) = pathname_ (dir_path, p_new_name);

      call hcs_$force_write (fm_data_$sys_pn_tbl_ptr, ""b, code);
      if code ^= 0
      then call ERROR_RETURN (code, "  Unable to force-write ^a (^p).", fm_data_$sys_pn_tbl_name, fm_data_$sys_pn_tbl_ptr)
	      ;

      call lock_manager_$unlock_fast (addr (sys_pn_tbl.h.lock), unlock_code);
      if unlock_code ^= 0
      then call ERROR_RETURN (unlock_code, "  Unable to unlock ^a.", fm_data_$sys_pn_tbl_name);

      return;

%page;
ERROR_RETURN:
   proc options (variable);


      dcl	    er_arg_list_ptr	       ptr;
      dcl	    er_code	       fixed bin (35) based (er_code_ptr);
      dcl	    er_code_ptr	       ptr;
      dcl	    er_code_len	       fixed bin (21);

      call cu_$arg_list_ptr (er_arg_list_ptr);
      call cu_$arg_ptr_rel (1, er_code_ptr, er_code_len, (0), er_arg_list_ptr);
      call fm_error_util_$signal (er_code, MYNAME, FM_ACTION_CANT_RESTART | FM_ACTION_LOG, LOG_SV,
	 MAKE_MESSAGE (er_arg_list_ptr));

/* fm_error_util_$signal never returns, however FINISH will be invoked when
   the stack is unwound. */

   end ERROR_RETURN;

MAKE_MESSAGE:
   proc (mm_p_arg_list_ptr) returns (char (*));

      dcl	    mm_p_arg_list_ptr      ptr;
      dcl	    mm_message_len	       fixed bin (21);
      dcl	    mm_message_buffer      char (1024);
      dcl	    (DONT_PAD, NO_NEW_LINE)
			       init ("0"b) bit (1) aligned;

      call ioa_$general_rs (mm_p_arg_list_ptr, 2, 3, mm_message_buffer, mm_message_len, DONT_PAD, NO_NEW_LINE);

      return (substr (mm_message_buffer, 1, min (length (mm_message_buffer), mm_message_len)));

   end MAKE_MESSAGE;


FINISH:
   proc ();


      if (lock_code = 0 | lock_code = dm_error_$fast_lock_invalid_reset) & unlock_code = UNLOCK_NOT_YET_ATTEMPTED
      then
         do;
	  call lock_manager_$unlock_fast (addr (sys_pn_tbl.h.lock), unlock_code);
	  if unlock_code ^= 0
	  then call dm_misc_util_$log (LOG_SV, unlock_code, MYNAME, "  Unable to unlock ^a during cleanup.",
		  fm_data_$sys_pn_tbl_name);
         end;

      return;

   end FINISH;
%page;
%include dm_fm_sub_error_flags;
%page;
%include dm_fm_sys_pn_tbl;
%page;
%include dm_log_sv_codes;

   end fm_sys_pn_tbl_rename;




		    fm_sys_pn_tbl_util_.alm         03/06/85  0802.6re  03/05/85  0759.5       12096



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
"
"  DESCRIPTION:
"
"       This is the fm_sys_pn_tbl_util_ transfer vector, which transfers
"  to entries which manipulate the Data Management file manager's
"  sys_pn_tbl.  The sys_pn_tbl is a registry of files which potentially
"  have outstanding before images to be processed.

" HISTORY:
" Written by Matthew Pierret, 10/29/84.
" Modified:
" 12/20/84 by Matthew Pierret:  Added the entry opens.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

          name     fm_sys_pn_tbl_util_

          macro    transfer
          entry    &1
&1:
          tra      &2

          &end

	transfer  get_path,fm_sys_pn_tbl_get_path$fm_sys_pn_tbl_get_path
          transfer  delete,fm_sys_pn_tbl_delete$fm_sys_pn_tbl_delete
          transfer  insert,fm_sys_pn_tbl_insert$fm_sys_pn_tbl_insert
          transfer  opens,fm_sys_pn_tbl_opens$fm_sys_pn_tbl_opens
          transfer  redelete_force,fm_sys_pn_tbl_delete$redelete_force
          transfer  rename,fm_sys_pn_tbl_rename$fm_sys_pn_tbl_rename

          end




		    fm_user_shutdown.pl1            03/06/85  0802.6re  03/05/85  0759.5        6021



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

/* format: style4,indattr,ifthenstmt,ifthen,^indcomtxt,idind33 */

fm_user_shutdown:
     proc ();

/* DESCRIPTION:

         This entry is currently a no-op and is simply being a place-holder
     until and if a real fm_user_shutdown is needed.
*/

/* HISTORY:

Written by L. A. Newcomb, 05/01/84.
Modified:
*/

	return;

     end fm_user_shutdown;




		    lm_check_for_deadlock_.pl1      03/06/85  0802.6re  03/05/85  0759.5       56403



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

/*  DESCRIPTION:
    Lock Manager Deadlock Detection

    Determines whether a deadlock (lock-wait cycle) exists involving this
    transaction and returns this determination via the error code.

    Lock_Deadlock_ptr -> a bit array of dimension (p_n_lock_deadlock, p_n_lock_deadlock).
    (x,y) is ON <=> transaction x is waiting for a lock held by transaction y.
    transaction 1 must be this transaction. As an optimization, it is only
    necessary to consider transactions which are waiting for locks and
    the current transaction (since a transaction which is not waiting cannot
    be involved in a deadlock).

    No lock need be held by this transaction, since a deadlock is stable.

    This program implements the Transitive Closure algorithm of
	     Reingold, Nievergelt and Deo, Combinatorial Algorithms,
	     page 341-341, to find an adjacency matrix. If
	     any diagonal bit is on, there is a cycle. If (1, 1) is on
	     the calling txn is in the cycle. All those txns t
	     whose diagonals are on and for which (1, t) is on
	     are part of this deadlock, so we can determine
	     the youngest one (by bit order of TXN id). Only
	     the youngest will roll back.
*/
/* HISTORY:

Written by J. Bongiovanni, January 1983.
Modified:
04/28/83 by Benson I. Margulies:  Reimplemented to use sneaky ADJ algorithm
            and optimize the small cases.
05/01/84 by R. Michael Tague:  Added the History section.  Added
            %include dm_lm_meters.
10/16/84 by Stanford S. Cox:  For DMS program standards.
*/

/* format: style2,^inddcls,ifthenstmt,ifthendo,^indnoniterdo,^inditerdo,ind3,idind32 */
lm_check_for_deadlock_:
   procedure (p_lock_deadlock_ptr, p_lock_deadlock_txn_ids_ptr, p_n_lock_deadlock, p_notify_txn, p_code);

/*  Parameter  */

dcl     p_code			fixed bin (35);	/* Standard error code */
dcl     p_lock_deadlock_ptr		ptr parameter;	/* -> lock_deadlock array */
dcl     p_lock_deadlock_txn_ids_ptr	ptr parameter;
dcl     p_n_lock_deadlock		fixed bin parameter;/* Number of transactions in array */
dcl     p_notify_txn		bit (36) aligned;

/*  Automatic  */

dcl     (l, txn_idx)		fixed bin;	/* array indices */
dcl     youngest			bit (36) aligned;

/*  External  */

dcl     dm_system_data_$max_n_transactions
				fixed bin ext;
dcl     dm_error_$lock_deadlock	fixed bin (35) external;




      p_code = 0;
      lock_deadlock_ptr = p_lock_deadlock_ptr;
      lock_deadlock_txn_ids_ptr = p_lock_deadlock_txn_ids_ptr;
      n_lock_deadlock = p_n_lock_deadlock;
      p_notify_txn = ""b;


/***** First, convert the digraph matrix to an adjancy matrix. */
/***** The three different procedures are to allow the compiler to avoid */
/***** EIS when possible, since the speed difference is large. */

      if n_lock_deadlock = 36 /* These procedure take advantage of */ then call CLOSURE_SINGLE_WORD (lock_deadlock_ptr);
						/* the non-eis bit manipulation */
      else if n_lock_deadlock = 72 /* instructions */ then call CLOSURE_DOUBLE_WORD (lock_deadlock_ptr);
      else call CLOSURE_MULTI_WORD (lock_deadlock_ptr);

/***** Now, wait_own is really ADJ (wait_own*).  If (1, 1) is on, */
/***** then there is a deadlock involving us. */

      if ^lock_deadlock.wait_own (1, 1) then return;

/***** Now, the diagonal entries are TXN's that are involved in some deadlock */
/***** wait_own (1, txn_idx) --> that txn txn_idx is in our deadlock. */
/***** this could also be benefited by the 36/72 trick, but is not really */
/***** worth it. */

      youngest = (36)"0"b;

      do txn_idx = 2 to n_lock_deadlock;
         if lock_deadlock.wait_own (txn_idx, txn_idx)
         then if lock_deadlock.wait_own (1, txn_idx)
	    then if lock_deadlock_txn_ids (txn_idx) > youngest then youngest = lock_deadlock_txn_ids (txn_idx);
      end;

      if lock_deadlock_txn_ids (1) > youngest /* we are junior */ then do;
         p_code = dm_error_$lock_deadlock;
         return;
      end;

      p_notify_txn = youngest;

      return;


CLOSURE_MULTI_WORD:
   procedure (cm_p_lock_deadlock_ptr);

dcl     cm_p_lock_deadlock_ptr	ptr;
dcl     1 cm_lock_deadlock		like lock_deadlock aligned based (cm_p_lock_deadlock_ptr);
dcl     cm_owner_txn_idx		fixed bin;
dcl     cm_waiter_txn_idx		fixed bin;

      do cm_owner_txn_idx = 1 to hbound (cm_lock_deadlock.wait_own, 1);
         do cm_waiter_txn_idx = 1 to hbound (cm_lock_deadlock.wait_own, 1);
	  if cm_lock_deadlock.wait_own (cm_waiter_txn_idx, cm_owner_txn_idx)
	  then cm_lock_deadlock.wait_own (cm_waiter_txn_idx, *) =
		  cm_lock_deadlock.wait_own (cm_waiter_txn_idx, *) | cm_lock_deadlock.wait_own (cm_owner_txn_idx, *);
         end;
      end;
   end CLOSURE_MULTI_WORD;

CLOSURE_SINGLE_WORD:
   procedure (cs_p_lock_deadlock_ptr);

dcl     cs_p_lock_deadlock_ptr	ptr;
declare rows			(36) bit (36) aligned based (cs_p_lock_deadlock_ptr);
						/* force compiler for efficiency */
dcl     cs_owner_txn_idx		fixed bin;
dcl     cs_waiter_txn_idx		fixed bin;

      do cs_owner_txn_idx = 1 to n_lock_deadlock;
         do cs_waiter_txn_idx = 1 to n_lock_deadlock;
	  if substr (rows (cs_waiter_txn_idx), cs_owner_txn_idx, 1)
	  then rows (cs_waiter_txn_idx) = rows (cs_waiter_txn_idx) | rows (cs_owner_txn_idx);
         end;
      end;

   end CLOSURE_SINGLE_WORD;

CLOSURE_DOUBLE_WORD:
   procedure (cd_p_lock_deadlock_ptr);

dcl     cd_p_lock_deadlock_ptr	ptr;
declare rows			(72) bit (72) aligned based (cd_p_lock_deadlock_ptr);
						/* force compiler for efficiency */
dcl     cd_owner_txn_idx		fixed bin;
dcl     cd_waiter_txn_idx		fixed bin;

      do cd_owner_txn_idx = 1 to n_lock_deadlock;
         do cd_waiter_txn_idx = 1 to n_lock_deadlock;
	  if substr (rows (cd_waiter_txn_idx), cd_owner_txn_idx, 1)
	  then rows (cd_waiter_txn_idx) = rows (cd_waiter_txn_idx) | rows (cd_owner_txn_idx);
         end;
      end;
   end CLOSURE_DOUBLE_WORD;

%page;
%include dm_lm_system_data;
%include dm_lm_meters;

   end lm_check_for_deadlock_;




		    lm_copy_data_.pl1               03/06/85  0802.6re  03/05/85  0759.5       35802



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

/* DESCRIPTION:
   lm_copy_data_	--Program to copy all the data segments under the log 
*/

/* HISTORY:

Written by Benson I. Margulies, 04/29/83.
Modified:
05/01/84 by R. Michael Tague:  Added the History section.  Added
            %include dm_lm_meters.
10/17/84 by Stanford S. Cox:  For DM program standards.
12/04/84 by Stanford S. Cox:  system_segment_count: Chg to return (0)
*/

/* format: style2,^inddcls,ifthenstmt,ifthendo,^indnoniterdo,^inditerdo,ind3,idind32 */
lm_copy_data_:
   procedure (p_copy_info_ptr, p_code);

declare p_copy_info_ptr		pointer;
declare p_code			fixed bin (35);

dcl     ME			char (13) int static options (constant) init ("lm_copy_data_");

declare lock_manager_$lock_lock_data	entry (fixed bin (35));
declare lock_manager_$unlock_lock_data	entry (fixed bin (35));

declare error_table_$smallarg		fixed bin (35) ext static;
declare error_table_$unimplemented_version
				fixed bin (35) ext static;

declare dm_system_data_$max_n_transactions
				fixed bin ext static;
declare lm_data_$lock_seg_ptr		pointer ext static;
declare lm_data_$lock_segments_ptr	pointer ext static;
declare lm_data_$n_lock_segments	fixed bin external;
declare cleanup			condition;

declare sx			fixed bin;
dcl     sub_err_			entry () options (variable);


      lm_copy_data_ptr = p_copy_info_ptr;
      p_code = 0;
      call CHECK_VERSION (LM_COPY_DATA_VERSION_1, lm_copy_data.version, "lm_copy_data");

      on cleanup call lock_manager_$unlock_lock_data (0);
      call lock_manager_$lock_lock_data (p_code);
      if p_code ^= 0 then return;

      lock_seg_ptr = lm_data_$lock_seg_ptr;
      call CHECK_VERSION (LOCK_SEG_VERSION_1, lock_seg.version, "lock_seg");
      lock_segments_ptr = lm_data_$lock_segments_ptr;

      do sx = 1 to min (lm_copy_data.n_segments, lm_data_$n_lock_segments);
         call COPY_SEGMENT ((lock_segments.seg_baseptr (sx)), lm_copy_data.segment_ptrs (sx));
      end;

      lm_copy_data.n_system_segments = lm_data_$n_lock_segments;
      if lm_copy_data.n_segments < lm_copy_data.n_system_segments then p_code = error_table_$smallarg;
      call lock_manager_$unlock_lock_data (0);
      return;


system_segment_count:
   entry (p_code) returns (fixed bin);

      p_code = 0;
      lock_seg_ptr = lm_data_$lock_seg_ptr;
      on cleanup call lock_manager_$unlock_lock_data (0);
      call lock_manager_$lock_lock_data (p_code);		/* this will make lm_data_$n_lock_segments up to date */
      if p_code ^= 0 then return (0);
      call lock_manager_$unlock_lock_data (0);
      return (lm_data_$n_lock_segments);


COPY_SEGMENT:
   procedure (cs_p_from, cs_p_to);

declare cs_p_from			pointer;
declare cs_p_to			pointer;
declare cs_max_length		fixed bin (19);
declare cs_copy_template		(lock_seg.lock_seg_size) bit (36) aligned based;

/* no business failing */
      cs_p_to -> cs_copy_template = cs_p_from -> cs_copy_template;
      return;
   end COPY_SEGMENT;

CHECK_VERSION:
   proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl     cv_p_expected_version		char (8) aligned parameter;
dcl     cv_p_received_version		char (8) aligned parameter;
dcl     cv_p_structure_name		char (32) aligned parameter;

      if cv_p_expected_version ^= cv_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, ME, 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;


%include dm_lm_copy_data;
%include dm_lm_system_data;
%include dm_lm_meters;
%include sub_err_flags;

   end lm_copy_data_;




		    lm_copy_fast_data_.pl1          04/24/85  1024.2re  04/24/85  0804.0       31464



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

/* DESCRIPTION:
    Copy fast_lock data/meters.
    p_fast_lock_data_ptr (I/O) is a ptr to a temp seg which will contain the
       copied fast_lock_data.  The offset is set to the offset of the
       fast_lock_data_ptr being copied.  This is done to save the overhead of
       recalculating the offsets.  If null, fast_lock_data is not copied.
    p_lock_list_meters_ptr (I) is a ptr to a structure declared like
       lock_list_meters.  If null, lock_list_meters is not copied.
*/

/* HISTORY:

Written by S. Cox, 03/25/85.
Modified:
04/01/85 by S. Cox: Chg to return et$action_not_performed if ^meter_fast_locks.
*/

/* format: style2,^inddcls,ifthenstmt,ifthendo,^indnoniterdo,^inditerdo,ind3,idind32 */
lm_copy_fast_data_:
   procedure (p_fast_lock_data_ptr, p_lock_list_meters_ptr, p_code);

/* Parameter */

dcl     p_fast_lock_data_ptr		ptr;
dcl     p_lock_list_meters_ptr	ptr;
declare p_code			fixed bin (35);

/* Based */

dcl     fast_lock_data_template	(fast_lock_data.size) bit (36) aligned based;

/* Static */

dcl     myname			char (18) int static options (constant) init ("lm_copy_fast_data_");

/* External */

declare (
        error_table_$action_not_performed,
        error_table_$unimplemented_version
        )				fixed bin (35) ext static;
dcl     dm_system_data_$meter_fast_locks
				bit (1) aligned ext;
declare lm_data_$fast_lock_data_ptr	pointer ext static;
dcl     lm_data_$lock_list_meters_ptr	ptr ext static;

/* Entry */

dcl     sub_err_			entry () options (variable);

      fast_lock_data_ptr = lm_data_$fast_lock_data_ptr;
      lock_list_meters_ptr = lm_data_$lock_list_meters_ptr;
      p_code = 0;

      if p_fast_lock_data_ptr ^= null () then do;
         call CHECK_VERSION (FAST_LOCK_DATA_VERSION_1, fast_lock_data.version, "fast_lock_data");
         p_fast_lock_data_ptr = pointer (p_fast_lock_data_ptr, rel (fast_lock_data_ptr));
         p_fast_lock_data_ptr -> fast_lock_data_template = fast_lock_data_ptr -> fast_lock_data_template;
      end;

      if dm_system_data_$meter_fast_locks then do;
         call CHECK_VERSION (LOCK_LIST_METERS_VERSION_1, lock_list_meters.version, "lock_list_meters");
         if p_lock_list_meters_ptr ^= null () then p_lock_list_meters_ptr -> lock_list_meters = lock_list_meters;
      end;
      else if ^dm_system_data_$meter_fast_locks & ^(p_lock_list_meters_ptr = null)
      then p_code = error_table_$action_not_performed;

      return;

CHECK_VERSION:
   proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl     cv_p_expected_version		char (8) aligned parameter;
dcl     cv_p_received_version		char (8) aligned parameter;
dcl     cv_p_structure_name		char (32) aligned parameter;

      if cv_p_expected_version ^= cv_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.", cv_p_expected_version,
	      cv_p_structure_name, cv_p_received_version);
   end CHECK_VERSION;

%include dm_lock_list_strucs;
%page;
%include dm_fast_lock_strucs;
%page;
%include sub_err_flags;

   end lm_copy_fast_data_;




		    lm_expand_lock_seg_.pl1         03/06/85  0802.6re  03/05/85  0759.6       36990



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

/*  DESCRIPTION
    Program to add a component to the lock data base. The lock lock must
    be held by the caller.
*/

/* HISTORY:
Written by J. Bongiovanni 12/14/82.
Modified:
08/06/83 by Lee A. Newcomb: removed obsolete code args from calls
	  to dm_per_system_ entries.
05/01/84 by R. Michael Tague:  Added %include dm_lm_meters
10/03/84 by Stanford S. Cox:  For DM program standards.
*/

/* format: style3 */
lm_expand_lock_seg_:
     proc (p_code);

/*  Parameter  */

dcl	p_code		fixed bin (35);

/*  Automatic  */

dcl	freex		fixed bin;
dcl	lock_segx		fixed bin;
dcl	n_segments	fixed bin;

/*  Static */

dcl	ME		char (19) int static options (constant) init ("lm_expand_lock_seg_");

/*  External  */

dcl	dm_system_data_$max_n_transactions
			fixed bin ext static;
dcl	lm_data_$lock_segments_ptr
			ptr external;
dcl	lm_data_$lock_seg_ptr
			ptr external;
dcl	dm_error_$lock_table_overflow
			fixed bin (35) external;
dcl	dm_error_$record_quota_overflow
			fixed bin (35) external;
dcl	error_table_$unimplemented_version
			fixed bin (35) ext static;


/*  Entry  */

dcl	dm_per_system_$create
			entry (char (*), ptr);
dcl	sub_err_		entry () options (variable);


/*  Builtin  */

dcl	addr		builtin;
dcl	divide		builtin;
dcl	fixed		builtin;
dcl	size		builtin;

/*  Condition  */

dcl	record_quota_overflow
			condition;
%page;
	p_code = 0;

	lock_seg_ptr = lm_data_$lock_seg_ptr;
	call CHECK_VERSION (LOCK_SEG_VERSION_1, lock_seg.version, "lock_seg");
	lock_segments_ptr = lm_data_$lock_segments_ptr;

	if lock_seg.n_lock_segments >= lock_seg.max_lock_segments
	then do;
		p_code = dm_error_$lock_table_overflow;
		return;
	     end;

	n_segments = lock_seg.n_lock_segments + 1;

	lock_segno = n_segments;
	call dm_per_system_$create (LOCK_SEGNAME || lock_segno, lock_aux_seg_ptr);

	on record_quota_overflow goto QUOTA_OVERFLOW;

	lock_block_array_ptr = addr (lock_aux_seg.free);
	n_lock_blocks = divide (lock_seg.lock_seg_size - fixed (wordno (lock_block_array_ptr)), size (lock_block), 17);

	lock_aux_seg.n_lock_blocks = n_lock_blocks;
	lock_aux_seg.lock_array_offset = wordno (lock_block_array_ptr);

	do freex = n_lock_blocks to 1 by -1;
	     lock_free_block_ptr = addr (lock_block_array (freex));
	     lock_free_block.seg_inx = n_segments;
	     lock_free_block.type = TYPE_FREE;
	     if freex = n_lock_blocks
	     then lock_free_block.free_fp = lock_seg.free_list_ptr;
	     else lock_free_block.free_fp = VPTR (addr (lock_block_array (freex + 1)));
	end;

	lock_seg.free_list_ptr = VPTR (addr (lock_block_array (1)));
	lock_seg.n_lock_segments = lock_seg.n_lock_segments + 1;

	return;


QUOTA_OVERFLOW:
	p_code = dm_error_$record_quota_overflow;
	return;
%page;
VPTR:
     proc (Lock_Block_ptr) returns (1 aligned like lock_virtual_ptr);

dcl	Lock_Block_ptr	ptr aligned parameter;

dcl	1 Lock_Virtual_Ptr	aligned like lock_virtual_ptr;

dcl	1 Lock_Block	aligned like lock_block based (Lock_Block_ptr);


	Lock_Virtual_Ptr.seg_inx = Lock_Block.seg_inx;
	Lock_Virtual_Ptr.offset = wordno (Lock_Block_ptr);

	return (Lock_Virtual_Ptr);

     end VPTR;

CHECK_VERSION:
     proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl	cv_p_expected_version
			char (8) aligned parameter;
dcl	cv_p_received_version
			char (8) aligned parameter;
dcl	cv_p_structure_name char (32) aligned parameter;

	if cv_p_expected_version ^= cv_p_received_version
	then call sub_err_ (error_table_$unimplemented_version, ME, 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_lm_system_data;
%page;
%include dm_lm_meters;
%page;
%include sub_err_flags;

     end lm_expand_lock_seg_;




		    lm_fast_lock_.pl1               04/24/85  1018.1re  04/24/85  0804.0      172656



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

/*  DESCRIPTION:
    This is the inner-ring portion of fast locking. It is called when the
    ruthlessly efficient user-ring routine code can not handle the
    request in its entirety. This means the following:

    1. The process could not lock the fast lock, and it is not locked
       to this process.

    2. The process has just unlocked the lock, but the notify switch
       was set after the unlock (it is reset now).

    The following entries are provided:

      lock_fast

      notify_unlock

    Note that efficiency is not of particular import here.
*/
/* HISTORY:
Written by J. Bongiovanni 06/15/82.
Modified:
83-04-24 by BIM: race when lock was unlocked just after failing
      stac in TRY_TO_LOCK corrected.
83-05-05 by BIM: logged all mylocks and timeouts.
10/11/84 by Stanford S. Cox:  MAIN: Chg all int procs to have prefix var names
      and use ER, chg to use dm_system_data_$lock_ips_mask.  MWB: Added
      lock_list_meters_ptr to lm_fast_lock_list_ call.  NOTIFY: Same as MWB.
      ER: Added for common return.  ELR: Renamed from LOG_ERROR.
12/11/84 by Stanford S. Cox:  notify_unlock: Add version check of fast_lock_data
      and lock_list_meters.
02/15/85 by Stanford S. Cox:  RETURN: Added for guaranteed eligibility.
03/01/85 by Lindsey L. Spratt:  Added SEND_WAKEUP internal proc to handle
            calling hcs_$wakeup correctly.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
05/16/85 by S. Cox: NOTIFY: Chg to meter thread_outs instead of thread_ins.
*/

/* format: style3 */
lm_fast_lock_$lock_fast:
     proc (p_fast_lock_ptr, p_timeout, p_code);		/*  Parameter  */

dcl	p_fast_lock_ptr	ptr;			/* Points to fast lock */
dcl	p_timeout		fixed bin (71);		/* Wait increment in microseconds */
dcl	p_code		fixed bin (35);		/* Status code */

/*  Automatic  */

dcl	code		fixed bin (35);
dcl	done_try_loop	bit (1) aligned;
dcl	owner_processid	bit (36) aligned;
dcl	timeout_time	fixed bin (71);		/* Absolute timeout time */

/*  Static  */

dcl	fast_lock_channel_id
			fixed bin (71) int static init (0);
dcl	first_time	bit (1) aligned int static init ("1"b);
dcl	ips_mask		bit (36) aligned int static init (""b);
dcl	my_processid	bit (36) aligned int static init (""b);
dcl	1 wait_list	aligned int static,
	  2 nchan		fixed bin init (1),
	  2 pad		fixed bin init (0),
	  2 channel_id	(1) fixed bin (71) init (0);

dcl	(
	INVALID_RESET	fixed bin init (1),
	VALID_LOCK	fixed bin init (0),
	IPS_NAMES		(3) char (32) init ("alrm", "quit", "cput"),
	MAX_WAIT_TIME	fixed bin (71) init (30000000),
	ME		char (13) init ("lm_fast_lock_"),
	MAXIMUM_NUMBER_OF_WAKEUP_ATTEMPTS
			fixed bin init (10),
	YES		bit (1) aligned init ("1"b),
	NO		bit (1) aligned init ("0"b),
	ITT_OVERFLOW_WAIT_TIME
			fixed bin (71) init (10000000 /* 10 seconds */),
	RELATIVE_SECONDS	bit (2) init ("11"b)
	)		internal static options (constant);

/*  External  */

dcl	dm_system_data_$lock_ips_mask
			bit (36) aligned external;
dcl	lm_data_$fast_lock_data_ptr
			ptr external;
dcl	lm_data_$lock_list_meters_ptr
			ptr external;
dcl	dm_error_$fast_lock_invalid_lock
			fixed bin (35) external static;
dcl	dm_error_$fast_lock_invalid_reset
			fixed bin (35) external static;
dcl	dm_error_$fast_lock_mylock
			fixed bin (35) external static;
dcl	dm_error_$fast_lock_no_free
			fixed bin (35) external static;
dcl	dm_error_$fast_lock_not_cleared
			fixed bin (35) external;
dcl	dm_error_$fast_lock_timeout
			fixed bin (35) external static;
dcl	(
	error_table_$unimplemented_version,
	error_table_$itt_overflow,
	error_table_$process_unknown
	)		fixed bin (35) ext static;

/*  Entry  */

dcl	cu_$caller_ptr	entry returns (pointer);
dcl	dm_hcs_$guaranteed_eligibility_off
			entry ();
dcl	dm_hcs_$guaranteed_eligibility_on
			entry ();
dcl	dm_misc_util_$log	entry options (variable);
dcl	create_ips_mask_	entry (ptr, fixed bin, bit (36) aligned);
dcl	find_pathname_	entry (ptr, ptr, fixed bin (35));
dcl	get_process_id_	entry () returns (bit (36));
dcl	hcs_$get_alarm_timer
			entry (fixed bin (71), fixed bin (71));
dcl	hcs_$get_uid_seg	entry (ptr, bit (36) aligned, fixed bin (35));
dcl	hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl	hcs_$set_alarm_timer
			entry (fixed bin (71), fixed bin, fixed bin (71));
dcl	hcs_$set_ips_mask	entry (bit (36) aligned, bit (36) aligned);
dcl	hcs_$validate_processid
			entry (bit (36) aligned, fixed bin (35));
dcl	hcs_$wakeup	entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl	lm_init_fast_lock_	entry (ptr, fixed bin (35));
dcl	ipc_$block	entry (ptr, ptr, fixed bin (35));
dcl	ipc_$create_ev_chn	entry (fixed bin (71), fixed bin (35));
dcl	ipc_$drain_chn	entry (fixed bin (71), fixed bin (35));
dcl	lm_fast_lock_list_$thread_in
			entry (ptr, ptr, ptr);
dcl	lm_fast_lock_list_$thread_out_first
			entry (ptr, ptr, ptr, ptr);
dcl	timer_manager_$sleep
			entry (fixed bin (71), bit (2));
dcl	sub_err_		entry () options (variable);

/*  Condition  */

dcl	cleanup		condition;

/*  Builtin  */

dcl	addr		builtin;
dcl	bin		builtin;
dcl	clock		builtin;
dcl	divide		builtin;
dcl	hbound		builtin;
dcl	min		builtin;
dcl	mod		builtin;
dcl	null		builtin;
dcl	ptr		builtin;
dcl	rel		builtin;
dcl	size		builtin;
dcl	stac		builtin;
dcl	stacq		builtin;
dcl	string		builtin;
dcl	substr		builtin;
dcl	unspec		builtin;

%page;
	p_code = 0;
	timeout_time = clock () + p_timeout;
	fast_lock_ptr = p_fast_lock_ptr;


	if first_time
	then do;
		call INIT ();
		first_time = "0"b;
	     end;

	fast_lock_data_ptr = lm_data_$fast_lock_data_ptr;
	call CHECK_VERSION (FAST_LOCK_DATA_VERSION_1, fast_lock_data.version, "fast_lock_data");
	lock_list_meters_ptr = lm_data_$lock_list_meters_ptr;
	if lock_list_meters_ptr ^= null ()
	then call CHECK_VERSION (LOCK_LIST_METERS_VERSION_1, lock_list_meters.version, "lock_list_meters");

/*  Validate that the fast lock itself is good */

	call VALIDATE_FAST_LOCK (fast_lock_ptr, fast_lock_block_ptr);
%page;
/*  Main loop of fast locking.

    1. Try to lock the lock. Return if successful.

    2. Validate that the owner is an active process. Bust the lock to this
       process if not.

    3. Wait until notified, the user's time has expired, or our timeout
       has expired.
*/

TRY_TO_LOCK:
	do while ("1"b);
	     done_try_loop = "0"b;
	     code = 0;

	     do while (^done_try_loop);
		if stac (addr (fast_lock.lock_word), my_processid)
		then call RETURN (VALID_LOCK);

		owner_processid = fast_lock.lock_word;
		if owner_processid = my_processid
		then call ERROR_LOG_AND_RETURN (dm_error_$fast_lock_mylock, fast_lock_ptr, cu_$caller_ptr ());
		else if owner_processid ^= ""b
		then do;
			call hcs_$validate_processid (owner_processid, code);
			if code = 0
			then done_try_loop = "1"b;
			else do;
				if stacq (fast_lock.lock_word, my_processid, owner_processid)
				then call RETURN (INVALID_RESET);
			     end;
		     end;
	     end;


/*  Check for the user's timeout expiring  */

	     if timeout_time < clock ()
	     then call ERROR_LOG_AND_RETURN (dm_error_$fast_lock_timeout, fast_lock_ptr, cu_$caller_ptr ());
%page;
/*  Thread ourselves into the wait list, set the notify switch, and wait.  */

	     call MAKE_WAIT_BLOCK (fast_lock_block_ptr);

	     fast_lock.notify_sw = "1"b;

	     call ipc_$drain_chn (fast_lock_channel_id, code);

/* Try once more for the lock. We could get it because of a race.  */

	     if stac (addr (fast_lock.lock_word), my_processid)
	     then call RETURN (VALID_LOCK);

/*  Now wait a bit. Notify to prevent congestion of wait blocks. */

	     call BLOCK;

	     call NOTIFY (fast_lock_block_ptr);

	end TRY_TO_LOCK;

MAIN_RETURN:
	return;
%skip;
RETURN:
     proc (r_p_status);

dcl	r_p_status	fixed bin (17) parameter;

	if r_p_status = INVALID_RESET
	then p_code = dm_error_$fast_lock_invalid_reset;
	else p_code = 0;
	call dm_hcs_$guaranteed_eligibility_on ();
	goto MAIN_RETURN;
     end RETURN;
%page;

/*  notify_unlock -

     Entry to notify all processes waiting for a lock. Called after the lock has
     been unlocked.
*/

notify_unlock:
     entry (p_fast_lock_ptr, p_code);

	p_code = 0;
	fast_lock_ptr = p_fast_lock_ptr;

	call dm_hcs_$guaranteed_eligibility_off ();

	if first_time
	then do;
		call INIT;
		first_time = "0"b;
	     end;

	fast_lock_data_ptr = lm_data_$fast_lock_data_ptr;
	call CHECK_VERSION (FAST_LOCK_DATA_VERSION_1, fast_lock_data.version, "fast_lock_data");
	lock_list_meters_ptr = lm_data_$lock_list_meters_ptr;
	if lock_list_meters_ptr ^= null ()
	then call CHECK_VERSION (LOCK_LIST_METERS_VERSION_1, lock_list_meters.version, "lock_list_meters");

/*  Validate that we've been passed a valid fast lock  */

	call VALIDATE_FAST_LOCK (fast_lock_ptr, fast_lock_block_ptr);

/*  Notify any process which is waiting  */

	call NOTIFY (fast_lock_block_ptr);


	goto MAIN_RETURN;
%page;
/*  Internal Procedure to wait until notified or until we time out.
    We can time out if we hit the user's timeout time, or if we
    hit our own. The latter is a safety valve - if we hit it, our
    caller retries locking, possibly calling us again.
*/

BLOCK:
     proc;


dcl	1 b_event_info	aligned,
	  2 channel_id	fixed bin (71),
	  2 message	fixed bin (71),
	  2 sender	bit (36) aligned,
	  2 origin,
	    3 dev_signal	bit (18) unaligned,
	    3 ring	bit (18) unaligned,
	  2 channel_index	fixed bin;
dcl	b_saved_channel	fixed bin (71);
dcl	b_saved_ips_mask	bit (36) aligned;
dcl	b_saved_timer	fixed bin (71);
dcl	b_wait_time	fixed bin (71);


/*  Setup a cleanup handler to reset the IPS mask and ring-0 timer  */

	b_saved_ips_mask = ""b;
	b_saved_channel = -1;

	on cleanup
	     begin;
		if substr (b_saved_ips_mask, 36, 1) = "1"b
		then call hcs_$reset_ips_mask (b_saved_ips_mask, b_saved_ips_mask);
		if b_saved_channel ^= -1
		then call hcs_$set_alarm_timer (b_saved_timer, 2, b_saved_channel);
	     end;


/*  Determine the wait time  */

	b_wait_time = min (clock () + MAX_WAIT_TIME, timeout_time);


/*  Mask IPS Signals and set our own ring-0 timer  */

	call hcs_$set_ips_mask (dm_system_data_$lock_ips_mask, b_saved_ips_mask);

	call hcs_$get_alarm_timer (b_saved_timer, b_saved_channel);
	call hcs_$set_alarm_timer (b_wait_time, 2, fast_lock_channel_id);

/*  Wait for something  */

	call ipc_$block (addr (wait_list), addr (b_event_info), code);

/*  Restore the ring-0 timer and the IPS mask  */

	call hcs_$set_alarm_timer (b_saved_timer, 2, b_saved_channel);
	call hcs_$reset_ips_mask (b_saved_ips_mask, b_saved_ips_mask);


     end BLOCK;
%page;
/*  Internal procedure to initialize static variables.  */

INIT:
     proc ();

dcl	i_code		fixed bin (35);

	my_processid = get_process_id_ ();

	call ipc_$create_ev_chn (fast_lock_channel_id, i_code);
	wait_list.channel_id (1) = fast_lock_channel_id;

	call create_ips_mask_ (addr (IPS_NAMES), hbound (IPS_NAMES, 1), ips_mask);

     end INIT;
%page;
/*  Internal Procedure to thread this process into the list of waiters
    for this fast lock
*/
MAKE_WAIT_BLOCK:
     proc (mw_p_fast_lock_block_ptr);

dcl	mw_p_fast_lock_block_ptr
			ptr;
dcl	1 mw_fast_lock_block
			aligned like fast_lock_block based (mw_p_fast_lock_block_ptr);

dcl	mw_tfast_lock_wakeup_block_ptr
			ptr;
dcl	mw_tlock_list_block_ptr
			ptr;
dcl	1 mw_tfast_lock_wakeup_block
			aligned like fast_lock_wakeup_block based (mw_tfast_lock_wakeup_block_ptr);
dcl	1 mw_tlock_list_block
			aligned like lock_list_block based (mw_tlock_list_block_ptr);


	call lm_fast_lock_list_$thread_out_first (addr (fast_lock_data.free_list_head), fast_lock_data_ptr, null (),
	     mw_tlock_list_block_ptr);
	if mw_tlock_list_block_ptr = null ()
	then call ERROR_RETURN (dm_error_$fast_lock_no_free);

	mw_tfast_lock_wakeup_block_ptr = addr (mw_tlock_list_block.block_data);
	mw_tfast_lock_wakeup_block.event_channel = fast_lock_channel_id;
	mw_tfast_lock_wakeup_block.processid = my_processid;
	mw_tfast_lock_wakeup_block.message = "WAIT";

	call lm_fast_lock_list_$thread_in (addr (mw_fast_lock_block.list_head), lock_list_meters_ptr,
	     mw_tlock_list_block_ptr);


     end MAKE_WAIT_BLOCK;
%page;
/*  Internal Procedure to notify all processes waiting for a fast lock.
    This is done one at a time to avoid races with other processes doing
    the same thing.
*/

NOTIFY:
     proc (nt_p_fast_lock_block_ptr);

dcl	nt_p_fast_lock_block_ptr
			ptr;
dcl	1 nt_fast_lock_block
			aligned like fast_lock_block based (nt_p_fast_lock_block_ptr);

dcl	nt_done_notify	bit (1) aligned;
dcl	nt_message_71	fixed bin (71);
dcl	nt_message_8	char (8) aligned;
dcl	nt_tfast_lock_wakeup_block_ptr
			ptr;
dcl	nt_tlock_list_block_ptr
			ptr;

dcl	1 nt_tfast_lock_wakeup_block
			aligned like fast_lock_wakeup_block based (nt_tfast_lock_wakeup_block_ptr);
dcl	1 nt_tlock_list_block
			aligned like lock_list_block based (nt_tlock_list_block_ptr);

	nt_done_notify = "0"b;

	do while (^nt_done_notify);
	     call lm_fast_lock_list_$thread_out_first (addr (nt_fast_lock_block.list_head), fast_lock_data_ptr,
		lock_list_meters_ptr, nt_tlock_list_block_ptr);
	     if nt_tlock_list_block_ptr = null ()
	     then nt_done_notify = "1"b;
	     else do;
		     nt_tfast_lock_wakeup_block_ptr = addr (nt_tlock_list_block.block_data);
		     if nt_tfast_lock_wakeup_block.processid ^= my_processid
						/* Don't wakeup ourselves */
		     then do;
			     nt_message_8 = nt_tfast_lock_wakeup_block.message;
			     unspec (nt_message_71) = unspec (nt_message_8);
			     call SEND_WAKEUP ("fast_lock unlock notification",
				nt_tfast_lock_wakeup_block.processid, nt_tfast_lock_wakeup_block.event_channel,
				nt_message_71);
			end;
		     call lm_fast_lock_list_$thread_in (addr (fast_lock_data.free_list_head), null (),
			nt_tlock_list_block_ptr);
		end;
	end;

     end NOTIFY;

%page;
/*  Internal Procedure to validate a fast lock supplied by the outer ring.
    If it is valid,  a pointer to the inner-ring block is returned. If it
    has never been initialized, it is done now. Note that this initialization
    (which is really binding to an inner-ring block) is done on demand, when
    first some process waits for it.
*/

VALIDATE_FAST_LOCK:
     proc (vf_p_fast_lock_ptr, vf_p_fast_lock_block_ptr);


dcl	vf_p_fast_lock_ptr	ptr;
dcl	vf_p_fast_lock_block_ptr
			ptr;
dcl	vf_code		fixed bin (35);

dcl	1 vf_fast_lock	aligned like fast_lock based (vf_p_fast_lock_ptr);
dcl	1 vf_fast_lock_block
			aligned like fast_lock_block based (vf_p_fast_lock_block_ptr);

dcl	vf_block_offset	bit (18) aligned;
dcl	vf_listx		fixed bin;
dcl	vf_rel_offset	fixed bin (18);
dcl	vf_uid		bit (36) aligned;

	if vf_fast_lock.offset = ""b			/* Not initialized yet */
	then do;
		call lm_init_fast_lock_ (vf_p_fast_lock_ptr, vf_code);
		if vf_code ^= 0
		then if vf_code ^= dm_error_$fast_lock_not_cleared
		     then call ERROR_RETURN (vf_code);
	     end;

	lock_list_block_words = size (fast_lock_wakeup_block);
	vf_block_offset = vf_fast_lock.offset;
	vf_rel_offset = bin (vf_block_offset) - bin (rel (addr (fast_lock_data.list)));

	if vf_rel_offset < 0
	then call ERROR_RETURN (dm_error_$fast_lock_invalid_lock);

	if mod (vf_rel_offset, size (lock_list_block)) ^= 0
	then call ERROR_RETURN (dm_error_$fast_lock_invalid_lock);

	vf_listx = divide (vf_rel_offset, size (lock_list_block), 17);
	if vf_listx < 0 | vf_listx > fast_lock_data.n_list_entries
	then call ERROR_RETURN (dm_error_$fast_lock_invalid_lock);

	vf_p_fast_lock_block_ptr = addr (ptr (fast_lock_data_ptr, vf_block_offset) -> lock_list_block.block_data);
	if vf_fast_lock_block.offset ^= rel (vf_p_fast_lock_ptr)
	then call ERROR_RETURN (dm_error_$fast_lock_invalid_lock);

	call hcs_$get_uid_seg (vf_p_fast_lock_ptr, vf_uid, code);
	if code ^= 0 | vf_uid ^= vf_fast_lock_block.uid
	then call ERROR_RETURN (dm_error_$fast_lock_invalid_lock);


     end VALIDATE_FAST_LOCK;

ERROR_LOG_AND_RETURN:
     procedure (el_p_code, el_p_lock_ptr, el_p_caller_ptr);

declare	el_p_code		fixed bin (35);
declare	el_p_lock_ptr	pointer;
declare	el_p_caller_ptr	pointer;
declare	1 el_lock_fpi	aligned like find_pathname_info;
declare	el_code		fixed bin (35);

	string (el_lock_fpi.strings) = "";

	call dm_misc_util_$log (INFORM_SV, el_p_code, "lm_fast_lock_", "Fast lock error.");

	call find_pathname_ (el_p_lock_ptr, addr (el_lock_fpi), el_code);
	if el_code = 0
	then call dm_misc_util_$log (INFORM_SV, "   On lock ^a.", string (el_lock_fpi.strings));
	else call dm_misc_util_$log (INFORM_SV, "   On lock ^p.", el_p_lock_ptr);
	call ERROR_RETURN (el_p_code);
     end ERROR_LOG_AND_RETURN;
%skip;
ERROR_RETURN:
     proc (er_p_code);

dcl	er_p_code		fixed bin (35) parameter;

	p_code = er_p_code;
	goto MAIN_RETURN;
     end ERROR_RETURN;
%page;
SEND_WAKEUP:
     proc (sw_p_wakeup_description, sw_p_process_id, sw_p_ev_channel, sw_p_message);
dcl	sw_p_wakeup_description
			char (*) parm;
dcl	sw_p_process_id	bit (36) aligned parm;
dcl	sw_p_ev_channel	fixed bin (71) parm;
dcl	sw_p_message	fixed bin (71) parm;

dcl	sw_code		fixed bin (35) init (0);
dcl	sw_try_wakeup	bit (1) aligned init (YES);
dcl	sw_wakeup_attempt_count
			fixed bin init (0);

	do sw_wakeup_attempt_count = 1 to MAXIMUM_NUMBER_OF_WAKEUP_ATTEMPTS while (sw_try_wakeup = YES);
	     call hcs_$wakeup (sw_p_process_id, sw_p_ev_channel, sw_p_message, sw_code);
	     if sw_code = 0 | (sw_code = error_table_$process_unknown & sw_p_process_id ^= "0"b)
						/* Probably a process_id for a now-dead process. */
	     then sw_try_wakeup = NO;
	     else if sw_code = error_table_$itt_overflow
	     then call timer_manager_$sleep (ITT_OVERFLOW_WAIT_TIME, RELATIVE_SECONDS);
	     else do;
		     call dm_misc_util_$log (INFORM_SV, sw_code, ME,
			"^/Unable to send a ^a for process ^w on event channel ^o.", sw_p_wakeup_description,
			sw_p_process_id, sw_p_ev_channel);
		     sw_try_wakeup = NO;
		end;
	end;
	if sw_wakeup_attempt_count > MAXIMUM_NUMBER_OF_WAKEUP_ATTEMPTS
	then call dm_misc_util_$log (INFORM_SV, error_table_$itt_overflow, ME,
		"^/Unable to send a ^a for process ^w on event channel ^w, after ^d attempts.",
		sw_p_wakeup_description, sw_p_process_id, sw_p_ev_channel, MAXIMUM_NUMBER_OF_WAKEUP_ATTEMPTS);
     end SEND_WAKEUP;


CHECK_VERSION:
     proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl	cv_p_expected_version
			char (8) aligned parameter;
dcl	cv_p_received_version
			char (8) aligned parameter;
dcl	cv_p_structure_name char (32) aligned parameter;

	if cv_p_expected_version ^= cv_p_received_version
	then call sub_err_ (error_table_$unimplemented_version, ME, 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 find_pathname_info;
%include dm_fast_lock_strucs;
%include dm_lock_list_strucs;
%include dm_log_sv_codes;
%include sub_err_flags;
     end lm_fast_lock_$lock_fast;




		    lm_firstref_tv_.alm             04/24/85  1018.1re  04/24/85  0804.1       18963



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"
" DESCRIPTION:
"
"	The inner ring transfer vector for the Lock Manager.  The entries
"    are in alphabetic order, please keep them so unless necessary.
"
"
" HISTORY:
"
" Written by Jeffrey D. Ives, 03/05/83.
" Modified:
" 05/09/83 by Benson I. Margulies:  cleaned up to conform to lock_manager_.
" 07/29/83 by Lindsey Spratt: added lm_per_system_ and lm_fast_lock_.
" 05/02/84 by Lee A. Newcomb: added lm_user_shutdown and alphabetized entries.
" 11/22/84 by Lee A. Newcomb:  Added $per_process_init entry and changed
"	    firstref to be transaction_manager_$per_process_init.
" 12/03/84 by Stanford S. Cox: Renamed lm_firstref_tv_.
" 03/25/85 by Stanford S. Cox:   Added copy_fast_data.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " 

	name	lm_firstref_tv_

	firstref	transaction_manager_$per_process_init


	macro	transfer
	segdef	&1
&1:
	getlp
	tra	&2
&end



	transfer	checkpoint,lm_per_process_$checkpoint
	transfer	copy_data,lm_copy_data_$lm_copy_data_
	transfer  copy_fast_data,lm_copy_fast_data_$lm_copy_fast_data_
	transfer	lock,lm_per_process_$lock
	transfer  lock_fast,lm_fast_lock_$lock_fast
	transfer  lock_lock_data,lm_per_system_$lock_lock_data
	transfer  notify_unlock,lm_fast_lock_$notify_unlock
	transfer	per_process_init,lm_per_process_init_$lm_per_process_init_
	transfer  reset_system_meters,lm_reset_system_meters_$lm_reset_system_meters_
	transfer	resolve_deadlock,lm_per_process_$lock_resolve_deadlock
	transfer	system_segment_count,lm_copy_data_$system_segment_count
	transfer	unlock,lm_per_process_$unlock
	transfer	unlock_all,lm_per_process_$unlock_all
	transfer  unlock_lock_data,lm_per_system_$unlock_lock_data
	transfer	unlock_to_checkpoint,lm_per_process_$unlock_to_checkpoint
	transfer	user_shutdown,lm_user_shutdown$lm_user_shutdown

	end




		    lm_hash_.alm                    03/06/85  0802.6re  03/05/85  0759.6       45063



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lm_hash_ - Routines to maintain lock hash tables in a ruthlessly
"		efficient manner.
"
"	Entries:
"
"		hash_in   - Adds an entry to the hash table
"		hash_out  - Deletes an entry from the hash table
"		search    - Searches for a UID, CI Number
"
"	Written August 1982 by J. Bongiovanni
"	Modified December 1982 by J. Bongiovanni for multi-segment lock data
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	lm_hash_

	entry	hash_in
	entry	hash_out
	entry	search


	even
NULL_ITS:
	its	-1,1
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	hash_in - Entry to add a lock object to a hash thread
"
"	call lm_hash_$hash_in (lock_objectp)
"
"	   lock_objectp -> filled in lock object	(Input)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


hash_in:
	eppbb	ap|2,*			" bb -> ptr -> lock object
	eppbb	bb|0,*			" bb -> lock object

	lda	bb|lock_object.uid		" Mash UID/CI
	era	bb|lock_object.ci_no
	tsx0	setup			" Get hash bucket

	lda	bp|0			" First in thread
	sta	bb|lock_object.ht_fp	" Make first second
	lda	bb|lock_object.seg_inx	" And this first
	eaq	bb|0
	arl	18
	lrl	18
	stq	bp|0

	short_return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	hash_out - Entry to remove a lock object from a hash thread
"
"	call lm_hash_$hash_out (lock_objectp)
"
"	   lock_objectp -> lock object		(Input)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


hash_out:
	eppbb	ap|2,*			" bb -> ptr -> lock object
	eppbb	bb|0,*			" bb -> lock object

	lda	bb|lock_object.uid		" Mash UID/CI
	era	bb|lock_object.ci_no
	tsx0	setup			" Get hash bucket

	lda	bb|lock_object.uid		" Setup for search
	ldq	bb|lock_object.ci_no
	tsx0	search_thread		" Look for it
	tra	hash_out_returns		" Not found (?)

	lda	bb|lock_object.ht_fp	" Next in thread
	eax1	0,x1			" Is this the first?
	tze	hash_out_null		" Yes
	sta	ab|lock_object.ht_fp	" No - thread next to prev
	tra	hash_out_returns

hash_out_null:
	sta	bp|0			" Make next first

hash_out_returns:
	short_return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	search - Entry to look for a UID/CI in the hash table
"
"	call lm_hash_$search (UID, CI, lock_objectp)
"
"	   UID = Page File UID			(Input)
"	   CI = Control Interval No.			(Input)
"	   lock_objectp -> lock object, or null		(Output)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


search:
	lda	ap|2,*			" Mash UID/CI
	era	ap|4,*
	tsx0	setup			" Get hash bucket

	lda	ap|2,*			" UID for search
	ldq	ap|4,*			" CI for search
	tsx0	search_thread		" Look for it
	tra	search_not_found		" Not found
	tra	search_returns		" Found

search_not_found:
	eppbb	NULL_ITS,*		" Return null
search_returns:
	spribb	ap|6,*
	short_return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	setup - Internal procedure to find hash bucket
"
"	tsx0	setup
"
"	On entry,
"	   A = XOR of UID and CI
"
"	On exit,
"	   bp -> hash table bucket
"	   lb -> lock segments array for this process
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

setup:
	epplb	lm_data_$lock_segments_ptr,*	" Per-Process segments array
	eppab	lm_data_$lock_seg_ptr,*	" First system lock segment
	lxl1	ab|lock_seg.hash_table_offset	" Offset of hash table
	eppbp	ab|0,x1			" bp -> hash table
	ana	ab|lock_seg.hash_mask	" Strip out index
	eppbp	bp|0,al			" And apply it
	tra	0,x0

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	search_thread - Internal procedure to search for a UID/CI
"
"	tsx0	search_thread
"	<return if not found>
"	<return if found>
"
"	On entry,
"	   bp -> hash table bucket
"	   A = UID
"	   Q = CI
"
"	On exit,
"	   bb -> lock object
"	   ab -> previous or null
"	   x1 = offset of previous or 0
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

search_thread:
	eax1	0			" No previous
	eppab	NULL_ITS,*		" Ditto
	ldx2	bp|0			" Segment index of first
	tmi	0,x0			" None
	lxl3	bp|0			" Offset of first
search_loop:
	lprpbb	lb|-1,x2			" bb -> segment of lock object
	eppbb	bb|0,x3			" bb -> lock object
	cmpa	bb|lock_object.uid		" UID match?
	tnz	search_next		" No
	cmpq	bb|lock_object.ci_no	" CI match?
	tze	1,x0			" Yes
search_next:
	eax1	0,x3			" Set previous to current
	ldx2	bb|lock_object.ht_fp	" And get next in thread
	tmi	0,x0			" None
	lxl3	bb|lock_object.ht_fp
	eppab	bb|0			" ab -> previous lock object
	tra	search_loop
"
	include	dm_lm_system_data
	end




		    lm_init_fast_lock_.pl1          03/06/85  0802.6re  03/05/85  0759.6       43335



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

/*  DESCRIPTION:
    Program to initialize a user-supplied double-word as a fast lock.

    The steps are the following:

    1. Fill in an automatic copy of the fast lock block.

    2. Get a free block from fast_lock_data.

    3. Copy the automatic block to the free block.

    4. Fill in the fast lock double-word. Avoid races with other
       processes doing the same thing for this lock.
*/

/*  HISTORY:
Written by J. Bongiovanni, 06/15/82
Modified:
10/11/84 by Stanford S. Cox:  For DM program standards, and to meter fast 
	locks.
*/

/* format: style3 */
lm_init_fast_lock_:
     proc (p_fast_lock_ptr, p_code);

/*  Parameter  */

dcl	p_fast_lock_ptr	ptr;			/* Pointer to fast lock */
dcl	p_code		fixed bin (35);		/* Status code */

/*  Automatic  */

dcl	Ap		ptr;
dcl	1 new_fast_lock	aligned like fast_lock;
dcl	1 old_fast_lock	aligned like fast_lock;
dcl	Qp		ptr;
dcl	1 temp_fast_lock_block
			aligned like fast_lock_block;
dcl	Wp		ptr;


/*  Based  */

dcl	A		bit (36) aligned based (Ap);
dcl	Q		bit (36) aligned based (Qp);
dcl	W		bit (36) aligned based (Wp);

/*  Static */

dcl	ME		char (18) int static options (constant) init ("lm_init_fast_lock_");

/*  External  */

dcl	lm_data_$fast_lock_data_ptr
			ptr external static;
dcl	lm_data_$lock_list_meters_ptr
			ptr external static;
dcl	dm_error_$fast_lock_not_cleared
			fixed bin (35) external static;
dcl	dm_error_$fast_lock_no_free
			fixed bin (35) external static;
dcl	error_table_$unimplemented_version
			fixed bin (35) ext static;

/*  Entry  */

dcl	find_fast_lock_data_
			entry (ptr, fixed bin (18), fixed bin (35));
dcl	hcs_$get_uid_seg	entry (ptr, bit (36) aligned, fixed bin (35));
dcl	lm_fast_lock_list_$thread_in
			entry (ptr, ptr, ptr);
dcl	lm_fast_lock_list_$thread_out_first
			entry (ptr, ptr, ptr, ptr);
dcl	sub_err_		entry () options (variable);

/*  Builtin  */

dcl	addr		builtin;
dcl	null		builtin;
dcl	rel		builtin;
dcl	stacq		builtin;
dcl	unspec		builtin;

%page;
	p_code = 0;
	fast_lock_ptr = p_fast_lock_ptr;

	fast_lock_data_ptr = lm_data_$fast_lock_data_ptr;
	call CHECK_VERSION (FAST_LOCK_DATA_VERSION_1, fast_lock_data.version, "fast_lock_data");
	lock_list_meters_ptr = lm_data_$lock_list_meters_ptr;
	if lock_list_meters_ptr ^= null ()
	then call CHECK_VERSION (LOCK_LIST_METERS_VERSION_1, lock_list_meters.version, "lock_list_meters");

/*  Save a copy of the fast lock. Make sure it hasn't been initialized
    already. */

RETRY:
	unspec (old_fast_lock) = unspec (fast_lock);
	if old_fast_lock.offset ^= ""b
	then do;
		p_code = dm_error_$fast_lock_not_cleared;
		return;
	     end;


/*  Build copy of fast lock block  */

	unspec (temp_fast_lock_block) = ""b;

	call hcs_$get_uid_seg (fast_lock_ptr, temp_fast_lock_block.uid, p_code);
	if p_code ^= 0
	then return;

	temp_fast_lock_block.offset = rel (fast_lock_ptr);

/*  Get a free block for the fast lock  */

	call lm_fast_lock_list_$thread_out_first (addr (fast_lock_data.free_list_head), fast_lock_data_ptr, null (),
	     lock_list_block_ptr);
	if lock_list_block_ptr = null ()
	then do;					/* None free */
		p_code = dm_error_$fast_lock_no_free;
		return;
	     end;

/*  Copy the block into the free block  */

	fast_lock_block_ptr = addr (lock_list_block.block_data);
	unspec (fast_lock_block) = unspec (temp_fast_lock_block);

/*  Fill in the fast lock double-word (this must be last). Watch
    for races. */

	unspec (new_fast_lock) = unspec (old_fast_lock);
	new_fast_lock.offset = rel (lock_list_block_ptr);

	Ap = addr (new_fast_lock.offset);
	Qp = addr (old_fast_lock.offset);
	Wp = addr (fast_lock.offset);
	if ^stacq (W, A, Q)
	then do;
		call lm_fast_lock_list_$thread_in (addr (fast_lock_data.free_list_head), lock_list_meters_ptr,
		     lock_list_block_ptr);
		goto RETRY;
	     end;

	return;
%page;
CHECK_VERSION:
     proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl	cv_p_expected_version
			char (8) aligned parameter;
dcl	cv_p_received_version
			char (8) aligned parameter;
dcl	cv_p_structure_name char (32) aligned parameter;

	if cv_p_expected_version ^= cv_p_received_version
	then call sub_err_ (error_table_$unimplemented_version, ME, 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;

%include dm_fast_lock_strucs;
%page;
%include dm_lock_list_strucs;
%include sub_err_flags;

     end lm_init_fast_lock_;




		    lm_init_fast_per_process_.pl1   03/06/85  0802.6re  03/05/85  0759.6       18126



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


/*  DESCRIPTION:
   Program to establish fast locking for this process.
   Called by init_lock_per_process_ during per-process
   Lock Manager initialization.
*/

/* HISTORY:
Written by John Bongiovanni 06/15/82.
Modified:
03/04/83 by Jeffrey D. Ives: Modified for new initialization.
10/10/84 by Stanford S. Cox:  For DM program standards, and to meter fast
            locks.
11/26/84 by Matthew Pierret:  Removed references to the obsolete dm_common_init
*/

/* format: style3,ifthenstmt,ifthendo,^indnoniterdo,^inditerdo,ind3 */
/* format: indcomtxt,indcom */

lm_init_fast_per_process_:
   proc ();

dcl	saved_validation_level
			fixed bin init (0);
dcl	cleanup		condition;

dcl	lm_data_$fast_lock_data_ptr
			ptr external;
dcl	lm_data_$lock_list_meters_ptr
			ptr external;
dcl	dm_system_data_$	external;
dcl	dm_system_data_$fast_lock_data_rel
			bit (18) aligned external;
dcl	dm_system_data_$lock_list_meters_rel
			bit (18) aligned external;

dcl	cu_$level_get	entry (fixed bin);
dcl	cu_$level_set	entry (fixed bin);
dcl	get_ring_		entry () returns (fixed bin (3));

dcl	addr		builtin;
dcl	ptr		builtin;

      call cu_$level_get (saved_validation_level);
      on cleanup call cu_$level_set (saved_validation_level);
      call cu_$level_set (get_ring_ ());

      lm_data_$fast_lock_data_ptr = ptr (addr (dm_system_data_$), dm_system_data_$fast_lock_data_rel);

      if dm_system_data_$lock_list_meters_rel = "0"b
      then lm_data_$lock_list_meters_ptr = null ();
      else lm_data_$lock_list_meters_ptr = ptr (addr (dm_system_data_$), dm_system_data_$lock_list_meters_rel);

      call cu_$level_set (saved_validation_level);

      return;


   end lm_init_fast_per_process_;




		    lm_log_.pl1                     03/06/85  0802.6re  03/05/85  0759.6       73458



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
lm_log_:
	procedure () options (variable);

/*
   lm_log_ - primitive interface to the data manatement log, to be used by
   all processes that need to leave a message in an accessable place
   for future use.  This procedure contains a locking protocol for the
   data management system log.  The actual writing is handled by write_log_.

   Two calling sequences are recognized by lm_log_, one for error reporting
   and one for simple reporting.  Error reports will generate two entries
   in the log, simple reports will generate one entry.  The calling sequences
   are:

	call lm_log_ (severity, code, caller, ioa_ctl_string, ioa_arg1, ..., ioa_argN);
	call lm_log_ (severity, ioa_ctl_string, ioa_arg1, ..., ioa_argN);

   the fundamental flow of this program is:

	DM_LOG_

	     MAKE_MESSAGE

	     LOCK_LOG
	     if   CANNOT_LOCK_LOG
	     then
	     else do
		WRITE_INTO_LOG (time, severity, id || message)
		UNLOCK_LOG
		end

        end DM_LOG_

*/

/*
   written  11jan83 by M. Pandolf
   modified 01feb83 by M. Pandolf to accept pointer to arg list in addition
			    to accepting an arglist directly.
  modified 830426 BIM to reconstitute as lm_log_. a hack.
*/

%page;

/* entrypoint to accept arg ptr as an argument */

	need_to_get_arglist_ptr = "1"b;
	goto setup_handler;

from_arg_ptr:
	entry (p_arglist_ptr);

	need_to_get_arglist_ptr = "0"b;
	arglist_ptr = p_arglist_ptr;

/* first, get ready to give up at the first sign of trouble */

setup_handler:
	on any_other begin;
	     if dm_system_data_$log_lock ^= ZERO
	     then call set_lock_$unlock (dm_system_data_$log_lock, status);

	     goto lm_log_returns;
	end;

/* get process identity and pointer to arglist for this block */

	call user_info_$whoami (person_id, project_id, acct);
	if need_to_get_arglist_ptr
	then call cu_$arg_list_ptr (arglist_ptr);

/* there can be no less than two arguments to this program, so verify it */

	if arglist_ptr -> arg_list.arg_count < 2
	then return;

/* get some values that will be required for calls to write_log_ */

	message_time = clock ();
	message_severity = FIXED_BIN_17 (1);

/* lock the log lock */

	call set_lock_$lock (dm_system_data_$log_lock, FIFTEEN_SECOND_WAIT, status);
	if status = error_table_$lock_wait_time_exceeded |
	     status = error_table_$no_w_permission
	then goto lm_log_returns;

/* if this is an error call, the second parameter will be fixed bin (35) */

	if arglist_ptr -> arg_list.desc_ptrs (2) -> arg_descriptor.type = FIXED_BIN_SHORT
	then do;

/* log the first of a two line message */

	     error_code = FIXED_BIN_35 (2);		/* from parm 2 */
	     caller = CHAR_32 (3);			/* from parm 3 */

	     if error_code = 0
	     then short_report, long_report = "";
	     else call convert_status_code_ (error_code, short_report, long_report);
	     message = "(" || substr (person_id, 1, 8) || " " || substr (project_id, 1, 8) || ") " || rtrim (caller) || ": " || rtrim (long_report);

	     call write_log_$write_log_file (message_time, message_severity, message, DMS_LOG, Log_ptr);

/* log the second line of the two line message, if it exists */

	     if arglist_ptr -> arg_list.arg_count > 3
	     then do;
		message_len = 116;
		call formline_ (4, 5, addr (message), message_len, 1, arglist_ptr);
		message = "(" || substr (person_id, 1, 8) || " " || substr (project_id, 1, 8) || ") " || message;

		call write_log_$write_log_file (message_time, message_severity, message, DMS_LOG, Log_ptr);
	     end;

	end;

/* not an error call, print one line of message */

	else do;

	     message_len = 116;
	     call formline_ (2, 3, addr (message), message_len, 1, arglist_ptr);
	     message = "(" || substr (person_id, 1, 8) || " " || substr (project_id, 1, 8) || ") " || message;

	     call write_log_$write_log_file (message_time, message_severity, message, DMS_LOG, Log_ptr);

	end;

	call set_lock_$unlock (dm_system_data_$log_lock, status);

lm_log_returns:
	return;

set_dir:
	entry (p_log_dir);

/* this entrypoint is used to set the dir for the log */

	if p_log_dir ^= ""
	then call write_log_$write_log_test (p_log_dir);
	else call write_log_$write_log_test (get_default_wdir_ ());

	return;

%page;

/* INTERNAL PROCEDURES */

FIXED_BIN_17:
	procedure (p_arg_no) returns (fixed bin (17));

dcl  p_arg_no fixed bin parameter;
dcl  fb17 fixed bin (17) based;

	if arglist_ptr -> arg_list.arg_count >= p_arg_no
	then return (arglist_ptr -> arg_list.arg_ptrs (p_arg_no) -> fb17);
	else return (0);

end FIXED_BIN_17;

FIXED_BIN_35:
	procedure (p_arg_no) returns (fixed bin (35));

dcl  p_arg_no fixed bin parameter;
dcl  fb35 fixed bin (35) based;

	if arglist_ptr -> arg_list.arg_count >= p_arg_no
	then return (arglist_ptr -> arg_list.arg_ptrs (p_arg_no) -> fb35);
	else return (0);

end FIXED_BIN_35;

CHAR_32:
	procedure (p_arg_no) returns (char (32));

dcl  p_arg_no fixed bin parameter;
dcl  c32 char (32) based;

	if arglist_ptr -> arg_list.desc_count >= p_arg_no
	then return (substr (arglist_ptr -> arg_list.arg_ptrs (p_arg_no) -> c32,
	     1,
	     arglist_ptr -> arg_list.desc_ptrs (p_arg_no) -> arg_descriptor.size));
	else return ("");

end CHAR_32;

%page;

/* DECLARATIONS */

/* Parameter */

dcl  p_arglist_ptr pointer parameter;			/* explicit pointer to arglist */
dcl  p_log_dir char (*) parameter;			/* dir in which the current log is to be found */

/* Automatic */

dcl  need_to_get_arglist_ptr bit (1) aligned;		/* true if arglist_ptr is implicitly received */
dcl  status fixed bin (35);				/* standard system status code */
dcl  person_id char (22);				/* of this process */
dcl  project_id char (9);				/* of this process */
dcl  acct char (32);				/* process account, is ignored here */
dcl  arglist_ptr pointer;				/* pointer to argument list for this block */
dcl  message_time fixed bin (71);			/* time message was received for logging */
dcl  message_severity fixed bin (17);			/* nonstandard code indicating nature of message */
dcl  error_code fixed bin (35);			/* standard status code to be translated for output */
dcl  caller char (32);				/* name of block calling this procedure */
dcl  short_report char (8) aligned;			/* short status message from error_code */
dcl  long_report char (100) aligned;			/* long status message from error_code */
dcl  message char (116);				/* message to be logged */
dcl  message_len fixed bin (21);			/* length of message, in bytes */

/* Static, Internal */

dcl  Log_ptr pointer internal static init (null ());	/* pointer to current log segment */

/* Static, External */

dcl  dm_system_data_$log_lock bit (36) aligned external static;
dcl  error_table_$lock_wait_time_exceeded fixed bin(35) ext static;
dcl  error_table_$no_w_permission fixed bin(35) ext static;

/* Constant */

dcl  ZERO bit (36) internal static options (constant)
     init ((36)"0"b);
dcl  FIXED_BIN_SHORT fixed bin (6) unsigned unaligned internal static options (constant)
     init (1);
dcl  FIFTEEN_SECOND_WAIT fixed bin internal static options (constant)
     init (15);
dcl  DMS_LOG char (32) internal static options (constant)
     init ("lm_log");

/* Entry */

dcl  set_lock_$lock entry (bit(36) aligned, fixed bin, fixed bin(35));
dcl  set_lock_$unlock entry (bit(36) aligned, fixed bin(35));
dcl  user_info_$whoami entry (char(*), char(*), char(*));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  convert_status_code_ entry (fixed bin(35), char(8) aligned, char(100) aligned);
dcl  formline_ entry options (variable);
dcl  write_log_$write_log_file entry (fixed bin(71), fixed bin, char(*), char(*), ptr);
dcl  write_log_$write_log_test entry (char(*));
dcl  get_default_wdir_ entry() returns(char(168) aligned);

/* Condition */

dcl  any_other condition;

/* Builtin */

dcl  clock builtin;
dcl  substr builtin;
dcl  rtrim builtin;

/* Include Files */

%page;
%include arg_list;
%page;
%include arg_descriptor;
%page;

end lm_log_;




		    lm_per_process_.pl1             04/04/85  1119.5re  04/04/85  0827.0      152343



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

/*  DESCRIPTION:
    Per-Process Pre-Processor for Data Management Locking

    Handles the (crude) locking hierarchy and does some optimizations.

    This involves the following:

    1. The locking hierarchy is two-level: Page File (parent) and Control
       Interval (child). 

    2. For each Control Interval lock, check whether a lock is required.
       It is not required if a sufficiently strong lock is already held
       on the parent Page File.

    3. If a lock is required, obtain a lock on the parent of the appropriate
       type. Do not do so if a sufficiently strong lock is already held.

    4. Obtain a lock on the Control Interval (child).

    Note the following:

    1. File Locks are optimized in several senses. If a strong lock is held
       on the File, it is not necessary to call per-system locking for
       each Control Interval. If a lock is already held on the File, it is
       not necessary to call per-system locking to determine this.
*/
/* HISTORY:

Written by J. Bongiovanni, 11/01/82.
Modified:
03/11/83 by Benson I. Margulies:  To make unlock_all work in the daemon without
            social services (Reagan cut them).
04/26/83 by Benson I. Margulies:  To log, optionally.
05/01/84 by R. Michael Tague:  Added %include dm_lm_meters.
10/15/84 by Stanford S. Cox:  MAIN: Chg all int proc to have prefix var names
	  and use ER, moved call to lm_log_ when tracing to LOCK_FILE.  ER:
	  Added for common return.
10/24/84 by Lindsey L. Spratt:  Added initialization of p_code to 0 for $lock
            entrypoint.  Removed spurious check of p_code after call to
            VALIDATE_MODE.  Added a check of p_code after call to 
	  lm_per_system_$unlock.
11/19/84 by Stanford S. Cox:  MAIN: Check for CHILD_LOCK = -1 (error).
02/26/85 by Lindsey L. Spratt:  Changed SETUP$$LOCK to reset
            lock_transaction_table.txn_id to the current_txn_id if it has
            gotten set to "0"b (by an lm_per_system_$unlock_all call).
*/

/* format: style3,idind30 */
lm_per_process_$lock:
     proc (p_f_uid, p_ci_number, p_mode_req, p_timeout, p_mode_obtained, p_code);

/*  Parameter  */

declare	p_ci_number		fixed bin (27) parameter;
						/* Control Interval Number */
declare	p_checkpoint_id		bit (36) aligned parameter;
						/* Checkpoint Unique ID */
declare	p_code			fixed bin (35) parameter;
						/* Standard Error p_code */
declare	p_mode_obtained		fixed bin parameter;/* Lock Mode Obtained */
declare	p_mode_req		fixed bin parameter;/* Lock Mode Requested */
declare	p_f_uid			bit (36) aligned parameter;
						/* Page File Unique ID */
declare	p_timeout			fixed bin (71) parameter;
						/* How long to wait */

/*  Automatic  */

declare	area_handler		entry variable;
declare	ci_number			fixed bin (27);
declare	hashx			fixed bin;
declare	mode_obtained		fixed bin;
declare	mode_req			fixed bin;
declare	f_uid			bit (36) aligned;
declare	set_code_parm_on_error_return bit (1);
declare	timeout			fixed bin (71);

/*  Static  */

declare	CHILD_LOCK		(2:6, 2:6) fixed bin int static options (constant)
				init (0, 0, 2, 2, 0, -1, 0, -1, 3, 3, 0, 0, 0, 0, 0, -1, 0, -1, 0, 0, -1, 0, -1,
				6, 0);
declare	COMMON_MODE		(2:6, 2:6) fixed bin int static options (constant)
				init (2, 3, 2, 6, 6, 3, 3, 3, 3, 3, 2, 3, 4, 5, 6, 6, 3, 5, 5, 6, 6, 3, 6, 6, 6);
declare	PARENT_MODE		(2:6) fixed bin int static options (constant) init (4, 5, 4, 5, 5);
dcl	ME			char (15) int static options (constant) init ("lm_per_process_");


/*  Based  */

declare	dm_area			area based (dm_data_$inner_ring_areap);

/*  External  */

declare	dm_system_data_$max_n_transactions
				fixed bin ext;
declare	dm_data_$current_txn_id	bit (36) aligned external;

declare	dm_data_$current_txn_index	fixed bin ext;
declare	dm_data_$inner_ring_areap	ptr external;

declare	dm_error_$lock_deadlock	fixed bin (35) external static;
declare	dm_error_$no_current_transaction
				fixed bin (35) external;
declare	dm_error_$unimplemented_entry fixed bin (35) external;
declare	dm_error_$lock_invalid_mode	fixed bin (35) external;
declare	dm_error_$per_process_area_overflow
				fixed bin (35) external;
dcl	error_table_$unimplemented_version
				fixed bin (35) ext static;
declare	lm_data_$trace		bit (1) aligned external static;
declare	lm_data_$lock_per_process_ptr pointer ext static;
declare	lm_data_$current_txn_id	bit (36) aligned ext static;
declare	lm_data_$lock_seg_ptr	pointer ext static;
declare	lm_data_$txn_table_ptr	pointer external static;

/*  Entry  */

declare	sub_err_			entry options (variable);
declare	lm_log_			entry options (variable);
declare	lm_per_system_$checkpoint	entry (bit (36) aligned, fixed bin (35));
declare	lm_per_system_$lock		entry (bit (36) aligned, fixed bin (27), fixed bin, fixed bin (71), fixed bin,
				fixed bin (35));
declare	lm_per_system_$lock_resolve_deadlock
				entry (bit (36) aligned, fixed bin (27), fixed bin, fixed bin (71), fixed bin,
				bit (36) aligned, fixed bin (35));
declare	lm_per_system_$unlock	entry (bit (36) aligned, fixed bin (27), fixed bin (35));
declare	lm_per_system_$unlock_all	entry;
declare	lm_per_system_$unlock_to_checkpoint
				entry (bit (36) aligned, fixed bin (35));
declare	lm_signal_deadlock_		entry (bit (36) aligned, bit (36) aligned, fixed bin (27), fixed bin);
declare	get_process_id_		entry returns (bit (36) aligned);

/*  Condition  */

declare	area			condition;

/*  Builtin  */

declare	addr			builtin;
declare	bit			builtin;
declare	fixed			builtin;
declare	null			builtin;
declare	unspec			builtin;
%page;

/* lm_per_process_$lock: entry (p_f_uid, p_ci_number, p_mode_req, p_timeout, p_mode_obtained, p_code); */

	p_code = 0;
	f_uid = p_f_uid;
	ci_number = p_ci_number;
	mode_req = p_mode_req;
	timeout = p_timeout;
	set_code_parm_on_error_return = "1"b;

	area_handler = NOOP;			/* handler in outer block to avoid nonquick */
	on area call area_handler;

	call VALIDATE_MODE (mode_req);

	call SETUP$$LOCK;

	if ci_number = LOCK_ENTIRE_FILE
	then call LOCK_FILE (f_uid, mode_req, timeout, p_mode_obtained, ci_number, ("lock(entire file)"), "0"b);
	else do;
		call LOCK_FILE (f_uid, PARENT_MODE (mode_req), timeout, mode_obtained, ci_number, ("lock(file)"),
		     "1"b);

		if CHILD_LOCK (mode_req, mode_obtained) > 0
		then call lm_per_system_$lock (f_uid, ci_number, mode_req, timeout, p_mode_obtained, p_code);
		else if CHILD_LOCK (mode_req, mode_obtained) = -1
		then call ERROR_RETURN (dm_error_$lock_invalid_mode);
		if lm_data_$trace
		then call lm_log_ (INFORM_SV, p_code, "lock", "TXN ^w File ^w CI ^d ModeReq ^a ^[ModeGot ^a^].",
			dm_data_$current_txn_id, f_uid, ci_number, LOCK_MODE_NAMES (mode_req), (p_code = 0),
			LOCK_MODE_NAMES (p_mode_obtained));
	     end;
MAIN_RETURN:
	return;
%page;
unlock:
     entry (p_f_uid, p_ci_number, p_code);

	f_uid = p_f_uid;
	ci_number = p_ci_number;
	p_code = 0;
	set_code_parm_on_error_return = "1"b;

	call SETUP;

	if lm_data_$trace
	then call lm_log_ (INFORM_SV, 0, "unlock", "TXN ^w File ^w ^[CI ^d^].", dm_data_$current_txn_id, f_uid,
		(ci_number ^= LOCK_ENTIRE_FILE), ci_number);

	if lock_transaction_table.txn_id = (36)"0"b	/* Never initialized */
	then return;				/* so there can be no locks */

/*****      NOTE -- this will make per_system unlock calls *****/
/*****	  for control intervals that were never per_system locked. */

	call lm_per_system_$unlock (f_uid, ci_number, p_code);
	if p_code ^= 0
	then call ERROR_RETURN (p_code);

	if ci_number = LOCK_ENTIRE_FILE
	then call HASH_OUT (f_uid);


	return;



unlock_all:
     entry;

	set_code_parm_on_error_return = "0"b;
	call SETUP;

	if lock_transaction_table.txn_id = (36)"0"b	/* Never initialized */
	then return;				/* so there can be no locks */


	call lm_per_system_$unlock_all;
	call FLUSH_PER_PROCESS;
	return;


abandon:
     entry (p_code);

/**** Do not try to unlock locks, leave that for the daemon. However, */
/**** remove per_process garbage */

	p_code = 0;
	set_code_parm_on_error_return = "0"b;
	call FLUSH_PER_PROCESS;
	return;


lock_resolve_deadlock:
     entry (p_f_uid, p_ci_number, p_mode_req, p_timeout, p_mode_obtained, p_checkpoint_id, p_code);

	p_code = dm_error_$unimplemented_entry;
	return;


checkpoint:
     entry (p_checkpoint_id, p_code);

	p_code = dm_error_$unimplemented_entry;
	return;


unlock_to_checkpoint:
     entry (p_checkpoint_id, p_code);

	p_code = dm_error_$unimplemented_entry;
	return;



/*  Internal Procedure to establish global pointers  */

SETUP:
     procedure;

declare	lock_entry		bit (1) aligned;

	lock_entry = "0"b;
	go to Common;

SETUP$$LOCK:
     entry;

	lock_entry = "1"b;

Common:
	lock_per_process_ptr = lm_data_$lock_per_process_ptr;
	lock_seg_ptr = lm_data_$lock_seg_ptr;
	call CHECK_VERSION (LOCK_SEG_VERSION_1, lock_seg.version, "lock_seg");
	if dm_data_$current_txn_id = ""b
	then call sub_err_ (dm_error_$no_current_transaction, "lock_manager_", ACTION_CANT_RESTART, null (), (0),
		"lock_manager_ requires a transaction.");
	if lm_data_$current_txn_id ^= dm_data_$current_txn_id
	then do;
		lm_data_$txn_table_ptr = addr (lock_seg.transaction_table (dm_data_$current_txn_index));
		lock_transaction_table_ptr = lm_data_$txn_table_ptr;
		call FLUSH_PER_PROCESS;		/* no longer valid */

		if lock_entry
		then call CLAIM_TRANSACTION_TABLE;	/* fill it in to us */
	     end;
	else lock_transaction_table_ptr = lm_data_$txn_table_ptr;

	if lock_entry
	then if lock_transaction_table.txn_id = "0"b
	     then lock_transaction_table.txn_id = dm_data_$current_txn_id;

     end SETUP;

CLAIM_TRANSACTION_TABLE:
     procedure;

	lock_transaction_table.process_id = get_process_id_ ();
	lock_transaction_table.txn_id = dm_data_$current_txn_id;
	lock_transaction_table.ev_channel = 0;
	lock_transaction_table.own_ptr = NULL_VPTR;
	lock_transaction_table.wait_ptr = NULL_VPTR;
	lm_data_$current_txn_id = dm_data_$current_txn_id;
	return;					/* Note that this is not done until all the proceeding has succeeded */
     end CLAIM_TRANSACTION_TABLE;



/*  Internal Procedure to validate a lock mode  */

VALIDATE_MODE:
     proc (vm_mode);

declare	vm_mode			fixed bin;

	if vm_mode < LOCK_MODE_S | vm_mode > LOCK_MODE_SIX
	then call ERROR_RETURN (dm_error_$lock_invalid_mode);

     end VALIDATE_MODE;

/*  Internal Procedure to lock a file in the appropriate mode  */

LOCK_FILE:
     proc (lf_p_f_uid, lf_p_mode_req, lf_p_timeout, lf_p_mode_obtained, lf_p_ci_number, lf_p_caller, lf_p_log_errors_only)
	;

declare	lf_p_f_uid		bit (36) aligned parameter;
declare	lf_p_mode_req		fixed bin parameter;
declare	lf_p_timeout		fixed bin (71) parameter;
declare	lf_p_mode_obtained		fixed bin parameter;
declare	lf_p_ci_number		fixed bin (27) parameter;
declare	lf_p_caller		char (17) parameter;
declare	lf_p_log_errors_only	bit (1) parameter;

declare	lf_code			fixed bin (35);
declare	new_mode			fixed bin;

	lf_code = 0;

	per_process_file_lock_ptr = HASH_SEARCH (lf_p_f_uid);
	if per_process_file_lock_ptr = null ()
	then do;
		per_process_file_lock_ptr = ALLOCATE_FILE ();
		call lm_per_system_$lock (lf_p_f_uid, LOCK_ENTIRE_FILE, lf_p_mode_req, lf_p_timeout,
		     lf_p_mode_obtained, lf_code);
		if lf_code = 0
		then do;
			per_process_file_lock.f_uid = lf_p_f_uid;
			per_process_file_lock.mode = lf_p_mode_obtained;
			call HASH_IN (per_process_file_lock_ptr);
		     end;
	     end;
	else do;
		new_mode = COMMON_MODE (lf_p_mode_req, per_process_file_lock.mode);
		if new_mode = per_process_file_lock.mode
		then lf_p_mode_obtained = per_process_file_lock.mode;
		else do;
			call lm_per_system_$lock (lf_p_f_uid, LOCK_ENTIRE_FILE, new_mode, lf_p_timeout,
			     lf_p_mode_obtained, lf_code);
			if lf_code = 0
			then per_process_file_lock.mode = lf_p_mode_obtained;
		     end;
	     end;

	if lm_data_$trace & ((lf_code ^= 0 & lf_p_log_errors_only) | ^lf_p_log_errors_only)
	then call lm_log_ (INFORM_SV, lf_code, lf_p_caller, "TXN ^w File ^w ModeReq ^a ^[CI ^d^;^s^[ModeGot ^a^]^]",
		dm_data_$current_txn_id, lf_p_f_uid, LOCK_MODE_NAMES (lf_p_mode_req),
		(lf_p_ci_number ^= LOCK_ENTIRE_FILE), lf_p_ci_number, (lf_code = 0),
		LOCK_MODE_NAMES (lf_p_mode_obtained));

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

     end LOCK_FILE;



/*  Internal Procedures for Hash Table Operations

    HASH_IN -     Hashes a block into the per-process hash table

    HASH_OUT -    Hashes out and frees a block

    HASH_SEARCH - Searches for a block given the Page File UID

*/

HASH_IN:
     proc (hi_p_file_ptr);

declare	hi_p_file_ptr		ptr parameter;

declare	hi_hashx			fixed bin;

declare	1 hi_cur_file		aligned like per_process_file_lock based (hi_p_file_ptr);

	hi_hashx = fixed (bit (hi_cur_file.f_uid & lock_per_process.ht_mask, 36), 36);
	hi_cur_file.ht_fp = lock_per_process.hash_table (hi_hashx);
	lock_per_process.hash_table (hi_hashx) = hi_p_file_ptr;

     end HASH_IN;



HASH_OUT:
     proc (ho_p_f_uid);

declare	ho_p_f_uid		bit (36) aligned parameter;

declare	ho_hashx			fixed bin;
declare	ho_file_ptr		ptr;
declare	ho_prev_file_ptr		ptr;

declare	1 ho_cur_file		aligned like per_process_file_lock based (ho_file_ptr);
declare	1 ho_prev_file		aligned like per_process_file_lock based (ho_prev_file_ptr);

	ho_hashx = fixed (bit (ho_p_f_uid & lock_per_process.ht_mask, 36), 36);
	ho_prev_file_ptr = null ();
	ho_file_ptr = lock_per_process.hash_table (ho_hashx);
	do while (ho_file_ptr ^= null ());
	     if ho_cur_file.f_uid = ho_p_f_uid
	     then do;
		     if ho_prev_file_ptr = null ()
		     then lock_per_process.hash_table (ho_hashx) = ho_cur_file.ht_fp;
		     else ho_prev_file.ht_fp = ho_cur_file.ht_fp;
		     call FREE_FILE (ho_file_ptr);
		     return;
		end;
	     else do;
		     ho_prev_file_ptr = ho_file_ptr;
		     ho_file_ptr = ho_cur_file.ht_fp;
		end;
	end;

     end HASH_OUT;



HASH_SEARCH:
     proc (hs_p_f_uid) returns (ptr);

declare	hs_p_f_uid		bit (36) aligned parameter;

declare	hs_hashx			fixed bin;
declare	hs_file_ptr		ptr;

declare	1 hs_cur_file		aligned like per_process_file_lock based (hs_file_ptr);

	hs_hashx = fixed (bit (hs_p_f_uid & lock_per_process.ht_mask, 36), 36);
	hs_file_ptr = lock_per_process.hash_table (hs_hashx);
	do while (hs_file_ptr ^= null ());
	     if hs_cur_file.f_uid = hs_p_f_uid
	     then return (hs_file_ptr);
	     else hs_file_ptr = hs_cur_file.ht_fp;
	end;

	return (null ());


     end HASH_SEARCH;



ALLOCATE_FILE:
     procedure () returns (pointer);

declare	af_new_file_ptr		pointer;
declare	1 af_new_file		aligned like per_process_file_lock based (af_new_file_ptr);

	area_handler = AREA_TOO_SMALL;

RETRY_ALLOC:
	allocate af_new_file in (lm_per_process_area) set (af_new_file_ptr);

	area_handler = NOOP;
	return (af_new_file_ptr);

AREA_TOO_SMALL:					/* Nonquick procedure to reallocate area */
     procedure;

declare	new_area_size		fixed bin (35);
declare	new_area_ptr		pointer;
declare	new_area			area (new_area_size) based (new_area_ptr);

	on area call ERROR_RETURN (dm_error_$per_process_area_overflow);

	new_area_size = lock_per_process.area_size * 2;
	allocate new_area in (dm_area) set (new_area_ptr);
	new_area = lm_per_process_area;
	lock_per_process.area_ptr = new_area_ptr;
	lock_per_process.area_size = new_area_size;
	go to RETRY_ALLOC;
     end AREA_TOO_SMALL;
     end ALLOCATE_FILE;

FREE_FILE:
     procedure (ff_file_ptr);
declare	ff_file_ptr		pointer;

	free ff_file_ptr -> per_process_file_lock;
	return;
     end FREE_FILE;

FLUSH_PER_PROCESS:
     procedure;

	lm_per_process_area = empty ();
	lock_per_process.hash_table (*) = null ();	/* aggregate */
	return;
     end FLUSH_PER_PROCESS;

NOOP:
     entry;
	return;					/* format: off */

CHECK_VERSION:
   proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl	cv_p_expected_version
			char (8) aligned parameter;
dcl	cv_p_received_version
			char (8) aligned parameter;
dcl	cv_p_structure_name char (32) aligned parameter;

      if cv_p_expected_version ^= cv_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, ME, 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;

ERROR_RETURN:
	 proc (er_p_code);
declare er_p_code fixed bin (35);

	 if set_code_parm_on_error_return then p_code = er_p_code;
	 goto MAIN_RETURN;
end ERROR_RETURN;
%page;  %include dm_lock_modes;
%page;  %include sub_err_flags;
%page;  %include dm_lm_per_process_data_;
%page;  %include dm_lm_system_data;
%page;  %include dm_lm_meters;
%page;  %include dm_log_sv_codes;

end lm_per_process_$lock;




		    lm_per_process_init_.pl1        03/06/85  0802.6re  03/05/85  0759.7       49779



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

/*  DESCRIPTION:
    Program to do per-process lock initialization. Assumes that fast
    locking is already initialized.
*/

/* HISTORY:

Written by J. Bongiovanni, 11/30/82.
Modified:
12/01/82 by J. Bongiovanni:  For multi-segment lock data.
02/08/83 by Lindsey Spratt:  Moved setting of lm_data_$lock_seg_ptr to just
            after lock_seg_ptr is set  by call to dm_per_system_$initiate.
            This fixes a problem where lm_salvage_lock_seg_ was being called 
            before lm_data_$lock_seg_ptr was set, but it depends on its
            value being non-null.
03/04/83 by Jeffrey D. Ives:  Modified for new initialization (add sub_err_).
04/06/83 by Benson I. Margulies:  To houseclean, make transaction oriented.
08/05/83 by Lee A. Newcomb:  removed obsolete status codes from calls
	  to dm_per_system_ entries.
83/12/02 by MPandolf: to make lm_data_$current_txn_id external
05/01/84 by R. Michael Tague:  Added %include dm_lm_meters
10/03/84 by Stanford S. Cox:  To use sub_err_flags.
11/22/84 by Lee A. Newcomb:  removed obsolete dm_common_init_ references.
12/04/84 by Stanford S. Cox:  Removed ptr check after dm_per_system_ call.
*/

/* format: style3,idind30 */
lm_per_process_init_:
     procedure;

/*  Automatic  */

dcl	code			fixed bin (35) init (0);
dcl	hx			fixed bin init (0);
dcl	lock_segx			fixed bin init (0);
dcl	px			fixed bin init (0);
dcl	retval			fixed bin (35) init (0);
dcl	saved_validation_level	fixed bin init (-1);

dcl	cleanup			condition;

/*  Static  */

dcl	ME			char (32) static options (constant) init ("lm_per_process_init_");
dcl	LOCK_TIMEOUT		fixed bin (71) int static options (constant) init (1000000000);
dcl	INITIAL_AREA_SIZE		fixed bin int static options (constant) init (1024);
dcl	N_HASH_TABLE_ENTRIES	fixed bin int static options (constant) init (128);
dcl	HASH_MASK			bit (36) aligned int static options (constant) init ("000000000177"b3);

/*  Based  */

dcl	dm_area			area based (dm_data_$inner_ring_areap);

/*  External  */

dcl	dm_system_data_$max_n_transactions
				fixed bin ext static;
dcl	dm_data_$inner_ring_areap	ptr external;

dcl	lm_data_$current_txn_id	bit (36) aligned ext static;
dcl	lm_data_$lock_per_process_ptr pointer ext static;
dcl	lm_data_$lock_seg_ptr	pointer ext static;
dcl	lm_data_$n_lock_segments	fixed bin external static;
dcl	lm_data_$lock_segments_ptr	pointer external static;

dcl	dm_error_$fast_lock_invalid_reset
				fixed bin (35) external;
dcl	dm_error_$lock_table_overflow fixed bin (35) external;
dcl	error_table_$unimplemented_version
				fixed bin (35) ext static;

/*  Entry  */

dcl	cu_$level_set		entry (fixed bin);
dcl	get_ring_			entry returns (fixed bin);
dcl	dm_per_system_$initiate	entry (char (*), char (*), ptr);
dcl	get_process_id_		entry () returns (bit (36));
dcl	hcs_$validate_processid	entry (bit (36) aligned, fixed bin (35));
dcl	lm_init_fast_per_process_	entry ();
dcl	lock_manager_$lock_fast	entry (ptr, fixed bin (71), fixed bin (35));
dcl	lock_manager_$unlock_fast	entry (ptr, fixed bin (35));
dcl	lm_salvage_lock_seg_	entry (fixed bin (35));
dcl	sub_err_			entry () options (variable);

/*  Builtin  */

dcl	addr			builtin;
dcl	hbound			builtin;
dcl	lbound			builtin;
dcl	null			builtin;
dcl	ptr			builtin;

	call cu_$level_set (get_ring_ ());

	call lm_init_fast_per_process_ ();

	lock_segno = 1;
	call dm_per_system_$initiate (LOCK_SEGNAME || lock_segno, "", lock_seg_ptr);
	call CHECK_VERSION (LOCK_SEG_VERSION_1, lock_seg.version, "lock_seg");

	lm_data_$lock_seg_ptr = lock_seg_ptr;

	lm_data_$n_lock_segments = lock_seg.n_lock_segments;

	allocate lock_segments in (dm_area) set (lock_segments_ptr);
	lm_data_$lock_segments_ptr = lock_segments_ptr;

	lock_segments.seg_baseptr (1) = ptr (lock_seg_ptr, 0);
	if lm_data_$n_lock_segments > 1
	then do lock_segx = 2 to lm_data_$n_lock_segments;
		lock_segno = lock_segx;
		call dm_per_system_$initiate (LOCK_SEGNAME || lock_segno, "", lock_aux_seg_ptr);
		lock_segments.seg_baseptr (lock_segx) = ptr (lock_aux_seg_ptr, 0);
	     end;


	n_hash_table_entries = N_HASH_TABLE_ENTRIES;
	allocate lock_per_process in (dm_area) set (lock_per_process_ptr);

	lock_per_process.ht_mask = HASH_MASK;
	lock_per_process.area_size = INITIAL_AREA_SIZE;
	allocate lm_per_process_area in (dm_area) set (lock_per_process.area_ptr);
	lock_per_process.hash_table (*) = null ();

	lm_data_$lock_per_process_ptr = lock_per_process_ptr;
	lm_data_$current_txn_id = ""b;		/* so we init */


	return;

CHECK_VERSION:
     proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl	cv_p_expected_version	char (8) aligned parameter;
dcl	cv_p_received_version	char (8) aligned parameter;
dcl	cv_p_structure_name		char (32) aligned parameter;

	if cv_p_expected_version ^= cv_p_received_version
	then call sub_err_ (error_table_$unimplemented_version, ME, 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_lm_per_process_data_;
%page; %include dm_lm_system_data;
%page; %include dm_lm_meters;
%page; %include sub_err_flags;
     end lm_per_process_init_;




		    lm_per_system_.pl1              04/04/85  1119.5re  04/04/85  1106.7      367668



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

/*  DESCRIPTION:
Data Management Locking
*/

/*  HISTORY:

Written by J. Bongiovanni,  11/01/82.
Modified:
12/01/82 by J. Bongiovanni:  For multi-segment lock data.
01/01/83 by J. Bongiovanni:  For deterministic deadlock detection.
03/01/83 by Lindsey Spratt to increase the lock_seg_timeout to 5 min.
04/24/83 by Benson I. Margulies:  To handle mylock more gracefully.
04/26/83 by Benson I. Margulies:  To log timeouts on the lock_seg lock.
05/06/83 by Benson I. Margulies:  To not create one ev channel per txn.
05/10/83 by Benson I. Margulies:  To meter.
08/05/83 by Lee A. Newcomb to remove obsolete code args. from calls
	  to dm_per_system_ entries.
05/01/84 by R. Michael Tague:  Added %include dm_lm_meters.
07/17/84 by Matthew Pierret:   Changed call to fm_open_$post_txn to
            file_manager_$post_transaction.
09/19/84 by Lindsey L. Spratt:  Fixed VALID_TXN to check for the invalid TXID
            = "0"b and return false.  txnmgr_$get_txn_index will return the
            idx for the current txn (and a 0 error code) when given "0"b.
            Fixed CONFLICT(6,6) to equal "1"b, it was "0"b (see MTB514, Fig.
            1, Compatibility Matrix).  Fixed to call lm_signal_deadlock_ when
            either returning from ipc_$block with an event_info.message of
            LOCK_MESSAGE_DEADLOCK, or if waiting on a lock would cause a
            deadlock (according to CHECK_DEADLOCK).
09/25/84 by Lindsey L. Spratt:  Removed use of the MAX_WAIT_TIME, the timer in
            REALLY_WAIT is now set to the give_up_time.
            Changed to do deadlock detection before waiting on the lock at
            all, as opposed to only doing deadlock detection after the first
            wait.  This change is necessary because of the removal of
            MAX_WAIT_TIME.
            Fixed to set the Lock_Txn_Table.deadlock_inx to 0 for invalid txns
            in CHECK_DEADLOCK.
10/17/84 by Stanford S. Cox:  MAIN: Chg all int proc to have prefix var names
	  and use ER, chg CONFLICT (6, 6) to "1"b.  ER: Added for common
	  return.  SETUP_LOCK: Chg RETRY_LOCK_LOOP to use do while.  LOCK_OBJECT:
	  Chg LOCK_LOOP to use do while.
01/22/85 by Lindsey L. Spratt:  Added the SETUP_UNLOCK internal proc for use
            by the $unlock_lock_data entry.  It was just calling UNLOCK, which
            relied on lock_seg_ptr being set by a previous call to SETUP_LOCK.
02/07/85 by Stanford S. Cox: unlock_all: Rmvd call to fm$post_transaction,
   	  LOCK_OBJECT: Added call to lm_signal_$timeout.
02/26/85 by Lindsey L. Spratt:  Fixed to UNWAIT_ME before signalling deadlock.
            Fixed to only cause deadlock resolution in CHECK_DEADLOCK when
            lm_check_for_deadlock_ has found a deadlock.  Fixed to make the
            deadlock meters consistent with the actual deadlock resolution.
03/01/85 by Lindsey L. Spratt:  Added the SEND_WAKEUP internal proc, which
            handles itt overflows and logs other errors encountered when
            calling hcs_$wakeup.  Changed to wake up and retry the lock very
	  INTERMEDIATE_WAIT_TIME (30 seconds), in case the wakeup on which
	  the proc is blocked isn't sent.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/

/* format: style3,idind30 */
lm_per_system_$lock:
     proc (p_f_uid, p_ci_number, p_mode_req, p_timeout, p_mode_obtained, p_code);

/*  Parameter  */

dcl	p_ci_number		fixed bin (27) parameter;
						/* Control Interval Number */
dcl	p_checkpoint_id		bit (36) aligned parameter;
						/* Checkpoint Unique ID */
dcl	p_code			fixed bin (35) parameter;
						/* Standard Error p_code */
dcl	p_mode_obtained		fixed bin parameter;/* Lock Mode Obtained */
dcl	p_mode_req		fixed bin parameter;/* Lock Mode Requested */
dcl	p_f_uid			bit (36) aligned parameter;
						/* Page File Unique ID */
dcl	p_timeout			fixed bin (71) parameter;
						/* How long to wait */

/*  Automatic  */

dcl	ci_number			fixed bin (27);
dcl	code			fixed bin (35);
dcl	give_up_time		fixed bin (71);
dcl	mode_req			fixed bin;
dcl	f_uid			bit (36) aligned;
dcl	error_in_unlock_all		bit (1) aligned;

/*  Static  */

dcl	COMMON_MODE		(2:6, 2:6) fixed bin int static options (constant)
				init (2, 3, 2, 6, 6, 3, 3, 3, 3, 3, 2, 3, 4, 5, 6, 6, 3, 5, 5, 6, 6, 3, 6, 6, 6);

dcl	CONFLICT			(2:6, 2:6) bit (1) aligned int static options (constant)
				init ("0"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b,
				"0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b);

dcl	(
	YES			init ("1"b),
	NO			init ("0"b)
	)			bit (1) aligned internal static options (constant);

dcl	LOCK_SEG_TIMEOUT		fixed bin (71) int static options (constant) init (300000000 /* 5 minutes */);
dcl	ITT_OVERFLOW_WAIT_TIME	init (1e7 /* 10 seconds */) fixed bin (71) int static options (constant);
dcl	INTERMEDIATE_WAIT_INTERVAL	init (3e7 /* 30 seconds */) fixed bin (71) int static options (constant);
dcl	ID_IS_INVALID		init ("0"b) bit (1) aligned internal static options (constant);
dcl	TIME_IS_ABSOLUTE		init (2) fixed bin (17) int static options (constant);
dcl	RELATIVE_SECONDS		init ("11"b) bit (2) int static options (constant);
dcl	MAXIMUM_NUMBER_OF_WAKEUP_ATTEMPTS
				init (10) fixed bin internal static options (constant);
dcl	ME			char (14) int static options (constant) init ("lm_per_system_");

/*  Based  */

dcl	dm_area			area based (dm_data_$inner_ring_areap);

/*  External  */

dcl	dm_system_data_$max_n_transactions
				fixed bin ext;
dcl	dm_data_$inner_ring_areap	ptr external;
dcl	dm_data_$current_txn_id	bit (36) aligned external;
dcl	lm_data_$ev_channel		fixed bin (71) ext static;
dcl	lm_data_$txn_table_ptr	pointer ext static;
dcl	lm_data_$lock_segments_ptr	ptr external;
dcl	lm_data_$lock_seg_ptr	ptr external;
dcl	lm_data_$n_lock_segments	fixed bin external;
dcl	dm_error_$fast_lock_mylock	ext static fixed bin (35);
dcl	dm_error_$fast_lock_invalid_reset
				fixed bin (35) external;
dcl	dm_error_$lock_invalid_mode	fixed bin (35) external;
dcl	dm_error_$lock_invalid_uid	fixed bin (35) external;
dcl	dm_error_$lock_not_found	fixed bin (35) external;
dcl	dm_error_$lock_table_overflow fixed bin (35) external;
dcl	dm_error_$lock_timeout	fixed bin (35) external;
dcl	dm_error_$unimplemented_entry fixed bin (35) external;
dcl	error_table_$unimplemented_version
				fixed bin (35) ext static;
dcl	error_table_$itt_overflow	fixed bin (35) ext static;
dcl	error_table_$process_unknown	fixed bin (35) ext static;
dcl	dm_system_data_$lock_ips_mask bit (36) aligned external;

/*  Entry  */

dcl	dm_misc_util_$log		entry options (variable);
dcl	lm_check_for_deadlock_	entry (ptr, ptr, fixed bin, bit (36) aligned, fixed bin (35));
dcl	lm_signal_$deadlock		entry (bit (36) aligned, bit (36) aligned, fixed bin (35), fixed bin);
dcl	lm_signal_$timeout		entry (bit (36) aligned, bit (36) aligned, fixed bin (35), fixed bin,
				fixed bin (71));
dcl	cu_$level_get		entry (fixed bin);
dcl	cu_$level_set		entry (fixed bin);
dcl	dm_per_system_$initiate	entry (char (*), char (*), ptr);
dcl	lm_expand_lock_seg_		entry (fixed bin (35));
dcl	get_ring_			entry () returns (fixed bin (3));
dcl	hcs_$get_alarm_timer	entry (fixed bin (71), fixed bin (71));
dcl	hcs_$reset_ips_mask		entry (bit (36) aligned, bit (36) aligned);
dcl	hcs_$set_alarm_timer	entry (fixed bin (71), fixed bin, fixed bin (71));
dcl	hcs_$set_ips_mask		entry (bit (36) aligned, bit (36) aligned);
dcl	hcs_$wakeup		entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl	ipc_$block		entry (ptr, ptr, fixed bin (35));
dcl	ipc_$create_ev_chn		entry (fixed bin (71), fixed bin (35));
dcl	lm_hash_$hash_in		entry (ptr);
dcl	lm_hash_$hash_out		entry (ptr);
dcl	lm_hash_$search		entry (bit (36) aligned, fixed bin (27), ptr);
dcl	lock_manager_$lock_fast	entry (ptr, fixed bin (71), fixed bin (35));
dcl	lock_manager_$unlock_fast	entry (ptr, fixed bin (35));
dcl	lm_salvage_lock_seg_	entry (fixed bin (35));
dcl	sub_err_			entry () options (variable);
dcl	timer_manager_$sleep	entry (fixed bin (71), bit (2));
declare	transaction_manager_$get_txn_index
				entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);

/*  Builtin  */

dcl	addr			builtin;
dcl	clock			builtin;
dcl	null			builtin;
dcl	ptr			builtin;
dcl	wordno			builtin;
dcl	substr			builtin;
dcl	unspec			builtin;

/*  Condition  */

dcl	cleanup			condition;


	f_uid = p_f_uid;
	ci_number = p_ci_number;
	mode_req = p_mode_req;
	give_up_time = p_timeout + clock ();

	if f_uid = ""b
	then call ERROR_RETURN (dm_error_$lock_invalid_uid);

	call VALIDATE_MODE (mode_req);

	call SETUP_LOCK ();

	on cleanup call CLEAN_LOCK;
	call LOCK_OBJECT (give_up_time, f_uid, ci_number, mode_req, p_mode_obtained, p_code);

	call UNLOCK;
MAIN_RETURN:
	return;



unlock_all:
     entry;

	call SETUP_LOCK ();
	error_in_unlock_all = "0"b;
	on cleanup call CLEAN_LOCK;

	lock_seg.meters.unlock_all_calls = lock_seg.meters.unlock_all_calls + 1;

/**** Note that lm_per_process_ has already made sure that ****/
/**** lm_data_$txn_table_ptr is correct. ****/
/**** no need to validate that.  ****/

UNLOCK_ALL_FOR_PROCESS:
	do while (lock_transaction_table.own_ptr.seg_inx ^= -1);
	     lock_owner_ptr = PTR (lock_transaction_table.own_ptr);
	     lock_object_ptr = PTR (lock_owner.lock_ptr);
	     call UNLOCK_OBJECT (lock_object_ptr, code);
	     if code ^= 0
	     then do;
		     call dm_misc_util_$log (INFORM_SV, code, "lm_per_system_$unlock_all", "Error unlocking ^d ^w ^p",
			lock_object.seg_inx, lock_object.uid, lock_object.ci_no);
		     error_in_unlock_all = "1"b;
		end;
	end;

/**** if error_in_unlock_all then call lm_salvage_lock_seg_; retry? */
	lock_transaction_table.txn_id = (36)"0"b;	/* Mark free */
	call UNLOCK;

	return;

unlock:
     entry (p_f_uid, p_ci_number, p_code);

	f_uid = p_f_uid;
	ci_number = p_ci_number;

	call SETUP_LOCK ();

	on cleanup call CLEAN_LOCK;

	lock_object_ptr = FIND_LOCK (f_uid, ci_number);

	call UNLOCK_OBJECT (lock_object_ptr, p_code);

	call UNLOCK;

	return;


lock_resolve_deadlock:
     entry (p_f_uid, p_ci_number, p_mode_req, p_timeout, p_mode_obtained, p_checkpoint_id, p_code);

	p_code = dm_error_$unimplemented_entry;
	return;

checkpoint:
     entry (p_checkpoint_id, p_code);

	p_code = dm_error_$unimplemented_entry;
	return;

unlock_to_checkpoint:
     entry (p_checkpoint_id, p_code);

	p_code = dm_error_$unimplemented_entry;
	return;
lock_lock_data:
     entry (p_code);

	call SETUP_LOCK ();
	return;

unlock_lock_data:
     entry (p_code);

	call SETUP_UNLOCK ();
	p_code = 0;
	return;

ERROR_RETURN:
     proc (er_p_code);
dcl	er_p_code			fixed bin (35);

	call CLEAN_LOCK ();
	p_code = er_p_code;
	goto MAIN_RETURN;
     end ERROR_RETURN;

/*  Internal Procedures to lock the lock table and set up pointers, and
    to unlock it. */

SETUP_LOCK:
     proc ();

dcl	sul_code			fixed bin (35);
dcl	sul_lock_segs_synchronized	bit (1) aligned init ("0"b);

	lock_seg_ptr = lm_data_$lock_seg_ptr;
	call CHECK_VERSION (LOCK_SEG_VERSION_1, lock_seg.version, "lock_seg");
	lock_transaction_table_ptr = lm_data_$txn_table_ptr;
	lock_segments_ptr = lm_data_$lock_segments_ptr;

LOCK:
     entry ();

RETRY_LOCK_LOOP:
	do while (^sul_lock_segs_synchronized);
	     call lock_manager_$lock_fast (addr (lock_seg.lock), LOCK_SEG_TIMEOUT, code);
	     if code ^= 0
	     then if code = dm_error_$fast_lock_invalid_reset | code = dm_error_$fast_lock_mylock
		then do;
			call dm_misc_util_$log (INFORM_SV, code, "lm_per_system_ SETUP", "locking lock_seg.");
			call lm_salvage_lock_seg_ (sul_code);
			if sul_code ^= 0
			then call ERROR_RETURN (sul_code);
		     end;
		else do;
			call dm_misc_util_$log (INFORM_SV, code, "lm_per_system_ SETUP", "locking lock seg.");
			call ERROR_RETURN (code);
		     end;

	     if lm_data_$n_lock_segments ^= lock_seg.n_lock_segments
	     then do;
		     call UNLOCK;
		     call SYNCH_LOCK_SEGMENTS ();
		end;
	     else sul_lock_segs_synchronized = "1"b;
	end RETRY_LOCK_LOOP;
     end SETUP_LOCK;


SETUP_UNLOCK:
     proc ();

dcl	ul_code			fixed bin (35);

	lock_seg_ptr = lm_data_$lock_seg_ptr;
	call CHECK_VERSION (LOCK_SEG_VERSION_1, lock_seg.version, "lock_seg");

UNLOCK:
     entry ();

	call lock_manager_$unlock_fast (addr (lock_seg.lock), ul_code);
	if ul_code ^= 0
	then call dm_misc_util_$log (INFORM_SV, ul_code, "lm_per_system_ UNLOCK", "unlocking lock_seg.");

     end SETUP_UNLOCK;

/*  Internal Procedure to get per-process table of lock segments into synch
    with the per-system lock segments. No lock is required (we depend on
    lock_seg.n_lock_segments monotonicity, and careful ordering of operations). */

SYNCH_LOCK_SEGMENTS:
     proc ();

dcl	sl_lock_segx		fixed bin;
dcl	sl_new_lock_segments_ptr	ptr;
dcl	sl_new_n_lock_segments	fixed bin;
dcl	sl_save_level		fixed bin;


/* Note that there's no cleanup handler to restore the level. It would make
   this procedure non-quick. The level will be restored by ring-alarm. This
   is OK, since it should happen ra(y. */

	call cu_$level_get (sl_save_level);
	call cu_$level_set (get_ring_ ());

	sl_new_n_lock_segments = lock_seg.n_lock_segments;
	allocate lock_segments in (dm_area) set (sl_new_lock_segments_ptr);
	do sl_lock_segx = 1 to lm_data_$n_lock_segments;
	     sl_new_lock_segments_ptr -> lock_segments.seg_baseptr (sl_lock_segx) =
		lock_segments.seg_baseptr (sl_lock_segx);
	end;
	free lock_segments;
	lock_segments_ptr, lm_data_$lock_segments_ptr = sl_new_lock_segments_ptr;

	do sl_lock_segx = lm_data_$n_lock_segments + 1 to sl_new_n_lock_segments;
	     lock_segno = sl_lock_segx;
	     call dm_per_system_$initiate (LOCK_SEGNAME || lock_segno, "", lock_aux_seg_ptr);
	     lock_segments.seg_baseptr (sl_lock_segx) = ptr (lock_aux_seg_ptr, 0);
	end;
	lm_data_$n_lock_segments = sl_new_n_lock_segments;
	call cu_$level_set (sl_save_level);

     end SYNCH_LOCK_SEGMENTS;

/*  Internal Procedure to validate a lock mode parameter  */

VALIDATE_MODE:
     proc (vm_p_mode);

dcl	vm_p_mode			fixed bin;

	if vm_p_mode < LOCK_MODE_S | vm_p_mode > LOCK_MODE_SIX
	then call ERROR_RETURN (dm_error_$lock_invalid_mode);

     end VALIDATE_MODE;

/*  Internal Procedure to get a pointer to a lock object, specified by
    UID and CI number.  */

FIND_LOCK:
     proc (fl_p_f_uid, fl_p_ci_number) returns (ptr);

dcl	fl_p_f_uid		bit (36) aligned;
dcl	fl_p_ci_number		fixed bin (27);

dcl	fl_lock_object_ptr		ptr;

	call lm_hash_$search (fl_p_f_uid, fl_p_ci_number, fl_lock_object_ptr);
	if fl_lock_object_ptr = null ()
	then call ERROR_RETURN (dm_error_$lock_not_found);

	return (fl_lock_object_ptr);

     end FIND_LOCK;


/*  Internal Procedure to get a pointer to a lock object, specified by PF UID
    and CI number. One is created if it does not exist.  */

FIND_OR_ALLOCATE_LOCK:
     proc (fal_p_f_uid, fal_p_ci_number) returns (ptr);

dcl	fal_p_f_uid		bit (36) aligned;
dcl	fal_p_ci_number		fixed bin (27);

dcl	fal_lock_object_ptr		ptr;

dcl	1 fal_lock_object		aligned like lock_object based (fal_lock_object_ptr);

	call lm_hash_$search (fal_p_f_uid, fal_p_ci_number, fal_lock_object_ptr);
	if fal_lock_object_ptr ^= null ()
	then return (fal_lock_object_ptr);

	fal_lock_object_ptr = GET_FREE ();
	if fal_lock_object_ptr = null ()
	then call ERROR_RETURN (dm_error_$lock_table_overflow);

	fal_lock_object.uid = fal_p_f_uid;
	fal_lock_object.ci_no = fal_p_ci_number;
	fal_lock_object.type = TYPE_OBJECT;
	fal_lock_object.owners_ptr = NULL_VPTR;
	fal_lock_object.waiters_ptr = NULL_VPTR;
	call lm_hash_$hash_in (fal_lock_object_ptr);

	return (fal_lock_object_ptr);

     end FIND_OR_ALLOCATE_LOCK;

/*  Internal Procedures to allocate and free lock blocks  */

GET_FREE:
     proc returns (ptr);

dcl	gf_code			fixed bin (35);


	lock_seg.meters.allocates = lock_seg.meters.allocates + 1;
	if unspec (lock_seg.free_list_ptr) = unspec (NULL_VPTR)
	then do;
		call lm_expand_lock_seg_ (gf_code);
		if gf_code ^= 0
		then return (null ());
		call SYNCH_LOCK_SEGMENTS ();
		if unspec (lock_seg.free_list_ptr) = unspec (NULL_VPTR)
		then return (null ());
	     end;

	lock_free_block_ptr = PTR (lock_seg.free_list_ptr);
	lock_seg.free_list_ptr = lock_free_block.free_fp;
	unspec (lock_free_block.pad) = ""b;
	return (lock_free_block_ptr);


     end GET_FREE;


RETURN_FREE:
     proc (rf_lock_free_block_ptr);

dcl	rf_lock_free_block_ptr	ptr;

dcl	1 rf_lock_free_block	aligned like lock_free_block based (rf_lock_free_block_ptr);

	lock_seg.meters.frees = lock_seg.meters.frees + 1;
	unspec (rf_lock_free_block.pad) = ""b;
	rf_lock_free_block.type = TYPE_FREE;
	rf_lock_free_block.free_fp = lock_seg.free_list_ptr;
	lock_seg.free_list_ptr = VPTR (rf_lock_free_block_ptr);

     end RETURN_FREE;

/*  Internal Procedure to attempt to acquire a lock, waiting if necessary.  */

LOCK_OBJECT:
     proc (lo_p_give_up_time, lo_p_f_uid, lo_p_ci_number, lo_p_mode_req, lo_p_mode_obtained, lo_p_code);

dcl	lo_p_f_uid		bit (36) aligned;
dcl	lo_p_give_up_time		fixed bin (71);
dcl	lo_p_ci_number		fixed bin (27);
dcl	lo_p_mode_req		fixed bin;
dcl	lo_p_mode_obtained		fixed bin;
dcl	lo_p_code			fixed bin (35);

dcl	lo_lock_object_ptr		ptr;

dcl	1 lo_lock_object		aligned like lock_object based (lo_lock_object_ptr);



	lock_seg.meters.lock_calls = lock_seg.meters.lock_calls + 1;
	if lo_p_ci_number = LOCK_ENTIRE_FILE
	then lock_seg.meters.file_locks_by_mode (lo_p_mode_req) =
		lock_seg.meters.file_locks_by_mode (lo_p_mode_req) + 1;
	else lock_seg.meters.ci_locks_by_mode (lo_p_mode_req) = lock_seg.meters.ci_locks_by_mode (lo_p_mode_req) + 1;
LOCK_LOOP:
	do while ("1"b);
	     lo_lock_object_ptr = FIND_OR_ALLOCATE_LOCK (lo_p_f_uid, lo_p_ci_number);

	     call TRY_TO_LOCK (lo_lock_object_ptr, lo_p_mode_req, lo_p_mode_obtained);
	     if lo_p_mode_obtained ^= 0
	     then return;

	     if lo_p_give_up_time < clock ()
	     then call lm_signal_$timeout (lock_transaction_table.txn_id, lo_p_f_uid, (lo_p_ci_number), lo_p_mode_req,
		     lo_p_give_up_time);

	     call CHECK_DEADLOCK (lo_lock_object_ptr);
	     if lo_lock_object.uid ^= lo_p_f_uid | lo_lock_object.ci_no ^= lo_p_ci_number
	     then lo_lock_object_ptr = FIND_OR_ALLOCATE_LOCK (lo_p_f_uid, lo_p_ci_number);
						/* CHECK_DEADLOCK unlocks */

	     call WAIT (lo_p_give_up_time, lo_lock_object_ptr, lo_p_mode_req);
	end LOCK_LOOP;

     end LOCK_OBJECT;

/*  Internal Procedure to attempt to obtain a lock without waiting  */

TRY_TO_LOCK:
     proc (tl_p_lock_object_ptr, tl_p_mode_req, tl_p_mode_obtained);

dcl	tl_p_lock_object_ptr	ptr;
dcl	tl_p_mode_req		fixed bin;
dcl	tl_p_mode_obtained		fixed bin;

dcl	tl_lock_owner_ptr		ptr;
dcl	tl_mode_needed		fixed bin;
dcl	tl_mode_req		fixed bin;
dcl	tl_my_lock_owner_ptr	ptr;
dcl	tl_owners_transaction_table_ptr
				ptr;
dcl	1 tl_owners_ptr		aligned like lock_virtual_ptr;

dcl	1 tl_lock_object		aligned like lock_object based (tl_p_lock_object_ptr);
dcl	1 tl_my_lock_owner		aligned like lock_owner based (tl_my_lock_owner_ptr);
dcl	1 tl_lock_owner		aligned like lock_owner based (tl_lock_owner_ptr);



	tl_p_mode_obtained = 0;
	tl_mode_req = tl_p_mode_req;

RETRY:
	tl_my_lock_owner_ptr = null ();
	tl_owners_ptr = tl_lock_object.owners_ptr;
	do while (tl_owners_ptr.seg_inx ^= -1);
	     tl_lock_owner_ptr = PTR (tl_owners_ptr);
	     tl_owners_transaction_table_ptr = PTR (tl_lock_owner.transaction_ptr);
	     if tl_owners_transaction_table_ptr = lock_transaction_table_ptr
						/* This transaction */
	     then do;
		     tl_my_lock_owner_ptr = tl_lock_owner_ptr;
		     tl_mode_needed = COMMON_MODE (tl_mode_req, tl_lock_owner.mode);
		     if tl_mode_needed = tl_lock_owner.mode
		     then do;
			     tl_p_mode_obtained = tl_mode_needed;
			     if tl_lock_object.ci_no = LOCK_ENTIRE_FILE
			     then lock_seg.meters.dup_file_locks_by_mode (tl_mode_needed) =
				     lock_seg.meters.dup_file_locks_by_mode (tl_mode_req) + 1;
			     else lock_seg.meters.dup_ci_locks_by_mode (tl_mode_req) =
				     lock_seg.meters.dup_ci_locks_by_mode (tl_mode_req) + 1;
			     return;
			end;
		     if tl_mode_needed ^= tl_mode_req
		     then do;
			     tl_mode_req = tl_mode_needed;
			     goto RETRY;
			end;
		end;
	     else /* Other transaction */
		if CONFLICT (tl_mode_req, tl_lock_owner.mode)
	     then return;

	     tl_owners_ptr = tl_lock_owner.owners_fp;
	end;

	if tl_my_lock_owner_ptr ^= null ()
	then do;
		tl_lock_owner_ptr = tl_my_lock_owner_ptr;
		tl_lock_owner.mode = tl_mode_req;
		tl_p_mode_obtained = tl_mode_req;
		return;
	     end;

	tl_lock_owner_ptr = GET_FREE ();
	if tl_lock_owner_ptr = null ()
	then call ERROR_RETURN (dm_error_$lock_table_overflow);

	tl_lock_owner.type = TYPE_OWNER;
	tl_lock_owner.lock_ptr = VPTR (tl_p_lock_object_ptr);
	tl_lock_owner.mode = tl_mode_req;
	tl_lock_owner.transaction_ptr.seg_inx = 1;
	tl_lock_owner.transaction_ptr.offset = wordno (lock_transaction_table_ptr);
	tl_lock_owner.transaction_fp = lock_transaction_table.own_ptr;
	lock_transaction_table.own_ptr = VPTR (tl_lock_owner_ptr);
	tl_lock_owner.owners_fp = tl_lock_object.owners_ptr;
	tl_lock_object.owners_ptr = VPTR (tl_lock_owner_ptr);

	tl_p_mode_obtained = tl_mode_req;

	return;

     end TRY_TO_LOCK;

/*  Internal Procedure to wait for a lock. Returns after the lock is
    notified to this transaction or after a timeout, whichever comes first.
*/
WAIT:
     proc (w_p_give_up_time, w_p_lock_object_ptr, w_p_mode_req);

dcl	w_p_lock_object_ptr		ptr;
dcl	w_p_mode_req		fixed bin;
dcl	w_p_give_up_time		fixed bin (71);

dcl	w_lock_waiter_ptr		ptr;
dcl	w_prev_lock_waiter_ptr	ptr;
dcl	1 w_waiters_ptr		aligned like lock_virtual_ptr;

dcl	1 w_lock_object		aligned like lock_object based (w_p_lock_object_ptr);
dcl	1 w_lock_waiter		aligned like lock_waiter based (w_lock_waiter_ptr);
dcl	1 w_prev_lock_waiter	aligned like lock_waiter based (w_prev_lock_waiter_ptr);


/*  Thread in a wait block for this transaction */

	lock_seg.meters.waits = lock_seg.meters.waits + 1;
	w_lock_waiter_ptr = GET_FREE ();
	if w_lock_waiter_ptr = null ()
	then call ERROR_RETURN (dm_error_$lock_table_overflow);

	w_lock_waiter.type = TYPE_WAITER;
	w_lock_waiter.lock_ptr = VPTR (w_p_lock_object_ptr);
	w_lock_waiter.mode = w_p_mode_req;
	w_lock_waiter.transaction_ptr.seg_inx = 1;
	w_lock_waiter.transaction_ptr.offset = wordno (lock_transaction_table_ptr);
	w_lock_waiter.waiters_fp = NULL_VPTR;
	lock_transaction_table.wait_ptr = VPTR (w_lock_waiter_ptr);


/* Thread block to object, FIFO */

	if w_lock_object.waiters_ptr.seg_inx = -1
	then w_lock_object.waiters_ptr = VPTR (w_lock_waiter_ptr);
	else do;
		w_waiters_ptr = w_lock_object.waiters_ptr;
		do while (w_waiters_ptr.seg_inx ^= -1);
		     w_prev_lock_waiter_ptr = PTR (w_waiters_ptr);
		     w_waiters_ptr = w_prev_lock_waiter.waiters_fp;
		end;
		w_prev_lock_waiter.waiters_fp = VPTR (w_lock_waiter_ptr);
	     end;

/*  Unlock and wait for something to happen  */

	call UNLOCK;

	call REALLY_WAIT (w_p_give_up_time);

/*  Relock and unthread the wait block, if it's still here (it will be if
    we timed out)  */

	call LOCK ();

	call UNWAIT_ME;
	return;

/*  Internal Procedure to do wait. Separated from WAIT to isolate it from
    other internal procedures, since this must be non-quick (due to cleanup
    condition handler).
*/

REALLY_WAIT:
     proc (rw_p_give_up_time);

dcl	rw_p_give_up_time		fixed bin (71) parameter;

dcl	rw_intermediate_give_up_time	fixed bin (71) init (0);
dcl	1 rw_event_info		aligned,
	  2 channel_id		fixed bin (71),
	  2 message		fixed bin (71),
	  2 sender		bit (36) aligned,
	  2 origin,
	    3 dev_signal		bit (18) unaligned,
	    3 ring		bit (18) unaligned,
	  2 channel_index		fixed bin;
dcl	rw_saved_channel		fixed bin (71);
dcl	rw_saved_ips_mask		bit (36) aligned;
dcl	rw_saved_timer		fixed bin (71);
dcl	1 rw_wait_list		aligned,
	  2 n_chan		fixed bin,
	  2 pad			fixed bin,
	  2 channel_id		(1) fixed bin (71);

	rw_saved_ips_mask = ""b;
	rw_saved_channel = -1;

	on cleanup
	     begin;
		if substr (rw_saved_ips_mask, 36, 1) = "1"b
		then call hcs_$reset_ips_mask (rw_saved_ips_mask, rw_saved_ips_mask);
		if rw_saved_channel ^= -1
		then call hcs_$set_alarm_timer (rw_saved_timer, TIME_IS_ABSOLUTE, rw_saved_channel);
	     end;

	rw_wait_list.n_chan = 1;
	if lock_transaction_table.ev_channel = 0
	then do;
		if lm_data_$ev_channel = 0
		then call ipc_$create_ev_chn (lm_data_$ev_channel, (0));
		lock_transaction_table.ev_channel = lm_data_$ev_channel;
	     end;
	rw_wait_list.channel_id (1) = lock_transaction_table.ev_channel;

	rw_intermediate_give_up_time = clock () + INTERMEDIATE_WAIT_INTERVAL;

	call hcs_$set_ips_mask (dm_system_data_$lock_ips_mask, rw_saved_ips_mask);
	call hcs_$get_alarm_timer (rw_saved_timer, rw_saved_channel);
	call hcs_$set_alarm_timer (min (rw_p_give_up_time, rw_intermediate_give_up_time), TIME_IS_ABSOLUTE,
	     lock_transaction_table.ev_channel);

	call ipc_$block (addr (rw_wait_list), addr (rw_event_info), (0));

	call hcs_$set_alarm_timer (rw_saved_timer, TIME_IS_ABSOLUTE, rw_saved_channel);
	call hcs_$reset_ips_mask (rw_saved_ips_mask, rw_saved_ips_mask);

	if rw_event_info.message = LOCK_MESSAGE_DEADLOCK
	then do;
		call LOCK ();
		call UNWAIT_ME ();
		call UNLOCK ();
		call lm_signal_$deadlock (lock_transaction_table.txn_id, f_uid, (ci_number), mode_req);
	     end;

     end REALLY_WAIT;

     end WAIT;

/*  Internal Procedure to see whether this transaction would cause a deadlock
    if it waited. This procedure builds the data structure for the external
    routine which checks for the deadlock.
*/

CHECK_DEADLOCK:
     proc (cd_p_lock_object_ptr);

dcl	cd_p_lock_object_ptr	ptr;

dcl	cd_code			fixed bin (35);
dcl	cd_lock_txn_table_ptr	ptr;
dcl	cd_txn_idx		fixed bin;

dcl	1 cd_lock_object		aligned like lock_object based (cd_p_lock_object_ptr);
dcl	1 cd_lock_txn_table		aligned like lock_transaction_table based (cd_lock_txn_table_ptr);
dcl	1 cd_lock_deadlock_36	aligned like lock_deadlock_36;
dcl	1 cd_lock_deadlock_72	aligned like lock_deadlock_72;
dcl	(cd_call_36, cd_call_72)	bit (1) aligned;
dcl	cd_small_txn_ids		(72) bit (36) aligned;
dcl	cd_auto_txn_ids		bit (1) aligned;
dcl	cd_txn_to_notify		bit (36) aligned;

	p_code = 0;
	n_lock_deadlock = 1;
	do cd_txn_idx = 1 to dm_system_data_$max_n_transactions;
	     cd_lock_txn_table_ptr = addr (lock_seg.transaction_table (cd_txn_idx));
	     if VALID_TXN (cd_lock_txn_table.txn_id)
	     then do;
		     if cd_lock_txn_table_ptr = lock_transaction_table_ptr
						/* This transaction */
		     then cd_lock_txn_table.deadlock_inx = 1;
		     else if cd_lock_txn_table.wait_ptr.seg_inx = -1
						/* Not waiting */
		     then cd_lock_txn_table.deadlock_inx = 0;
		     else do;
			     n_lock_deadlock = n_lock_deadlock + 1;
			     cd_lock_txn_table.deadlock_inx = n_lock_deadlock;
			end;
		end;
	     else cd_lock_txn_table.deadlock_inx = 0;
	end;
	lock_seg.meters.deadlock_checks = lock_seg.meters.deadlock_checks + 1;
	if n_lock_deadlock <= 1
	then return;
	lock_seg.meters.real_deadlock_checks = lock_seg.meters.real_deadlock_checks + 1;

	cd_call_36, cd_call_72 = "0"b;
	if n_lock_deadlock <= 36
	then do;
		lock_seg.meters.deadlock_checks_36 = lock_seg.meters.deadlock_checks_36 + 1;
		lock_deadlock_ptr = addr (cd_lock_deadlock_36);
		n_lock_deadlock = 36;
		cd_call_36 = "1"b;
	     end;
	else if n_lock_deadlock <= 72
	then do;
		lock_seg.meters.deadlock_checks_72 = lock_seg.meters.deadlock_checks_72 + 1;
		lock_deadlock_ptr = addr (cd_lock_deadlock_72);
		n_lock_deadlock = 72;
		cd_call_72 = "1"b;
	     end;
	else allocate lock_deadlock in (dm_area) set (lock_deadlock_ptr);
	unspec (lock_deadlock) = ""b;
	if n_lock_deadlock <= 72
	then do;
		cd_auto_txn_ids = "1"b;
		lock_deadlock_txn_ids_ptr = addr (cd_small_txn_ids);
	     end;
	else do;
		cd_auto_txn_ids = "0"b;
		allocate lock_deadlock_txn_ids in (dm_area) set (lock_deadlock_txn_ids_ptr);
	     end;					/* We could use automatic arrays for this as well ... */

	lock_deadlock_txn_ids = ""b;
	lock_deadlock_txn_ids (1) = dm_data_$current_txn_id;
	call SET_WAIT_OWN (1, cd_p_lock_object_ptr);
	do cd_txn_idx = 1 to dm_system_data_$max_n_transactions;
	     cd_lock_txn_table_ptr = addr (lock_seg.transaction_table (cd_txn_idx));
	     if cd_lock_txn_table.deadlock_inx > 1
	     then do;
		     lock_deadlock_txn_ids (cd_lock_txn_table.deadlock_inx) = cd_lock_txn_table.txn_id;
		     call SET_WAIT_OWN (cd_lock_txn_table.deadlock_inx,
			PTR (PTR (cd_lock_txn_table.wait_ptr) -> lock_waiter.lock_ptr));
		end;
	end;

	call UNLOCK;
	call lm_check_for_deadlock_ (lock_deadlock_ptr, lock_deadlock_txn_ids_ptr, n_lock_deadlock, cd_txn_to_notify,
	     cd_code);				/* This will special case 36 and 72 */
	if ^(cd_call_36 | cd_call_72)
	then free lock_deadlock;
	if ^cd_auto_txn_ids
	then free lock_deadlock_txn_ids;
	call LOCK ();
	if cd_code = 0 & cd_txn_to_notify = ""b
	then return;				/* No deadlock was found. */
	else if cd_code ^= 0			/* we are it */
	then do;
		lock_seg.meters.deadlock_self_youngest = lock_seg.meters.deadlock_self_youngest + 1;
		call UNLOCK ();
		call lm_signal_$deadlock (lock_transaction_table.txn_id, f_uid, (ci_number), mode_req);
	     end;
	else /* if cd_txn_to_notify ^= ""b then */
	     do;
		lock_seg.meters.deadlock_other_youngest = lock_seg.meters.deadlock_other_youngest + 1;
		call NOTIFY_TXN (cd_txn_to_notify);
	     end;

	return;


/* Internal Procedure to send a DEADLOCK wakeup to a transaction */

NOTIFY_TXN:
     procedure (nt_p_txn_id);

declare	nt_p_txn_id		bit (36) aligned;
declare	nt_txn_idx		fixed bin;
declare	1 nt_lock_txn_table		aligned like lock_transaction_table based (nt_lock_txn_table_ptr);
declare	nt_lock_txn_table_ptr	ptr;
declare	nt_code			fixed bin (35);
declare	transaction_manager_$get_txn_index
				entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);

	nt_txn_idx = transaction_manager_$get_txn_index (nt_p_txn_id, nt_code);
	if nt_code ^= 0
	then return;				/* Something is different, perhaps the transaction has dies and will unlock */
	nt_lock_txn_table_ptr = addr (lock_seg.transaction_table (nt_txn_idx));

	call SEND_WAKEUP ("a deadlock notification", nt_lock_txn_table.process_id, nt_lock_txn_table.ev_channel,
	     LOCK_MESSAGE_DEADLOCK);

	return;
     end NOTIFY_TXN;





/*  Internal Procedure to set all bits in the lock_deadlock array corresponding
    to the supplied index and the indices of all waiters for the supplied
    lock.
*/

SET_WAIT_OWN:
     proc (sw_p_deadlock_inx, sw_p_lock_object_ptr);

dcl	sw_p_deadlock_inx		fixed bin;
dcl	sw_p_lock_object_ptr	ptr;

dcl	sw_lock_owner_ptr		ptr;
dcl	1 sw_owners_ptr		aligned like lock_virtual_ptr;
dcl	sw_owner_deadlock_inx	fixed bin;

dcl	1 sw_lock_object		aligned like lock_object based (sw_p_lock_object_ptr);
dcl	1 sw_lock_owner		aligned like lock_owner based (sw_lock_owner_ptr);

	sw_owners_ptr = sw_lock_object.owners_ptr;
	do while (sw_owners_ptr.seg_inx ^= -1);
	     sw_lock_owner_ptr = PTR (sw_owners_ptr);
	     sw_owner_deadlock_inx = PTR (sw_lock_owner.transaction_ptr) -> lock_transaction_table.deadlock_inx;
	     if sw_owner_deadlock_inx > 0
	     then lock_deadlock.wait_own (sw_p_deadlock_inx, sw_owner_deadlock_inx) = "1"b;
	     sw_owners_ptr = sw_lock_owner.owners_fp;
	end;

     end SET_WAIT_OWN;


     end CHECK_DEADLOCK;

/* Internal Procedure to unthread the transaction whose table is defined by 
   lock_transaction_table_ptr as a waiter for any lock. */

UNWAIT_ME:
     proc;

dcl	um_lock_object_ptr		ptr;
dcl	um_lock_waiter_ptr		ptr;
dcl	um_prev_lock_waiter_ptr	ptr;
dcl	1 um_waiters_ptr		aligned like lock_virtual_ptr;

dcl	1 um_lock_object		aligned like lock_object based (um_lock_object_ptr);
dcl	1 um_lock_waiter		aligned like lock_waiter based (um_lock_waiter_ptr);
dcl	1 um_prev_lock_waiter	aligned like lock_waiter based (um_prev_lock_waiter_ptr);




	if lock_transaction_table.wait_ptr.seg_inx ^= -1
	then do;
		um_lock_waiter_ptr = PTR (lock_transaction_table.wait_ptr);
		um_lock_object_ptr = PTR (um_lock_waiter.lock_ptr);
		if unspec (um_lock_object.waiters_ptr) = unspec (lock_transaction_table.wait_ptr)
		then um_lock_object.waiters_ptr = um_lock_waiter.waiters_fp;
		else do;
			um_waiters_ptr = um_lock_object.waiters_ptr;
			do while (um_waiters_ptr.seg_inx ^= -1);
			     um_prev_lock_waiter_ptr = PTR (um_waiters_ptr);
			     if unspec (um_prev_lock_waiter.waiters_fp) = unspec (lock_transaction_table.wait_ptr)
			     then do;
				     um_prev_lock_waiter.waiters_fp = um_lock_waiter.waiters_fp;
				     um_waiters_ptr = NULL_VPTR;
				end;
			     else um_waiters_ptr = um_prev_lock_waiter.waiters_fp;
			end;
		     end;
		call RETURN_FREE (um_lock_waiter_ptr);
		lock_transaction_table.wait_ptr = NULL_VPTR;
	     end;

     end UNWAIT_ME;

/* Internal Procedure to unlock an object and notify anybody waiting for it,
   unthreading their wait blocks in the transaction */

UNLOCK_OBJECT:
     proc (uo_p_lock_object_ptr, uo_p_code);

dcl	uo_p_lock_object_ptr	ptr;
dcl	uo_p_code			fixed bin (35);

dcl	uo_found			bit (1) aligned;
dcl	uo_lock_owner_ptr		ptr;
dcl	uo_lock_waiter_ptr		ptr;
dcl	1 uo_owner_ptr		aligned like lock_virtual_ptr;
dcl	uo_prev_lock_owner_ptr	ptr;
dcl	1 uo_temp_ptr		aligned like lock_virtual_ptr;
						/* Silly compiler */
dcl	uo_waiter_transaction_table_ptr
				ptr;
dcl	1 uo_waiter_ptr		aligned like lock_virtual_ptr;

dcl	1 uo_lock_object		aligned like lock_object based (uo_p_lock_object_ptr);
dcl	1 uo_lock_owner		aligned like lock_owner based (uo_lock_owner_ptr);
dcl	1 uo_lock_waiter		aligned like lock_waiter based (uo_lock_waiter_ptr);
dcl	1 uo_prev_lock_owner	aligned like lock_owner based (uo_prev_lock_owner_ptr);
dcl	1 uo_waiter_transaction_table aligned like lock_transaction_table based (uo_waiter_transaction_table_ptr);


/*  Unthread this transaction from list of owners  */

	uo_p_code = 0;
	uo_found = "0"b;
	uo_prev_lock_owner_ptr = null ();
	uo_owner_ptr = uo_lock_object.owners_ptr;
	do while (^uo_found & (uo_owner_ptr.seg_inx ^= -1));
	     uo_lock_owner_ptr = PTR (uo_owner_ptr);
	     if uo_lock_owner.transaction_ptr.offset = wordno (lock_transaction_table_ptr)
	     then uo_found = "1"b;
	     else uo_prev_lock_owner_ptr = uo_lock_owner_ptr;
	     uo_owner_ptr = uo_lock_owner.owners_fp;
	end;
	if ^uo_found
	then do;
		uo_p_code = dm_error_$lock_not_found;
		return;
	     end;

	if uo_prev_lock_owner_ptr = null ()
	then uo_lock_object.owners_ptr = uo_lock_owner.owners_fp;
	else uo_prev_lock_owner.owners_fp = uo_lock_owner.owners_fp;


/*  Unthread owner from this transaction list of locks  */

	uo_temp_ptr = VPTR (uo_lock_owner_ptr);
	if unspec (lock_transaction_table.own_ptr) = unspec (uo_temp_ptr)
	then lock_transaction_table.own_ptr = uo_lock_owner.transaction_fp;
	else do;
		uo_found = "0"b;
		uo_owner_ptr = lock_transaction_table.own_ptr;
		do while (^uo_found & (uo_owner_ptr.seg_inx ^= -1));
		     uo_prev_lock_owner_ptr = PTR (uo_owner_ptr);
		     if unspec (uo_prev_lock_owner.transaction_fp) = unspec (uo_temp_ptr)
		     then uo_found = "1"b;
		     else uo_owner_ptr = uo_prev_lock_owner.transaction_fp;
		end;
		if ^uo_found
		then do;
			uo_p_code = dm_error_$lock_not_found;
			return;
		     end;
		uo_prev_lock_owner.transaction_fp = uo_lock_owner.transaction_fp;
	     end;

	call RETURN_FREE (uo_lock_owner_ptr);

/*  Free the lock object if there are no owners or waiters (if there are waiters,
    one, at least, will soon become an owner; so it pays to leave the object around).
    If there are waiters, notify all of them and remove their wait blocks.
*/

	if uo_lock_object.owners_ptr.seg_inx = -1 & uo_lock_object.waiters_ptr.seg_inx = -1
	then do;
		call lm_hash_$hash_out (uo_p_lock_object_ptr);
		call RETURN_FREE (uo_p_lock_object_ptr);
	     end;
	else do;
		uo_waiter_ptr = uo_lock_object.waiters_ptr;
		do while (uo_waiter_ptr.seg_inx ^= -1);
		     uo_lock_waiter_ptr = PTR (uo_waiter_ptr);
		     uo_waiter_transaction_table_ptr = PTR (uo_lock_waiter.transaction_ptr);
		     uo_waiter_transaction_table.wait_ptr = NULL_VPTR;
		     call SEND_WAKEUP ("an unlock notification", uo_waiter_transaction_table.process_id,
			uo_waiter_transaction_table.ev_channel, 0);
		     uo_waiter_ptr = uo_lock_waiter.waiters_fp;
		     call RETURN_FREE (uo_lock_waiter_ptr);
		end;

		uo_lock_object.waiters_ptr = NULL_VPTR;
	     end;

     end UNLOCK_OBJECT;

SEND_WAKEUP:
     proc (sw_p_wakeup_description, sw_p_process_id, sw_p_ev_channel, sw_p_message);
dcl	sw_p_wakeup_description	char (*) parm;
dcl	sw_p_process_id		bit (36) aligned parm;
dcl	sw_p_ev_channel		fixed bin (71) parm;
dcl	sw_p_message		fixed bin (71) parm;

dcl	sw_code			fixed bin (35) init (0);
dcl	sw_try_wakeup		bit (1) aligned init (YES);
dcl	sw_wakeup_attempt_count	fixed bin init (0);

	do sw_wakeup_attempt_count = 1 to MAXIMUM_NUMBER_OF_WAKEUP_ATTEMPTS while (sw_try_wakeup = YES);
	     call hcs_$wakeup (sw_p_process_id, sw_p_ev_channel, sw_p_message, sw_code);
	     if sw_code = 0 | (sw_code = error_table_$process_unknown & sw_p_process_id ^= "0"b)
						/* Probably a process_id for a now-dead process. */
	     then sw_try_wakeup = NO;
	     else if sw_code = error_table_$itt_overflow
	     then call timer_manager_$sleep (ITT_OVERFLOW_WAIT_TIME, RELATIVE_SECONDS);
	     else do;
		     call dm_misc_util_$log (ERROR_SV, sw_code, ME, "^/Unable to send ^a for process ^w on event channel ^o.",
			sw_p_wakeup_description, sw_p_process_id, sw_p_ev_channel);
		     sw_try_wakeup = NO;
		end;
	end;
	if sw_wakeup_attempt_count > MAXIMUM_NUMBER_OF_WAKEUP_ATTEMPTS
	then call dm_misc_util_$log (ERROR_SV, error_table_$itt_overflow, ME,
		"^/Unable to send a ^a for process ^w on event channel ^w, after ^d attempts.",
		sw_p_wakeup_description, sw_p_process_id, sw_p_ev_channel, MAXIMUM_NUMBER_OF_WAKEUP_ATTEMPTS);
     end SEND_WAKEUP;



/*  Internal Procedures to translate between pointers and lock virtual pointers.

    PTR - turns a virtual pointer into a pointer

    VPTR - turns a pointer to a lock block (only) into a virtual pointer
*/

PTR:
     proc (ptr_lock_virtual_ptr) returns (ptr);

dcl	1 ptr_lock_virtual_ptr	aligned like lock_virtual_ptr;

	return (ptr (lock_segments.seg_baseptr (ptr_lock_virtual_ptr.seg_inx), ptr_lock_virtual_ptr.offset));

     end PTR;





VPTR:
     proc (vptr_lock_block_ptr) returns (1 aligned like lock_virtual_ptr);

dcl	vptr_lock_block_ptr		ptr;

dcl	1 vptr_lock_virtual_ptr	aligned like lock_virtual_ptr;

dcl	1 vptr_lock_block		aligned like lock_block based (vptr_lock_block_ptr);

	vptr_lock_virtual_ptr.seg_inx = vptr_lock_block.seg_inx;
	vptr_lock_virtual_ptr.offset = wordno (vptr_lock_block_ptr);

	return (vptr_lock_virtual_ptr);

     end VPTR;

VALID_TXN:
     procedure (vt_txid) returns (bit (1) aligned);

/* This internal procedure determines if there is an active transaction
associated with the identifier TXID.  If the TXID is "0"b, then there is no
transaction associated with the transaction_table_entry which the TXID was
taken from and a ID_IS_INVALID is returned.  Otherwise, the
transaction_manager_ is asked about TXID.
*/

declare	vt_txid			bit (36) aligned;
declare	vt_code			fixed bin (35);
declare	vt_txix			fixed bin;

	if vt_txid = "0"b
	then return (ID_IS_INVALID);
	else do;
		vt_txix = transaction_manager_$get_txn_index (vt_txid, vt_code);
		return (vt_code = 0);
	     end;
     end VALID_TXN;


CLEAN_LOCK:
     procedure;

	call lock_manager_$unlock_fast (addr (lock_seg.lock), (0));
     end CLEAN_LOCK;				/* format: off */

CHECK_VERSION:
   proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl	cv_p_expected_version
			char (8) aligned parameter;
dcl	cv_p_received_version
			char (8) aligned parameter;
dcl	cv_p_structure_name char (32) aligned parameter;

      if cv_p_expected_version ^= cv_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, ME, 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_lock_modes;
%page;  %include dm_log_sv_codes;
%page;  %include dm_lm_system_data;
%page;  %include dm_lm_meters;
%page;  %include sub_err_flags;

     end lm_per_system_$lock;




		    lm_reset_system_meters_.pl1     04/04/85  1119.5re  04/04/85  0827.0       24624



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* Program to reset lock meters for the system. This is a */
/* PRIVILEGED function. */
/* format: style2 */
lm_reset_system_meters_:
     procedure;

/* HISTORY:

Written by Benson I. Margulies, 05/10/83.
Modified:
05/01/84 by R. Michael Tague:  Added the History section.  Added
	  %include dm_lm_meters.  Changed meters assignment to reference
	  the lm_meters structure, avoid zeroing the version information.
10/18/84 by Stanford S. Cox:  For DM program standards.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/

	declare (
	        lock_manager_$lock_lock_data,
	        lock_manager_$unlock_lock_data
	        )			 entry (fixed bin (35));
	declare get_group_id_	 entry () returns (char (32));
	declare dm_misc_util_$log	 entry () options (variable);
	declare sub_err_		 entry () options (variable);

	declare lm_data_$lock_seg_ptr	 pointer external;
	declare dm_system_data_$max_n_transactions
				 fixed bin ext;
	dcl     error_table_$unimplemented_version
				 fixed bin (35) ext static;

	declare code		 fixed bin (35);

	declare cleanup		 condition;

	dcl     ME		 char (23) int static options (constant) init ("lm_reset_system_meters_");


	lock_seg_ptr = lm_data_$lock_seg_ptr;
	call CHECK_VERSION (LOCK_SEG_VERSION_1, lock_seg.version, "lock_seg");
	call dm_misc_util_$log (INFORM_SV, "Lock meters reset by ^a.", get_group_id_ ());
	call lock_manager_$lock_lock_data (code);
	if code = 0
	then on cleanup call lock_manager_$unlock_lock_data ((0));
	else call sub_err_ (code, ME, ACTION_CANT_RESTART, null (), (0), "Error locking lock data.");

	lock_seg.lm_meters = 0;			/* Aggregate ! */
	call lock_manager_$unlock_lock_data ((0));
	return;

CHECK_VERSION:
     proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

	dcl     cv_p_expected_version	 char (8) aligned parameter;
	dcl     cv_p_received_version	 char (8) aligned parameter;
	dcl     cv_p_structure_name	 char (32) aligned parameter;

	if cv_p_expected_version ^= cv_p_received_version
	then call sub_err_ (error_table_$unimplemented_version, ME, 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;

%include dm_lm_system_data;
%include dm_lm_meters;
%include sub_err_flags;
%include dm_log_sv_codes;

     end lm_reset_system_meters_;




		    lm_salvage_lock_seg_.pl1        04/04/85  1119.5re  04/04/85  0827.0        5940



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
lm_salvage_lock_seg_:
	procedure (Code);

declare Code fixed bin (35);
declare dm_misc_util_$log entry options (variable);

	Code = 0;
	call dm_misc_util_$log (INFORM_SV, "lm_salvage_lock_seg_: Lock seg salvage requested.");
%include dm_log_sv_codes;

/* This is just a stub until check_lock_seg can be written */

	end lm_salvage_lock_seg_;




		    lm_signal_.pl1                  04/04/85  1119.5re  04/04/85  0827.2       43353



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

/* DESCRIPTION:
   Signals the condition: "transaction_deadlock_" when a deadlock exists
   involving the current transaction, "transaction_lock_timeout_" when a 
   timeout occurs waiting for a control interval lock.  It is the 
   responsibility of the DM caller to handle these conditions as necessary.
*/

/* HISTORY:
Written by Benson I. Margulies 06/01/83.
Modified:
10/03/84 by Stanford S. Cox: Chg to set support_signal on, rn TDI to local_txn*
12/06/84 by Stanford S. Cox: Added dm_lm prefix to txn_deadlock_info.incl.pl1.
02/05/85 by Stanford S. Cox: Chg to: handle transaction_lock_timeout_, rollback
   current txn.  Renamed from lm_signal_deadlock_.
02/12/85 by Stanford S. Cox: Chg to set cant_restart, improve ioa_$rsnnl call
   which builds info_string, and moved rollback_txn call before signal_ call.
03/02/85 by Lindsey L. Spratt:  Fixed to not reference p_give_up_time when
            using the $deadlock entry (p_give_up_time is only a parameter to
            the $timeout entry).
*/

/* format: style2 */
lm_signal_$deadlock:
     proc (p_txn, p_file_uid, p_ci_number, p_requested_mode);

/* Parameter */

	declare p_txn		 bit (36) aligned parameter;
	declare p_file_uid		 bit (36) aligned parameter;
	declare p_ci_number		 fixed bin (35) parameter;
	declare p_requested_mode	 fixed bin parameter;
	declare p_give_up_time	 fixed bin (71);

/* Automatic */

	declare code		 fixed bin (35);
	declare give_up_time	 fixed bin (71) init (-1);
	declare signal_type		 fixed bin (17);

	declare 1 local_txn_timeout_info
				 aligned like txn_timeout_info;
	declare 1 local_txn_dlk_info	 aligned like txn_deadlock_info;

/* Static */

	declare (
	        DEADLOCK_SIGNAL_TYPE	 fixed bin (17) init (1),
	        TIMEOUT_SIGNAL_TYPE	 fixed bin (17) init (2),
	        ME		 char (10) init ("lm_signal_"),
	        NO		 bit (1) init ("0"b),
	        YES		 bit (1) init ("1"b)
	        )			 internal static options (constant);

/* Builtin */

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

/* External */

	declare (
	        dm_error_$lock_deadlock,
	        dm_error_$lock_timeout,
	        dm_error_$programming_error
	        )			 fixed bin (35) external static;

/* Entry */

	declare ioa_$rsnnl		 entry options (variable);
	declare signal_		 entry options (variable);
	declare sub_err_		 entry () options (variable);
	declare transaction_manager_$rollback_txn
				 entry (bit (36) aligned, fixed bin, fixed bin (35));

/**** lm_signal_$deadlock */

	signal_type = DEADLOCK_SIGNAL_TYPE;
	goto JOIN;

lm_signal_$timeout:
     entry (p_txn, p_file_uid, p_ci_number, p_requested_mode, p_give_up_time);

	give_up_time = p_give_up_time;
	signal_type = TIMEOUT_SIGNAL_TYPE;
	goto JOIN;

JOIN:	/*** Fill in common info to both condition structures, move by name if timeout */
	unspec (local_txn_dlk_info) = ""b;
	local_txn_dlk_info.info_string = "";
	local_txn_dlk_info.action_flags.cant_restart = YES;
	local_txn_dlk_info.action_flags.support_signal = YES;
	local_txn_dlk_info.file_uid = p_file_uid;
	local_txn_dlk_info.control_interval = p_ci_number;
	local_txn_dlk_info.transaction_id = p_txn;
	call ioa_$rsnnl (
	     "Transaction ID: ^d ^[Timeout ^d^;^s^] File UID: ^w^[, Control Interval ^d^;^s^]. Requested ^a mode lock.",
	     local_txn_dlk_info.info_string, (0), bin (p_txn), (signal_type = TIMEOUT_SIGNAL_TYPE), give_up_time,
	     p_file_uid, p_ci_number ^= -1, p_ci_number, LOCK_MODE_NAMES (p_requested_mode));

	call transaction_manager_$rollback_txn (p_txn, (0), code);

	if signal_type = DEADLOCK_SIGNAL_TYPE
	then do;
		local_txn_dlk_info.version = TXN_DEADLOCK_INFO_VERSION_1;
		local_txn_dlk_info.status_code = dm_error_$lock_deadlock;
		call signal_ (TXN_DEADLOCK_CONDITION_NAME, null (), addr (local_txn_dlk_info));
	     end;
	else if signal_type = TIMEOUT_SIGNAL_TYPE
	then do;
		local_txn_timeout_info = local_txn_dlk_info, by name;
		local_txn_timeout_info.version = TXN_TIMEOUT_INFO_VERSION_1;
		local_txn_timeout_info.status_code = dm_error_$lock_timeout;
		local_txn_timeout_info.give_up_time = give_up_time;
		call signal_ (TXN_TIMEOUT_CONDITION_NAME, null (), addr (local_txn_timeout_info));
	     end;
	else call sub_err_ (dm_error_$programming_error, ME, ACTION_CANT_RESTART, null (), 0, "^/^a",
		local_txn_dlk_info.info_string);

	return;
%page;
%include condition_info_header;
%page;
%include dm_lm_txn_timeout_info;
%page;
%include dm_lm_txn_deadlock_info;
%page;
%include dm_lock_modes;
%page;
%include sub_err_flags;

     end lm_signal_$deadlock;




		    lm_user_shutdown.pl1            03/06/85  0802.6re  03/05/85  0759.7        9288



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

/* DESCRIPTION:

         This entry is currently a no-op and is simply being a place-holder
     until and if something real is necessary to be done.  The main reason
     this is a no-op is all transactions the user has should be gone at the
     time this routine is invoked, and the process of cleaning out
     transactions should clear any locks the user holds.  At this time, we do
     not verify that all locks are gone, but could at a future time and
     indicate a logic error.
*/

/* HISTORY:

Written by L. A. Newcomb, 05/01/84.
Modified:
*/

/* format: style2,^inddcls,linecom,ifthendo,ifthen,^indnoniterdo,dclind5,idind35 */

lm_user_shutdown:
     proc ();


	return;

     end lm_user_shutdown;




		    tm_abandon.pl1                  05/06/86  1321.1rew 05/06/86  1257.6       86715



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




/****^  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 to execute file_mangaer_$post_transaction before unlocking locks.
                                                   END HISTORY COMMENTS */


/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_abandon: proc (A_txn_id, A_code);

/* DESCRIPTION:

   The entry point $tm_abandon abandons the user's current transaction by
   turning on its abandoned_sw and giving the user process a new TDT slot
   to work with.

   The entry point $tm_kill kills a user's own transaction by deleting it
   without a rollback. This is done immediately if the transaction belongs to
   the user's current process and has not already been abandoned, otherwise
   a message is sent to the daemon to perform the kill.

/* HISTORY:
Written by Steve Herbst 10/12/82
Modified:
12/10/82 by Steve Herbst: Made to call lock_manager_$(adopt abandon).
01/13/83 by Steve Herbst: Added $tm_kill and made $tm_abandon work on the
	user's own transaction.
02/22/83 by Steve Herbst: Changed to not call lock_manager_$abandon.
03/14/83 by Steve Herbst: Fixed argument validation.
04/29/83 by Steve Herbst: Changed to call file_manager_$adopt before
	calling before_journal_manager_$adopt.
05/03/83 by Steve Herbst: Changed $tm_kill to kill immediately if same
	process and txn not abandoned.
05/04/83 by Steve Herbst: Split tm_adopt into tm_abandon (this module) and
	tm_daemon_adopt for daemon to call.
05/11/83 by Steve Herbst: Changed kill to allow killing another user's
	transaction.
05/13/83 by Steve Herbst: Changed to call fm_$abandon.
08/23/84 by Steve Herbst: Responded to audit comments.
02/07/85 by S. Cox: Added fm$post_transaction call (moved from lm_per_system_)
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
04/23/85 by Matthew C. Pierret:  Switched order of calls to
            file_manager_$post_transaction and lock_manager_$unlock_all.
            Having the file_manager_ call first allows it to operate under the
            locks acquired by the transaction.
*/

/* DECLARATIONS */

/* Parameters */

dcl  A_txn_id bit (36) aligned parameter;
dcl  A_code fixed bin (35) parameter;


/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl  txn_id bit (36) aligned;
dcl  txn_index fixed bin;

/* External */

dcl  dm_data_$current_txn_id bit (36) aligned external;
dcl  dm_data_$current_txn_index fixed bin external;
dcl  dm_data_$my_process_id bit (36) aligned external;
dcl  dm_data_$my_tdt_index fixed bin external;
dcl  dm_data_$suspended_txn_index fixed bin external;
dcl  dm_data_$tm_tdt_ptr ptr external;
dcl  dm_error_$invalid_current_txn fixed bin (35) ext;
dcl  dm_error_$no_current_transaction fixed bin (35) ext;
dcl  dm_error_$not_own_transaction fixed bin (35) external;
dcl  dm_error_$tdt_full fixed bin (35) ext;
dcl  dm_error_$transaction_not_current fixed bin (35) ext;
dcl  dm_error_$transaction_suspended fixed bin (35) ext;

/* Entries */

dcl  before_journal_manager_$write_aborted_mark entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  dm_misc_util_$log entry options (variable);
dcl  dm_send_request_$adjust_txn entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  file_manager_$abandon entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  file_manager_$post_transaction entry ();
dcl  get_process_id_ entry returns (bit (36) aligned);
dcl  lock_manager_$unlock_all entry;
dcl  tm_get_txn_index entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);

/* Builtins */

dcl  (addr, before, fixed, stac, unspec) builtin;

/* Conditions */

dcl  cleanup condition;

/* END OF DECLARATIONS */
%page;
/* When a process abandons its own transaction, the transaction goes into an abandoned state (abandoned_sw = "1"b).
   When it is in this state, only the Daemon can touch it. The owner process gets a new TDT entry and
   can begin transactions */

	A_code = 0;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if dm_data_$current_txn_index = 0 then
	     if dm_data_$suspended_txn_index ^= 0 then call ERROR_RETURN (dm_error_$transaction_suspended);
	     else call ERROR_RETURN (dm_error_$no_current_transaction);

	txn_index = dm_data_$current_txn_index;

	if txn_index < 1 | txn_index > tm_tdt.entry_count then
	     call ERROR_RETURN (dm_error_$invalid_current_txn);

	if A_txn_id = "0"b | A_txn_id = tm_tdt.txn_id (txn_index) then
	     txn_id = tm_tdt.txn_id (txn_index);
	else call ERROR_RETURN (dm_error_$transaction_not_current);

	if tm_tdt.process_id (txn_index) ^= dm_data_$my_process_id then
	     call ERROR_RETURN (dm_error_$not_own_transaction);

	tm_tdt.abandoned_sw (txn_index) = "1"b;

	call file_manager_$abandon (txn_id, txn_index, A_code);
	if A_code ^= 0 then call ERROR_RETURN (A_code);

	call GET_NEW_TDT_SLOT;

	call dm_send_request_$adjust_txn (txn_id, txn_index, 0);

	call dm_misc_util_$log (INFORM_SV, "User abandoned transaction ^d, TID = ^o, pid = ^w, owner = ^a, state = ^d",
	     txn_index, fixed (tm_tdt.txn_id (txn_index)), tm_tdt.process_id (txn_index),
	     PERSON_ID (txn_index), tm_tdt.state (txn_index));

RETURN:
	return;
%page;
tm_kill: entry (A_txn_id, A_code);

/* Killing a transaction causes it to disappear from the TDT even if it cannot be aborted or otherwise completed.
   The transaction to be killed must be the user's own, either in the current process or in a previous process.
   If the transaction belongs to the user's current process and has not already been abandoned, it is killed
   immediately. Otherwise, the transaction's kill_sw is turned on and a message is sent to the daemon to perform
   the actual kill. In the latter case, the user's process immediately gets a new TDT entry to play with. */

	A_code = 0;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if A_txn_id = "0"b then do;
	     txn_index = dm_data_$current_txn_index;
	     if txn_index = 0 then call ERROR_RETURN (dm_error_$no_current_transaction);
	     else if txn_index < 1 | txn_index > tm_tdt.entry_count then
		call ERROR_RETURN (dm_error_$invalid_current_txn);
	     txn_id = tm_tdt.txn_id (txn_index);
	end;

	else do;
	     txn_id = A_txn_id;
	     txn_index = tm_get_txn_index (txn_id, A_code);
	     if A_code ^= 0 then call ERROR_RETURN (A_code);
	end;

	if tm_tdt.abandoned_sw (txn_index) |		/* previously abandoned; daemon must kill */
	     tm_tdt.process_id (txn_index) ^= dm_data_$my_process_id then do; /* same for old process's txn */

	     tm_tdt.abandoned_sw (txn_index) = "1"b;	/* abandon for sure */

	     if get_process_id_ () = tm_tdt.process_id (txn_index) then call GET_NEW_TDT_SLOT;

	     tm_tdt.kill_sw (txn_index) = "1"b;		/* mark the old slot killed in any case */

	     call dm_send_request_$adjust_txn (txn_id, txn_index, 0);

	     call dm_misc_util_$log (INFORM_SV,
		"User requested kill, transaction ^d, TID = ^o, pid = ^w, owner = ^a, state = ^d",
		txn_index, fixed (tm_tdt.txn_id (txn_index)), tm_tdt.process_id (txn_index),
		PERSON_ID (txn_index), tm_tdt.state (txn_index));

	     return;
	end;

/* Kill the transaction immediately */

	if OK_TO_WRITE_MARK ((tm_tdt.state (txn_index))) then
	     call before_journal_manager_$write_aborted_mark (txn_id, txn_index, 0);

	call file_manager_$post_transaction;

	call lock_manager_$unlock_all;

	unspec (tm_tdt.transaction (txn_index)) = "0"b;

	call file_manager_$abandon (txn_id, txn_index, 0);

	dm_data_$current_txn_id = "0"b;
	dm_data_$current_txn_index = 0;

	call dm_misc_util_$log (INFORM_SV, "User killed transaction ^d, pid = ^w, owner = ^a",
	     txn_index, tm_tdt.process_id (txn_index), PERSON_ID (txn_index));

	return;
%page;
ERROR_RETURN: proc (P_code);

dcl  P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

     end ERROR_RETURN;
%page;
GET_NEW_TDT_SLOT: proc;

dcl  tdt_index fixed bin;

	do tdt_index = 1 to tm_tdt.entry_count;

	     if stac (addr (tm_tdt.process_id (tdt_index)), dm_data_$my_process_id) then do; /* a free one */

		tm_tdt.owner_name (tdt_index) = tm_tdt.owner_name (txn_index);
		tm_tdt.event_channel (tdt_index) = tm_tdt.event_channel (txn_index);

		on cleanup call SET_DM_DATA;

		call SET_DM_DATA;

		return;
	     end;
	end;

	call ERROR_RETURN (dm_error_$tdt_full);


SET_DM_DATA: proc;

	dm_data_$my_tdt_index = tdt_index;
	dm_data_$current_txn_index = 0;
	dm_data_$current_txn_id = "0"b;

     end SET_DM_DATA;

     end GET_NEW_TDT_SLOT;
%page;
OK_TO_WRITE_MARK: proc (P_state) returns (bit (1));

dcl  (P_state, state) fixed bin;

	state = P_state;

	if state > TM_ERROR_INCREMENT then state = state - TM_ERROR_INCREMENT;

	if state ^= TM_ABORT_UNLOCKING_STATE		/* don't write a second abort mark if possible */
	     & state ^= TM_ABORT_METERING_STATE

	     & state ^= TM_COMMIT_UNLOCKING_STATE	/* also don't abort if commit mark has been written */
	     & state ^= TM_COMMIT_METERING_STATE then return ("1"b);

	else return ("0"b);

     end OK_TO_WRITE_MARK;
%page;
PERSON_ID: proc (P_txn_index) returns (char (32));

dcl  P_txn_index fixed bin;
dcl  name char (32);

	name = tm_tdt.owner_name (P_txn_index);
	return (before (name, "."));

     end PERSON_ID;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_states;
%page;
%include dm_log_sv_codes;


     end tm_abandon;




		    tm_abort.pl1                    05/06/86  1321.1rew 05/06/86  1258.3       90873



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


/****^  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 to execute file_mangaer_$post_transaction before unlocking locks.
  2) change(86-04-22,Pierret), approve(86-04-22,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Removed file_manager_$post_commit as it is not used (and does not even
     exist!).
                                                   END HISTORY COMMENTS */


/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_abort: proc (A_txn_id, A_code);

/* DESCRIPTION:

   This procedure implements transaction_manager_$abort_txn
   It rolls back the transaction by undoing all changes to protected files
   made during the transaction, then writes an aborted mark and ends the
   transaction.
*/

/* HISTORY:
Written by Steve Herbst, 08/10/82.
Modified:
08/16/82 by Steve Herbst: Added call to bjm_$write_rolled_back_mark and
	changed to use dm_data_$tm_tdt_ptr.
08/23/82 by Steve Herbst: Removed call to bjm_$write_rolled_back_mark.
08/27/82 by Steve Herbst: Added calls to flush the transaction.
09/09/82 by Steve Herbst: Changed to eliminate locking.K 09/09/82 S. Herbst.
09/21/82 by Steve Herbst: Added tm_$priv_abort.
09/23/82 by Lindsey Spratt: Changed to use new lock_manager_ calling sequences.
10/05/82 by Steve Herbst: Removed tm_$priv_abort again; will be done by
	tm_$adjust_txn.
10/14/82 by Steve Herbst: Changed pfm_ calling sequence and added check for
	funny states.
11/01/82 by Steve Herbst: Changed to turn on tm_tdt.error_sw for error states.
11/05/82 by Steve Herbst: Changed to set tm_tdt.error_code on error return.
11/05/82 by Steve Herbst: Changed to handle suspended transaction.
01/11/83 by Steve Herbst: Changed to log error states.
01/17/83 by Steve Herbst: Changed to complete previous error abort, and to
	call tm_error_state.
01/24/83 by Steve Herbst: Changed to work on user's own abandoned transaction.
05/27/83 by Steve Herbst: Made to update checkpoint_id & rollback_count in
	TDT entry.
03/28/84 by Lee A. Newcomb:  changed tm_get_state_info call to be
	  transaction_manager_$get_state_info.
08/23/84 by Steve Herbst: Responded to auditing comments.
01/29/85 by Steve Herbst: Changed to ignore dm_error_$file_was_deleted.
02/07/85 by S. Cox: Added fm$post_transaction call (moved from lm_per_system_)
04/23/85 by Matthew C. Pierret:  Switched order of calls to
            file_manager_$post_transaction and lock_manager_$unlock_all so
            that post_transaction operates under the safety of the locks
            acquired by the transaction.
*/
%page;
/* DECLARATIONS */

/* Parameters */

dcl  A_txn_id bit (36) aligned parameter;
dcl  A_code fixed bin (35) parameter;

/* Constants */

dcl  ME char (32) int static options (constant) init ("tm_abort");

/* Based */

/* Static */

/* Automatic */

dcl  person char (22);
dcl  project char (9);
dcl  op_name char (32);
dcl  txn_id bit (36) aligned;
dcl  txn_index fixed bin;
dcl  (code, op_error_code) fixed bin (35);

/* External */

dcl  dm_data_$current_txn_id bit (36) aligned ext;
dcl  dm_data_$current_txn_index fixed bin ext;
dcl  dm_data_$my_process_id bit (36) ext;
dcl  dm_data_$suspended_txn_index fixed bin ext;
dcl  dm_data_$tm_tdt_ptr ptr ext;
dcl  dm_error_$file_was_deleted fixed bin (35) ext;
dcl  dm_error_$invalid_current_txn fixed bin (35) ext;
dcl  dm_error_$no_current_transaction fixed bin (35) ext;
dcl  dm_error_$not_own_transaction fixed bin (35) ext;
dcl  dm_error_$transaction_not_current fixed bin (35) ext;
dcl  dm_error_$transaction_suspended fixed bin (35) ext;
dcl  error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl  before_journal_manager_$flush_transaction entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  before_journal_manager_$rollback entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  before_journal_manager_$write_aborted_mark entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  dm_send_request_$adjust_txn entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  lock_manager_$unlock_all entry;
dcl  file_manager_$flush_modified_ci entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  file_manager_$post_transaction entry ();
dcl  tm_cleanup entry (ptr, fixed bin);
dcl  tm_cleanup$restart_error entry (ptr, fixed bin);
dcl  tm_error_state entry (fixed bin, fixed bin, fixed bin (35), char (*), char (*));
dcl  transaction_manager_$get_state_info entry (fixed bin, char (*), fixed bin (35));
dcl  user_info_ entry options (variable);

/* Builtins */

dcl  (rtrim, unspec) builtin;

/* Conditions */

dcl  cleanup condition;

/* END OF DECLARATIONS */
%page;
	A_code = 0;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version);

	if dm_data_$current_txn_index = 0 then
	     if dm_data_$suspended_txn_index ^= 0 then call ERROR_RETURN (dm_error_$transaction_suspended);
	     else call ERROR_RETURN (dm_error_$no_current_transaction);

	txn_index = dm_data_$current_txn_index;

	if txn_index < 1 | txn_index > tm_tdt.entry_count then
	     call ERROR_RETURN (dm_error_$invalid_current_txn);

	if tm_tdt.abandoned_sw (txn_index) then do;

	     call user_info_ (person, project);
	     if tm_tdt.owner_name (txn_index) = rtrim (person) || "." || project then do;
						/* if txn is abandoned, let daemon adjust it */
		call dm_send_request_$adjust_txn (tm_tdt.txn_id (txn_index), txn_index, 0);
		return;
	     end;
	end;

	if A_txn_id = "0"b | A_txn_id = tm_tdt.txn_id (txn_index) then
	     txn_id = tm_tdt.txn_id (txn_index);
	else call ERROR_RETURN (dm_error_$transaction_not_current);

	if tm_tdt.process_id (txn_index) ^= dm_data_$my_process_id then
	     call ERROR_RETURN (dm_error_$not_own_transaction);

	if tm_tdt.state (txn_index) ^= TM_IN_PROGRESS_STATE then do;

	     call transaction_manager_$get_state_info ((tm_tdt.state (txn_index)), op_name, op_error_code);
	     if op_name = OP_NAME_ROLLBACK then

		call CONVERT_ROLLBACK_TO_ABORT;

	     else if op_name ^= OP_NAME_ABORT then call ERROR_RETURN (op_error_code);

	     call tm_cleanup$restart_error (tm_tdt_ptr, txn_index); /* this call completes the abort */
	     if tm_tdt.error_sw (txn_index) then
		call ERROR_STATE ((tm_tdt.state (txn_index)), tm_tdt.error_code (txn_index), "tm_cleanup");
	     return;
	end;

	on cleanup begin;
	     call tm_cleanup (tm_tdt_ptr, txn_index);
	end;

	tm_tdt.state (txn_index) = TM_ABORT_FLUSHING_TXN_STATE;

	call before_journal_manager_$flush_transaction (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ABORT_FLUSHING_TXN_ERROR, code,
		"before_journal_manager_$flush_transaction");

	tm_tdt.state (txn_index) = TM_ABORT_ROLLING_BACK_STATE;

	call before_journal_manager_$rollback (txn_id, txn_index, 0, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ABORT_ROLLING_BACK_ERROR, code, "before_journal_manager_$rollback");

	tm_tdt.checkpoint_id (txn_index) = 0;
	tm_tdt.rollback_count (txn_index) = tm_tdt.rollback_count (txn_index) + 1;

	tm_tdt.state (txn_index) = TM_ABORT_FLUSHING_CI_STATE;

/* Make sure the file itself is really restored to how it was */

	call file_manager_$flush_modified_ci (txn_id, txn_index, code);
	if code ^= 0 & code ^= dm_error_$file_was_deleted then
						/* previous abort may have deleted the file */
	     call ERROR_STATE (TM_ABORT_FLUSHING_CI_ERROR, code, "file_manager_$flush_modified_ci");

	tm_tdt.state (txn_index) = TM_ABORT_WRITING_MARK_STATE;

	call before_journal_manager_$write_aborted_mark (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ABORT_WRITING_MARK_ERROR, code,
		"before_journal_manager_$write_aborted_mark");

	tm_tdt.state (txn_index) = TM_ABORT_UNLOCKING_STATE;

	call file_manager_$post_transaction ();

	call lock_manager_$unlock_all;

	tm_tdt.state (txn_index) = TM_ABORT_METERING_STATE;

/* Dump meters here */

	dm_data_$current_txn_id = "0"b;
	dm_data_$current_txn_index = 0;

	tm_tdt.state (txn_index) = 0;			/* show intent to zero whole entry */
	unspec (tm_tdt.transaction (txn_index)) = "0"b;	/* transaction is now gone */

	A_txn_id = "0"b;				/* zero caller's arg */
RETURN:
	return;
%page;
CONVERT_ROLLBACK_TO_ABORT: proc;

/* Maps rollback states to corresponding abort states, since both do the same calls.
   However, it maps any state after TM_ROLLBACK_WRITING_MARK_STATE to TM_ABORT_WRITING_MARK_STATE
   to make sure an abort mark is written. */

dcl  error_sw bit (1);
dcl  state fixed bin;

	state = tm_tdt.state (txn_index);
	if state > TM_ERROR_INCREMENT then do;
	     error_sw = "1"b;
	     state = state - TM_ERROR_INCREMENT;
	end;

	if state = TM_ROLLBACK_FLUSHING_TXN_STATE then state = TM_ABORT_FLUSHING_TXN_STATE;
	else if state = TM_ROLLBACK_ROLLING_BACK_STATE then state = TM_ABORT_ROLLING_BACK_STATE;
	else if state = TM_ROLLBACK_FLUSHING_CI_STATE then state = TM_ABORT_FLUSHING_CI_STATE;
	else if state = TM_ROLLBACK_WRITING_MARK_STATE |
	     state = TM_ROLLBACK_UNLOCKING_STATE |
	     state = TM_ROLLBACK_METERING_STATE then state = TM_ABORT_WRITING_MARK_STATE;

	if error_sw then state = state + TM_ERROR_INCREMENT;

	tm_tdt.state (txn_index) = state;

     end CONVERT_ROLLBACK_TO_ABORT;
%page;
ERROR_RETURN: proc (P_code);

dcl  P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

     end ERROR_RETURN;
%page;
ERROR_STATE: proc (P_state, P_code, P_name);

dcl  P_state fixed bin;
dcl  P_code fixed bin (35);
dcl  P_name char (*);

	call tm_error_state (txn_index, P_state, P_code, ME, P_name);

	A_code = P_code;

	go to RETURN;

     end ERROR_STATE;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_states;


     end tm_abort;




		    tm_adjust.pl1                   04/04/85  1119.5re  04/04/85  0827.0       24057



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_adjust: proc (A_txn_id, A_code);

/* DESCRIPTION:

   Called  by  the  user,  sends  a  message  to  the daemon to adjust a
   transaction.
*/

/* HISTORY:

Written by Steve Herbst, 05/11/83.
Modified:
10/23/84 by Steve Herbst: Changed in response to audit comments.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/

/* DECLARATIONS */

/* Parameters */

dcl  A_txn_id bit (36) aligned parameter;
dcl  A_code fixed bin (35) parameter;


/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl person char (22);
dcl project char (9);
dcl txn_id bit (36) aligned;
dcl txn_index fixed bin;
dcl code fixed bin (35);

/* External */

dcl dm_data_$tm_tdt_ptr ptr ext;
dcl dm_error_$not_own_transaction fixed bin (35) ext;
dcl dm_error_$transaction_not_abandoned fixed bin (35) ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl dm_misc_util_$log entry options (variable);
dcl dm_send_request_$adjust_txn entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl tm_get_txn_index entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);
dcl user_info_ entry options (variable);

/* Builtins */

dcl (fixed, rtrim) builtin;

/* Conditions */

/* END OF DECLARATIONS */
%page;
	A_code = 0;
	txn_id = A_txn_id;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version);

	txn_index = tm_get_txn_index (txn_id, code);
	if code ^= 0 then call ERROR_RETURN (code);

	call user_info_ (person, project);
	if tm_tdt.owner_name (txn_index) ^= rtrim (person) || "." || project then
	     call ERROR_RETURN (dm_error_$not_own_transaction);

	if ^tm_tdt.abandoned_sw (txn_index) then
	     call ERROR_RETURN (dm_error_$transaction_not_abandoned);

	call dm_send_request_$adjust_txn (tm_tdt.txn_id (txn_index), txn_index, 0);

	call dm_misc_util_$log (INFORM_SV, "User requested adjustment of txn ^d, TID = ^o, pid = ^w, state = ^d",
	     txn_index, fixed (tm_tdt.txn_id (txn_index)), tm_tdt.process_id (txn_index), tm_tdt.state (txn_index));
RETURN:
	return;
%page;
ERROR_RETURN: proc (P_code);

dcl P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

end ERROR_RETURN;
%page;
%include dm_tm_tdt;
%page;
%include dm_log_sv_codes;


end tm_adjust;




		    tm_adjust_tdt.pl1               04/04/85  1119.5re  04/04/85  0827.0       37278



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_adjust_tdt: proc;

/* DESCRIPTION:

   This procedure adjusts all the dead transactions in the TDT.
   A dead transaction is one that either  1) belongs to a process whose
   process_id is rejected by hcs_$validate_processid (dead process) or
   2) has its dead_process_sw on (turned on by tm_$terminate_process)
   even though the owner process may not yet be dead.
*/

/* HISTORY:

Written by Steve Herbst, 11/01/82
Modified:
12/07/82 by Steve Herbst: Fixed to adjust only if txn is not in error state.
01/11/83 by Steve Herbst: Changed to adjust txn only if daemon has not erred
	trying to adjust it.
01/24/83 by Steve Herbst: Refined this to "if daemon has not erred
	MAX_DAEMON_ERRORS times".
02/16/83 by Steve Herbst: Changed to log failure to adjust a txn
	MAX_DAEMON_ERRORS times.
09/25/84 by Steve Herbst: Changed in response to audit comments.
11/27/84 by Steve Herbst: Changed further in response to audit comments.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/

/* DECLARATIONS */

/* Parameters */


/* Constants */

dcl MAX_DAEMON_ERRORS fixed bin int static options (constant) init (3);
dcl ME char (32) int static options (constant) init ("tm_adjust_tdt");

/* Based */

/* Static */

/* Automatic */

dcl tdt_index fixed bin;

/* External */

dcl dm_data_$tm_tdt_ptr ptr ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl dm_misc_util_$log entry options (variable);
dcl dm_send_request_$adjust_tdt_entry entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl dm_send_request_$adjust_txn entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl hcs_$validate_processid entry (bit (36) aligned, fixed bin (35));

/* Builtins */

dcl (fixed, index, substr) builtin;

/* Conditions */

/* END OF DECLARATIONS */
%page;
	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then do;
	     call dm_misc_util_$log (ERROR_SV, error_table_$unimplemented_version, ME);
	     return;
	end;

	do tdt_index = 1 to tm_tdt.entry_count;

	     if tm_tdt.process_id (tdt_index) ^= "0"b then	/* entry in use */

		if tm_tdt.daemon_adjust_count (tdt_index) = MAX_DAEMON_ERRORS then do;

		     tm_tdt.daemon_adjust_count (tdt_index) = tm_tdt.daemon_adjust_count (tdt_index) + 1;
		     call dm_misc_util_$log (ERROR_SV, "**** Daemon tried ^d times to adjust TDT entry and is giving up.
^7x(index = ^d, id = ^o, process = ^w (^[d^;a^]), owner = ^a, state = ^d)",
			MAX_DAEMON_ERRORS, tdt_index, fixed (tm_tdt.txn_id (tdt_index)),
			tm_tdt.process_id (tdt_index), DEAD_PROCESS (tdt_index),
			PERSON_ID (tdt_index), tm_tdt.state (tdt_index));
		end;

		else if tm_tdt.daemon_adjust_count (tdt_index) < MAX_DAEMON_ERRORS then do;

		     if DEAD_PROCESS (tdt_index) | tm_tdt.dead_process_sw (tdt_index) then

			if tm_tdt.txn_id (tdt_index) ^= "0"b then
			     call dm_send_request_$adjust_txn (tm_tdt.txn_id (tdt_index), tdt_index, 0);
					/* causes tm_$adjust_txn to be called, cleans up txn too */

			else call dm_send_request_$adjust_tdt_entry ("0"b, tdt_index, 0);
					/* causes tm_$adjust_tdt_entry to be called */
					/* (No transaction to adjust before cleaning up TDT entry) */
		end;
	end;

	return;
%page;
DEAD_PROCESS: proc (P_index) returns (bit (1));

dcl P_index fixed bin;
dcl code fixed bin (35);

	if tm_tdt.process_id (P_index) = "0"b then return ("0"b);

	call hcs_$validate_processid (tm_tdt.process_id (P_index), code);
	return (code ^= 0);

end DEAD_PROCESS;
%page;
PERSON_ID: proc (P_index) returns (char (22));

dcl P_index fixed bin;
dcl name char (32);

	name = tm_tdt.owner_name (P_index);
	return (substr (name, 1, index (name, ".") - 1));

end PERSON_ID;
%page;
%include dm_tm_tdt;
%page;
%include dm_log_sv_codes;


end tm_adjust_tdt;




		    tm_begin.pl1                    04/04/85  1119.5re  04/04/85  0827.1       44865



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_begin: proc (A_mode, A_bj_opening_id, A_txn_id, A_code);

/* DESCRIPTION:

   This procedure implements transaction_manager_$begin_txn, which creates a
   new transaction in the "in progress" state. Information about the
   transaction is kept in the user's TDT entry.
*/

/* HISTORY:

Written by Steve Herbst, 08/04/82
Modified:
08/16/82 by Steve Herbst: Changed to use dm_data_$tm_tdt_ptr and new
	dm_tm_tdt.incl.pl1
08/18/82 by Steve Herbst: Added $tm_priv_begin
08/23/82 by Steve Herbst: Fixed to initialize A_code.
09/10/82 by Steve Herbst: Changed to eliminate locking.
01/19/83 by Steve Herbst: Added mode check.
03/23/84 by Steve Herbst: ADdded $begins_off and $begins_on for use during
	initialization.
05/13/83 by Steve Herbst: Changed A_mode to fixed bin (17) aligned.
05/25/83 by Steve Herbst: Made to log $begins_off and $begins_on.
09/25/84 by Steve Herbst: Changed in response to audit comments.
11/27/84 by Steve Herbst: Changed further in response to audit comments.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/

/* DECLARATIONS */

/* Parameters */

dcl A_mode fixed bin (17) aligned parameter;
dcl A_bj_opening_id bit (36) parameter;
dcl A_txn_id bit (36) aligned parameter;
dcl A_code fixed bin (35) parameter;

/* Constants */

dcl ME char (32) int static options (constant) init ("tm_begin");

/* Based */

/* Static */

/* Automatic */

dcl txn_id bit (36) aligned;
dcl txn_index fixed bin;
dcl code fixed bin (35);

/* External */

dcl dm_data_$current_txn_id bit (36) aligned ext;
dcl dm_data_$current_txn_index fixed bin ext;
dcl dm_data_$my_process_id bit (36) ext;
dcl dm_data_$my_tdt_index fixed bin ext;
dcl dm_data_$tm_tdt_ptr ptr external;
dcl dm_error_$invalid_mode fixed bin (35) ext;
dcl dm_error_$no_begins fixed bin (35) ext;
dcl dm_error_$not_own_transaction fixed bin (35) ext;
dcl dm_error_$transaction_in_progress fixed bin (35) ext;
dcl dm_error_$transaction_suspended fixed bin (35) ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl before_journal_manager_$write_begin_mark entry (bit (36) aligned, fixed bin, bit (36), fixed bin (35));
dcl dm_misc_util_$log entry options (variable);
dcl tm_cleanup entry (ptr, fixed bin);
dcl tm_generate_txn_id entry (ptr) returns (bit (36) aligned);

/* Builtins */

dcl (clock, unspec) builtin;

/* Conditions */

dcl cleanup condition;

/* END OF DECLARATIONS */
%page;
	A_txn_id = "0"b;
	A_code = 0;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version);

	if tm_tdt.no_begins then call ERROR_RETURN (dm_error_$no_begins);

	txn_index = dm_data_$my_tdt_index;
	tm_tdt_entry_ptr = addr (tm_tdt.entry (txn_index));

	if tm_tdt_entry.txn_id ^= "0"b then
	     if tm_tdt_entry.suspended_sw then call ERROR_RETURN (dm_error_$transaction_suspended);
	     else call ERROR_RETURN (dm_error_$transaction_in_progress);

	if tm_tdt_entry.process_id ^= dm_data_$my_process_id then
	     call ERROR_RETURN (dm_error_$not_own_transaction);

	if A_mode < LOWEST_MODE | A_mode > HIGHEST_MODE then
	     call ERROR_RETURN (dm_error_$invalid_mode);

	tm_tdt_entry.state = 0;			/* for cleanup in case we are interrupted */

	on cleanup begin;
	     call tm_cleanup (tm_tdt_ptr, txn_index);
	end;

	unspec (tm_tdt_entry.transaction) = "0"b;
	tm_tdt_entry.date_time_created = clock ();
	tm_tdt_entry.mode = A_mode;

	tm_tdt_entry.state = TM_BEGIN_STARTING_STATE;

	txn_id = tm_generate_txn_id (tm_tdt_ptr);
	call before_journal_manager_$write_begin_mark (txn_id, txn_index, A_bj_opening_id, code);
	if code ^= 0 then do;
	     tm_tdt_entry.state = 0;
	     unspec (tm_tdt_entry.transaction) = "0"b;
	     call ERROR_RETURN (code);
	end;

	tm_tdt_entry.txn_id = txn_id;			/* transaction is now official */

	dm_data_$current_txn_id = txn_id;
	dm_data_$current_txn_index = txn_index;

	tm_tdt_entry.state = TM_IN_PROGRESS_STATE;	/* nothing to clean up now */

	A_txn_id = txn_id;

RETURN:
	return;
%page;
begins_off: entry;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	tm_tdt.no_begins = "1"b;

	call dm_misc_util_$log (INFORM_SV, "Turning off transaction begins.");

	return;




begins_on: entry;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	tm_tdt.no_begins = "0"b;

	call dm_misc_util_$log (INFORM_SV, "Turning on transaction begins.");

	return;
%page;
ERROR_RETURN: proc (P_code);

dcl P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

end ERROR_RETURN;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_states;
%page;
%include dm_tm_modes;
%page;
%include dm_log_sv_codes;


end tm_begin;




		    tm_bump_all.pl1                 10/28/86  1606.8r w 10/28/86  1024.7       70092



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

/* DESCRIPTION:
   This procedure is called by the Daemon via the transaction_manaager_ to
   logout anyone who is still using the DM system.  This is used in conjunction
   with DM shutdown.
*/

/* HISTORY:
Written by R. Michael Tague, 12/06/84.
Modified:
12/19/84 by R. Michael Tague: changed format style to not mess up history.
01/16/85 by R. Michael Tague: Made an ERROR_RETURN procedure, declared the
            addr and size builtins, changed the BUMP_USER procedure parameters
            prefixes.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/06/85 by R. Michael Tague: Elaborated the history notice of 01/16/85,
            removed the null and sub_err_ declarations, put in a statement to
	  initialize code to zero, and changed the bump grace time to zero
	  instead of 5 seconds.
*/

/* format: style5,^indcomtxt */

tm_bump_all:
        proc ();

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

/* Automatic */

        dcl     as_request_channel	fixed bin (71);
        dcl     as_request_dir	char (168);
        dcl     as_request_proc_id	bit (36) aligned;
        dcl     as_request_seg	char (32);
        dcl     as_request_uid	bit (72) aligned;
        dcl     1 bump_user_info	aligned like asr_bump_user_info;

        dcl     code		fixed bin (35);
        dcl     failed_bumps		fixed bin;
        dcl     successful_bumps	fixed bin;
        dcl     tdt_index		fixed bin;

/* Based */
/* Builtin */

        dcl     (addr, fixed, size)	builtin;

/* Constant */

        dcl     BITS_PER_WORD		fixed bin init (36) int static
				options (constant);
        dcl     myname		char (32) init ("tm_bump_all")
				int static options (constant);

/* Entry */

        dcl     dm_misc_util_$log	entry options (variable);
        dcl     hcs_$wakeup		entry (bit (36) aligned, fixed bin (71),
				fixed bin (71), fixed bin (35));
        dcl     message_segment_$add_file
				entry (char (*), char (*), ptr,
				fixed bin (18), bit (72) aligned,
				fixed bin (35));
        dcl     system_info_$request_chn
				entry (bit (36) aligned, fixed bin (71),
				char (*), char (*));


/* External */

        dcl     dm_data_$tm_tdt_ptr	ptr ext;
        dcl     dm_system_data_$initializer_processid
				bit (36) aligned ext;
        dcl     error_table_$unimplemented_version
				fixed bin (35) ext;

/* END OF DECLARATIONS */
%page;
/* *************************************************************************
   * tm_bump_all - This is the main procedure.  We fill out the	     *
   * bump_user_info structure with everything except the process_id, we    *
   * then walk the TDT calling BUMP_USER for each process_id.	     *
   * BUMP_USER will fill in the process_id in the bump_user_info structure *
   * and send an ASR_BUMP_USER request to the Answering Service to logout  *
   * the specified process.					     *
   ************************************************************************* */

        code = 0;
        tm_tdt_ptr = dm_data_$tm_tdt_ptr;
        call CHECK_VERSION (tm_tdt.version, (TM_TDT_VERSION_3), "tm_tdt");

        bump_user_info.header.version = as_request_version_1;
        bump_user_info.header.type = ASR_BUMP_USER;
        bump_user_info.header.reply_channel = 0;
        bump_user_info.version = asr_bump_user_info_version_1;
        bump_user_info.message =
	  "Due to your failure or inability to exit the Data Management System"
	  ;
        bump_user_info.grace_time_in_seconds = 0;
        bump_user_info.reply_reference_id = "0"b;
        call system_info_$request_chn (as_request_proc_id, as_request_channel,
	  as_request_dir, as_request_seg);

        failed_bumps = 0;
        successful_bumps = 0;
        do tdt_index = 1 to tm_tdt.entry_count;
	      if tm_tdt.process_id (tdt_index) ^= "0"b
		& tm_tdt.process_id (tdt_index)
		^= dm_system_data_$initializer_processid then
		    do;
		    call BUMP_USER (tm_tdt.process_id (tdt_index), code);
		    if code = 0 then
			  successful_bumps = successful_bumps + 1;
		    else
			  failed_bumps = failed_bumps + 1;
		    end;
        end;
        if failed_bumps > 0 then
	      call dm_misc_util_$log (ERROR_SV, 0, myname,
		"^/Unable to bump ^i users of ^i users to be bumped.",
		failed_bumps, failed_bumps + successful_bumps);
        call RETURN ();

MAIN_RETURN:
        return;
%page;
/* *************************************************************************
   * BUMP_USER -Given a user process id, this routine sends a request to   *
   * the Answering Service to bump that user.  We assume that except for   *
   * the process id, the global structure asr_bump_user_info has been      *
   * filled in.  as_request_channel, as_request_dir, as_request_proc_id,   *
   * as_request_seg, and as_request_uid are global values that contain     *
   * information needed to send a request to the Answering Service.	     *
   ************************************************************************* */

BUMP_USER:
        proc (bu_p_process_id, bu_p_code);
        dcl     bu_p_process_id	bit (36) aligned;
        dcl     bu_p_code		fixed bin (35);

        bump_user_info.process_id = bu_p_process_id;
        call message_segment_$add_file (as_request_dir, as_request_seg,
	  addr (bump_user_info), BITS_PER_WORD * size (bump_user_info),
	  as_request_uid, bu_p_code);
        if bu_p_code ^= 0 then
	      call dm_misc_util_$log (ERROR_SV, bu_p_code, myname,
		"^/Cannot add to Answering Servce request message segment.^/Cannot send bump request."
		);
        else
	      do;
	      call hcs_$wakeup (as_request_proc_id, as_request_channel,
		fixed (as_request_uid), bu_p_code);
	      if bu_p_code ^= 0 then
		    call dm_misc_util_$log (ERROR_SV, bu_p_code, myname,
		        "^/Cannot send IPC wakeup to Answering Service.^/Cannot send bump request."
		        );
	      end;
        end BUMP_USER;
%page;
/* *************************************************************************
   * CHECK_VERSION - Checks the character version structure.	     *
   ************************************************************************* */

CHECK_VERSION:
        proc (cv_p_input_version, cv_p_expected_version, cv_p_structure_name);
        dcl     (
	      cv_p_input_version	char (8) aligned,
	      cv_p_expected_version	char (8) aligned,
	      cv_p_structure_name	char (*)
	      )			parameter;

        if cv_p_input_version ^= cv_p_expected_version then
	      do;
	      call dm_misc_util_$log (ERROR_SV,
		error_table_$unimplemented_version, myname,
		"Expected version ^a of structure ^a, received ^a.",
		cv_p_expected_version, cv_p_structure_name,
		cv_p_input_version);
	      call ERROR_RETURN ();
	      end;
        end CHECK_VERSION;
%page;
/* *************************************************************************
   * RETURN - All returns from this program come through here.	     *
   ************************************************************************* */

RETURN:
        proc ();

        go to MAIN_RETURN;
        end RETURN;
%page;
/* *************************************************************************
   * ERROR_RETURN - For error exits.  No clean up required in this program.*
   ************************************************************************* */

ERROR_RETURN:
        proc ();

        call RETURN ();
        end ERROR_RETURN;
%page;
%include as_request_header;
%page;
%include as_requests;
%page;
%include dm_log_sv_codes;
%page;
%include dm_tm_tdt;

        end tm_bump_all;





		    tm_cleanup.pl1                  05/06/86  1321.1rew 05/06/86  1256.7      134271



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


/****^  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 to execute file_mangaer_$post_transaction before unlocking locks.
                                                   END HISTORY COMMENTS */


/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_cleanup: proc (A_tdt_ptr, A_txn_index);

/* DESCRIPTION:

   This procedure is invoked by all operations' cleanup handlers.
   It looks at the state of the process's TDT entry and does whatever
   is necessary to put the entry in a consistent state.
*/

/* HISTORY:

Written by Steve Herbst, 08/04/82
Modified:
08/16/82 by Steve Herbst: Changed to use consolidated dm_tm_tdt.incl.pl1 with
	entry declarations.
09/13/82 by Steve Herbst: Changed for no-locking environment.
09/22/82 by Steve Herbst: Added $crawlout
09/23/82 by Lindsey Spratt: Changed to use new lock_manager_ calling sequences.
10/05/82 by Steve Herbst: Added TM_ABORT_POST_COMMIT_STATE
10/14/82 by Steve Herbst: Changed calling sequence of pfm_$flush_modified_ci
11/01/82 by Steve Herbst: Changed to turn on txn's error_sw for error states.
11/05/82 by Steve Herbst: Made to set tm_tdt.error_code on error return.
12/14/82 by Steve Herbst: Let daemon try to adjust an error txn if it hasn't.
01/12/83 by Steve Herbst: Made to log errors that occur while cleaning up.
01/14/83 by Steve Herbst: Added $restart_error, changed to log errors by
	calling tm_error_state.
03/21/83 by Steve Herbst: Fixed $restart_error to set dm_data_$current_txn_id,
	made all entries save & restore dm_data_.
05/27/83 by Steve Herbst: Made to update checkpoint_id & rollback_count in
	TDT entry.
10/19/83 by Steve Herbst: Changed behavior in case where perprocess list of
	modified ci's is no longer available.
09/25/84 by Steve Herbst: Changed in response to audit comments.
11/27/84 by Steve Herbst: Changed further in response to audit comments.
12/26/84 by Matthew Pierret: Commented out call to file_manager_$post_commit.
            before_journal_manager_ currently handles postcommit operations
            for file_manager_.
01/29/85 by Steve Herbst: Fixed to ignore dm_error_$file_was_deleted.
02/07/85 by Stanford S. Cox:  Added fm$post_transaction call (moved from
            lm_per_system_), STATE 45:  Chg lm$unlock_to_checkpoint call to
            lm$unlock_all.
02/12/85 by S. Cox: TM_ROLLBACK_UNLOCKING_STATE: Rmvd fm$post_transaction call.
04/23/85 by Matthew C. Pierret:  Switched the order of the calls to
            file_manager_$post_transaction and lock_manager_$unlock_all.  This
            allows file_manager_$post_transaction to operate under the safety
            of the locks acquired by the transaction.
*/

/* DECLARATIONS */

/* Parameter */

dcl  A_tdt_ptr ptr parameter;
dcl  A_txn_index fixed bin parameter;


/* Constants */

dcl  ME char (32) int static options (constant) init ("tm_cleanup");

/* Based */

/* Static */

/* Automatic */

dcl  (process_id, saved_current_txn_id, txn_id) bit (36) aligned;
dcl  daemon_sw bit (1);
dcl  (saved_current_txn_index, state, txn_index) fixed bin;
dcl  code fixed bin (35);

/* External */

dcl  dm_data_$current_txn_id bit (36) aligned ext;
dcl  dm_data_$current_txn_index fixed bin ext;
dcl  dm_data_$my_tdt_index fixed bin ext;
dcl  dm_data_$tm_tdt_ptr ptr ext;
dcl  dm_error_$file_was_deleted fixed bin (35) ext;
dcl  dm_system_data_$initializer_processid bit (36) ext;

/* Entries */

dcl  before_journal_manager_$flush_transaction entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  before_journal_manager_$rollback entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  before_journal_manager_$write_aborted_mark entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  before_journal_manager_$write_committed_mark entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  before_journal_manager_$write_rolled_back_mark entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  get_process_id_ entry returns (bit (36));
dcl  lock_manager_$unlock_all entry;
dcl  file_manager_$flush_modified_ci entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  file_manager_$post_transaction entry ();
dcl  tm_error_state entry (fixed bin, fixed bin, fixed bin (35), char (*), char (*));

/* Builtins */

dcl  unspec builtin;

/* Conditions */

dcl  cleanup condition;

/* END OF DECLARATIONS */
%page;
	tm_tdt_ptr = A_tdt_ptr;
	txn_index = A_txn_index;
	call SAVE_DM_DATA;
	on cleanup call RESTORE_DM_DATA;

	go to COMMON;

restart_error: entry (A_tdt_ptr, A_txn_index);

/* This entry point acts like $tm_cleanup but first changes an error state into the corresponding
   state before the call that produced the error */

	tm_tdt_ptr = A_tdt_ptr;
	txn_index = A_txn_index;
	call SAVE_DM_DATA;
	on cleanup call RESTORE_DM_DATA;

	dm_data_$current_txn_id = tm_tdt.txn_id (txn_index);

	if tm_tdt.error_sw (txn_index) then do;
	     tm_tdt.error_sw (txn_index) = "0"b;
	     tm_tdt.error_code (txn_index) = 0;

	     if tm_tdt.state (txn_index) > TM_ERROR_INCREMENT then
		tm_tdt.state (txn_index) = tm_tdt.state (txn_index) - TM_ERROR_INCREMENT;
	end;
	go to COMMON;

crawlout: entry;					/* callable from any program in the process */

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;
	txn_index = dm_data_$my_tdt_index;
	call SAVE_DM_DATA;
	on cleanup call RESTORE_DM_DATA;

COMMON:
	process_id = get_process_id_ ();
	daemon_sw = (process_id = dm_system_data_$initializer_processid);

	txn_id = tm_tdt.txn_id (txn_index);
	if txn_id = "0"b then go to HANDLE_STATE;	/* deleted transaction */

/* If this is not the process that created the transaction, we no longer have
   the (perprocess) list of modified control intervals. So... */

	if tm_tdt.process_id (txn_index) ^= process_id then do;

/* if commit hasn't flushed modified ci's, must convert to an abort */
	     if tm_tdt.state (txn_index) = TM_COMMIT_FLUSHING_TXN_STATE |
		tm_tdt.state (txn_index) = TM_COMMIT_FLUSHING_CI_STATE then
		tm_tdt.state (txn_index) = TM_ABORT_FLUSHING_TXN_STATE;

	     else if tm_tdt.state (txn_index) = TM_ABORT_FLUSHING_CI_STATE then
		tm_tdt.state (txn_index) = TM_ABORT_ROLLING_BACK_STATE; /* repeat the rollback */

	     else if tm_tdt.state (txn_index) = TM_ROLLBACK_FLUSHING_CI_STATE then
		tm_tdt.state (txn_index) = TM_ROLLBACK_ROLLING_BACK_STATE; /* repeat the rollback */
	end;

HANDLE_STATE:
	state = tm_tdt.state (txn_index);
	if state < 0 | state > HIGHEST_STATE then state, tm_tdt.state (txn_index) = 0;
	go to STATE (state);


STATE (0):					/* transaction does not exist */

	if dm_data_$current_txn_index ^= 0 then do;
	     dm_data_$current_txn_id = "0"b;
	     dm_data_$current_txn_index = 0;
	end;

	unspec (tm_tdt.transaction (txn_index)) = "0"b;	/* now it's really gone */
RETURN:
	call RESTORE_DM_DATA;
	return;


/* TM_IN_PROGRESS_STATE */
STATE (1):

	if dm_data_$current_txn_index ^= 0 then do;	/* dm_data_$current_txn_id = "0"b if */
						/* transaction was in error previously */
	     dm_data_$current_txn_id = tm_tdt.txn_id (dm_data_$current_txn_index);
	end;

	go to RETURN;				/* nothing to clean up */


/* TM_BEGIN_STARTING_STATE */
STATE (11):

	tm_tdt.state (txn_index) = 0;
	go to HANDLE_STATE;				/* nothing to clean up; delete txn */


/* TM_ABORT_FLUSHING_TXN_STATE */
STATE (21):

	call before_journal_manager_$flush_transaction (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ABORT_FLUSHING_TXN_ERROR, code, "bjm_$flush_transaction");

	tm_tdt.state (txn_index) = TM_ABORT_ROLLING_BACK_STATE;
	go to HANDLE_STATE;

/* TM_ABORT_ROLLING_BACK_STATE */
STATE (22):

	call before_journal_manager_$rollback (txn_id, txn_index, 0, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ABORT_ROLLING_BACK_ERROR, code, "bjm_$rollback");

	tm_tdt.checkpoint_id (txn_index) = 0;
	tm_tdt.rollback_count (txn_index) = tm_tdt.rollback_count (txn_index) + 1;

	tm_tdt.state (txn_index) = TM_ABORT_FLUSHING_CI_STATE;
	go to HANDLE_STATE;

/* TM_ABORT_FLUSHING_CI_STATE */
STATE (23):

	call file_manager_$flush_modified_ci (txn_id, txn_index, code);
	if code ^= 0 & code ^= dm_error_$file_was_deleted then
						/* previous cleanup may have deleted the file */
	     call ERROR_STATE (TM_ABORT_FLUSHING_CI_ERROR, code, "fm_$flush_modified_ci");

	tm_tdt.state (txn_index) = TM_ABORT_WRITING_MARK_STATE;
	go to HANDLE_STATE;

/* TM_ABORT_WRITING_MARK_STATE */
STATE (24):

	call before_journal_manager_$write_aborted_mark (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ABORT_WRITING_MARK_ERROR, code, "bjm_$write_aborted_mark");

	tm_tdt.state (txn_index) = TM_ABORT_UNLOCKING_STATE;
	go to HANDLE_STATE;

/* TM_ABORT_UNLOCKING_STATE */
STATE (25):

	call file_manager_$post_transaction;
	call lock_manager_$unlock_all;

	tm_tdt.state (txn_index) = TM_ABORT_METERING_STATE;
	go to HANDLE_STATE;

/* TM_ABORT_METERING_STATE */
STATE (26):

/* Metering not implemented yet */

	tm_tdt.state (txn_index) = 0;
	go to HANDLE_STATE;


/* TM_COMMIT_FLUSHING_TXN_STATE */
STATE (31):

	call before_journal_manager_$flush_transaction (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_COMMIT_FLUSHING_TXN_ERROR, code, "bjm_$flush_transaction");

	tm_tdt.state (txn_index) = TM_COMMIT_FLUSHING_CI_STATE;
	go to HANDLE_STATE;

/* TM_COMMIT_FLUSHING_CI_STATE */
STATE (32):

	call file_manager_$flush_modified_ci (txn_id, txn_index, code);
	if code ^= 0 then				/* for commit, dm_error_$file_was_deleted is always an error */
	     call ERROR_STATE (TM_COMMIT_FLUSHING_CI_ERROR, code, "fm_$flush_modified_ci");

	tm_tdt.state (txn_index) = TM_COMMIT_WRITING_MARK_STATE;
	go to HANDLE_STATE;

/* TM_COMMIT_WRITING_MARK_STATE */
STATE (33):

	call before_journal_manager_$write_committed_mark (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_COMMIT_WRITING_MARK_ERROR, code, "bjm_$write_committed_mark");

	tm_tdt.state (txn_index) = TM_COMMIT_POST_COMMIT_STATE;
	go to HANDLE_STATE;

/* TM_COMMIT_POST_COMMIT_STATE */
STATE (34):

/* **************************************************************************
 * There are no post_commit operations handled by transaction_manager_ yet. *

	if tm_tdt.post_commit_flags.fmgr (txn_index) then do;
	     call file_manager_$post_commit (txn_id, txn_index, code);
	     if code ^= 0 then
		call ERROR_STATE (TM_COMMIT_POST_COMMIT_ERROR, code, "fm_$post_commit");
	end;

	if tm_tdt.bjmgr (txn_index) then do;
	     call before_journal_manager_$post_commit (txn_id, txn_index, code);
	     if code ^= 0 then
		call ERROR_STATE (TM_COMMIT_POST_COMMIT_ERROR, code, "bjm_$post_commit");
	end;
************************************************************************** */
	tm_tdt.state (txn_index) = TM_COMMIT_UNLOCKING_STATE;
	go to HANDLE_STATE;

/* TM_COMMIT_UNLOCKING_STATE */
STATE (35):

	call file_manager_$post_transaction;
	call lock_manager_$unlock_all;

	tm_tdt.state (txn_index) = TM_COMMIT_METERING_STATE;
	go to HANDLE_STATE;

/* TM_COMMIT_METERING_STATE */
STATE (36):

/* Metering not implemented yet */

	tm_tdt.state (txn_index) = 0;
	go to HANDLE_STATE;


/* TM_ROLLBACK_FLUSHING_TXN_STATE */
STATE (41):

	call before_journal_manager_$flush_transaction (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ROLLBACK_FLUSHING_TXN_ERROR, code, "bjm_$flush_transaction");

	tm_tdt.state (txn_index) = TM_ROLLBACK_ROLLING_BACK_STATE;
	go to HANDLE_STATE;

/* TM_ROLLBACK_ROLLING_BACK_STATE */
STATE (42):

	call before_journal_manager_$rollback (txn_id, txn_index, 0 /* USE CHECKPOINT FROM ENTRY */, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ROLLBACK_ROLLING_BACK_ERROR, code, "bjm_$rollback");

	tm_tdt.checkpoint_id (txn_index) = 0;
	tm_tdt.rollback_count (txn_index) = tm_tdt.rollback_count (txn_index) + 1;

	tm_tdt.state (txn_index) = TM_ROLLBACK_FLUSHING_CI_STATE;
	go to HANDLE_STATE;

/* TM_ROLLBACK_FLUSHING_CI_STATE */
STATE (43):

	call file_manager_$flush_modified_ci (txn_id, txn_index, code);
	if code ^= 0 & code ^= dm_error_$file_was_deleted then
						/* previous cleanup may have deleted the file */
	     call ERROR_STATE (TM_ROLLBACK_FLUSHING_CI_ERROR, code, "fm_$flush_modified_ci");

	tm_tdt.state (txn_index) = TM_ROLLBACK_WRITING_MARK_STATE;
	go to HANDLE_STATE;

/* TM_ROLLBACK_WRITING_MARK_STATE */
STATE (44):

	call before_journal_manager_$write_rolled_back_mark (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ROLLBACK_WRITING_MARK_ERROR, code, "bjm_$write_rolled_back_mark");

	tm_tdt.state (txn_index) = TM_ROLLBACK_UNLOCKING_STATE;
	go to HANDLE_STATE;

/* TM_ROLLBACK_UNLOCKING_STATE */
STATE (45):

	call lock_manager_$unlock_all ();

	tm_tdt.state (txn_index) = TM_ROLLBACK_METERING_STATE;
	go to HANDLE_STATE;

/* TM_ROLLBACK_METERING_STATE */
STATE (46):

/* Metering not implemented yet */

	tm_tdt.state = TM_IN_PROGRESS_STATE;
	go to RETURN;


/* ERROR STATES */

STATE (71): STATE (72): STATE (73): STATE (74): STATE (75): STATE (76):
STATE (81): STATE (82): STATE (83): STATE (84): STATE (85): STATE (86):
STATE (91): STATE (92): STATE (93): STATE (94): STATE (95): STATE (96):

	go to RETURN;				/* nothing to try */


/* UNASSIGNED STATES */

STATE (2): STATE (3): STATE (4): STATE (5): STATE (6): STATE (7): STATE (8): STATE (9): STATE (10):
STATE (12): STATE (13): STATE (14): STATE (15): STATE (16): STATE (17): STATE (18): STATE (19): STATE (20):
STATE (27): STATE (28): STATE (29): STATE (30):
STATE (37): STATE (38): STATE (39): STATE (40):
STATE (47): STATE (48): STATE (49): STATE (50):
STATE (51): STATE (52): STATE (53): STATE (54): STATE (55): STATE (56): STATE (57): STATE (58): STATE (59): STATE (60):
STATE (61): STATE (62): STATE (63): STATE (64): STATE (65): STATE (66): STATE (67): STATE (68): STATE (69): STATE (70):
STATE (77): STATE (78): STATE (79): STATE (80):
STATE (87): STATE (88): STATE (89): STATE (90):

	state, tm_tdt.state (txn_index) = 0;
	go to HANDLE_STATE;
%page;
ERROR_STATE: proc (P_state, P_code, P_name);

dcl  P_state fixed bin;
dcl  P_code fixed bin (35);
dcl  P_name char (*);

	call tm_error_state (txn_index, P_state, P_code, ME, P_name);

	go to RETURN;

     end ERROR_STATE;


RESTORE_DM_DATA: proc;

	dm_data_$current_txn_index = saved_current_txn_index;
	dm_data_$current_txn_id = saved_current_txn_id;

     end RESTORE_DM_DATA;


SAVE_DM_DATA: proc;

	saved_current_txn_index = dm_data_$current_txn_index;
	saved_current_txn_id = dm_data_$current_txn_id;

     end SAVE_DM_DATA;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_states;


     end tm_cleanup;




		    tm_commit.pl1                   05/06/86  1321.1rew 05/06/86  1256.9       69975



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


/****^  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 to execute file_mangaer_$post_transaction before unlocking locks.
                                                   END HISTORY COMMENTS */


/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_commit: proc (A_txn_id, A_code);

/* DESCRIPTION:

   This procedure implements transaction_manager_$commit_txn
   Committing a transaction consists of flushing all modifications to disk
   and writing a committed-mark in the journal. After being committed, the
   transaction disappears.
*/

/* HISTORY:

04/23/85 by Matthew C. Pierret:  Switched order of calls to
            file_manager_$post_transaction and lock_manager_$unlock_all.  This
            allows file_manager_$post_transaction to operate underthe safety
            of the locks acquired by the transaction.
Written by Steve Herbst, 08/09/82. */
/* Modified:
08/16/82 by Steve Herbst: Changed to use dm_data_$tm_tdt_ptr and new
	dm_tm_tdt.incl.pl1
08/23/82 by Steve Herbst: Fixed to initialize A_code.
08/26/82 by Steve Herbst: Changed calling sequence of bjm_$flush_transaction.
09/10/82 by Steve Herbst: Changed to eliminate locking.
09/23/82 by Lindsey Spratt: Changed to use new lock_manager_ calling sequence.
10/04/82 by Steve Herbst: Changed to just abort if in one of the test modes.
10/14/82 by Steve Herbst: Change pfm_ calling sequence and added check for
	funny states.
10/28/82 by Steve Herbst: Changed to always call fm_$post_commit (rather than
	check post-commit flag in TDT).
11/01/82 by Steve Herbst: Made to turn on txn's error_sw for error states.
11/05/82 by Steve Herbst: Made to set tm_tdt.error_code on error return.
01/12/83 by Steve Herbst: Made to log its errors.
01/14/83 by Steve Herbst: Changed to complete previous error commit, and to
	call tm_error_state.
03/28/84 by Lee A. Newcomb:  changed tm_get_state_info call to be
	  transaction_manager_$get_state_info.
09/27/84 by Steve Herbst: Changed in response to audit comments.
02/07/85 by S. Cox: Added fm$post_transaction call (moved from lm_per_system_)
                    Added addr dcl.
*/
%page;
/* DECLARATIONS */

/* Parameters */

dcl  A_txn_id bit (36) aligned;
dcl  A_code fixed bin (35);


/* Constants */

dcl  ME char (32) int static options (constant) init ("tm_commit");

/* Based */

/* Static */

/* Automatic */

dcl  op_name char (32);
dcl  txn_id bit (36) aligned;
dcl  (mode, txn_index) fixed bin;
dcl  (code, op_error_code) fixed bin (35);

/* External */

dcl  dm_data_$current_txn_id bit (36) aligned ext;
dcl  dm_data_$current_txn_index fixed bin ext;
dcl  dm_data_$my_process_id bit (36) ext;
dcl  dm_data_$suspended_txn_index fixed bin ext;
dcl  dm_data_$tm_tdt_ptr ptr external;
dcl  dm_error_$invalid_current_txn fixed bin (35) ext;
dcl  dm_error_$no_current_transaction fixed bin (35) ext;
dcl  dm_error_$not_own_transaction fixed bin (35) ext;
dcl  dm_error_$transaction_not_current fixed bin (35) ext;
dcl  dm_error_$transaction_suspended fixed bin (35) ext;
dcl  error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl  before_journal_manager_$flush_transaction entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  before_journal_manager_$write_committed_mark entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  lock_manager_$unlock_all entry;
dcl  file_manager_$flush_modified_ci entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  file_manager_$post_transaction entry ();
dcl  tm_abort entry (bit (36) aligned, fixed bin (35));
dcl  tm_cleanup entry (ptr, fixed bin);
dcl  tm_cleanup$restart_error entry (ptr, fixed bin);
dcl  tm_error_state entry (fixed bin, fixed bin, fixed bin (35), char (*), char (*));
dcl  transaction_manager_$get_state_info entry (fixed bin, char (*), fixed bin (35));

/* Builtins */

dcl  (addr, unspec) builtin;

/* Conditions */

dcl  cleanup condition;

/* END OF DECLARATIONS */
%page;
	A_code = 0;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version);

	if dm_data_$current_txn_index = 0 then
	     if dm_data_$suspended_txn_index ^= 0 then call ERROR_RETURN (dm_error_$transaction_suspended);
	     else call ERROR_RETURN (dm_error_$no_current_transaction);

	txn_index = dm_data_$current_txn_index;

	if txn_index < 1 | txn_index > tm_tdt.entry_count then
	     call ERROR_RETURN (dm_error_$invalid_current_txn);

	if A_txn_id = "0"b | A_txn_id = tm_tdt.txn_id (txn_index) then
	     txn_id = tm_tdt.txn_id (txn_index);
	else call ERROR_RETURN (dm_error_$transaction_not_current);

	tm_tdt_entry_ptr = addr (tm_tdt.entry (txn_index));

	if tm_tdt_entry.process_id ^= dm_data_$my_process_id then
	     call ERROR_RETURN (dm_error_$not_own_transaction);

	if tm_tdt_entry.state ^= TM_IN_PROGRESS_STATE then do;

	     call transaction_manager_$get_state_info ((tm_tdt_entry.state), op_name, op_error_code);
	     if op_name ^= OP_NAME_COMMIT then
		call ERROR_RETURN (op_error_code);	/* dm_error_$unfinished_(abort rollback) */

	     call tm_cleanup$restart_error (tm_tdt_ptr, txn_index); /* finishes an incomplete commit */
	     if tm_tdt_entry.error_sw then
		call ERROR_STATE ((tm_tdt_entry.state), tm_tdt_entry.error_code, "tm_cleanup");
	     return;
	end;

	mode = tm_tdt_entry.mode;
	if mode = TM_TEST_NORMAL_MODE |
	     mode = TM_TEST_STATISTICAL_MODE |
	     mode = TM_TEST_READ_ONLY_MODE |
	     mode = TM_TEST_NEVER_WRITE_MODE then do;

	     call tm_abort (A_txn_id, A_code);		/* test modes: just abort */
	     return;
	end;

	on cleanup begin;
	     call tm_cleanup (tm_tdt_ptr, txn_index);
	end;

	tm_tdt_entry.state = TM_COMMIT_FLUSHING_TXN_STATE;

	call before_journal_manager_$flush_transaction (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_COMMIT_FLUSHING_TXN_ERROR, code, "before_journal_manager_$flush_transaction");

	tm_tdt_entry.state = TM_COMMIT_FLUSHING_CI_STATE;

	call file_manager_$flush_modified_ci (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_COMMIT_FLUSHING_CI_ERROR, code, "file_manager_$flush_modified_ci");

	tm_tdt_entry.state = TM_COMMIT_WRITING_MARK_STATE;

	call before_journal_manager_$write_committed_mark (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_COMMIT_WRITING_MARK_ERROR, code, "before_journal_manager_$write_committed_mark");

	tm_tdt_entry.state = TM_COMMIT_UNLOCKING_STATE;

	call file_manager_$post_transaction;

	call lock_manager_$unlock_all;

	tm_tdt_entry.state = TM_COMMIT_METERING_STATE;

/* Dump meters here */

	dm_data_$current_txn_id = "0"b;
	dm_data_$current_txn_index = 0;

	tm_tdt_entry.state = 0;			/* show intent to zero whole entry */
	unspec (tm_tdt_entry.transaction) = "0"b;	/* transaction is now officially gone */

	A_txn_id = "0"b;				/* zero caller's arg */
RETURN:
	return;
%page;
ERROR_RETURN: proc (P_code);

dcl  P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

     end ERROR_RETURN;
%page;
ERROR_STATE: proc (P_state, P_code, P_name);

dcl  P_state fixed bin;
dcl  P_code fixed bin (35);
dcl  P_name char (*);

	call tm_error_state (txn_index, P_state, P_code, ME, P_name);

	A_code = P_code;

	go to RETURN;

     end ERROR_STATE;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_states;
%page;
%include dm_tm_modes;


     end tm_commit;




		    tm_daemon_adjust.pl1            04/04/85  1119.5re  04/04/85  0827.1      129465



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/* --------------- */

tm_daemon_adjust: proc;

/* DESCRIPTION:

   Called  only  by the Data Management Daemon, $tm_adjust_tdt_entry cleans up
   a transaction belonging to a dead or "suspended" (to be defined) process.
   If a "committed" mark may have been  written  for  the  transaction,  the
   transaction is committed.  Otherwise, it is aborted.

   The entry point $tm_adjust_process_id adjusts the transaction
   belonging to a specified process_id, only if the process is dead.
*/

/* HISTORY:

Written by Steve Herbst, 10/12/82.
Modified:
11/01/82 by Steve Herbst: Changed to not adjust if txn's error_sw is on.
11/08/82 by Steve Herbst: Added $tm_adjust_process_id.
11/11/82 by Steve Herbst: Made to respect tm_tdt_entry.dead_process_sw.
11/22/82 by Steve Herbst: Changed to just return if passed a zero txn_id.
11/22/82 by Steve Herbst: Changed to free TDT entry when done.
12/07/82 by Steve Herbst: Changed to call other mgrs' adjusters, and free TDT
	entry, if txn not in error state.
12/14/82 by Steve Herbst: Changed to return error if tm_cleanup$restart_error
	couldn't adjust the transaction.
01/11/83 by Steve Herbst: Added code for tm_tdt.kill_sw="1"b, adjusting
	requested by tm_$kill.
01/11/83 by Steve Herbst: Changed to always adjust an error txn, a live
	abandoned txn, or one to be killed.
01/17/83 by Steve Herbst: Changed abort heuristic: only force abort of
	IN-PROGRESS txns, else finish up op
01/24/83 by Steve Herbst: Fixed to free entry despite no txn, call
	bjm_$adjust... only for dead proc, log adjust_txn
04/14/83 by Benson Margulies: Removed the code to unlock all, and removed a
          bad substr argument in process_id.
04/19/83 by Steve Herbst: Fixed adjust_txn internal proc to copy its arg.
04/20/83 by Lee A. Newcomb: Removed temp hack to pause in $tm_adjust_process_id
	since answering service (dpg_) is fixed.
04/26/83 by Steve Herbst: Added logging of "kill" path.
05/02/83 by Steve Herbst: Separated out the kill code into kill_txn, changed
	to kill without calling tm_cleanup.
05/04/83 by Steve Herbst: Converted tm_adopt calls to tm_daemon_adopt calls.
05/11/83 by Steve Herbst: Renamed module to tm_daemon_adjust; tm_adjust will
	be for user to call.
05/16/83 by Steve Herbst: Changed to send mail to owner if it can't adjust
	a transaction.
10/20/83 by Steve Herbst: Fixed bug preventing TDT entry from being freed if
	owner process still active.
03/28/84 by Lee A. Newcomb: Changed tm_get_state_info call to be
	transaction_manager_$get_state_info.
10/19/84 by Steve Herbst: Changed in response to audit comments.
01/23/84 by R. Michael Tague: Changed it so that the $adjust_tdt_entry would
          use the supplied txn_id if the supplied txn_index is zero.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/18/85 by Steve Herbst: Removed logging except for error situations.
*/

/* DECLARATIONS */

/* Parameters */

dcl  A_txn_id bit (36) aligned parameter;
dcl  A_txn_index fixed bin parameter;
dcl  A_code fixed bin (35) parameter;
dcl  A_process_id bit (36) aligned;


/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl  message char (256);
dcl  error_message char (100) aligned;
dcl  (ME, op_name) char (32);

dcl  txn_id bit (36) aligned;
dcl  process_id bit (36);
dcl  (dead_process_sw, kill_sw, process_id_entry_sw) bit (1);
dcl  txn_index fixed bin;
dcl  message_len fixed bin (21);
dcl  code fixed bin (35);

/* External */

dcl  dm_data_$current_txn_id bit (36) aligned ext;
dcl  dm_data_$current_txn_index fixed bin ext;
dcl  dm_data_$tm_tdt_ptr ptr external;
dcl  dm_error_$not_daemon fixed bin (35) ext;
dcl  dm_error_$tdt_entry_in_use fixed bin (35) ext;
dcl  dm_system_data_$initializer_processid bit (36) ext;
dcl  error_table_$badcall fixed bin (35) ext;
dcl  dm_error_$process_not_found fixed bin (35) ext;
dcl  error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl  before_journal_manager_$adjust_process_id entry (bit (36) aligned, fixed bin (35));
dcl  before_journal_manager_$write_aborted_mark entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  dm_misc_util_$log entry options (variable);
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  get_process_id_ entry returns (bit (36));
dcl  hcs_$validate_processid entry (bit (36) aligned, fixed bin (35));
dcl  ioa_$rs entry options (variable);
dcl  lock_manager_$unlock_all entry;
dcl  send_mail_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  tm_cleanup$restart_error entry (ptr, fixed bin);
dcl  tm_daemon_adopt$tm_daemon_abandon entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  tm_daemon_adopt entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  transaction_manager_$get_state_info entry (fixed bin, char (*), fixed bin (35));

/* Builtins */

dcl  (addr, before, fixed, null, stacq, string, substr, unspec) builtin;

/* Conditions */

/* END OF DECLARATIONS */
%page;
tm_adjust_tdt_entry: entry (A_txn_id, A_txn_index, A_code);

	process_id_entry_sw = "0"b;
	ME = "tm_adjust_tdt_entry";
	txn_id = A_txn_id;
	txn_index = A_txn_index;
	A_code = 0;

	go to COMMON;

tm_adjust_process_id: entry (A_process_id, A_code);

	process_id_entry_sw = "1"b;
	ME = "tm_adjust_process_id";
	process_id = A_process_id;
	A_code = 0;
	txn_index = 0;

COMMON:
						/* must be called by Data_Management.Daemon */
	if get_process_id_ () ^= dm_system_data_$initializer_processid then do;
	     A_code = dm_error_$not_daemon;
	     return;
	end;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	tm_tdt_entry_ptr = null;			/* tested by ERROR_RETURN, in case next line errs */

	if tm_tdt.version ^= TM_TDT_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version);

	if process_id_entry_sw then do;

	     txn_index = SEARCH_FOR_PROCESS (process_id);

	     txn_id = tm_tdt.txn_id (txn_index);
	end;
	else do;
	     if txn_index = 0 then
		txn_index = SEARCH_FOR_ID (txn_id);
	     if txn_index < 1 | txn_index > tm_tdt.entry_count then call ERROR_RETURN (error_table_$badcall);
	     else if tm_tdt.process_id (txn_index) = "0"b then return; /* nothing to adjust */
	end;

	tm_tdt_entry_ptr = addr (tm_tdt.entry (txn_index));

	call hcs_$validate_processid (tm_tdt_entry.process_id, code);
	dead_process_sw = (code ^= 0);
	kill_sw = tm_tdt_entry.kill_sw;

	if ^dead_process_sw
	     & ^tm_tdt_entry.dead_process_sw		/* flagged as expected to die, same as dead */
	     & ^tm_tdt_entry.abandoned_sw then		/* can't adjust a living process' slot unless abandoned */
	     call ERROR_RETURN (dm_error_$tdt_entry_in_use);

	tm_tdt_entry.daemon_adjust_count = tm_tdt_entry.daemon_adjust_count + 1; /* intend to adjust */

/* If there is still a transaction in the slot, adjust it */

	if tm_tdt_entry.txn_id ^= "0"b then

	     if kill_sw then call KILL_TXN (tm_tdt_entry.txn_id);

	     else call ADJUST_TXN (tm_tdt_entry.txn_id);

/* Tell other managers to clean up their data on this process */
/* If they are all successful (no pending transactions indicated), free the TDT entry */

	if tm_tdt_entry.txn_id = "0"b then do;		/* unless transaction is in an error state */

	     if dead_process_sw then do;

		call before_journal_manager_$adjust_process_id (tm_tdt_entry.process_id, A_code);
						/* Call other managers too? */
		if A_code ^= 0 then do;
		     call dm_misc_util_$log (ERROR_SV, A_code, ME,
			"  Error calling bjm_$adjust_process_id; TDT entry not freed. (index = ^d, pid = ^w)",
			txn_index, tm_tdt_entry.process_id);
		     go to RETURN;
		end;
	     end;

	     tm_tdt_entry.owner_name = "";
	     tm_tdt_entry.event_channel = 0;
	     unspec (tm_tdt_entry.entry_flags) = "0"b;

	     if stacq (tm_tdt_entry.process_id, "0"b, tm_tdt_entry.process_id) then ;
						/* free entry indivisibly */
	end;

RETURN:
	return;
%page;
ADJUST_TXN: proc (A_txn_id);

dcl  (A_txn_id, txn_id) bit (36) aligned;

/* Adjusts a transaction and zeros the transaction portion of the TDT entry. */

	txn_id = A_txn_id;

	call tm_daemon_adopt (txn_id, txn_index, A_code);
	if A_code ^= 0 then do;
	     call dm_misc_util_$log (ERROR_SV, A_code, ME,
		"  (index = ^d, TID = ^o, pid = ^w, owner = ^a, state = ^d) From tm_daemon_adopt.",
		txn_index, fixed (tm_tdt_entry.txn_id), tm_tdt_entry.process_id,
		PERSON_ID (), tm_tdt_entry.state);
	     go to RETURN;
	end;

/* If transaction is in progress (normal), cause tm_cleanup$restart_error to abort it by setting the state.
   Else let tm_cleanup$restart_error finish up the unfinished operation. */

	if tm_tdt_entry.state = TM_IN_PROGRESS_STATE then
	     tm_tdt_entry.state = TM_ABORT_FLUSHING_TXN_STATE;

	call tm_cleanup$restart_error (tm_tdt_ptr, txn_index);
	if tm_tdt_entry.error_sw then do;
	     A_code = tm_tdt_entry.error_code;
	     call dm_misc_util_$log (ERROR_SV, A_code, ME,
		"  Failed to adjust txn ^d, TID = ^o, pid = ^w, owner = ^a, state = ^d",
		txn_index, fixed (tm_tdt_entry.txn_id), tm_tdt_entry.process_id,
		PERSON_ID (), tm_tdt_entry.state);

/* Send mail to owner */

	     send_mail_info.version = 2;
	     send_mail_info.sent_from = "";
	     unspec (send_mail_info.switches) = "0"b;
	     send_mail_info.always_add = "1"b;

	     call transaction_manager_$get_state_info ((tm_tdt_entry.state), op_name, 0);

	     call convert_status_code_ (A_code, "", error_message);

	     call ioa_$rs ("Failed to adjust transaction ^d, TID = ^o, pid = ^w, owner = ^a, state = ^d^/^a: ^a",
		message, message_len,
		txn_index, fixed (tm_tdt_entry.txn_id), tm_tdt_entry.process_id,
		PERSON_ID (), tm_tdt_entry.state, op_name, error_message);

	     call send_mail_ ((tm_tdt_entry.owner_name), substr (message, 1, message_len),
		addr (send_mail_info), 0);

	     send_mail_info.notify, send_mail_info.never_add = "1"b;
	     send_mail_info.always_add = "0"b;
	     call send_mail_ ((tm_tdt_entry.owner_name), "", addr (send_mail_info), 0);
						/* also send mail notification to terminal */
	end;

	call tm_daemon_adopt$tm_daemon_abandon (txn_id, txn_index, code);
	if code ^= 0 then
	     call dm_misc_util_$log (ERROR_SV, code, ME,
		"  (index = ^d, TID = ^o, pid = ^w, owner = ^a, state = ^d) From tm_daemon_adopt$tm_daemon_abandon",
		txn_index, fixed (tm_tdt_entry.txn_id), tm_tdt_entry.process_id,
		PERSON_ID (), tm_tdt_entry.state);

     end ADJUST_TXN;
%page;
ERROR_RETURN: proc (P_code);

dcl  P_code fixed bin (35);

	A_code = P_code;

	if process_id_entry_sw then call dm_misc_util_$log (ERROR_SV, P_code, ME, "(pid = ^w)", process_id);

	else if tm_tdt_entry_ptr = null then call dm_misc_util_$log (ERROR_SV, P_code, ME, "(index = ^d)", txn_index);

	else call dm_misc_util_$log (ERROR_SV, P_code, ME, "(index = ^d, TID = ^o, pid = ^w, owner = ^a, state = ^d)",
		txn_index, fixed (tm_tdt_entry.txn_id), tm_tdt_entry.process_id,
		PERSON_ID (), tm_tdt_entry.state);

	go to RETURN;

     end ERROR_RETURN;
%page;
KILL_TXN: proc (A_txn_id);

dcl  (A_txn_id, txn_id) bit (36) aligned;

/* Kills a transaction and zeros the transaction portion of the TDT entry. */

	txn_id = A_txn_id;

	call tm_daemon_adopt (txn_id, txn_index, A_code);
	if A_code ^= 0 then do;

/* If can't adopt, fake it and kill anyway */

	     dm_data_$current_txn_id = txn_id;
	     dm_data_$current_txn_index = txn_index;

	     call KILL;

	     return;
	end;

/* Write an abort mark (kludge) so bjm can keep track of things. */

	if OK_TO_WRITE_MARK ((tm_tdt_entry.state)) then
	     call before_journal_manager_$write_aborted_mark (txn_id, txn_index, 0);

	call KILL;

	call tm_daemon_adopt$tm_daemon_abandon (txn_id, txn_index, code);
	if code ^= 0 then
	     call dm_misc_util_$log (ERROR_SV, code, ME,
		"  (index = ^d, TID = ^o, pid = ^w, owner = ^a, state = ^d) From tm_daemon_adopt$tm_daemon_abandon",
		txn_index, fixed (tm_tdt_entry.txn_id), tm_tdt_entry.process_id,
		PERSON_ID (), tm_tdt_entry.state);
%page;
KILL: proc ();

	call lock_manager_$unlock_all;

	unspec (tm_tdt_entry.transaction) = "0"b;

	dm_data_$current_txn_id = "0"b;
	dm_data_$current_txn_index = 0;

	call dm_misc_util_$log (INFORM_SV, "Killed transaction ^d, TID = ^o, pid = ^w, owner = ^a",
	     A_txn_index, fixed (tm_tdt_entry.txn_id),
	     tm_tdt_entry.process_id, PERSON_ID ());

     end KILL;

     end KILL_TXN;
%page;
OK_TO_WRITE_MARK: proc (P_state) returns (bit (1));

dcl  (P_state, state) fixed bin;

	state = P_state;

	if state > TM_ERROR_INCREMENT then state = state - TM_ERROR_INCREMENT;

	if state ^= TM_ABORT_UNLOCKING_STATE		/* don't write a second abort mark if possible */
	     & state ^= TM_ABORT_METERING_STATE

	     & state ^= TM_COMMIT_UNLOCKING_STATE	/* also don't abort if commit mark has been written */
	     & state ^= TM_COMMIT_METERING_STATE then return ("1"b);

	else return ("0"b);

     end OK_TO_WRITE_MARK;
%page;
PERSON_ID: proc () returns (char (22));

dcl  name char (32);

	name = tm_tdt_entry.owner_name;
	return (before (name, "."));

     end PERSON_ID;
%page;
SEARCH_FOR_PROCESS: proc (P_process_id) returns (fixed bin);

dcl  P_process_id bit (36);
dcl  txn_index fixed bin;

	do txn_index = 1 to tm_tdt.entry_count;
	     if tm_tdt.process_id (txn_index) = P_process_id then return (txn_index);
	end;

	A_code = dm_error_$process_not_found;
	go to RETURN;

     end SEARCH_FOR_PROCESS;
%page;
/* *************************************************************************
   * SEARCH_FOR_ID - Given a transaction ID, this routine returns that     *
   * transaction's index in the TDT if it exists.  If it doesn't exist,    *
   * zero is returned.					     *
   ************************************************************************* */

SEARCH_FOR_ID: proc (sfi_p_txn_id) returns (fixed bin);

dcl  sfi_p_txn_id bit (36) aligned;
dcl  sfi_txn_index fixed bin;

	do sfi_txn_index = 1 to tm_tdt.entry_count;
	     if tm_tdt.txn_id (sfi_txn_index) = sfi_p_txn_id then return (sfi_txn_index);
	end;
	return (0);
     end SEARCH_FOR_ID;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_states;
%page;
%include dm_log_sv_codes;
%page;
%include send_mail_info;

     end tm_daemon_adjust;




		    tm_daemon_adopt.pl1             03/06/85  0802.6re  03/05/85  0759.9       36504



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_daemon_adopt: proc (A_txn_id, A_txn_index, A_code);

/* DESCRIPTION:

   The entry point tm_daemon_adopt does the necessary creating of journals and
   work spaces prior to operating on a transaction AS IF the calling process
   were the process that created the transaction, i.e., on behalf of another
   process.  It sets various dm_data_ values and then calls bjm_$adopt.  The
   entry point tm_daemon_abandon reverses the process  by  restoring  the
   dm_data_ values to innocuous values (like zero) and calling bjm_$abandon.

/* HISTORY:

Written by Steve Herbst, 10/12/82.
Modified:
12/10/82 by Steve Herbst: Made to call lock_manager_$(adopt abandon).
01/13/83 by Steve Herbst: Added $tm_kill and made $tm_abandon work on the
	user's owwn transaction.
02/22/83 by Steve Herbst: Changed to not call lock_manager_$abandon.
03/14/83 by Steve Herbst: Fixed argument validation.
04/29/83 by Steve Herbst: Changed to call file_manager_$adopt before
	calling before_journal_manager_$adopt.
05/03/83 by Steve Heerbst: Changed $tm_kill to kill immediately if same
	process & transaction not abandoned.
05/04/83 by Steve Herbst: Split tm_adopt into tm_daemon_adopt (this module) and
	tm_abandon (for users to call).
08/11/83 by Steve Herbst: Fixed to restore dm_data_$my_tdt_index since Daemon
	might want to begin a txn later.
10/19/84 by Steve Herbst: Changed in response to audit comments.


/* DECLARATIONS */

/* Parameters */

dcl  A_txn_id bit (36) aligned parameter;
dcl  A_txn_index fixed bin parameter;
dcl  A_code fixed bin (35) parameter;



/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl (txn_id, saved_current_txn_id) bit (36) aligned;
dcl (txn_index, saved_current_txn_index, saved_my_tdt_index) fixed bin;
dcl code fixed bin (35);

/* External */

dcl dm_data_$current_txn_id bit (36) aligned external;
dcl dm_data_$current_txn_index fixed bin external;
dcl dm_data_$my_tdt_index fixed bin external;
dcl dm_data_$tm_tdt_ptr ptr external;

/* Entries */

dcl before_journal_manager_$abandon entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl before_journal_manager_$adopt entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl file_manager_$adopt entry (bit (36) aligned, fixed bin, fixed bin (35));

/* Builtins */

/* Conditions */

dcl cleanup condition;

/* END OF DECLARATIONS */
%page;
	A_code = 0;
	txn_id = A_txn_id;
	txn_index = A_txn_index;
	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	saved_current_txn_id = dm_data_$current_txn_id;
	saved_current_txn_index = dm_data_$current_txn_index;
	saved_my_tdt_index = dm_data_$my_tdt_index;

	on cleanup call RESTORE_DM_DATA ();

	dm_data_$current_txn_id = "0"b;
	dm_data_$current_txn_index = 0;

	call file_manager_$adopt (txn_id, txn_index, A_code);
	if A_code ^= 0 then do;
	     call RESTORE_DM_DATA ();
	     return;
	end;

	call before_journal_manager_$adopt (txn_id, txn_index, A_code);
	if A_code ^= 0 then do;
	     call RESTORE_DM_DATA ();
	     return;
	end;

	dm_data_$current_txn_id = txn_id;
	dm_data_$current_txn_index, dm_data_$my_tdt_index = txn_index;

RETURN:
	return;
%page;
tm_daemon_abandon: entry (A_txn_id, A_txn_index, A_code);

	A_code = 0;
	txn_id = A_txn_id;
	txn_index = A_txn_index;
	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	dm_data_$current_txn_id = "0"b;

	call before_journal_manager_$abandon (txn_id, txn_index, code);
	if code ^= 0 then A_code = code;

	dm_data_$current_txn_index = 0;

	return;
%page;
RESTORE_DM_DATA: proc;

	dm_data_$current_txn_id = saved_current_txn_id;
	dm_data_$current_txn_index = saved_current_txn_index;
	dm_data_$my_tdt_index = saved_my_tdt_index;

end RESTORE_DM_DATA;
%page;
%include dm_tm_tdt;


end tm_daemon_adopt;




		    tm_error_state.pl1              04/04/85  1119.5re  04/04/85  0827.1       25011



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_error_state: proc (A_txn_index, A_state, A_code, A_caller, A_name);

/* DESCRIPTION:
   Puts  a  specified  transaction in a specified error state, and logs
   the error by calling dm_misc_util_$log.   Also  zeroes  dm_data_$current_txn_id  so
   that  protected  data operations will be prohibited until the transaction
   is fixed.
*/
/* HISTORY:

Written by Steve Herbst, 01/14/83.
Modified:
10/18/84 by Steve Herbst: Changed in response to audit comments.
01/04/85 by Steve Herbst: Changed ACTION_DEFAULT_RESTART to ACTION_CANT_RESTART.
01/29/85 by Steve Herbst: Fixed to not zero dm_data_$current_txn_id.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/

/* DECLARATIONS */

/* Parameters */

dcl  A_txn_index fixed bin parameter;
dcl  A_state fixed bin parameter;
dcl  A_code fixed parameter;
dcl  A_caller char (*) parameter;
dcl  A_name char (*) parameter;


/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl txn_index fixed bin;

/* External */

dcl dm_data_$current_txn_id bit (36) aligned ext;
dcl dm_data_$tm_tdt_ptr ptr ext;
dcl dm_system_data_$initializer_processid bit (36) aligned ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl dm_misc_util_$log entry options (variable);
dcl get_process_id_ entry returns (bit (36) aligned);
dcl sub_err_ entry options (variable);

/* Builtins */

dcl (fixed, null) builtin;

/* Conditions */

/* END OF DECLARATIONS */
%page;
	txn_index = A_txn_index;
	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then do;
	     call sub_err_ (error_table_$unimplemented_version, "tm_error_state", ACTION_CANT_RESTART,
		null, 0, "Expected TDT version ^a, received version ^a", TM_TDT_VERSION_3, tm_tdt.version);
	     return;
	end;

	call dm_misc_util_$log (ERROR_SV, A_code, A_caller,
	     "  (index = ^d, TID = ^o, owner = ^a) Calling ^a",
	     txn_index, fixed (tm_tdt.txn_id (txn_index)), tm_tdt.owner_name (txn_index), A_name);

	tm_tdt.state (txn_index) = A_state;

	tm_tdt.error_sw (txn_index) = "1"b;
	tm_tdt.error_code (txn_index) = A_code;

	if get_process_id_ () ^= dm_system_data_$initializer_processid then
	     tm_tdt.daemon_adjust_count (txn_index) = 0;	/* user call; let the daemon try to adjust again */

	return;
%page;
%include dm_tm_tdt;
%page;
%include dm_log_sv_codes;
%page;
%include sub_err_flags;


end tm_error_state;




		    tm_firstref_tv_.alm             03/06/85  0802.6re  03/05/85  0759.9       43272



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"
" DESCRIPTION:
"
"	This is the inner-ring transfer vector for transaction_manager_.
"    tm_ entries that need the DM fref trap set off should be channelled
"    through here.
"
"
" HISTORY:
"
" Written by Jeffrey D. Ives, 01/25/83.
" Modified:
" 03/03/83 by S. Herbst: Changed from dm_tm_gate_ to tm_inner_ring_tv_.
" 03/10/83 by Matthew Pierret: Changed tm_ndle_conditions to
"	    tm_handle_conditions.
" 03/23/83 by S. Herbst: Added begins_off & begins_on.
" 04/06/83 by S. Herbst: Added get_txn_index, needed by lock_manager_.
" 04/20/83 by S. Herbst: Added get_tdt_size & get_txn_info_index.
" 05/04/83 by S. Herbst: Changed abandon_txn and kill_txn targets
"	    to tm_abandon.
" 05/11/83 by S. Herbst: Added adjust_txn with target tm_adjust, changed
"	    adjust_tdt_entry and adjust_process_id to
"	    call tm_daemon_adjust.
" 05/27/83 by S. Herbst: Added get_current_ids.
" 06/06/83 by S. Herbst: Deleted handle_conditions, transaction_manager_
"	    will call it directly.
" 07/29/83 by Lindsey Spratt: Put handle_conditions back.  This is
"	    necessary for the binding to work, since
"	    transaction_manager_ is bound in a different segment from
"	    the one containing tm_handle_conditions.
" 09/07/83 by Lee A. Newcomb:  to add trailing "_" to per-process init.
" 09/15/83 by L. A. Newcomb:  removed tm_handle_conditions, it is called
"	    directly by tm_ as it is supposed to run in the user's curr.
"	    ring of execution and is again bound with tm_. *****
" 01/27/84 by S. Herbst:  Added get_state_description, user_shutdown.
" 03/16/84 by S. Herbst:  Removed get_state_description again
"	    (no longer called through gate).
" 05/03/84 by Lee A. Newcomb:  added $user_shutdown_adjust and
"	    $user_shutdown_free.  Replaced $user_shutdown with the
"	    $user_shutdown_real hack, tm_user_shutdown is still the
"	    target procedure, but the hack gets us into the DM ring where
"	    user shutdown is supposed to be executing.
" 05/31/84 by Lindsey Spratt:  Removed user_shutdown, as the
"	    transaction_manager_ tv was mistakenly transfering to it
"	    through the tm_inner_ring_tv_, but has been fixed to
"	    transfer to tm_user_shutdown_real (the replacement for
"	    tm_user_shutdown) directly.
" 07/31/84 by S. Herbst:  Added the entry $dm_system_in_use for shutdown.
" 08/08/84 by Lee A. Newcomb:  Added $ips_wakeup entry.
" 10/01/84 by Lee A. Newcomb:  Changed $ips_wakeup to only send to one process
"	    and added $ips_wakeup_all to replace old functionality.
" 11/22/84 by Lee A. Newcomb:  Added $per_process_init entry and changed
"	    firstref to transaction_manager_$per_process_init.
" 12/02/84 by Stanford S. Cox: Renamed tm_firstref_tv_ from tm_inner_ring_tv_
" 12/06/84 by R. Michael Tague: Added $bump_all.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	tm_firstref_tv_

	firstref	transaction_manager_$per_process_init

	macro	transfer
	entry	&1
&1:	tra	<&2>|[&3]
	&end


	transfer	abandon_txn,tm_abandon,tm_abandon

	transfer	abort_txn,tm_abort,tm_abort

	transfer	adjust_process_id,tm_daemon_adjust,tm_adjust_process_id

	transfer	adjust_tdt,tm_adjust_tdt,tm_adjust_tdt

	transfer	adjust_tdt_entry,tm_daemon_adjust,tm_adjust_tdt_entry

	transfer	adjust_txn,tm_adjust,tm_adjust

	transfer	begin_txn,tm_begin,tm_begin

	transfer	begins_off,tm_begin,begins_off

	transfer	begins_on,tm_begin,begins_on

	transfer  bump_all,tm_bump_all,tm_bump_all

	transfer	commit_txn,tm_commit,tm_commit

	transfer	get_current_ids,tm_get_current_txn_id,tm_get_current_ids

	transfer	get_current_txn_id,tm_get_current_txn_id,tm_get_current_txn_id

	transfer	get_tdt_size,tm_get_tdt_size,tm_get_tdt_size

	transfer	get_txn_index,tm_get_txn_index,tm_get_txn_index

	transfer	get_txn_info,tm_get_txn_info,tm_get_txn_info

	transfer	get_txn_info_index,tm_get_txn_info,tm_get_txn_info_index

	transfer	ips_wakeup,tm_ips_wakeup,single_process

	transfer	ips_wakeup_all,tm_ips_wakeup,all_processes

	transfer	kill_txn,tm_abandon,tm_kill

	transfer	per_process_init,tm_per_process_init_,tm_per_process_init_

	transfer	recover_after_crash,tm_recover_after_crash,tm_recover_after_crash

	transfer	resume_txn,tm_suspend,tm_resume

	transfer	rollback_txn,tm_rollback,tm_rollback

	transfer	suspend_txn,tm_suspend,tm_suspend

	transfer	dm_system_in_use,tm_get_tdt_size,dm_system_in_use

	transfer	user_shutdown_adjust,tm_user_shutdown_adjust,tm_user_shutdown_adjust

	transfer	user_shutdown_free,tm_user_shutdown_free,tm_user_shutdown_free

	end




		    tm_generate_txn_id.pl1          03/06/85  0802.6re  03/05/85  0759.9       20817



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_generate_txn_id: proc (A_tdt_ptr) returns (bit (36) aligned);

/* DESCRIPTION:

   This  procedure  generates  a unique transaction identifier from the
   TDT's last_uid field.
*/

/* HISTORY:

Written by Steve Herbst 08/06/82
Modified:
08/16/82 by Steve Herbst: Changed to use consolidated dm_tm_tdt.incl.pl1
	with entry declarations.
10/17/84 by Steve Herbst: Changed in response to audit comments.
11/27/84 by Steve Herbst: Changed further in response to audit comments.
*/

/* DECLARATIONS */

/* Parameters */

dcl A_tdt_ptr ptr;

/* Constants */

/* Based */

dcl fixed_bin_uid fixed bin (27) unsigned unaligned based;

/* Static */

/* Automatic */

dcl txn_id bit (36) aligned;
dcl system_id bit (9) unaligned;
dcl (last_uid, new_uid) bit (27) unaligned;

/* External */

dcl dm_data_$system_id bit (9) ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl sub_err_ entry options (variable);

/* Builtins */

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

/* Conditions */

/* END OF DECLARATIONS */
%page;
/* (Since stacq is used to check the TDT's last_uid, the TDT need not be locked.) */

	tm_tdt_ptr = A_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then
	     call sub_err_ (error_table_$unimplemented_version, "tm_generate_txn_id", ACTION_CANT_RESTART,
		null, 0, "Expected TDT version ^a, found ^a.", TM_TDT_VERSION_3, tm_tdt.version);

	system_id = unspec (dm_data_$system_id);

REPEAT_IF_LAST_UID_CHANGES:

	last_uid = tm_tdt.last_uid;

	addr (new_uid) -> fixed_bin_uid = addr (last_uid) -> fixed_bin_uid + 1;
						/* increment the last_uid value from the TDT */

	if stacq (tm_tdt.last_uid, new_uid, last_uid) then txn_id = system_id || new_uid;

	else go to REPEAT_IF_LAST_UID_CHANGES;		/* tm_tdt.last_uid has been changed meanwhile */
						/* by another process */

	return (txn_id);
%page;
%include dm_tm_tdt;
%page;
%include sub_err_flags;


end tm_generate_txn_id;




		    tm_get_current_txn_id.pl1       03/06/85  0802.6re  03/05/85  0759.9       34560



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_get_current_txn_id: proc (A_txn_id, A_code);


/* DESCRIPTION:
   The entry point tm_get_current_txn_id returns the txn_id of the current
   transaction. The entry point tm_get_current_ids does the same but also
   returns the transaction's checkpoint_id and rollback_count. Both entries
   return a nonzero code if the transaction is not IN-PROGRESS:

				txn_id	     code
				------	     ----
   1. Transaction in progress		valid tid	     0
   2. No transaction currently defined	   0	     dm_error_$no_current_transaction
   3. Transaction suspended		valid tid	     dm_error_$transaction_suspended
   4. Transaction left in error state	valid tid	     dm_error_$unfinished_abort
					or:  dm_error_$unfinished_commit
					or:  dm_error_$unfinished_rollback
*/

/* HISTORY:

Written by Steve Herbst, 01/11/83.
Modified:
01/17/83 by Steve Herbst: Changed to return the combinations documented above.
04/08/83 by Steve Herbst: Changed to return dm_error_$no_current_transaction if
	TIX^=0 but TID(TIX)="0"b.
05/27/83 by Steve Herbst: Added $tm_get_current_ids
03/28/84 by Lee A. Newcomb: Changed tm_get_state_info call to be
	  transaction_manager_$get_state_info.
10/17/84 by Steve Herbst: Changed in response to audit comments.
*/


/* DECLARATIONS */

/* Parameters */

dcl  A_txn_id bit (36) aligned parameter;
dcl (A_checkpoint_id, A_rollback_count) fixed bin parameter;
dcl  A_code fixed bin (35) parameter;


/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl txn_index fixed bin;

/* External */

dcl dm_data_$current_txn_index fixed bin ext;
dcl dm_data_$suspended_txn_index fixed bin ext;
dcl dm_data_$tm_tdt_ptr ptr ext;
dcl dm_error_$no_current_transaction fixed bin (35) ext;
dcl dm_error_$transaction_suspended fixed bin (35) ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl transaction_manager_$get_state_info entry (fixed bin, char (*), fixed bin (35));

/* Builtins */

/* Conditions */

/* END OF DECLARATIONS */
%page;
	call GET_TXN_ID (A_txn_id, A_code);

	return;

tm_get_current_ids: entry (A_txn_id, A_checkpoint_id, A_rollback_count, A_code);

	call GET_TXN_ID (A_txn_id, A_code);

	if A_code = dm_error_$no_current_transaction then do;
	     A_checkpoint_id, A_rollback_count = 0;
	     return;
	end;

	A_checkpoint_id = tm_tdt.checkpoint_id (txn_index);
	A_rollback_count = tm_tdt.rollback_count (txn_index);

	return;
%page;
GET_TXN_ID: proc (P_txn_id, P_code);

dcl P_txn_id bit (36) aligned;
dcl P_code fixed bin (35);

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	txn_index = dm_data_$current_txn_index;
	if txn_index = 0 then
	     if dm_data_$suspended_txn_index ^= 0 then do;
		txn_index = dm_data_$suspended_txn_index;
		P_txn_id = tm_tdt.txn_id (txn_index);
		P_code = dm_error_$transaction_suspended;
	     end;
	     else do;
		P_txn_id = "0"b;
		P_code = dm_error_$no_current_transaction;
	     end;
	else do;
	     P_txn_id = tm_tdt.txn_id (txn_index);
	     if P_txn_id = "0"b then P_code = dm_error_$no_current_transaction;
	     else if tm_tdt.error_sw (txn_index) then	/* transaction was left in the middle of an operation */
		call transaction_manager_$get_state_info ((tm_tdt.state (txn_index)), "", P_code);
	     else P_code = 0;			/* in progress */
	end;

	return;

end GET_TXN_ID;
%page;
%include dm_tm_tdt;


end tm_get_current_txn_id;




		    tm_get_tdt_size.pl1             03/06/85  0802.6re  03/05/85  0759.9       22653



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_get_tdt_size: proc (A_highest_txn_index);


/* DESCRIPTION:

   Returns the highest index corresponding to an in-use TDT slot.
*/

/* HISTORY:
Written by Steve Herbst, 04/20/83.
Modified:
07/31/84 by Steve Herbst: Added $tdt_in_use.
08/03/84 by Lee A. Newcomb: Moved style comment and proc statement, and
   renamed loop index i to tdt_index to follow DM project standards.
10/17/84 by Steve Herbst: Changed in response to audit comments.
11/27/84 by Steve Herbst: Changed further in response to audit comments.
*/


/* DECLARATIONS */

/* Parameters */

dcl A_highest_txn_index fixed parameter;


/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl tdt_index fixed bin;

/* External */

dcl dm_data_$tm_tdt_ptr ptr external;
dcl dm_system_data_$initializer_processid bit (36) aligned external;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl sub_err_ entry options (variable);

/* Builtins */

dcl null builtin;

/* Conditions */

/* END OF DECLARATIONS */
%page;
	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then
	     call sub_err_ (error_table_$unimplemented_version, "tm_get_tdt_size", ACTION_CANT_RESTART,
		null, 0, "Expected TDT version ^a, found ^a.", TM_TDT_VERSION_3, tm_tdt.version);

	do tdt_index = tm_tdt.entry_count by -1 to 1 while (tm_tdt.process_id (tdt_index) = "0"b); end;

	A_highest_txn_index = tdt_index;

	return;
%page;
dm_system_in_use: entry () returns (bit (1) aligned);

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then
	     call sub_err_ (error_table_$unimplemented_version, "tm_get_tdt_size$dm_system_in_use",
		ACTION_CANT_RESTART, null, 0, "Expected TDT version ^a, found ^a.",
		     TM_TDT_VERSION_3, tm_tdt.version);

	do tdt_index = 1 to tm_tdt.entry_count;

	     if tm_tdt.process_id (tdt_index) ^= "0"b then
		if tm_tdt.process_id (tdt_index) ^= dm_system_data_$initializer_processid then return ("1"b);
		else if tm_tdt.txn_id (tdt_index) ^= "0"b then return ("1"b);
	end;

	return ("0"b);
%page;
%include dm_tm_tdt;
%page;
%include sub_err_flags;

     end tm_get_tdt_size;




		    tm_get_txn_index.pl1            03/06/85  0802.6re  03/05/85  0759.9       20061



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_get_txn_index: proc (A_txn_id, A_code) returns (fixed bin);

/* DESCRIPTION:

   This  procedure  looks for A_txn_id in the TDT and returns the index
   of the corresponding TDT entry. If there is none, it returns an error code.
*/

/* HISTORY:

Written by Steve Herbst, 08/06/82.
Modified:
08/16/82 by Steve Herbst: Changed to use consolidated dm_tm_tdt.incl.pl1 with
	entry declarations.
09/10/82 by Steve Herbst: Changed for Version 2 TDT structure.
03/14/83 by Steve Herbst: Fixed to reject A_txn_id = "0"b.
04/26/84 by Steve Herbst: Changed to accept "0"b to refer to current txn.


/* DECLARATIONS */

/* Parameters */

dcl A_txn_id bit (36) aligned;
dcl A_code fixed bin (35);



/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl txn_id bit (36) aligned;
dcl txn_index fixed bin;

/* External */

dcl dm_data_$current_txn_index fixed bin ext;
dcl dm_data_$tm_tdt_ptr ptr ext;
dcl dm_error_$no_current_transaction fixed bin (35) ext;
dcl dm_error_$transaction_not_found fixed bin (35) ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

/* Builtins */

/* Conditions */

/* END OF DECLARATIONS */
%page;
	txn_id = A_txn_id;
	if txn_id = "0"b then
	     if dm_data_$current_txn_index = 0 then do;
		A_code = dm_error_$no_current_transaction;
		return (0);
	     end;
	     else return (dm_data_$current_txn_index);

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then do;
	     A_code = error_table_$unimplemented_version;
	     return (0);
	end;

	do txn_index = 1 to tm_tdt.entry_count;

	     if tm_tdt.process_id (txn_index) ^= "0"b then
		if tm_tdt.txn_id (txn_index) = txn_id then do;
		     A_code = 0;
		     return (txn_index);
		end;
	end;

	A_code = dm_error_$transaction_not_found;

	return (0);
%page;
%include dm_tm_tdt;


end tm_get_txn_index;




		    tm_get_txn_info.pl1             03/06/85  0802.6re  03/05/85  0759.9       54189



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_get_txn_info:
     proc (A_txn_id, A_txn_info_ptr, A_code);

/* DESCRIPTION:

	This procedure looks up the specified transaction and returns
     info about it in dm_tm_txn_info.incl.pl1. The $tm_get_txn_info_index
     entry point does the same but uses a txn_index to find the TDT entry.
*/

/* HISTORY:
Written by Steve Herbst, 08/06/82.
Modified:
08/16/82 by Steve Herbst: Changed to use dm_data_$tm_tdt_ptr and consolidated
	  dm_tm_tdt.incl.pl1 with entry declarations.
08/23/82 by Steve Herbst: Fixed to initialize A_code.
09/10/82 by Steve Herbst: Changed for Version 2 TDT structure.
10/15/82 by Steve Herbst: Changed to assume current transaction given "0"b.
01/18/83 by Steve Herbst: Converted to Version 2, adding recent TDT additions.
04/20/83 by Steve Herbst: Added $tm_get_txn_info_index, does same but looks up
	  TIX not TID.
05/10/83 by Steve Herbst: Version 3: Changed to copy some bj_txt fields into
	  txn_info.journal_info (new).
05/27/83 by Steve Herbst: Version 4: Added checkpoint_id & rollback_count.
05/10/84 by Steve Herbst: Fixed to require dm_admin_gate_ access for other
	  user's transactions.
05/15/84 by L. A. Newcomb: Fixed reference to error_table_$bad_version
            (non-existant) to $unimplemented_version and to handle a version 5
            txn_info without returning $unimplemented_version.
10/17/84 by Steve Herbst: Changed in response to audit comments.
*/

/* DECLARATIONS */

/* Parameters */

dcl A_txn_id bit (36) aligned;
dcl A_txn_index fixed bin;
dcl A_txn_info_ptr ptr;
dcl A_code fixed bin (35);

/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl dummy_entry entry variable;
dcl (person, txn_person) char (22);
dcl saved_version char (8);
dcl txn_id bit (36) aligned;
dcl (dot_pos, txn_index) fixed bin;

/* External */

dcl dm_admin_gate_$ entry ext;
dcl dm_data_$bj_txt_ptr ptr ext;
dcl dm_data_$current_txn_index fixed bin ext;
dcl dm_data_$tm_tdt_ptr ptr external;
dcl dm_error_$no_current_transaction fixed bin (35) ext;
dcl dm_error_$not_own_transaction fixed bin (35) ext;
dcl dm_error_$transaction_not_found fixed bin (35) ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl tm_get_txn_index entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);
dcl user_info_ entry (char (*));

/* Builtins */

dcl (index, substr, unspec) builtin;

/* Conditions */

dcl linkage_error condition;

/* END OF DECLARATIONS */
%page;
	A_code = 0;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version);

	if A_txn_id = "0"b then			/* use current txn */
	     if dm_data_$current_txn_index = 0 then call ERROR_RETURN (dm_error_$no_current_transaction);
	     else do;
		txn_index = dm_data_$current_txn_index;
		txn_id = tm_tdt.txn_id (dm_data_$current_txn_index);
	     end;
	else do;
	     txn_id = A_txn_id;
	     txn_index = tm_get_txn_index (txn_id, A_code);
	     if A_code ^= 0 then return;
	end;

	go to COMMON;


tm_get_txn_info_index: entry (A_txn_index, A_txn_info_ptr, A_code);

	A_code = 0;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version);

	txn_index = A_txn_index;

	if txn_index < 1 | txn_index > tm_tdt.entry_count then call ERROR_RETURN (dm_error_$transaction_not_found);

	txn_id = tm_tdt.txn_id (txn_index);

COMMON:
	txn_info_ptr = A_txn_info_ptr;

	if txn_info.version ^= TXN_INFO_VERSION_5 then call ERROR_RETURN (error_table_$unimplemented_version);

/* Require dm_admin_gate_ access if not own transaction */

	dot_pos = index (tm_tdt.owner_name (txn_index), ".");
	if dot_pos = 0 then txn_person = tm_tdt.owner_name (txn_index);
	else txn_person = substr (tm_tdt.owner_name (txn_index), 1, dot_pos - 1);
	call user_info_ (person);
	if txn_person ^= person then do;

	     on linkage_error call ERROR_RETURN (dm_error_$not_own_transaction);

	     dummy_entry = dm_admin_gate_$;

	     revert linkage_error;
	end;

	txn_info.txn_id = txn_id;
	txn_info.txn_index = txn_index;
	txn_info.mode = tm_tdt.mode (txn_index);
	txn_info.state = tm_tdt.state (txn_index);
	txn_info.error_code = tm_tdt.error_code (txn_index);
	txn_info.checkpoint_id = tm_tdt.checkpoint_id (txn_index);
	txn_info.rollback_count = tm_tdt.rollback_count (txn_index);
	txn_info.owner_process_id = tm_tdt.process_id (txn_index);
	txn_info.owner_name = tm_tdt.owner_name (txn_index);
	txn_info.date_time_created = tm_tdt.date_time_created (txn_index);
	txn_info.dead_process_sw = tm_tdt.dead_process_sw (txn_index);
	txn_info.suspended_sw = tm_tdt.suspended_sw (txn_index);
	txn_info.error_sw = tm_tdt.error_sw (txn_index);
	txn_info.abandoned_sw = tm_tdt.abandoned_sw (txn_index);
	txn_info.kill_sw = tm_tdt.kill_sw (txn_index);

/* Really need a bjm_ entry point that returns the following information.
   Transaction manager shouldn't look in the BJ TXT */

	bj_txt_ptr = dm_data_$bj_txt_ptr;

	txn_info.bj_uid = bj_txt.bj_uid (txn_index);
	txn_info.bj_oid = bj_txt.bj_oid (txn_index);
	txn_info.last_completed_operation = bj_txt.last_completed_operation (txn_index);
	txn_info.first_bj_rec_id = bj_txt.first_bj_rec_id (txn_index);
	txn_info.last_bj_rec_id = bj_txt.last_bj_rec_id (txn_index);
	txn_info.n_rec_written = bj_txt.n_rec_written (txn_index);
	txn_info.n_bytes_written = bj_txt.n_bytes_written (txn_index);
RETURN:
	return;
%page;
ERROR_RETURN: proc (P_code);

dcl P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

end ERROR_RETURN;
%page;
%include dm_bj_txt;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_txn_info;


end tm_get_txn_info;




		    tm_ips_wakeup.pl1               03/06/85  0802.6re  03/05/85  0759.9       47106



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

/* DESCRIPTION:

	The tm_ips_wakeup sends a (Data Management) IPS to a current user of
     a DMS.  At this writing, the only valid DM IPS is dm_shutdown_scheduled_.
     We  do not currently lock the TDT.  Note: the current caretaker Daemon of
     the DMS is never sent an IPS.

	The first entry, $all_processes, walks the TDT looking for processes
     using  the DMS and then sends the IPS.  The other entry, $single_process,
     sends  the  IPS  to  only  one process as specified by the caller; if the
     process is not in the TDT, the IPS is NOT sent.

	A  call  to  sub_err_  will  result if the TDT is not the version we
     expect it to be.
*/

/* HISTORY:

Written by Lee A. Newcomb, 08/07/84.
Modified:
09/17/84 by Lee A. Newcomb:  Added check of TDT version, fixed bad format
            comment, and corrected DESCRIPTION section.
10/01/84 by Lee A. Newcomb:  Renamed original program to be tm_ips_wakeup to
	  correspond to the TV entry calling it, changed original program to
	  be the $all_processes entry, added the $single_process entry, and
	  changed CHECK_VERSION to use sub_err_ to report an error.
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */

tm_ips_wakeup$all_processes:
   proc (p_ips_name, p_dm_system_in_use);

/* START OF DECLARATIONS */
/* Parameter */
dcl  (
     p_ips_name			char (*),		/*the name of the IPS to send to each process using the DMS.*/
     p_dm_system_in_use		bit (1) aligned,	/* used by $all_processes entry */
     p_process_id			bit (36) aligned	/* for $single_process */
     )				parameter;

/* Automatic */
dcl  (
     dm_system_in_use		bit (1) aligned init ("0"b),
						/* active users/txns in DMS */
     ips_name			char (32),	/* parameter copy */
     process_id			bit (36) aligned,	/* parameter copy */
     tdt_index			fixed bin		/* to loop through TDT */
     )				automatic;

/* Based */
/* Builtin */
dcl  null				builtin;

/* Constant */
dcl  (
     myname			char (32) init ("tm_ips_wakeup")
     )				int static options (constant);

/* Entry */
dcl  (
     dm_hphcs_$ips_wakeup		entry (bit (36) aligned, char (*)),
     sub_err_			entry () options (variable)
     )				external;

/* External */
dcl  (
     dm_data_$tm_tdt_ptr		ptr,
     dm_system_data_$initializer_processid
				bit (36) aligned,
     error_table_$unimplemented_version fixed bin (35)
     )				external;

/* END OF DECLARATIONS */
%page;
   ips_name = p_ips_name;				/* copy parameter for use */
   tm_tdt_ptr = dm_data_$tm_tdt_ptr;			/* and find TDT */
   call CHECK_VERSION (tm_tdt.version, (TM_TDT_VERSION_3), "tm_tdt");
						/* if return, then OK */

FIND_PROCESSES_TO_SIGNAL:
   do tdt_index = 1 to tm_tdt.entry_count;

      if tm_tdt.process_id (tdt_index) ^= "0"b then
         if tm_tdt.process_id (tdt_index)
	    ^= dm_system_data_$initializer_processid then
SEND_SIGNAL:
	  do;
	  call dm_hphcs_$ips_wakeup (tm_tdt.process_id (tdt_index), ips_name)
	       ;
	  dm_system_in_use = "1"b;
         end SEND_SIGNAL;
         else if tm_tdt.txn_id (tdt_index) ^= "0"b then	/* Daemon adjusting a txn */
	  dm_system_in_use = "1"b;			/* do not send IPS to Daemon */
   end FIND_PROCESSES_TO_SIGNAL;

   p_dm_system_in_use = dm_system_in_use;

MAIN_RETURN:
   return;

/* end tm_ips_wakeup$all_processes; */


tm_ips_wakeup$single_process:
   entry (p_ips_name, p_process_id);

   ips_name = p_ips_name;				/* copy parameters */
   process_id = p_process_id;
   if process_id = dm_system_data_$initializer_processid then
      call RETURN;					/* we don't allow this */

   tm_tdt_ptr = dm_data_$tm_tdt_ptr;			/* and find TDT */
   call CHECK_VERSION (tm_tdt.version, (TM_TDT_VERSION_3), "tm_tdt");

/* dm_system_in_use in $single_process tells if user is active */
TRY_TO_FIND_SINGLE_USER:				/* or how to do a pick-up */
   do tdt_index = 1 to tm_tdt.entry_count while (^dm_system_in_use);
      if tm_tdt.process_id (tdt_index) = process_id then
         dm_system_in_use = "1"b;
   end TRY_TO_FIND_SINGLE_USER;

   if dm_system_in_use then
SEND_SIGNAL_TO_SINGLE_USER:
      call dm_hphcs_$ips_wakeup (process_id, ips_name);

   return;

/* end tm_ips_wakeup$single_process; */
%page;
RETURN:
   proc ();
   go to MAIN_RETURN;

   end RETURN;



CHECK_VERSION:
   proc (cv_p_input_version, cv_p_expected_version, cv_p_structure_name);

dcl  (
     cv_p_input_version		char (8) aligned,
     cv_p_expected_version		char (8) aligned,
     cv_p_structure_name		char (*)
     )				parameter;

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

   end CHECK_VERSION;
%page;
%include dm_tm_tdt;
%page;
%include sub_err_flags;


   end tm_ips_wakeup$all_processes;




		    tm_per_process_init_.pl1        05/17/85  1651.3re  05/17/85  1328.6      206046




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

/* DESCRIPTION:

	tm_per_process_init_ is the first-reference trap for all Data
     Management (DM) inner ring transfer vectors (*_firstref_tv_.alm),
     except for those which MAY NOT do DM per-process init
     (*_no_firstref_tv_.alm).  There are four parts of this routine:

     1.  Does initialization common to all inner ring DM (replacing
     dm_common_init_).  It initializes dm_data_ cells used by all managers,
     initiates dm_system_data_ in the per-bootload directory.  For testing,
     when get_ring_ () ^= sys_info$data_management_ringno, a fake
     dm_journal_seg_ is initiated.  The real dm_journal_seg_ is not avaliable
     outside of ring 0.  Also, fake versions of dm_hcs_ and dm_hphcs_
     are made known, instead of the real hardcore gates.  IF THIS AND
     STEP 2 HAVE COMPLETED, WE RETURN WITHOUT EXECUTING THE REMAINING 
     STEPS (an internal static variable is used to do this); this is
     because all the DM *_firstref_tv_'s use this program as their
     first-reference trap, but are eventually invoked by this program
     in step 3; steps one and two should not be redone for each time
     the first-reference goes off.

     2.  This step does transaction_manager_ initialization.  It calculates
     dm_data_$tm_tdt_ptr from dm_system_data_$tm_tdt_relp, notifies the
     Daemon about TDT entries for dead processes, reserves a TDT entry for
     the process and puts its index in dm_data_$my_tdt_index.  We also set
     the internal static variable to indicate this and the previous step
     have been done; this is necessary since we will set off the first
     reference traps of the other DM managers' inner rig TV's with fref
     traps.

     3.  Calls the other inner ring managers' initialization routines.

     4.  Notifies the DM caretaker Daemon if the process running this
     first-reference trap needs to be sent the dm_shutdown_scheduled_ IPS.
     If no DM shutdown is scheduled, we skip this step.

	There are two methods of error reporting from this module.
     Because it is the target of all DM first-reference traps, we can only
     use signals to report errors.  We use sub_err_ calls to report errors
     which should not happen (or which the Daemon should have picked up on
     in per-system initialization, at least).  An example is an invalid
     Transaction Definition Table (TDT) version.  This is all handled in
     the internal procedure ERROR_RETURN.  We also use sub_err_ to warn
     a person testing DMS in the user ring, with default restart.

	The second error case is when no DMS exists for the process to
     use; and is reported via the dm_not_available_ condition.  This may
     happen when there is no DMS bootload, the DMS has been shutdown, or
     there is no room in the TDT to record the required data about the
     process starting its use of DM.  The process recorded as the
     initializer process in dm_system_data_ is given more flexibility since
     it may be bringing up or shutting down the system; normal users will
     always take an error when the DMS state in dm_system_data_ does not
     indicate running.  All DM commands should handle the dm_not_available_
     condition, call transaction_manager_$user_shutdown, and report the
     error to the user.  This program handles dm_not_available_ by
     terminating any reference names it has initiated and deleting the event
     channel it has created.

	NOTES	NOTES	NOTES	NOTES
	If this procedure is executed in a ring greater than the DM ring,
     we simply return as we can only do init in the DM ring.  We use the
     read bracket of dm_gate_ as the indicator of the DM ring in case the
     user is running a test DMS.
	In the clean up of this procedure, we try to terminate various
     things we may have initiated (e.g., dm_hcs_fake_ with refname of
     dm_hcs_, dm_system_data_).  We must take care to do any terminations
     as dm_misc_util_$terminate_dm does; we MAY NOT call the dm_misc_util_
     entry as it would terminate the firstref modules, causing the linker
     to fail when it tries to do the same thing when we unwind.
*/

/* HISTORY:

Written by Steve Herbst, 08/16/82.
Modified:
09/09/82 by Steve Herbst: Added code to find dead processes and reserve
	  a TDT entry for the process.
11/01/82 by Steve Herbst: Changed to call dm_send_request_$adjust_tdt when
	  it finds a dead process.
11/01/82 by Steve Herbst: Also changed to set up an event channel
	  and put its id in the TDT entry.
11/22/82 by Steve Herbst: Made to zero dm_data_$suspended_txn_(id index).
11/22/82 by Steve Herbst: Fixed to call dm_send_request_$adjust_txn only
	  if txn_id (i) ^= "0"b.
12/07/82 by Steve Herbst: Changed to call tm_adjust_tdt rather than duplicate
	  its code to check dead processes.
01/12/83 by Steve Herbst: Made to store process' Person.Project in the TDT entry.
03/03/83 by Steve Herbst: Changed for new initialization scheme.
03/07/83 by Steve Herbst: Changed to set validation level to current ring.
09/07/83 by Lee A. Newcomb: Added trailing "_" to main procedure name.
10/17/84 by Steve Herbst: Changed in response to audit comments.
11/20/84 by Lee A. Newcomb:  Merged dm_common_init_ into this module so this
            will be the target of all DM transfer vectors with fref traps.
            Fixed up error handling in general and added signalling of the
            dm_not_available_ condition if no DMS is to be found.  Changed to
            not fail if the new_process_notifications request to the Daemon
            fails.  Also changed to only set validation level where needed.
01/24/84 by R. Michael Tague: Changed the name of dm_send_request_$ entry
            new_process_notifications to new_process_notifies.
01/28/85 by Steve Herbst: Changed to signal dm_not_available_ with the
	  standard structure specifying "DM is not running" and no-restart.
02/04/85 by Steve Herbst: Added dm_not_available_ handler to terminate
	  initiated reference names and delete created event channel.
02/15/85 by Steve Herbst: Addressed audit comment by initializing
	  callers_validation_level to -1 and resetting only if not -1.
03/03/85 by Lee A. Newcomb:  Removed handler of dm_not_available_ condition so
            it would get back to users; changed to do terminations as in
            dm_misc_util_$terminate_dm and to only do term_$single_refname for
            dm_hcs_ and dm_hphcs_ in case user had init'd the fake versions.
03/05/85 by Lee A. Newcomb:  Created CLEAN_UP proc from first half of proc to
            signal dm_not_available_ so the operations therein may be used in
            all cleanup cases.  Fixed to just return if ring of execution is
            greater than DM ring and use cu_$arg_ptr_rel in ERROR_RETURN
            instead of using the arg_list directly.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
05/15/85 by R. Michael Tague: Changed to not try to initiate dm_journal_seg_
            when not testing.
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */
%page;
tm_per_process_init_:
   proc;

/* DECLARATIONS */

/* Parameters */
/* Automatic */
dcl  (
     1 auto_condition_info		aligned like condition_info_header,
     bootload_dir_path		char (168) init (""),
     callers_validation_level		fixed bin init (-1),
     channel_id			fixed bin (71) init (0),
     code				fixed bin (35) init (0),
     current_ring			fixed bin init (-1),
     dir_path			char (168) init (""),
     dm_gate_dir			char (168) init (""),
     dm_gate_dir_length		fixed bin init (0),
     dm_gate_ptr			ptr init (null),
     dm_hcs_fake_ptr		ptr init (null),
     dm_hphcs_fake_ptr		ptr init (null),
     dm_system_data_ptr		ptr init (null),
     entry_name			char (32) init (""),
     ldn				fixed bin init (0),
     process_group_id		char (32) init (""),
     ring_brackets			dim (3) fixed bin (3)
				init (-1, -1, -1),
     txn_index			fixed bin init (-1),
     using_test_data_management_system	bit (1) aligned init (""b)
     )				automatic;

/* Based */
/* Builtins */
dcl  (addr, codeptr, index, null, pointer, size, stac, substr, unspec)
				builtin;

/* Condition */
dcl  cleanup			condition;

/* Constants */
dcl  (
     DM_GATE_NAME			char (32) init ("dm_gate_"),
     DM_HCS_FAKE_NAME		char (32) init ("dm_hcs_fake_"),
     DM_HCS_REFNAME			char (32) init ("dm_hcs_"),
     DM_HPHCS_FAKE_NAME		char (32) init ("dm_hphcs_fake_"),
     DM_HPHCS_REFNAME		char (32) init ("dm_hphcs_"),
     DM_JOURNAL_SEG_NAME		char (32) init ("dm_journal_seg_"),
     DM_NOT_AVAILABLE_INFO_VERSION_1	fixed bin init (1),
     DM_PER_PROCESS_INIT_STARTED	char (8) aligned init ("STARTED"),
     DM_PER_PROCESS_INIT_THROUGH_TM_COMPLETE
				char (8) aligned init ("COMPLETE"),
     DM_SYSTEM_DATA_REFNAME		char (32) init ("dm_system_data_"),
     DM_SYSTEM_DATA_ENTRYNAME		char (32) init ("dm_system_data_"),
     IOA_GENERAL_RS_NO_NEW_LINE	bit (1) aligned init ("0"b),
     IOA_GENERAL_RS_DONT_PAD		bit (1) aligned init ("1"b),
     MYNAME			char (32) init ("tm_per_process_init_")
     )				internal static options (constant);

/* Entry */
dcl  (
     before_journal_manager_$per_process_init
				entry (),
     cu_$arg_list_ptr		entry (ptr),
     cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21),
				fixed bin (35), ptr),
     cu_$level_get			entry (fixed bin),
     cu_$level_set			entry (fixed bin),
     dm_misc_util_$log		entry options (variable),
     dm_misc_util_$get_begin_shutdown_time
				entry returns (fixed bin (71)),
     dm_misc_util_$get_bootload_dir	entry (char (*)),
     dm_per_system_$initiate		entry (char (*), char (*), ptr),
     dm_send_request_$new_process_notifies
				entry (fixed bin (35)),
     file_manager_$per_process_init	entry (),
     get_group_id_$tag_star		entry () returns (char (32)),
     get_process_id_		entry () returns (bit (36)),
     get_ring_			entry returns (fixed bin (3)),
     get_system_free_area_		entry () returns (ptr),
     hcs_$fs_get_path_name		entry (ptr, char (*), fixed bin,
				char (*), fixed bin (35)),
     hcs_$get_ring_brackets		entry (char (*), char (*),
				(3) fixed bin (3), fixed bin (35)),
     hcs_$initiate			entry (char (*), char (*), char (*),
				fixed bin (1), fixed bin (2), ptr,
				fixed bin (35)),
     hcs_$make_ptr			entry (ptr, char (*), char (*), ptr,
				fixed bin (35)),
     hcs_$terminate_noname		entry (ptr, fixed bin (35)),
     ioa_$general_rs		entry (ptr, fixed bin, fixed bin,
				char (*), fixed bin (21),
				bit (1) aligned, bit (1) aligned),
     ipc_$create_ev_chn		entry (fixed bin (71), fixed bin (35)),
     ipc_$delete_ev_chn		entry (fixed bin (71), fixed bin (35)),
     lock_manager_$per_process_init	entry (),
     pathname_			entry (char (*), char (*))
				returns (char (168)),
     signal_			entry options (variable),
     sub_err_			entry options (variable),
     term_$refname			entry (char (*), fixed bin (35)),
     term_$single_refname		entry (char (*), fixed bin (35)),
     tm_adjust_tdt			entry
     )				external;

/* External */
dcl  (
     dm_data_$area_ptr		ptr,
     dm_data_$current_txn_id		bit (36) aligned,
     dm_data_$current_txn_index	fixed bin,
     dm_data_$dm_journal_segp		ptr,
     dm_data_$initialization_state	char (8) aligned,
     dm_data_$my_process_id		bit (36),
     dm_data_$my_tdt_index		fixed bin,
     dm_data_$suspended_txn_id	bit (36) aligned,
     dm_data_$suspended_txn_index	fixed bin,
     dm_data_$tm_tdt_ptr		ptr,
     dm_system_data_$,
     dm_system_data_$current_dm_state	char (4) aligned,
     dm_system_data_$initializer_name	char (32) aligned,
     dm_system_data_$tm_tdt_relp	bit (18),
     error_table_$unimplemented_version fixed bin (35),
     sys_info$data_management_ringno	fixed bin
     )				external static;

/* END OF DECLARATIONS */
%page;
   current_ring = get_ring_ ();

RETURN_IF_HIGHER_THAN_DM_RING:
   do;

      call hcs_$make_ptr (codeptr (tm_per_process_init_), DM_GATE_NAME, "",
	 dm_gate_ptr, code);
      if dm_gate_ptr = null () then
         call ERROR_RETURN (code, "^/Returned by hcs_$make_ptr for ^a.",
	    DM_GATE_NAME);

      call hcs_$fs_get_path_name (dm_gate_ptr, dm_gate_dir, dm_gate_dir_length,
	 "" /* already know dm_gate_'s name */, code);
      if code ^= 0 then
         call ERROR_RETURN (code,
	    "^/Returned by hcs_$fs_get_path_name using ^p.", dm_gate_ptr);

      call hcs_$get_ring_brackets (substr (dm_gate_dir, 1, dm_gate_dir_length),
	 DM_GATE_NAME, ring_brackets, code);
      if code ^= 0 then
         call ERROR_RETURN (code, "^/Cannot get the ring brackets of ^a.",
	    pathname_ (dm_gate_dir, DM_GATE_NAME));

      if current_ring > ring_brackets (2) then		/* nothing to do */
         call RETURN ();

   end RETURN_IF_HIGHER_THAN_DM_RING;


IS_GENERAL_AND_TM_SETUP_DONE:
   do;

/* See if this is another DM inner ring transfer vector's first reference */
/* trap going off after the initial trap being sprung.  If so, we must    */
/* have completed the first two steps and should return.		    */

      if dm_data_$initialization_state
	 = DM_PER_PROCESS_INIT_THROUGH_TM_COMPLETE then	/* steps 1 & 2 are done */
         call RETURN ();
   end IS_GENERAL_AND_TM_SETUP_DONE;

   using_test_data_management_system =
        (current_ring > sys_info$data_management_ringno);
WARN_IF_NOT_IN_REAL_DATA_MANAGEMENT:
   if using_test_data_management_system then
      call sub_err_ (0, MYNAME, ACTION_DEFAULT_RESTART, null (), (0),
	 " CAUTION: You are initiating a ring ^d data management system in which files can not be fully protected.",
	 current_ring);

SETUP_IN_CASE_DM_NOT_AVAILABLE:
   dm_data_$dm_journal_segp = null ();


GENERAL_DM_SETUP:
   do;
      dm_data_$initialization_state = DM_PER_PROCESS_INIT_STARTED;

      call dm_misc_util_$get_bootload_dir (bootload_dir_path);

      call cu_$level_get (callers_validation_level);
      on cleanup call CLEAN_UP ();
      call cu_$level_set (current_ring);

      call hcs_$initiate (bootload_dir_path, DM_SYSTEM_DATA_ENTRYNAME,
	 DM_SYSTEM_DATA_REFNAME, 0, 0, dm_system_data_ptr, code);
      if dm_system_data_ptr = null () then
         call DM_SYSTEM_NOT_AVAILABLE ();

      process_group_id = get_group_id_$tag_star ();
      if process_group_id = dm_system_data_$initializer_name then
CHECK_SYSTEM_STATE_FOR_DM_DAEMON:
         do;
         if dm_system_data_$current_dm_state ^= DM_SYSTEM_STATE_RUNNING
	    & dm_system_data_$current_dm_state
	    ^= DM_SYSTEM_STATE_INITIALIZING
	    & dm_system_data_$current_dm_state ^= DM_SYSTEM_STATE_RECOVERING
	    & dm_system_data_$current_dm_state
	    ^= DM_SYSTEM_STATE_SHUTDOWN_BEGUN
	    & dm_system_data_$current_dm_state
	    ^= DM_SYSTEM_STATE_SHUTDOWN_BUMP_USERS then
	  call DM_SYSTEM_NOT_AVAILABLE ();
      end CHECK_SYSTEM_STATE_FOR_DM_DAEMON;
      else
CHECK_SYSTEM_STATE_FOR_NORMAL_USERS:
         do;
         if dm_system_data_$current_dm_state ^= DM_SYSTEM_STATE_RUNNING then
	  call DM_SYSTEM_NOT_AVAILABLE;
      end CHECK_SYSTEM_STATE_FOR_NORMAL_USERS;

      dm_data_$area_ptr = get_system_free_area_ ();	/* AKA dm_data_$inner_ring_areap */
      dm_data_$my_process_id = get_process_id_ ();

      if using_test_data_management_system then
INIT_FAKE_HARDCORE_FILES:
         do;
INIT_DM_HCS_FAKE_GATE:
         do;
	  call hcs_$make_ptr (codeptr (tm_per_process_init_),
	       DM_HCS_FAKE_NAME, "", dm_hcs_fake_ptr, code);
	  if dm_hcs_fake_ptr = null () then
	     call ERROR_RETURN (code, "Returned by hcs_$make_ptr for ^a.",
		DM_HCS_FAKE_NAME);

	  call hcs_$fs_get_path_name (dm_hcs_fake_ptr, dir_path, ldn,
	       entry_name, code);
	  if code ^= 0 then
	     call ERROR_RETURN (code,
		"Returned by hcs_$fs_get_path_name using ^p.",
		dm_hcs_fake_ptr);

	  call hcs_$terminate_noname (dm_hcs_fake_ptr, 0);
	  dm_hcs_fake_ptr = null;

	  call hcs_$initiate (dir_path, entry_name, DM_HCS_REFNAME, 0, 0,
	       dm_hcs_fake_ptr, code);
	  if dm_hcs_fake_ptr = null () then
	     call ERROR_RETURN (code,
		"Unable to initiate ^a, with the reference name ^a.",
		pathname_ (dir_path, entry_name), DM_HCS_REFNAME);
         end INIT_DM_HCS_FAKE_GATE;

INIT_DM_HPHCS_FAKE_GATE:
         do;
	  call hcs_$make_ptr (codeptr (tm_per_process_init_),
	       DM_HPHCS_FAKE_NAME, "", dm_hphcs_fake_ptr, code);
	  if dm_hphcs_fake_ptr = null () then
	     call ERROR_RETURN (code, "Returned by hcs_$make_ptr for ^a.",
		DM_HPHCS_FAKE_NAME);

	  call hcs_$fs_get_path_name (dm_hphcs_fake_ptr, dir_path, ldn,
	       entry_name, code);
	  if code ^= 0 then
	     call ERROR_RETURN (code,
		"Returned by hcs_$fs_get_path_name using ^p.",
		dm_hphcs_fake_ptr);

	  call hcs_$terminate_noname (dm_hphcs_fake_ptr, 0);
	  dm_hphcs_fake_ptr = null;

	  call hcs_$initiate (dir_path, entry_name, DM_HPHCS_REFNAME, 0, 0,
	       dm_hphcs_fake_ptr, code);
	  if dm_hphcs_fake_ptr = null () then
	     call ERROR_RETURN (code,
		"Unable to initiate ^a with the reference name ^a.",
		pathname_ (dir_path, entry_name), DM_HPHCS_REFNAME);
         end INIT_DM_HPHCS_FAKE_GATE;

INIT_TESTING_DM_JOURNAL_SEGMENT:
         do;
	  call dm_per_system_$initiate ("dm_journal_seg_", "dm_journal_seg_",
	       dm_data_$dm_journal_segp);
         end INIT_TESTING_DM_JOURNAL_SEGMENT;

      end INIT_FAKE_HARDCORE_FILES;

      call RESET_VALIDATION_LEVEL ();			/* we don't need validaton level set anymore */

   end GENERAL_DM_SETUP;


TRANSACTION_MANAGER_SPECIFIC_SETUP:
   do;

      dm_data_$current_txn_id, dm_data_$suspended_txn_id = "0"b;
      dm_data_$current_txn_index, dm_data_$suspended_txn_index = 0;

      dm_data_$tm_tdt_ptr, tm_tdt_ptr = pointer (addr (dm_system_data_$),
						/* TDT is allocated in dm_system_data_ segment */
	 dm_system_data_$tm_tdt_relp);

      if tm_tdt.version ^= TM_TDT_VERSION_3 then
         call ERROR_RETURN (error_table_$unimplemented_version,
	    "Expected version ^a of TDT, received ^a.", TM_TDT_VERSION_3,
	    tm_tdt.version);

CHECK_FOR_AND_CLEANUP_DEAD_PROCESSES:
      call tm_adjust_tdt ();

      dm_data_$my_tdt_index = 0;
FIND_FREE_TDT_ENTRY:
      do txn_index = 1 to tm_tdt.entry_count while (dm_data_$my_tdt_index = 0);

         tm_tdt_entry_ptr = addr (tm_tdt.entry (txn_index));

         if stac (addr (tm_tdt_entry.process_id), dm_data_$my_process_id) then
RESERVE_FREE_TDT_ENTRY:				/* we found one */
	  do;					/* reserve it */
	  unspec (tm_tdt_entry.transaction) = "0"b;	/* just to be safe; entry should be zero already */

	  tm_tdt_entry.owner_name =
	       substr (process_group_id, 1,
	       index (process_group_id, ".*") - 1);

	  call cu_$level_set (current_ring);		/* only needed for channel creation */
	  call ipc_$create_ev_chn (channel_id, code);
	  call RESET_VALIDATION_LEVEL ();
	  if code = 0 then
	     tm_tdt_entry.event_channel = channel_id;

	  dm_data_$my_tdt_index = txn_index;
         end RESERVE_FREE_TDT_ENTRY;
      end FIND_FREE_TDT_ENTRY;

      if txn_index > tm_tdt.entry_count then		/* no free slots */
         call DM_SYSTEM_NOT_AVAILABLE ();

      dm_data_$initialization_state = DM_PER_PROCESS_INIT_THROUGH_TM_COMPLETE;
						/* don't redo the previous work */
   end TRANSACTION_MANAGER_SPECIFIC_SETUP;


DO_OTHER_MANAGERS_SETUP:
   do;
      call lock_manager_$per_process_init ();
      call file_manager_$per_process_init ();
      call before_journal_manager_$per_process_init ();
   end DO_OTHER_MANAGERS_SETUP;

/* ask Daemon to tell us if a shutdown is scheduled */
/* if we fail, we let user continue, but log fact   */
/* Daemon was not present.			  */
   if dm_misc_util_$get_begin_shutdown_time () ^= 0 then
ASK_DAEMON_FOR_SHUTDOWN_IPS:
      do;
      call dm_send_request_$new_process_notifies (code);
      if code ^= 0 then
         call dm_misc_util_$log (LOG_SV, code, MYNAME,
	    "A DMS shutdown is scheduled, but could not tell Daemon to send the dm_shutdown_scheduled_ IPS."
	    );
   end ASK_DAEMON_FOR_SHUTDOWN_IPS;

   call RETURN ();
%page;
MAIN_RETURN:
   return;
%skip (4);
RETURN:
   proc ();

   go to MAIN_RETURN;

   end RETURN;
%skip (4);
ERROR_RETURN:
   proc options (variable);

dcl  (
     er_arg_list_ptr		ptr,
     er_code_ptr			ptr,
     er_message			char (1024),
     er_message_length		fixed bin (21)
     )				automatic;

dcl  (
     er_code			fixed bin (35) based (er_code_ptr),
     er_message_overlay		char (er_message_length)
     )				based;

   call cu_$arg_list_ptr (er_arg_list_ptr);
   call cu_$arg_ptr_rel (1, er_code_ptr, (0), (0), er_arg_list_ptr);
						/* get status code */

   call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_message, er_message_length,
        IOA_GENERAL_RS_DONT_PAD, IOA_GENERAL_RS_NO_NEW_LINE);
   call sub_err_ (er_code, MYNAME, ACTION_CANT_RESTART, null (), 0,
        addr (er_message) -> er_message_overlay);

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

/* We are unwinding out of this module, probably because of	*/
/* the dm_not_available_ condition, or because of a sub_err_*/
/* call or fault.  Cleanup any of various things we may have*/
/* done.  This is an attempt to leave the process address	*/
/* space close to how we found it (or expect it next try).	*/

   call term_$refname (DM_SYSTEM_DATA_REFNAME, 0);
   call term_$refname (DM_JOURNAL_SEG_NAME, 0);
   if dm_hcs_fake_ptr ^= null then
      call term_$single_refname (DM_HCS_REFNAME, 0);
   if dm_hphcs_fake_ptr ^= null then
      call term_$single_refname (DM_HPHCS_REFNAME, 0);
   if channel_id ^= 0 then
      call ipc_$delete_ev_chn (channel_id, 0);		/* shouldn't be necessary, but...*/

   call RESET_VALIDATION_LEVEL ();

   return;
   end CLEAN_UP;
%skip (4);
RESET_VALIDATION_LEVEL:
   proc ();

   if callers_validation_level ^= -1 then
      call cu_$level_set (callers_validation_level);

   return;

   end RESET_VALIDATION_LEVEL;
%page;
DM_SYSTEM_NOT_AVAILABLE:
   proc ();

/* now build condition info struct and tell user no dice */

   unspec (auto_condition_info) = "0"b;
   auto_condition_info.length = size (auto_condition_info);
   auto_condition_info.version = DM_NOT_AVAILABLE_INFO_VERSION_1;
   auto_condition_info.cant_restart = "1"b;
   auto_condition_info.info_string =
        "The Data Management system is not currently running.";

   call signal_ ("dm_not_available_", null, addr (auto_condition_info));

   call ERROR_RETURN (0,
        "Unexpected return from signalling dm_not_available_.");

   end DM_SYSTEM_NOT_AVAILABLE;
%page;
%include condition_info_header;
%page;
%include dm_system_states;
%page;
%include dm_tm_tdt;
%page;
%include dm_log_sv_codes;
%page;
%include sub_err_flags;


   end tm_per_process_init_;




		    tm_recover_after_crash.pl1      04/04/85  1119.5re  04/04/85  0827.2       70146



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_recover_after_crash: proc (A_temp_tdt_ptr, A_bj_txt_ptr, A_code);

/* DESCRIPTION:

     Called at system start-up time, this procedure aborts any unfinished
   transactions left over from the last bootload.  Given by the caller
   (intended to be dm_recovery_) a structure containing transaction info for
   the left-over transactions, it rebuilds the TDT and calls tm_abort for
   each transaction.

     Note: It is only for convenience that we use the tm_tdt and bj_txt
   structures since these structures contain all the currently needed
   fields.  This convention may be changed in the future.
*/

/* HISTORY:

Written by Steve Herbst, 10/12/82.
Modified:
10/27/82 by Steve Herbst: Added A_temp_tdt_ptr arg. & changed to copy from
	  recovery TDT instead of TXT structure.
11/05/82 by Steve Herbst: Added A_code parameter.
11/09/82 by Steve Herbst: Changed to turn on tm_tdt.no_begin teporarily, log
	  errors and clear TDT when done.
11/18/82 by Steve Herbst: Added call to clear_txn_tables entry in
	  before_journal_manager_.
11/06/82 by Steve Herbst: Changed to use state in recovery TDT.
11/17/82 by L. A. Newcomb: Put A_code in the parameter list and fixed
	  before_journal_manager_ calls to pass a code.  Much
	  general fixing up.
03/14/83 by L. A. Newcomb: Call dm_log_ instead of dmsd_logger_.
03/15/83 by L. A. Newcomb: To not destroy tm_tdt.entry_count value.
03/27/83 by L. A. Newcomb: To report how many txns recovered.
03/29/83 by L. A. Newcomb: To report how many txns are to be recovered.
04/29/83 by L. A. Newcomb: Expanded log msg of # of txns to recover to
            include the journal the txns were found in.
05/01/83 by L. A. Newcomb: Added clearing of the tm_tdt state and txn_id
            components so dm_who doesn't think the entries are in use.
06/08/83 by Steve Herbst: Renamed tm_adjust to
	  tm_daemon_adjust$tm_adjust_tdt_entry (bug fix)
10/17/84 by Steve Herbst: Changed in response to audit comments.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/

/* DECLARATIONS */

/* Parameters */

dcl (A_temp_tdt_ptr, A_bj_txt_ptr) ptr parameter;
dcl A_code fixed bin (35) parameter;

/* Constants */

dcl ME char (32) int static options (constant) init ("tm_recover_after_crash");

/* Based */

/* Static */

/* Automatic */

dcl bj_dir char (168);
dcl bj_name char (32);
dcl temp_tdt_ptr ptr;
dcl (new_tdt_count, txn_index) fixed bin;
dcl (code, sentinel_code) fixed bin (35);

/* External */

dcl dm_data_$current_txn_id bit (36) aligned ext;
dcl dm_data_$current_txn_index fixed bin ext;
dcl dm_data_$my_tdt_index fixed bin ext;
dcl dm_data_$tm_tdt_ptr ptr ext;
dcl dm_system_data_$max_n_transactions fixed bin ext;
dcl error_table_$action_not_performed fixed bin (35) ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl before_journal_manager_$clear_txn_tables entry (fixed bin (35));
dcl before_journal_manager_$get_bj_path_from_uid entry (bit (36) aligned, char (*), char (*), fixed bin (35));
dcl before_journal_manager_$rebuild_after_crash entry (ptr, fixed bin (35));
dcl dm_misc_util_$log entry options (variable);
dcl tm_daemon_adjust$tm_adjust_tdt_entry entry (bit (36) aligned, fixed bin, fixed bin (35));

/* Builtins */

dcl clock builtin;

/* Conditions */

/* END OF DECLARATIONS */
%page;
/* Copy input parameters to local and initialize output error code */

	temp_tdt_ptr = A_temp_tdt_ptr;		/* recovery tm_ data */
	bj_txt_ptr = A_bj_txt_ptr;			/* recovery bjm_ data */
	tm_tdt_ptr = dm_data_$tm_tdt_ptr;		/* current bootload tm_ TDT data */
	A_code = 0;				/* error_code */

/* Verify version of the recovery tm_tdt passed to us. */

	if temp_tdt_ptr -> tm_tdt.version ^= TM_TDT_VERSION_3 then do;
	     A_code = error_table_$unimplemented_version;
	     call dm_misc_util_$log (ERROR_SV, A_code, ME, "Version ^a expected, version ^a supplied.",
		temp_tdt_ptr -> tm_tdt.version, TM_TDT_VERSION_3);
	     return;
	end;

	tm_tdt.no_begins = "1"b;			/* prevent new transactions from beginning meanwhile */

/* Get the before journal path for error msgs, and pray we don't need it */

	call before_journal_manager_$get_bj_path_from_uid (bj_txt.bj_uid (1), bj_dir, bj_name, code);
	if code ^= 0 then do;
	     call dm_misc_util_$log (ERROR_SV, code, ME, "Cannot get pathname of before journal to recover.");
	     A_code = code;
	     return;
	end;

/* How many txns are to be recovered? */

	call dm_misc_util_$log (LOG_SV, 0, ME, "^d txns to recover in ^a>^a.",
	     temp_tdt_ptr -> tm_tdt.entry_count, bj_dir, bj_name);

/* Rebuild TDT containing the transactions passed in recovery TDT structure */
/* Note the temp TDT contains the real number of txns to be recovered. */

	new_tdt_count = 0;

	do txn_index = 1 to temp_tdt_ptr -> tm_tdt.entry_count;

	     if temp_tdt_ptr -> tm_tdt.process_id (txn_index) ^= "0"b then do;  /* slot in use */
		new_tdt_count = new_tdt_count + 1;
		if new_tdt_count > tm_tdt.entry_count then do;  /* this is unlikely */
		     call dm_misc_util_$log (ERROR_SV, 0, ME, "TDT too small to hold previous transactions to recover.");
		     return;
		end;
		tm_tdt.entry (new_tdt_count) = temp_tdt_ptr -> tm_tdt.entry (txn_index);
		tm_tdt.entry (new_tdt_count).date_time_created = clock ();
		tm_tdt.entry (new_tdt_count).mode = TM_NORMAL_MODE;
	     end;
	end;

/* Zero unused entries in new TDT */

	do txn_index = (new_tdt_count + 1) to tm_tdt.entry_count;
	     tm_tdt.entry (txn_index).process_id = ""b;		/* the field that counts */
	end;

/* Let before_journal_manager_ rebuild its transaction table(s) also */

	call before_journal_manager_$rebuild_after_crash (bj_txt_ptr, code);
	if code ^= 0 then do;
	     call dm_misc_util_$log (ERROR_SV, code, ME, "Cannot rebuild before journal manager tables.");
	     return;
	end;
%page;
/* Adjust all the transactions */
/* Adopts and abandons are explicit so as to log any failure */

	sentinel_code = 0;

	do txn_index = 1 to tm_tdt.entry_count;

	     dm_data_$current_txn_id = tm_tdt.txn_id (txn_index);
	     dm_data_$current_txn_index, dm_data_$my_tdt_index = txn_index;

	     call tm_daemon_adjust$tm_adjust_tdt_entry (tm_tdt.txn_id (txn_index), txn_index, code);
	     if code ^= 0 then do;
		sentinel_code = code;
		call dm_misc_util_$log (ERROR_SV, code, ME,
		     "Unable to adjust transaction ^o, before journal uid ^a>^a.",
		     tm_tdt.entry (txn_index).txn_id, bj_dir, bj_name);
	     end;
	end;


/* Log errors and clear TDT */

	if sentinel_code ^= 0 then do;		/* report recovery error */
	     A_code = error_table_$action_not_performed;
	     call dm_misc_util_$log (ERROR_SV, sentinel_code, ME, "Recovery errors. Before journal ^a>^a", bj_dir, bj_name);
	end;
	else call dm_misc_util_$log (LOG_SV, 0, ME, "No errors recovering before journal ^a>^a", bj_dir, bj_name);

/* DONE: must free the TDT and TXT entries */
	tm_tdt.process_id,				/* free all process_id and txn_id */
	     tm_tdt.transaction.txn_id = "0"b;		/* entries so dm_who doesn't see anything */
	tm_tdt.transaction.state = 0;			/* dm_who also looks at this */

	call before_journal_manager_$clear_txn_tables (0);

	dm_data_$current_txn_id = "0"b;
	dm_data_$current_txn_index, dm_data_$my_tdt_index = 0;

	tm_tdt.no_begins = "0"b;

	return;
%page;
%include dm_bj_txt;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_modes;
%page;
%include dm_tm_states;
%page;
%include dm_log_sv_codes;


end tm_recover_after_crash;




		    tm_rollback.pl1                 03/06/85  0802.6re  03/05/85  0800.0       63981



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_rollback: proc (A_txn_id, A_checkpoint, A_code);

/* DESCRIPTION:

   This procedure implements transaction_manager_$rollback_txn.
   It calls bjm_$rollback, modifies the TDT entry, and writes a
   rolled-back mark. This scenario is similar to an abort but leaves
   the transaction in the IN-PROGRESS state.
*/

/* HISTORY:

Written by Steve Herbst, 08/27/82.
Modified:
09/10/82 by Steve Herbst: Changed to eliminate locking.
09/23/82 by Lindsey Spratt: Changed to use new lock_manager_ calling sequences.
10/14/82 by Steve Herbst: Changed pfm_ calling sequence and added check for
	funny states.
11/01/82 by Steve Herbst: Changed to turn on txn's error_sw for error states.
11/05/82 by Steve Herbst: Made to set tm_tdt.error_code on error return.
11/05/82 by Steve Herbst: Changed to work on suspended transactions.
01/12/83 by Steve Herbst: Made to log its errors.
01/17/83 by Steve Herbst: Changed to complete previous error rollback, and to
	call tm_error_state.
05/27/83 by Steve Herbst: Made to update checkpoint_id & rollback_count in
	TDT entry.
03/28/84 by Lee A. Newcomb: Changed tm_get_state_info call to be
	  transaction_manager_$get_state_info.
10/18/84 by Steve Herbst: Changed in response to audit comments.
01/29/85 by Steve Herbst: Fixed to ignore dm_error_$file_was_deleted.
02/07/85 by S. Cox: Added fm_$post_transaction call (moved from lm_per_system_).
02/12/85 by Stanford S. Cox:  Removed fm$post_transaction call.
*/

/* DECLARATIONS */

/* Parameters */

dcl  A_txn_id bit (36) aligned parameter;
dcl  A_checkpoint fixed bin parameter;
dcl  A_code fixed bin (35) parameter;

/* Constants */

dcl  ME char (32) int static options (constant) init ("tm_rollback");

/* Based */

/* Static */

/* Automatic */

dcl  op_name char (32);
dcl  txn_id bit (36) aligned;
dcl  txn_index fixed bin;
dcl  (code, op_error_code) fixed bin (35);

/* External */

dcl  dm_data_$current_txn_index fixed bin ext;
dcl  dm_data_$my_process_id bit (36) ext;
dcl  dm_data_$suspended_txn_index fixed bin ext;
dcl  dm_data_$tm_tdt_ptr ptr external;
dcl  dm_error_$file_was_deleted fixed bin (35) ext;
dcl  dm_error_$invalid_current_txn fixed bin (35) ext;
dcl  dm_error_$no_current_transaction fixed bin (35) ext;
dcl  dm_error_$not_own_transaction fixed bin (35) ext;
dcl  dm_error_$transaction_not_current fixed bin (35) ext;
dcl  dm_error_$transaction_suspended fixed bin (35) ext;
dcl  error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl  before_journal_manager_$flush_transaction entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  before_journal_manager_$rollback entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  before_journal_manager_$write_rolled_back_mark entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  lock_manager_$unlock_to_checkpoint entry (fixed bin, fixed bin (35));
dcl  lock_manager_$unlock_all entry;
dcl  file_manager_$flush_modified_ci entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  tm_cleanup entry (ptr, fixed bin);
dcl  tm_cleanup$restart_error entry (ptr, fixed bin);
dcl  tm_error_state entry (fixed bin, fixed bin, fixed bin (35), char (*), char (*));
dcl  transaction_manager_$get_state_info entry (fixed bin, char (*), fixed bin (35));

/* Builtins */

/* Conditions */

dcl  cleanup condition;

/* END OF DECLARATIONS */
%page;
	A_code = 0;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version);

	if dm_data_$current_txn_index = 0 then
	     if dm_data_$suspended_txn_index ^= 0 then call ERROR_RETURN (dm_error_$transaction_suspended);
	     else call ERROR_RETURN (dm_error_$no_current_transaction);

	txn_index = dm_data_$current_txn_index;

	if txn_index < 1 | txn_index > tm_tdt.entry_count then call ERROR_RETURN (dm_error_$invalid_current_txn);

	if A_txn_id = "0"b | A_txn_id = tm_tdt.txn_id (txn_index) then
	     txn_id = tm_tdt.txn_id (txn_index);
	else call ERROR_RETURN (dm_error_$transaction_not_current);

	if tm_tdt.process_id (txn_index) ^= dm_data_$my_process_id then call ERROR_RETURN (dm_error_$not_own_transaction);

	if tm_tdt.state (txn_index) ^= TM_IN_PROGRESS_STATE then do;

	     call transaction_manager_$get_state_info ((tm_tdt.state (txn_index)), op_name, op_error_code);
	     if op_name ^= OP_NAME_ROLLBACK then call ERROR_RETURN (op_error_code);

	     call tm_cleanup$restart_error (tm_tdt_ptr, txn_index); /* finishes the commit if possible */
	     if tm_tdt.error_sw (txn_index) then
		call ERROR_STATE ((tm_tdt.state (txn_index)), tm_tdt.error_code (txn_index), "tm_cleanup");
	     return;
	end;

	on cleanup begin;
	     call tm_cleanup (tm_tdt_ptr, txn_index);
	end;

	tm_tdt.state (txn_index) = TM_ROLLBACK_FLUSHING_TXN_STATE;

	call before_journal_manager_$flush_transaction (txn_id, txn_index, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ROLLBACK_FLUSHING_TXN_ERROR, code, "before_journal_manager_$flush_transaction");

	tm_tdt.state (txn_index) = TM_ROLLBACK_ROLLING_BACK_STATE;

	call before_journal_manager_$rollback (txn_id, txn_index, A_checkpoint, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ROLLBACK_ROLLING_BACK_ERROR, code, "before_journal_manager_$rollback");

	tm_tdt.checkpoint_id (txn_index) = 0;
	tm_tdt.rollback_count (txn_index) = tm_tdt.rollback_count (txn_index) + 1;

	tm_tdt.state (txn_index) = TM_ROLLBACK_FLUSHING_CI_STATE;

	call file_manager_$flush_modified_ci (txn_id, txn_index, code);
	if code ^= 0 then				/* previous rollback may have deleted the file */
	     if code = dm_error_$file_was_deleted then code = 0;
	     else call ERROR_STATE (TM_ROLLBACK_FLUSHING_CI_ERROR, code, "file_manager_$flush_modified_ci");

	tm_tdt.state (txn_index) = TM_ROLLBACK_WRITING_MARK_STATE;

	call before_journal_manager_$write_rolled_back_mark (txn_id, txn_index, A_checkpoint, code);
	if code ^= 0 then
	     call ERROR_STATE (TM_ROLLBACK_WRITING_MARK_ERROR, code, "before_journal_manager_$write_rolled_back_mark");

	tm_tdt.state (txn_index) = TM_ROLLBACK_UNLOCKING_STATE;

	call lock_manager_$unlock_all;


	tm_tdt.state (txn_index) = TM_ROLLBACK_METERING_STATE;

/* Dump meters here */

	tm_tdt.state (txn_index) = TM_IN_PROGRESS_STATE;	/* nothing to clean up now */
RETURN:
	return;
%page;
ERROR_RETURN: proc (P_code);

dcl  P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

     end ERROR_RETURN;
%page;
ERROR_STATE: proc (P_state, P_code, P_name);

dcl  P_state fixed bin;
dcl  P_code fixed bin (35);
dcl  P_name char (*);

	call tm_error_state (txn_index, P_state, P_code, ME, P_name);

	A_code = P_code;

	go to RETURN;

     end ERROR_STATE;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_states;


     end tm_rollback;




		    tm_suspend.pl1                  03/06/85  0802.6re  03/05/85  0800.0       33786



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_suspend: proc (A_code);

/* DESCRIPTION:

   The entry point tm_suspend$tm_suspend suspends the current transaction.
   The entry point tm_suspend$tm_resume resumes the current transaction.
*/

/* HISTORY:

Written by Steve Herbst, 11/05/82.
Modified:
01/20/83 by Steve Herbst: Added cleanup handlers.
03/21/84 by Steve Herbst: Fixed to initialize code argument to zero.
10/18/84 by Steve Herbst: Changed in response to audit comments.
01/04/85 by Steve Herbst: Reformatted history section in response to audit.
*/

/* DECLARATIONS */

/* Parameters */

dcl  A_code fixed parameter;



/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl (current_id, suspended_id) bit (36) aligned;
dcl (current_index, suspended_index) fixed bin;

/* External */

dcl dm_data_$current_txn_id bit (36) aligned ext;
dcl dm_data_$current_txn_index fixed bin ext;
dcl dm_data_$suspended_txn_id bit (36) aligned ext;
dcl dm_data_$suspended_txn_index fixed bin ext;
dcl dm_data_$tm_tdt_ptr ptr ext;
dcl dm_error_$no_current_transaction fixed bin (35) ext;
dcl dm_error_$no_suspended_transaction fixed bin (35) ext;
dcl dm_error_$transaction_in_progress fixed bin (35) ext;
dcl dm_error_$transaction_suspended fixed bin (35) ext;
dcl dm_error_$transactions_out_of_sequence fixed bin (35) ext;
dcl dm_error_$transaction_not_found fixed bin (35) ext;

/* Entries */

dcl tm_get_txn_index entry (ptr, bit (36) aligned, fixed bin (35)) returns (fixed bin);

/* Builtins */

/* Conditions */

dcl cleanup condition;

/* END OF DECLARATIONS */
%page;
	A_code = 0;

	if dm_data_$current_txn_index = 0 & dm_data_$suspended_txn_index = 0 then
	     call ERROR_RETURN (dm_error_$no_current_transaction);

	if dm_data_$suspended_txn_index ^= 0 then
	     if dm_data_$current_txn_index ^= 0 then
		call ERROR_RETURN (dm_error_$transactions_out_of_sequence);
	     else call ERROR_RETURN (dm_error_$transaction_suspended);

	call SETUP ();

	on cleanup begin;

	     tm_tdt.suspended_sw (current_index) = "1"b;

	     call SWITCH ();
	end;

	tm_tdt.suspended_sw (current_index) = "1"b;

	call SWITCH ();
RETURN:
	return;
%page;
tm_resume: entry (A_code);

/* This entry point resumes the currently suspended transaction. */

	A_code = 0;

	if dm_data_$current_txn_index = 0 & dm_data_$suspended_txn_index = 0 then
	     call ERROR_RETURN (dm_error_$no_current_transaction);

	if dm_data_$suspended_txn_index = 0 then call ERROR_RETURN (dm_error_$no_suspended_transaction);

	if dm_data_$current_txn_index ^= 0 then call ERROR_RETURN (dm_error_$transaction_in_progress);

	call SETUP ();

	on cleanup begin;

	     call SWITCH ();

	     tm_tdt.suspended_sw (suspended_index) = "0"b;
	end;

	call SWITCH ();

	tm_tdt.suspended_sw (suspended_index) = "0"b;

	return;
%page;
ERROR_RETURN: proc (P_code);

dcl P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

end ERROR_RETURN;
%page;
SETUP: proc;

	current_id = dm_data_$current_txn_id;
	current_index = dm_data_$current_txn_index;
	suspended_id = dm_data_$suspended_txn_id;
	suspended_index = dm_data_$suspended_txn_index;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

end SETUP;
%page;
SWITCH: proc;

	dm_data_$suspended_txn_id = current_id;
	dm_data_$suspended_txn_index = current_index;
	dm_data_$current_txn_id = suspended_id;
	dm_data_$current_txn_index = suspended_index;

end SWITCH;
%page;
%include dm_tm_tdt;


end tm_suspend;




		    tm_user_shutdown_adjust.pl1     04/04/85  1119.5re  04/04/85  0827.2       60966



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

/* DESCRIPTION:

	This entry walks through the entire TDT adjusting any
     transactions held by the calling process.  The tm_user_shutdown_info
     structure is allocated and filled in by this procedure in an area
     supplied by the calling process (see the dm_tm_shutdown_info.incl.pl1
     include file).  This entry is only available in the DM ring for DM
     user shutdown and assumes its caller (tm_user_shutdown) has guaranteed
     TDT entries owned by the user process will not disappear out from
     under it.  It does not free any TDT entries owned by the process, but
     leaves them for transaction_manager_$user_shutdown_free in a later
     part of user shutdown.  The program has the following steps:

	1) loops through the TDT to find out how many TDT entries the
     calling process owns to allocate the tm_shutdown_info structure.

	2) For each user TDT entry, calls tm_cleanup$restart_error on the
     transaction therein and fills in the shutdown info for that TDT entry.
     If the tm_cleanup call fails, abandons the transaction.
*/

/* HISTORY:

Written by Steve Herbst, 05/01/84.
Modified:
05/10/84 by Lee A. Newcomb:  to match on user process id instead of
	  user name.project to prevent multi-process conflicts.
05/16/84 by S. Herbst:  Changed to adjust TDT entry and add an element
	  to tm_shutdown_info only when there's a transaction.
	  Added "tm_shutdown_info.op_completed = ABANDONED".
10/19/84 by Steve Herbst: Changed in response to audit comments.
02/20/85 by Lee A. Newcomb:  Fixed to call transaction_manager_$get_state_info
            instead of tm_=; the latter is in a different bound module.
02/25/85 by Lee A. Newcomb:  Fixed to not be missing a ";" after the "do" in
            the version check.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
%page;
tm_user_shutdown_adjust:
     proc (A_area_ptr, A_tm_shutdown_info_ptr, A_code);

/* DECLARATIONS */

/* Parameters */

dcl  (A_area_ptr, A_tm_shutdown_info_ptr) ptr parameter;
dcl  A_code fixed bin (35);

/* Constants */

dcl  ME char (32) int static options (constant) init ("tm_user_shutdown_adjust");

/* Based */

dcl  based_area area based;

/* Static */

/* Automatic */
dcl  (
     code fixed bin (35) init (0),
     my_process_id bit (36) init (""b),
     op_name char (32) init (""),
     (txn_index, tix_index, tix_count) fixed bin init (0)
     ) automatic;

/* External */

dcl  dm_data_$tm_tdt_ptr ptr ext;
dcl  error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl  dm_misc_util_$log entry options (variable);
dcl  get_process_id_ entry () returns (bit (36));
dcl  tm_abandon entry (bit (36) aligned, fixed bin (35));
dcl  tm_cleanup$restart_error entry (ptr, fixed bin);
dcl  transaction_manager_$get_state_info entry (fixed bin, char (*), fixed bin (35));

/* Builtins */

dcl  (addr, null, unspec) builtin;

/* Conditions */

dcl  cleanup condition;

/* END OF DECLARATIONS */
%page;
	A_code = 0;
	A_tm_shutdown_info_ptr = null;

	on cleanup call CLEAN_UP;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then do;
	     A_code = error_table_$unimplemented_version;
	     return;
	end;

	my_process_id = get_process_id_ ();		/* to match our TDTE's */

/* Walk through the TDT to see how many entries the user owns. */

	tm_shutdown_alloc_count = 0;

	do txn_index = 1 to tm_tdt.entry_count;
	     if tm_tdt.process_id (txn_index) = my_process_id & ^tm_tdt.abandoned_sw (txn_index) then
		tm_shutdown_alloc_count = tm_shutdown_alloc_count + 1;
	end;

/* Now get storage for the returned info and initialize it. */

	allocate tm_shutdown_info in (A_area_ptr -> based_area) set (tm_shutdown_info_ptr);
	unspec (tm_shutdown_info) = "0"b;
	tm_shutdown_info.version = TM_SHUTDOWN_INFO_VERSION_1;

/* This begin block allocates a temporary array of TDT indices to be */
/* acted upon. This array, not the TDT itself, is looped through when */
/* adjusting transactions since if we need to abandon a transaction, */
/* we don't want to adjust and return shutdown_info about the new slot */
/* created by the abandon. */

ADJUST_USER_TRANSACTIONS: begin;

dcl  tix_array (tm_shutdown_alloc_count) fixed bin;

	     tix_count = 0;

	     do txn_index = 1 to tm_tdt.entry_count;

		tm_tdt_entry_ptr = addr (tm_tdt.entry (txn_index));

		if tm_tdt_entry.process_id = my_process_id & tm_tdt_entry.txn_id ^= "0"b &
		     ^tm_tdt_entry.abandoned_sw then do;
		     tix_count = tix_count + 1;
		     tix_array (tix_count) = txn_index;
		end;
	     end;

	     tm_shutdown_info.count = 0;

	     do tix_index = 1 to tix_count;

		txn_index = tix_array (tix_index);
		tm_tdt_entry_ptr = addr (tm_tdt.entry (txn_index));

		tm_shutdown_info.count = tm_shutdown_info.count + 1;
		tm_shutdown_info.txn_id (tm_shutdown_info.count) = tm_tdt.txn_id (txn_index);

		call transaction_manager_$get_state_info ((tm_tdt_entry.state), op_name, (0));
		if op_name = "commit" then
		     tm_shutdown_info.op_completed (tm_shutdown_info.count) = FINISHED_COMMIT;
		else if op_name = "abort" then
		     tm_shutdown_info.op_completed (tm_shutdown_info.count) = FINISHED_ABORT;
		else do;				/* convert all other unfinished ops and */
						/* in-progress state into an abort */
		     tm_shutdown_info.op_completed (tm_shutdown_info.count) = ABORTED;
		     tm_tdt_entry.state = TM_ABORT_FLUSHING_TXN_STATE;
		end;

		call tm_cleanup$restart_error (tm_tdt_ptr, txn_index);

		tm_shutdown_info.state (tm_shutdown_info.count) = tm_tdt.state (txn_index);
		tm_shutdown_info.error_code (tm_shutdown_info.count) = tm_tdt.error_code (txn_index);

		if tm_tdt_entry.state ^= 0 then do;	/* could not adjust it; let the Daemon try */
		     tm_shutdown_info.op_completed (tm_shutdown_info.count) = ABANDONED;
		     call tm_abandon (tm_tdt_entry.txn_id, code);
		     if code ^= 0 then call dm_misc_util_$log (ERROR_SV, code, ME,
			     "Abandoning TDT entry ^d for user ^a", txn_index, tm_tdt_entry.owner_name);
		end;
	     end;

	end ADJUST_USER_TRANSACTIONS;			/* begin block */

	A_tm_shutdown_info_ptr = tm_shutdown_info_ptr;

	return;
%page;
CLEAN_UP: proc;

	if tm_shutdown_info_ptr ^= null then
	     free tm_shutdown_info in (A_area_ptr -> based_area);

     end CLEAN_UP;
%page;
%include dm_tm_shutdown_info;
%page;
%include dm_tm_tdt;
%page;
%include dm_tm_states;
%page;
%include dm_log_sv_codes;


     end tm_user_shutdown_adjust;




		    tm_user_shutdown_free.pl1       04/04/85  1119.5re  04/04/85  0827.2       27720



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_user_shutdown_free: proc (A_code);

/* DESCRIPTION:

	This program frees any TDT entries held by the calling process.  It
     is only to be called as part of user shutdown just before resetting the
     first reference traps for the DM ring managers.  If an entry is not
     really free (tid ^= 0), the entry is not freed, and an error code is
     returned.
*/

/* HISTORY:

Written by Steve Herbst, 05/01/84.
Modified:
05/10/84 by Lee A. Newcomb: Changed to match on user process id instead of
	  user name.project to prevent multi-process conflicts.
10/23/84 by Steve Herbst: Changed in response to audit comments.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/

/* DECLARATIONS */

/* Parameters */

dcl A_code fixed bin (35) parameter;

/* Constants */

dcl ME char (32) int static options (constant) init ("tm_user_shutdown_free");

/* Automatic */

dcl my_process_id bit (36);
dcl txn_index fixed bin;
dcl code fixed bin (35);

/* External */

dcl dm_data_$tm_tdt_ptr ptr ext;
dcl dm_error_$tdt_entry_not_freed fixed bin (35) ext;
dcl error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl dm_misc_util_$log entry options (variable);
dcl get_process_id_ entry () returns (bit (36));
dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl user_info_ entry (char (*), char (*));

/* Builtins */

dcl (rtrim, stacq, unspec) builtin;

/* Conditions */

/* END OF DECLARATIONS */
%page;
	A_code = 0;

	tm_tdt_ptr = dm_data_$tm_tdt_ptr;

	if tm_tdt.version ^= TM_TDT_VERSION_3 then do;
	     A_code = error_table_$unimplemented_version;
	     call dm_misc_util_$log (ERROR_SV, A_code, ME);
	     return;
	end;

	my_process_id = get_process_id_ ();

	do txn_index = 1 to tm_tdt.entry_count;

	     tm_tdt_entry_ptr = addr (tm_tdt.entry (txn_index));

	     if tm_tdt_entry.process_id = my_process_id & ^tm_tdt_entry.abandoned_sw then do;

		if tm_tdt_entry.txn_id ^= "0"b then do;
		     A_code = dm_error_$tdt_entry_not_freed;
		     call dm_misc_util_$log (ERROR_SV, A_code, ME);
		end;
		else do;
		     tm_tdt_entry.owner_name = "";
		     if tm_tdt_entry.event_channel ^= 0 then do;
			call ipc_$delete_ev_chn (tm_tdt_entry.event_channel, code);
			if code ^= 0 then call dm_misc_util_$log (ERROR_SV, code, ME,
				"Error freeing event channel ^w for user ^a",
				tm_tdt_entry.event_channel, tm_tdt_entry.owner_name);
		     end;

		     unspec (tm_tdt_entry.transaction) = "0"b;

		     if stacq (tm_tdt_entry.process_id, "0"b, tm_tdt_entry.process_id) then ;
						/* free TDT entry indivisibly */
		end;
	     end;
	end;

	return;
%page;
%include dm_tm_tdt;
%page;
%include dm_log_sv_codes;


end tm_user_shutdown_free;

*/
                                          -----------------------------------------------------------


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

*/
