



		    bootload_fs.pl1                 07/20/88  1256.2r w 07/19/88  1535.0      207666



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bootload_fs:
     procedure options (variable);
						/* format: style4,indattr,insnl,delnl */

/* command interface to bootload_fs_ for service use.
   Benson I. Margulies November 1980
   Miscelaneous fixes and renaming, Keith Loepere, May 1984.	*/

dcl  bootload_fs_$init      entry (bit (1) aligned, fixed bin (19), fixed bin (35));
dcl  bootload_fs_$get       entry (char (*), ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  bootload_fs_$put       entry (char (*), ptr, fixed bin (21), bit (1) aligned, fixed bin (35));
dcl  bootload_fs_$list      entry (area (*), ptr, fixed bin (35));
dcl  bootload_fs_$delete    entry (char (*), fixed bin (35));
dcl  bootload_fs_$rename    entry (char (*), char (*), fixed bin (35));

dcl  hcs_$fs_get_seg_ptr    entry (char (*), ptr, fixed bin (35));
dcl  hcs_$make_seg	        entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  initiate_file_	        entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  initiate_file_$create  entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
dcl  terminate_file_        entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  cu_$af_arg_count       entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$add_suffix
		        entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_pdir_	        entry () returns (char (168));
dcl  get_system_free_area_  entry () returns (ptr);
dcl  command_query_	        entry () options (variable);
dcl  com_err_	        entry () options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  mdc_$pvname_info       entry (char (*), bit (36) aligned, char (*), bit (36) aligned, fixed bin, fixed bin (35));
dcl  hphcs_$read_partition  entry (bit (36) aligned, char (*), fixed bin (35), pointer, fixed bin (18), fixed bin (35));
dcl  hphcs_$write_partition entry (bit (36) aligned, char (*), fixed bin (35), pointer, fixed bin (18), fixed bin (35));
dcl  adjust_bit_count_      entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35))
		        ;
dcl  ioa_		        entry () options (variable);
dcl  cv_dec_check_	        entry (char (*), fixed bin (35)) returns (fixed bin (35));

dcl  char_count	        fixed bin (21);
dcl  seg_bits	        bit (bit_count) unal based;
dcl  bit_count_for_abc      fixed bin (35);
dcl  new_part_length        fixed bin (19);
dcl  bit_count	        fixed bin (24);
dcl  part_name	        char (4) unal;
dcl  answer	        char (32) varying;
dcl  pv_name	        char (32);
dcl  lvname	        char (32);
dcl  (t_pvid, lvid)	        bit (36) aligned;
dcl  device_type	        fixed bin;
dcl  code		        fixed bin (35);
dcl  file_name	        char (32);
dcl  dir_name	        char (168);
dcl  entryname	        char (32);
dcl  which_key	        fixed bin;
dcl  ap		        pointer;
dcl  al		        fixed bin (21);
dcl  argument	        char (al) based (ap);
dcl  areap	        pointer;
dcl  force	        bit (1);
dcl  must_be_new	        bit (1) aligned;
dcl  part_length	        fixed bin (18);
dcl  current_argument       fixed bin;
dcl  an_area	        based (areap) area (1024);
dcl  seg_ptr	        pointer;
dcl  n_arguments	        fixed bin;
dcl  n_key_arguments        fixed bin;
dcl  i		        fixed bin;

%page;
%include query_info;
%include bootload_fs_list;
%include access_mode_values;
%include terminate_file;
%page;


dcl  sys_info$max_seg_size  fixed bin (35) ext static;
dcl  (cleanup, bootload_fs_bad_arg_parse)
		        condition;
dcl  (
     error_table_$action_not_performed,
     error_table_$active_function,
     error_table_$bad_arg,
     error_table_$bad_conversion,
     error_table_$inconsistent,
     error_table_$item_too_big,
     error_table_$noentry,
     error_table_$not_act_fnc,
     error_table_$too_many_args
     )		        fixed bin (35) ext static;

dcl  Me		        char (11) init ("bootload_fs") int static options (constant);
dcl  Suffix	        char (7) init ("boot_fs") int static options (constant);

dcl  Write_partition        init (2) fixed bin int static options (constant);

dcl  1 Operations	        (11) int static aligned options (constant),
       2 long_name	        char (32) unal
		        init ("read_partition", "write_partition", "use_partition", "save_partition",
		        "discard_partition", "init_partition", "read_file", "write_file", "list_files", "delete_file",
		        "rename_file"),
       2 medium_name        char (32) unal
		        init ("", "", "", "svpart", "", "", "read", "write", "list", "delete", "rename"),
       2 short_name	        char (32) unal
		        init ("rpart", "wpart", "upart", "spart", "dpart", "ipart", "r", "w", "ls", "dl", "rn"),
       2 min_arguments      init (2, 2, 1, 1, 0, 0, 2, 2, 0, 1, 2) fixed bin,
       2 max_arguments      init (2, 3, 1, 1, 1, 2, 2, 3, 0, 1, 2) fixed bin,
       2 usage	        char (132) unal init ("pv_name part_name",
						/* read_partition */
		        "pv_name part_name",		/* write_partition */
		        "path",			/* use_partition */
		        "path",			/* save_partition */
		        "{-control_arg}",		/* discard_partition */
		        "{-control_arg}",		/* init_partition */
		        "file_name path",		/* read_file */
		        "path file_name",		/* write_file */
		        "",			/* list_files */
		        "file_name",		/* delete_file */
		        "old_file_name new_file_name"); /* rename_file */

dcl  1 static_info	        internal static aligned,
       2 flags	        aligned,
       ( 3 partition_valid,
         3 temp_valid,
         3 pv_info_valid
         )	        bit (1) unal init (""b),
       2 temp	        aligned,
         3 tsp	        pointer,
         3 dir_name	        char (168) unaligned,
         3 entryname        char (32) unal,
       2 pv_info	        aligned,
         3 name	        char (32) unal,
         3 pvid	        bit (36) aligned,
         3 part	        char (4) unal,
         3 length	        fixed bin (35);

dcl  (addr, divide, hbound, index, length, min, null)
		        builtin;


	call cu_$af_arg_count (n_arguments, code);
	if code = error_table_$not_act_fnc
	then code = 0;
	else if code = 0
	then code = error_table_$active_function;
	if code ^= 0 then do;
	     call com_err_ (code, Me);
	     return;
	end;

	if n_arguments = 0 then do;
	     call com_err_$suppress_name (0, Me, "Usage: bootload_fs Key {arguments}");
	     return;
	end;
	call init_arguments;

	call get_next_argument;
	do which_key = 1 to hbound (Operations, 1)
	     while (argument ^= Operations (which_key).long_name & argument ^= Operations (which_key).medium_name
	     & argument ^= Operations (which_key).short_name);
	end;
	if which_key > hbound (Operations, 1) then do;
	     call com_err_ (error_table_$bad_arg, Me, "The ^a keyword does not exist.", argument);
	     return;
	end;
	n_key_arguments = n_arguments - 1;
	if n_key_arguments < Operations (which_key).min_arguments
	     | n_key_arguments > Operations (which_key).max_arguments then do;
	     call com_err_$suppress_name (0, Me, "Usage: bootload_fs ^a ^a", Operations (which_key).long_name,
		Operations (which_key).usage);
	     return;
	end;

	goto Keywords (which_key);			/* frazzle the rope -- from now on its command by command */

%page;


Keywords (2 /* write_partition */):			/* These two parse the arguments identically */
	force = ""b;
	if n_key_arguments = 1 then do;		/* check for -force */
	     call get_this_argument (1);
	     if argument = "-force" | argument = "-fc"
	     then force = "1"b;
	     else do;
		if index (argument, "-") = 1
		then call com_err_ (error_table_$bad_arg, Me, "Invalid control argument ^a.", argument);
		else call com_err_ (error_table_$inconsistent, Me,
			"Both a Pvname and a Partition name must be given.");
	     end;
	end;
	if static_info.pv_info_valid & n_key_arguments = 0
	then goto PART_INFO_KNOWN;			/* saving back where we had it */
						/* else fall through into get code to find out about partition from arguments */

Keywords (1 /* read_partition */):
	call get_next_argument;			/* unspecific, and we know its there */
	pv_name = argument;
	call get_next_argument;
	if length (argument) > 4 then do;
	     call com_err_ (error_table_$bad_arg, Me, "Partition names may be only 4 characters. ^a.", argument);
	     return;
	end;
	part_name = argument;
	call mdc_$pvname_info (pv_name, t_pvid, lvname, lvid, device_type, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Pv ^a.", pv_name);
	     return;
	end;
	call get_part_info (t_pvid, part_name, part_length, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Partition ^a on Pv ^a.", part_name, pv_name);
	     return;
	end;

	if part_length > sys_info$max_seg_size then do;
	     call com_err_ (0, Me,
		"Warning: Partition ^a on Pv ^a, length ^d, is longer than a segment. Only ^d words will be used.",
		part_name, pv_name, part_length, sys_info$max_seg_size);
	end;
	static_info.pv_info.name = pv_name;
	static_info.pv_info.part = part_name;
	static_info.pv_info.length = part_length;
	static_info.pv_info.pvid = t_pvid;
	static_info.pv_info_valid = "1"b;

PART_INFO_KNOWN:
	if ^static_info.partition_valid then do;
	     if which_key = Write_partition then do;
		call com_err_ (error_table_$action_not_performed, Me, "There is no partition to write.");
		return;
	     end;
	     call get_temp;
	end;

/* split functions again */

	goto READ_WRITE (which_key);

READ_WRITE (1):					/* read partition */
	call ioa_ ("Starting read of Partition ^a of Pv ^a.", static_info.pv_info.part, static_info.pv_info.name);
	call hphcs_$read_partition (static_info.pv_info.pvid, static_info.pv_info.part, (0) /* beginning */,
	     static_info.tsp, min (sys_info$max_seg_size, static_info.pv_info.length), code);
						/* read the data to temp seg */
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Could not read partition.");
	     return;
	end;
	call ioa_ ("Read completed.");
	static_info.partition_valid = "1"b;		/* the temp segment now constains a partition */
	return;					/* End of Read_partition */

READ_WRITE (2):					/* write partition */
						/* at this point we supposedly know that there is a partition image in the temp segment. Query and write */
	if ^force then do;
	     query_info.version = query_info_version_4;
	     query_info.yes_or_no_sw = "1"b;
	     call command_query_ (addr (query_info), answer, Me,
		"Writing current partition into the ^a partition of volume ^a. ^/This operation will destroy the current contents of the partition. ^/Do you wish to proceed?"
		, static_info.pv_info.part, static_info.pv_info.name);
	     if answer ^= "yes"
	     then return;
	end;
	call ioa_ ("Starting write to Partition ^a of Pv ^a.", static_info.pv_info.part, static_info.pv_info.name);
	call hphcs_$write_partition (static_info.pv_info.pvid, static_info.pv_info.part, (0) /* beginning */,
	     static_info.tsp, min (static_info.pv_info.length, sys_info$max_seg_size), code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Could not write partition.");
	     return;
	end;
	call ioa_ ("Write completed.");
	return;					/* end of write partition */

%page;

Keywords (3 /* use partition */):
	call get_next_argument;			/* its there */
	seg_ptr = null ();
	on cleanup call clean_seg;
	call expand_pathname_$add_suffix (argument, Suffix, dir_name, entryname, code);
	if code ^= 0
	then go to use_part_error;
	seg_ptr = null ();
	call initiate_file_ (dir_name, entryname, RW_ACCESS, seg_ptr, bit_count, code);
	if seg_ptr = null () then do;
use_part_error:
	     call com_err_ (code, Me, "^a", argument);
	     return;
	end;

	if static_info.partition_valid then do;
	     query_info.yes_or_no_sw = "1"b;
	     query_info.version = query_info_version_4;
	     call command_query_ (addr (query_info), answer, Me,
		"Information in working partition will be lost. ^[^/(copy of Partition ^a of Pv ^a)^;^]^/Do you wish to proceed?"
		, static_info.pv_info_valid, static_info.pv_info.part, static_info.pv_info.name);
	     if answer ^= "yes"
	     then return;
	end;
	static_info.tsp -> seg_bits = seg_ptr -> seg_bits;/* copy to temp segment */
	static_info.partition_valid = "1"b;
	call bootload_fs_$init ("0"b, (0), code);	/* inquire as to whether it is valid to warn early */
	if code ^= 0
	then call com_err_ (code, Me);
	return;					/* end of use partition */

%page;

Keywords (4 /* save partition */):
	if ^static_info.partition_valid then do;
	     call com_err_ (error_table_$action_not_performed, Me, "No working partition to save.");
	     return;
	end;
	call get_next_argument;
	on cleanup call clean_seg;
	call expand_pathname_$add_suffix (argument, Suffix, dir_name, entryname, code);
	if code ^= 0
	then go to save_part_error;
	seg_ptr = null ();
	call initiate_file_$create (dir_name, entryname, RW_ACCESS, seg_ptr, ("0"b), (0), code);
	if seg_ptr = null () then do;
save_part_error:
	     call com_err_ (code, Me, "^a", argument);
	     return;
	end;
	call adjust_bit_count_ ((static_info.temp.dir_name), (static_info.temp.entryname), ""b, bit_count_for_abc, code)
	     ;
	bit_count = bit_count_for_abc;
	if bit_count < 0 then do;
	     call com_err_ (code, Me, "Adjusting bc on temp seg.");
	     call clean_seg;
	end;
	seg_ptr -> seg_bits = static_info.tsp -> seg_bits;/* home */
	call terminate_file_ (seg_ptr, bit_count, TERM_FILE_BC | TERM_FILE_TERM, code);
	if code ^= 0
	then call com_err_ (code, Me, "^a", argument);
	return;					/* end of save partition */

%page;

Keywords (5 /* discard */):				/* throw out all static information, to avoid gratuitous queries and the like */
	force = ""b;
	if n_key_arguments = 1 then do;		/* perhaps -fc */
	     call get_next_argument;
	     if argument = "-fc" | argument = "-force"
	     then force = "1"b;
	     else if index (argument, "-") = 1
	     then call com_err_ (error_table_$bad_arg, Me, "^a.", argument);
	     else call com_err_ (error_table_$inconsistent, Me, "Spurious argument ^a.", argument);
	end;

	if static_info.partition_valid & ^force then do;
	     query_info.version = query_info_version_4;
	     query_info.yes_or_no_sw = "1"b;
	     call command_query_ (addr (query_info), answer, Me, "Do you really want to discard the working partition?")
		;
	     if answer ^= "yes"
	     then return;
	end;
	static_info.partition_valid = ""b;
	static_info.temp_valid = ""b;
	call terminate_file_ (static_info.tsp, 0, TERM_FILE_TRUNC, code);
	static_info.pv_info_valid = ""b;
	return;					/* end of discard-partition */
%page;


Keywords (6 /* init partition */):			/* the two both look for -force */
	new_part_length = -1;
	force = ""b;
	do i = 1 to n_key_arguments;
	     call get_next_argument;
	     if index (argument, "-") = 1 then do;
		if argument = "-force" | argument = "-fc"
		then force = "1"b;
		else do;
		     call com_err_ (error_table_$bad_arg, Me, "^a.", argument);
		     return;
		end;
	     end;
	     else do;				/* has to be a length */
		if new_part_length > -1 then do;
		     call com_err_ (error_table_$too_many_args, Me, "Only one length may be supplied.");
		     return;
		end;
		new_part_length = cv_dec_check_ (argument, code);
		if code ^= 0 then do;
		     call com_err_ (error_table_$bad_conversion, Me, "Unable to convert ^a to an integer.", argument);
		     return;
		end;
	     end;
	     if new_part_length > sys_info$max_seg_size then do;
		call com_err_ (error_table_$item_too_big, Me,
		     "Bootload file partition may not be bigger than a segment.");
		return;
	     end;
	end;					/* have the info */
	if new_part_length = -1
	then new_part_length = sys_info$max_seg_size;
	if static_info.partition_valid & ^force then do;
	     query_info.version = query_info_version_4;
	     query_info.yes_or_no_sw = "1"b;
	     call command_query_ (addr (query_info), answer, Me,
		"Do you really want to reinitialize the working partition?");
	     if answer ^= "yes"
	     then return;
	end;
	call get_temp;
	static_info.partition_valid = "1"b;
	call bootload_fs_$init ("1"b, new_part_length, code);
						/* reinitialize */
	if code ^= 0
	then call com_err_ (code, Me);
	return;					/* end of init partition */
%page;


Keywords (7 /* read file */):
	if ^static_info.partition_valid then do;
	     call com_err_ (error_table_$action_not_performed, Me,
		"No working partition exists. Use init_partition or read_partition.");
	     return;
	end;
	call get_next_argument;			/* file_name */
	file_name = argument;
	call get_next_argument;			/* get the pathname */
	call expand_pathname_ (argument, dir_name, entryname, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "^a.", argument);
	     return;
	end;
	seg_ptr = null ();
	call initiate_file_$create (dir_name, entryname, RW_ACCESS, seg_ptr, ("0"b), (0), code);
	if seg_ptr = null () then do;
	     call com_err_ (code, Me, "^a>^a.", dir_name, entryname);
	     return;
	end;
	call bootload_fs_$get (file_name, seg_ptr, sys_info$max_seg_size * 4, char_count, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "^a", file_name);
	     call clean_seg;
	     return;
	end;
	call terminate_file_ (seg_ptr, char_count * 9, TERM_FILE_BC | TERM_FILE_TERM, code);
	if code ^= 0
	then call com_err_ (code, Me, "^a", argument);
	return;					/* ent of get file */
%page;

Keywords (8 /* write file */):
	if ^static_info.partition_valid then do;
	     call com_err_ (error_table_$action_not_performed, Me,
		"No working partition exists. Use init_partition or read_partition.");
	     return;
	end;
	call get_next_argument;			/* get the pathname */
	call expand_pathname_ (argument, dir_name, entryname, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "^a.", argument);
	     return;
	end;
	seg_ptr = null ();
	call initiate_file_ (dir_name, entryname, R_ACCESS, seg_ptr, bit_count, code);
	if seg_ptr = null () then do;
	     call com_err_ (code, Me, "^a>^a.", dir_name, entryname);
	     return;
	end;
	call get_next_argument;			/* file_name */
	file_name = argument;
	must_be_new = ""b;
	if n_key_arguments = 3 then do;		/* positional, but its only a (capitalist) tool */
	     call get_next_argument;
	     if argument = "-new"
	     then must_be_new = "1"b;
	     else do;
		if index (argument, "-") = 1
		then call com_err_ (error_table_$bad_arg, Me, "^a.", argument);
		else call com_err_ (error_table_$too_many_args, Me, "^a is extraneous.", argument);
		call clean_seg;
		return;
	     end;
	end;
	call bootload_fs_$put (file_name, seg_ptr, divide (bit_count, 9, 21, 0), must_be_new, code);
	if code ^= 0
	then call com_err_ (code, Me, "^a.", file_name);
	call clean_seg;
	return;					/* end of put file */
%page;


Keywords (9 /* list files */):
	if ^static_info.partition_valid then do;
	     call com_err_ (error_table_$action_not_performed, Me, "No working partition exists.");
	     return;
	end;
	areap = get_system_free_area_ ();
	call bootload_fs_$list (an_area, bootload_fs_list_ptr, code);
	if code ^= 0 then do;
	     if code = error_table_$noentry
	     then call ioa_ ("No files.");
	     else call com_err_ (code, Me);
	     return;
	end;
	call ioa_ ("Length^-File Name^/");
	do i = 1 to bootload_fs_list.n_files;
	     call ioa_ ("^d^-^a", bootload_fs_list.files (i).length, bootload_fs_list.files (i).name);
	end;
	free bootload_fs_list;
	return;					/* end of list files */
%page;

Keywords (10 /* delete */):
	if ^static_info.partition_valid then do;
	     call com_err_ (error_table_$action_not_performed, Me, "No working partition exists.");
	     return;
	end;
	call get_next_argument;
	call bootload_fs_$delete (argument, code);
	if code ^= 0
	then call com_err_ (code, Me, "^a", argument);
	return;					/* end of delete */
%page;

Keywords (11 /* rename */):
	if ^static_info.partition_valid then do;
	     call com_err_ (error_table_$action_not_performed, Me, "No working partition exists.");
	     return;
	end;
	call get_next_argument;
	file_name = argument;
	call get_next_argument;
	call bootload_fs_$rename (file_name, argument, code);
	if code ^= 0
	then call com_err_ (code, Me, "^a", file_name);
	return;					/* end of rename */
%page;

clean_seg:
     procedure;

	if seg_ptr ^= null ()
	then call terminate_file_ (seg_ptr, (0), TERM_FILE_TERM, code);
	return;
     end clean_seg;

init_arguments:
     procedure;

dcl  code		        fixed bin (35);

	current_argument = 1;
	return;

get_next_argument:
     entry;

	call cu_$arg_ptr (current_argument, ap, al, code);
	if code ^= 0
	then signal condition (bootload_fs_bad_arg_parse);
	current_argument = current_argument + 1;
	return;

get_this_argument:
     entry (n);

dcl  n		        fixed bin;
	call cu_$arg_ptr (n, ap, al, code);
	if code ^= 0
	then signal condition (bootload_fs_bad_arg_parse);
	return;
     end init_arguments;


get_temp:
     procedure;

dcl  Partition_name	        char (32) static options (constant) init ("bootload_file_partition");
dcl  refname_ptr	        ptr;

	if ^static_info.temp_valid then do;
	     static_info.tsp = null ();
	     static_info.temp.dir_name = get_pdir_ ();
	     static_info.temp.entryname = Partition_name;
	     call hcs_$make_seg (static_info.temp.dir_name, static_info.temp.entryname, Partition_name, RW_ACCESS_BIN,
		static_info.tsp, code);		/* initiate with refname so bootload_fs_ can find */
	     if static_info.tsp = null () then do;
		call com_err_ (code, Me, "Can't initiate working file system.");
		go to RETURN;
	     end;
	     call hcs_$fs_get_seg_ptr (Partition_name, refname_ptr, code);
	     if code ^= 0 | refname_ptr ^= static_info.tsp then do;
		call com_err_ (code, Me, "Refname ^a does not refer to temp file system in [pd].", Partition_name);
		call terminate_file_ (static_info.tsp, 0, TERM_FILE_TRUNC, code);
		go to RETURN;
	     end;
	     static_info.temp_valid = "1"b;
	end;
     end get_temp;

%page;
get_part_info:
     procedure (id, name, n_words, code);

dcl  id		        bit (36) aligned;
dcl  name		        char (4) unal;
dcl  n_words	        fixed bin (18);
dcl  code		        fixed bin (35);

dcl  phcs_$read_disk_label  entry (bit (36) aligned, pointer, fixed bin (35));

	labelp = null ();
	on cleanup
	     begin;
		if labelp ^= null ()
		then free label;
	     end;
	allocate label;
	call phcs_$read_disk_label (id, labelp, code);
	if code ^= 0
	then goto RETURN;
	code = error_table_$noentry;
	do i = 1 to label.nparts;
	     if parts (i).part = name then do;
		n_words = parts (i).nrec * 1024;
		code = 0;
	     end;
	end;
RETURN:
	free label;
	return;

%include fs_vol_label;
     end get_part_info;
RETURN:
	return;
     end bootload_fs;




		    get_flagbox.pl1                 06/01/84  1543.5r w 06/01/84  1426.2       42417



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

/* Modified 9/83 by Keith Loepere for bce_command string */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

get_flagbox: proc;

dcl  af_result_len		        fixed bin;
dcl  af_result_ptr		        ptr;
dcl  arg_count		        fixed bin;
dcl  arg_len		        fixed bin;
dcl  arg_ptr		        ptr;
dcl  code			        fixed bin (35);
dcl  bce_command		        char (128);
dcl  flag_num		        fixed bin;
dcl  flags		        bit (36);
dcl  flags_to_reset		        bit (36) init ("0"b);
dcl  flags_to_set		        bit (36) init ("0"b);
dcl  name			        char (12) init ("get_flagbox");
dcl  not_active_fnc		        bit (1) init ("0"b);
dcl  result		        char (256) var;

dcl  af_result		        char (af_result_len) var based (af_result_ptr);
dcl  arg			        char (arg_len) based (arg_ptr);

dcl  error_table_$badopt	        fixed bin (35) ext;
dcl  error_table_$not_act_fnc	        fixed bin (35) ext;

dcl  active_fnc_err_	        entry options (variable);
dcl  active_fnc_err_$suppress_name    entry options (variable);
dcl  com_err_		        entry options (variable);
dcl  com_err_$suppress_name	        entry options (variable);
dcl  cu_$af_arg_ptr		        entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$af_return_arg	        entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count		        entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr		        entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_		        entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  phcs_$get_bce_command	        entry (char (128));
dcl  phcs_$get_flagbox	        entry (bit (36));
dcl  hphcs_$set_bce_command	        entry (char (128));
dcl  hphcs_$set_flagbox	        entry (bit (36), bit (36));
dcl  ioa_			        entry options (variable);
dcl  requote_string_	        entry (char (*)) returns (char (*));

dcl  substr		        builtin;
%page;
	call cu_$af_return_arg (arg_count, af_result_ptr, af_result_len, code);
	if code ^= 0 then
	     if code = error_table_$not_act_fnc then do;
		not_active_fnc = "1"b;
		code = 0;
	     end;
	if arg_count ^= 1 | code ^= 0 then do;
	     if not_active_fnc then call com_err_$suppress_name (code, name, "Usage is: ^a <flag_name>.", name);
	     else call active_fnc_err_$suppress_name (code, name, "Usage is: ^a <flag_name>.", name);
	     return;
	end;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);

	if arg = "bce_command" then do;
	     call phcs_$get_bce_command (bce_command);
	     result = requote_string_ (bce_command);
	end;
	else do;
	     flag_num = cv_dec_check_ (arg, code);
	     if code ^= 0 then do;
		do flag_num = 1 to 36 while (arg ^= flagbox_flag_names (flag_num)); end;
		if flag_num > 36 then go to fail;
	     end;

	     call phcs_$get_flagbox (flags);
	     if substr (flags, flag_num, 1) then result = "true"; else result = "false";
	end;

	if not_active_fnc then call ioa_ (result);
	else af_result = result;
	return;
%page;
set_flagbox: entry;

	name = "set_flagbox";
	not_active_fnc = "1"b;
	call cu_$arg_count (arg_count, code);
	if arg_count ^= 2 | code ^= 0 then do;
	     call com_err_$suppress_name (code, name, "Usage is: ^a <flag_name> <value>.", name);
	     return;
	end;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);

	if arg = "bce_command" then do;
	     call cu_$arg_ptr (2, arg_ptr, arg_len, code);
	     bce_command = arg;
	     call hphcs_$set_bce_command (bce_command);
	end;
	else do;
	     flag_num = cv_dec_check_ (arg, code);
	     if code ^= 0 then do;
		do flag_num = 1 to 36 while (arg ^= flagbox_flag_names (flag_num)); end;
		if flag_num > 36 then go to fail;
	     end;
	     call cu_$arg_ptr (2, arg_ptr, arg_len, code);

	     if arg = "true" then substr (flags_to_set, flag_num, 1) = "1"b;
	     else if arg = "false" then substr (flags_to_reset, flag_num, 1) = "1"b;
	     else go to fail;

	     call hphcs_$set_flagbox (flags_to_set, flags_to_reset);
	end;
	return;

/* ------------------------------------------------------- */

fail:	code = error_table_$badopt;
	if not_active_fnc then call com_err_ (code, name, arg);
	else call active_fnc_err_ (code, name, arg);
	return;
%page;
%include flagbox_flags;
     end get_flagbox;






		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


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
