



		    build_message_segment.pl1       11/15/82  1837.9rew 11/15/82  1508.8       65133



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


build_message_segment:	proc(xsource_ptr,xobj_ptr, bitcnt);

/* Modified: 17 Dec 1979 to make all return statements in another_string return value	*/
/*		This program is in sad shape and should be rewritten.		*/

dcl (xsource_ptr, xobj_ptr, source_ptr, obj_ptr) ptr, bitcnt fixed bin(24);

dcl 1 object_segment based(obj_ptr),
      2 index_block(0:500),
        3 message_pointer fixed bin(17), /*Pointer to start of message.*/
        3 severity fixed bin(17), /*Severity level for this message*/
        3 len fixed bin(17),  /*Number of characters for this message.*/
      2 message_block char(248000) aligned; /*Text for all messages.*/

dcl (old_seq_number init(0), new_seq_number,i,
	severity_code) fixed bin(17);

dcl xstring char(64) varying aligned, garbage bit(1) aligned;

dcl	ll fixed bin(15);

dcl ioa_ entry options(variable);

dcl ( s_first,s_last,o_current ) fixed bin(17) init (1);

dcl source_string char(256000) aligned based(source_ptr);

dcl old_first fixed bin(17); /*Beginning of string; to facilitate backing up. */

dcl cur_char char(1) aligned;

dcl white_space char(3) static init("
 	");	/* new_lline, space, tab */


dcl NLNL init("

") char(2) int static;

dcl	(index,length,search,substr)  builtin;





	obj_ptr = xobj_ptr;
	source_ptr=xsource_ptr;


	do while(another_message());
	/*Process sequence number.*/
	  garbage=another_string(xstring); /*Get first string*/
	  new_seq_number=0;
		  do ll=1 to length(xstring);
			new_seq_number=new_seq_number*10+index("123456789",substr(xstring,ll,1));
		  end;
	  if new_seq_number > 500
	  then do;
	         call ioa_("Sequence number > 500--fatal error");
	         return;
	       end;
	  if new_seq_number <= old_seq_number
	  then do;
		call ioa_("Message number ^d is out of sequence--fatal error",new_seq_number);
	         return;
	       end;
	  else do i=old_seq_number+1 to new_seq_number-1;
	  /*Set index block entries for missing messages.*/
	         index_block(i).message_pointer = -1;
	         index_block(i).len = 0;
	         index_block(i).severity = 0;
	       end;

	  old_seq_number = new_seq_number; /*Advance old_seq_number.*/




	/*Process Severity Level Code.*/

	 old_first = s_first; /*To permit backing up if no Severity Code.*/

	  if another_string(xstring)
	  then do;  /*Determine and insert severity level code*/
	         if substr(xstring,1,1) = "("  /*Assume "(" adequate*/
	         then do;
	                do i = 2 by 1 while(substr(xstring,i,1) ^= ")" ); end;
	                /*Extract severity code from enclosing parentheses*/
		      severity_code = index("1234",substr(xstring,2,1));
	                if severity_code > 4
	                then do;
			call ioa_("Invalid severity for message ^d--fatal error",new_seq_number);
	                       return;
	                     end;
	                else index_block(new_seq_number).severity
	                 = severity_code;
	              end;
	         else do;
	                index_block(new_seq_number).severity
	                = 2; /*Default value of two.*/
	                s_first = old_first; /*Back up.*/
	              end;
	       end;
	  else do;  /*No more strings after sequence number*/
		call ioa_("Message number ^d is null--fatal error.");
	         return;
	       end;
	/*End of Severity Level Code Processing.*/




	/* Move message text to object segment. */

dcl cum_length fixed bin(17), delim_count fixed bin(17) init(0);
	  cum_length=0;

	  do s_first = s_first by 1 while
	  (substr(source_string,s_first,2)^=NLNL);
		/*Copy message.*/


	    cur_char=substr(source_string,s_first,1);
	     if search(cur_char,white_space) = 1
	    then do;
	           delim_count=delim_count+1;/*Count redundant delimeters.*/
	           if delim_count = 1 
	           then do;
	                  substr(message_block,o_current,1)=" ";
	                  o_current=o_current+1;
	                  cum_length=cum_length+1;
	                end;
	         end;
	    else do;
	           delim_count=0;
	           substr(message_block,o_current,1)=cur_char;
	           o_current=o_current+1;
	           cum_length=cum_length+1;
	         end;

	  end;

	  index_block(new_seq_number).len = cum_length;
	  index_block(new_seq_number).message_pointer
		=o_current-cum_length;
	  s_first=s_first+2; /*Bypass two trailing nl's.*/


	end; /*End of the major "do while(another_message)" block.*/


	/*Close out object segment by filling in remaining
	index block entries with "null" values. */


	do i=old_seq_number+1 to 500;
	  index_block(i).message_pointer = -1;
	  index_block(i).len = 0;
	  index_block(i).severity = 0;
	end;

	/*Compute bit count for return to command.*/

	bitcnt = 3*501*36+9*o_current;

	return;  /*Processing done.*/



	/*Internal procedure to locate next string in text.*/

another_string:	proc(xstring) returns(bit(1));

	/*another_string locates and returns the next string,
	if there is one, in a message, returning with its function
	value set to "1".  If no more strings exist in the message,
	the value is "0".  another_string is entered with s_first
	pointing to the first character following the previous 
	string in the message.*/

dcl xstring char(64) varying aligned;

dcl k fixed bin, skip_comments bit(1);

	if substr(source_string,s_first,2)^=NLNL 
	then do;

	     skip_comments = "1"b;
	     do while(skip_comments);

		/* skip over white space */

		do while(search(substr(source_string,s_first,1),white_space) ^= 0);
		     s_first = s_first + 1;
		     end;

		if substr(source_string,s_first,2) = "/*"
		then do;
		     k = index(substr(source_string,s_first+2),"*/");

		     if k = 0
		     then do;
			call ioa_("Unbalanced comment--fatal error");
			return("0"b);
			end;

		     s_first = s_first + k + 4;
		     end;
		else skip_comments = "0"b;
		end;

	     /* scan until we hit white space */

	     s_last = s_first + 1;
	     do while(search(substr(source_string,s_last,1),white_space) = 0);
		s_last = s_last + 1;
		end;

	     xstring = substr(source_string,s_first,s_last-s_first);
	     s_first = s_last;

	     return("1"b);
	    end;

	return("0"b); /*End of message.*/

	end another_string;



	/*Internal procedure to determine existance of
	another message in the text.*/

another_message:	proc returns(bit(1));

	/*another_message returns with a function value of
	"1" if there is another message in the text; else
	it returns with a value of "0".*/


dcl xstring char(64) varying aligned;


	old_first=s_first; /*To permit backing up, if necessary.*/
	garbage=another_string(xstring);
	if xstring="(end)" then return("0"b);
	else do;
	       s_first=old_first;  /*Back up.*/
	       return("1"b);
	     end;

	end another_message;



	end build_message_segment;




		    compile_messages.pl1            12/01/87  1600.6rew 12/01/87  1558.0       42588



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





/****^  HISTORY COMMENTS:
  1) change(87-06-01,Huen), approve(87-06-01,MCR7696), audit(87-06-17,RWaters),
     install(87-12-01,MR12.2-1005):
     Fix bug 2173: If incorrect number of argument is supplied when invoking
     "compile_messages", a usage message is printed.
                                                   END HISTORY COMMENTS */


compile_messages:	proc;

/* Modified: 29 Apr 1987 by SH to fix bug 2173 - A usage message should
                         be printed when invoking this procedure with
                         incorrect number of argument.
*/

/* Apr29,1987.  This procedure is rewritten so that it accepts any valid
pathname (such as the pathname of the source segment or archive segment).
In addition, the ".message" suffix is added by default if the user does
not supply it. */

/* This procedure accepts a pathname of a "source" segment as an argument.
The source segment which is suffixed by ".message" containing messages
to be reformatted is initialised.  An object segment with the name
object_name is created in the user's working directory and the reformatted
messages are placed into it. */

dcl       my_name char(16) int static options(constant) init("compile_messages");
dcl	arg char(arg_len) based(arg_ptr);
dcl	arg_count fixed bin;
dcl	arg_len fixed bin(21);
dcl	arg_ptr ptr;
dcl	code fixed bin(35);
dcl	dir char(512);
dcl	(entry, comp) char(33);	/* 33 to force trailing blank */
dcl	(object_bc, source_bc) fixed bin(24);
dcl	object_name char(32);
dcl	(source_ptr, obj_ptr, aclinfo) ptr;
dcl	w_dir_path char(168);

dcl	(before, null) builtin;
dcl	cleanup condition;

dcl	build_message_segment external entry (ptr, ptr, fixed bin(24));
dcl	com_err_ external entry options(variable);
dcl	cu_$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_$component_add_suffix entry(char(*), char(*), char(*), char(*), char(*), fixed bin(35));
dcl	get_wdir_ entry() returns(char(168) aligned);
dcl	initiate_file_$component entry(char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl	terminate_file_ entry(ptr, fixed bin(24), bit(*), fixed bin(35));
dcl	tssi_$clean_up_segment entry(ptr);
dcl	tssi_$finish_segment entry(ptr, fixed bin(24), bit(36) aligned, ptr, fixed bin(35));
dcl	tssi_$get_segment entry(char(*), char(*), ptr, ptr, fixed bin(35));

	source_ptr, obj_ptr, aclinfo = null();
	call cu_$arg_count(arg_count, code);
	if code ^= 0 then call error("");
	if arg_count ^= 1 then call error("^/Usage: compile_messages <pathname>");

	call cu_$arg_ptr(1, arg_ptr, arg_len, code);
	if code ^= 0 then call error("");

	call expand_pathname_$component_add_suffix(arg, "message", dir, entry, comp, code);
	if code ^= 0 then call error(arg);

on	cleanup begin;
	     if source_ptr ^= null() then call terminate_file_(source_ptr, 0, "001"b, 0);
	     if aclinfo ^= null() then call tssi_$clean_up_segment(aclinfo);
	  end;

	call initiate_file_$component(dir, entry, comp, "100"b, source_ptr, source_bc, code);
	if code ^= 0 then call error(arg);

	/* Get pathname for current working directory. */

	w_dir_path = get_wdir_();
	if comp = "" then object_name = before(entry, ".message ");
	             else object_name = before(comp, ".message ");

	/* Create an object segment with name object_name and get a pointer to it. */

	call tssi_$get_segment(w_dir_path, object_name, obj_ptr, aclinfo, code);
	if code ^= 0 then call error(object_name);

	/* Reformat messages. */

	call build_message_segment(source_ptr, obj_ptr, object_bc);

	/* Wrap up by setting bit count and access control information
	on the new object segment and terminating the source segment. */

	call tssi_$finish_segment(obj_ptr, object_bc, "1100"b, aclinfo, code);
	if code ^= 0 then call error(object_name);

	call terminate_file_(source_ptr, 0, "001"b, code);
	if code ^= 0 then call error(arg);


error:	proc(str);
dcl	str char(*);

	call com_err_(code, my_name, str);
	goto abort;
end error;

abort:	return;
end compile_messages;




		    gen_pl1_version_.pl1            11/15/82  1837.9rew 11/15/82  1509.2       30564



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


(stringsize):
gen_pl1_version_:
	procedure(pl1_version_struc,RELEASE,code);

/*     Written:  12 Dec 1979 by PCK to generate pl1_version information
	from the installation time (the current clock time) and the
	RELEASE string */

/* parameters */

dcl  RELEASE character(3) varying;
     /* RELEASE = "EXL" for the >experimental_library compiler,
	      = <release_number> for the >system_standard_library compiler */
dcl  1 pl1_version_struc,
	2 pl1_version character(256) varying,
	2 pl1_release character(3) varying;
dcl  code fixed bin(35);

/* external entries */

dcl  ioa_ entry options (variable);
dcl  decode_clock_value_$date_time entry (fixed bin(71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, 
	fixed bin, fixed bin(71), fixed bin, char(3), fixed bin(35));

/* builtins */

dcl  (clock,addr) builtin;

/* internal static */

dcl  day_of_week_string(1:7) character(9) varying int static options(constant) 
     init("Monday","Tuesday","Wednesday","Thursday",
	"Friday","Saturday","Sunday");
dcl  month_string(1:12) character(9) varying int static options(constant)
     init("January","February","March","April","May","June","July","August",
	"September","October","November","December");
dcl  my_name character(16) int static init("gen_pl1_version_") options(constant);

/* conditions */

dcl  (stringsize,error) condition;

/* automatic */

dcl  (clock_reading,microsecond) fixed bin(71);
dcl  (month,day_of_month,year,day_of_week,hour,minute,second) fixed bin;
dcl  time_zone character(3) init("");
dcl  pl1_version_string character(256) varying;
dcl  year_pic picture "9999";
dcl  day_of_month_pic picture "zz";
dcl  hour_pic picture "99";
dcl  minute_pic picture "99";

/* on unit */

	on stringsize
	begin;
	     call ioa_("^a: ^a",my_name,"Stringsize raised.");
	     signal error;
	end;

/* program */

	/* Read system clock and convert to calendar date-time */

	clock_reading = clock();
	call decode_clock_value_$date_time(clock_reading,month,day_of_month
	     ,year,hour,minute,second,microsecond,day_of_week,time_zone,code);

	if code^=0
	then return;

	year_pic = year;
	day_of_month_pic = day_of_month;

	/* Generate a pl1_version_string appropriate for an EXL or SSS compiler */

	if RELEASE ^= "EXL"
	then pl1_version_string = "Multics PL/I Compiler, Release "
		|| RELEASE || ", of " || month_string(month)
		|| " " || ltrim(day_of_month_pic) || ", " || year_pic;
	else do;
		hour_pic = hour;
		minute_pic = minute;
		pl1_version_string = "Experimental PL/I Compiler of "
		     || day_of_week_string(day_of_week) || ", "
		     || month_string(month) || " " || day_of_month_pic
		     || ", " || year_pic || " at " || hour_pic
		     || ":" || minute_pic;
	     end;
	

	/* Fill in pl1_version_struc with version and release info */

	pl1_version = pl1_version_string;
	pl1_release = RELEASE;

	code = 0;
	return;

	end /* gen_pl1_version_ */;




		    generate_compatible.pl1         11/15/82  1837.9rew 11/15/82  1508.9      143460



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


generate_compatible: genc: proc;

/* Automatic */

dcl  linep ptr;
dcl  c1 char (1);
dcl  chars72 char (72);
dcl  new bit (1);
dcl  old bit (1);
dcl  error_phase fixed bin;
dcl  next_term fixed bin;
dcl  next_pr fixed bin;
dcl  pname char (36) var;
dcl  search_name char (36) var;
dcl (i, j, k) fixed bin;
dcl  linel fixed bin;
dcl  tx fixed bin;
dcl  pr_ptrs (20) ptr;
dcl  term_names (20) char (36) var;
dcl 1 symbols (200) aligned,
    2 name char (36) var,
    2 nt_ptr ptr unal,
    2 unused bit (1) aligned;
dcl  ptrs (1) ptr;
dcl  N fixed bin;
dcl  matrix (108, 108) bit (1) unal;
dcl  code fixed bin (35);
dcl  txp ptr;
dcl  rootp ptr;
dcl  temp ptr;
dcl  nsymbols fixed bin;
dcl  stack (108) fixed bin;
dcl  depth fixed bin;
dcl  bits (72) bit (72);
dcl  eof bit (1) aligned;


/* Based */

dcl  line char (linel) based (linep);
dcl  total_buffer char (8000) based (txp);
dcl  chars (10000) char (1) unaligned based;
dcl  area area based;
dcl 1 symbol based,
    2 name char (36) var,
    2 nt_ptr ptr unal;


dcl 1 pr based aligned,
    2 numt fixed bin,
    2 dummy bit (1),
    2 term (N refer (pr.numt)),
      3 terminal bit (1) unal,
      3 processed bit (1) unal,
      3 pad bit (34) unal,
      3 value fixed bin,
      3 datap ptr;

dcl 1 nt based aligned,
    2 nump fixed bin,
    2 id char (36) var,
    2 prod (N refer (nt.nump)) ptr;

/* Static */

dcl  formats (10) char (48) aligned static options (constant) init (
     "No ""NL"" found in bnf text.",
     "No ""NL<"" sequence found in bnf text.",
     "Not enough lines in bnf text.",
     "No root production found.",
     "Missing "">"" in line:   ^s^a",
     "Missing "">"" in line:   ^s^a",
     "Keyword lookup failed: ""^a""",
     "Non-terminal ""^a"" is undefined.",
     "Non-terminal ""^a"" has never been referenced.",
     "Missing ""]"" in line:   ^s^a");
dcl  me char (2) static options (constant) init ("gc");
dcl  gc_new bit (1) static init ("1"b);
dcl  gc_diff bit (1) static init ("1"b);
dcl  NL char (1) static options (constant) init ("
");
dcl  NL_LESS char (2) static options (constant) init ("
<");
dcl  WHITE char (3) static options (constant) init ("
	 ");
dcl  cleanup condition;

/* Builtin */

dcl (null, addr, substr, search, verify, index) builtin;

/* External */

dcl  compatible_bnf$ ext;
dcl  incompatible_bnf$ ext;

/* Entries */

dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35));
dcl  area_ entry (fixed bin (19), ptr);

/*  */

/*

   Initialize variables, set up buffer, get ptrs

*/

	txp = addr (compatible_bnf$);
	ptrs (1) = null;
	on cleanup call clean;
	call get_temp_segments_ (me, ptrs, code);
	temp = ptrs (1);
	call area_ (200000, temp);

/* Initially, every attribute is incompatible with every other attribute except itself. */

	do i = 1 to 108;
	     do j = 1 to 108;
		matrix (i, j) = "1"b;
	     end;
	     matrix (i, i) = "0"b;
	end;

/* Mark compatible attributes. */

	error_phase = 0;

	call parse_bnf;
	call mark (rootp, "0"b);

/* Now mark as incompatible certain combinations that fell out
   of the compatible BNF that we didn't want */

	error_phase = 10;
	txp = addr (incompatible_bnf$);

	call parse_bnf;
	call mark (rootp, "1"b);
	do i = 1 to 108;
	     matrix (i, i) = "0"b;
	end;

/*
   Output the compatible matrix, both to user_output and to file
*/

	if gc_new then do;
	     call ioa_ ("^-PROGRAM GENERATED TABLE^2/");
	     call ioa_ ("          111111111122222222223333333333444444444455555555556666666666777");
	     call ioa_ (" 123456789012345678901234567890123456789012345678901234567890123456789012");
	     call ioa_ (" ------------------------------------------------------------------------");
	end;
	do i = 1 to 72;
	     do j = 1 to 72;
		substr (bits (i), j, 1) = matrix (i, j);
	     end;
	     if gc_new then call ioa_ ("""^b""b, /* ^2d ^a */", bits (i), i, lookup_keyword (i));
	end;

	if gc_diff then do;
	     call ioa_ ("^|^2/^-DIFFERENCES FROM REAL TABLE^2/");
	     call ioa_ ("          1111111111222222222233333333334444444444555555555566666666667777777");
	     call ioa_ (" 1234567890123456789012345678901234567890123456789012345678901234567890123456");
	     call ioa_ (" ----------------------------------------------------------------------------");
	     do i = 1 to 72;
		do j = 1 to 72;
		     new = substr (bits (i), j, 1);
		     old = substr (incompatable (i), j, 1);
		     if old = new then c1 = "=";
		     else if old then c1 = "I";
		     else c1 = "C";
		     substr (chars72, j, 1) = c1;
		end;
		substr (chars72, i, 1) = "\";
		call ioa_ ("""^a""b, /* ^2d ^a */", chars72, i, lookup_keyword (i));
	     end;
	     call ioa_ (" ----------------------------------------------------------------------------");
	     call ioa_ ("          1111111111222222222233333333334444444444555555555566666666667777777");
	     call ioa_ (" 1234567890123456789012345678901234567890123456789012345678901234567890123456");
	end;


	call clean;
	return;

GLOBAL_ERROR:
	call clean;
	return;

ERROR:	proc (x);

dcl  x fixed bin;

	     call com_err_ (0, "generate_compatible", "Error ^d while scanning ^[^;in^]compatible_bnf.", x, error_phase=0);
	     call com_err_ (0, "generate_compatible", formats (x), search_name, line);
	     goto GLOBAL_ERROR;
	end;

lookup_keyword: proc (x) returns (char (16) aligned);

dcl  x fixed bin;
dcl  first_i fixed bin;
dcl  i fixed bin;

	     first_i = 0;
	     do i = 1 to hbound (keyword (*), 1);
		if x = bit_index (i)
		then if first_i = 0
		     then first_i = i;
		     else return (keyword (i));	/* short names usually preceed long names... */
	     end;
	     if first_i ^= 0
	     then return (keyword (first_i));

	     do i = 1 to hbound (system_keyword (*), 1);
		if x = system_bit_index (i)
		then return (system_keyword (i));
	     end;

	     return ("***");

	end lookup_keyword;


clean:	proc;

	     call release_temp_segments_ (me, ptrs, code);

	end;

/*  */

/* Subroutines */

parse_bnf: proc;


/* This routine parses the BNF pointed to by txp. It allocates nodes for all terminals and non-terminals
   and threads them together in the indicated fashion (not necessarily tree form).

   The syntax of the BNF is as follows:

   first char on line is "<" implies new non-terminal, i.e. a production that defines a new non-terminal.

   first char on line is blank implies another production for the current non-terminal.

   first chars on line are "eof" implies no more productions.

   any other first char(s) implies line is ignored.

   The total BNF cannot be more than 8K characters.
   A production must be entirely on a single line.
   Nonterminals are distinguished by being enclosed in "<" and ">".
   Symbols must be <= 36 characters.
   The root of the tree is called "<root>".

*/

	     rootp = null;
	     eof = "0"b;
	     nsymbols = 0;
	     depth = 0;
	     linep = txp;
	     next_term = 1;
	     next_pr = 1;
	     pname = "";

/* start scan with first line with a "<" at beginning */

	     if substr (total_buffer, 1, 1) = "<"
	     then do;
		i = index (total_buffer, NL);
		if i <= 0 then call ERROR (1);
		linel = i;
	     end;
	     else do;
		i = index (total_buffer, NL_LESS);
		if i <= 0 then call ERROR (2);
		linep = addr (linep -> chars (i+1));
		linel = index (linep -> total_buffer, NL);
		if linel <= 0 then call ERROR (3);
	     end;

	     do while (linep ^= null);
		call parse_production;
		call finish_production;
		call get_line;
	     end;
	     eof = "1"b;
	     linep = txp;				/* so test in parse_production will not get null ptr ref */
	     call parse_production;			/* to get last NT structure allocated */

/* Now scan all nodes converting pointers to symbols into pointers to non-terminal nodes */

	     rootp = lookup ("<root>") -> symbol.nt_ptr;
	     if rootp = null then call ERROR (4);
	     call scan (rootp);

	     do i = 1 to nsymbols while (symbols (i).unused = "0"b);
	     end;

	     if i <= nsymbols
	     then do;
		     search_name = symbols (i).name;
		     call ERROR (9);
		end;

	     return;

/*  */

get_line:	     proc;

dcl  i fixed bin;

dummy_line:
		linep = addr (linep -> chars (linel+1));
		i = index (linep -> total_buffer, NL);
		if i <= 0 then do;
		     linep = null;
		     return;
		end;
		linel = i;
		if substr (line, 1, 3) = "eof"
		then do;
		     linep = null;
		     return;
		end;
		if substr (line, 1, 1) = "<" | substr (line, 1, 1) = " " | substr (line, 1, 1) = "	" then return;
		goto dummy_line;

	     end get_line;

/*  */

parse_production: proc;

dcl  ntp ptr;

/* called with production in "line". If first char is not "<" then start filling in terms
   at position 2. Else start with position 1 and finish the previous non-terminal.
*/

		tx = 1;
		if (substr (line, 1, 1) = "<" & pname ^= "") | eof
		then do;				/* a new production, clean up previous */
		     N = next_pr - 1;
		     allocate nt in (temp -> area) set (ntp);
		     ntp -> nt.nump = N;
		     ntp -> nt.id = pname;
		     do i = 1 to N;
			ntp -> nt.prod (i) = pr_ptrs (i);
		     end;
		     do i = 1 to nsymbols;
			if pname = symbols (i).name	/* name used on rhs before defined on lhs */
			then do;
			     symbols (i).nt_ptr = ntp;
			     goto done;
			end;
		     end;
		     nsymbols = nsymbols + 1;
		     symbols (nsymbols).name = pname;
		     symbols (nsymbols).nt_ptr = ntp;
		     symbols (nsymbols).unused = "1"b;
done:
		     next_pr = 1;
		end;

		if eof then return;			/* all we wanted was to generate the nt structure */

		if substr (line, 1, 1) = "<" then do;
		     i = index (line, ">");
		     if i <= 0 then call ERROR (5);
		     pname = substr (line, 1, i);
		     tx = i+1;
		end;

/* Now scan for specific terms */
next_token:
		j = verify (substr (line, tx), WHITE)-1;
		if j < 0 then return;		/* all filled in */
		tx = tx + j;
		if substr (line, tx, 1) = "<"
		then do;				/* a non-terminal term */
		     k = index (substr (line, tx), ">");
		     if k <= 0 then call ERROR (6);
		end;
		else if substr (line, tx, 1) = "["	/* optional terminal */
		then do;
		     k = index (substr (line, tx), "]");
		     if k = 0 then call ERROR (10);
		end;
		else do;
		     k = search (substr (line, tx), WHITE)-1;
		     if k < 0 then return;
		end;

		term_names (next_term) = substr (line, tx, k);
		next_term = next_term + 1;
		tx = tx + k;
		goto next_token;

	     end parse_production;

finish_production: proc;

/* input is array of symbols in term_names. This program builds a "pr" structure and fills
   in a pointer to the structure in pr_ptrs (i).

*/

dcl  pp ptr;

		N = next_term - 1;
		allocate pr in (temp -> area) set (pp);
		pp -> pr.numt = N;
		do i = 1 to N;
		     pp -> pr (i).datap = lookup (term_names (i));
		     if substr (term_names (i), 1, 1) ^= "<"
		     then do;
			pp -> pr (i).terminal = "1"b;
			pp -> pr (i).value = map_number (term_names (i));
		     end;
		end;
		pr_ptrs (next_pr) = pp;
		next_pr = next_pr + 1;
		next_term = 1;
		return;

map_number:	proc (name) returns (fixed bin);

dcl  name char (36) var;

dcl  i fixed bin;

		     search_name = name;
		     do i = 1 to hbound (keyword (*), 1) while (keyword (i) ^= name);
		     end;
		     if i <= hbound (keyword (*), 1)
		     then return (bit_index (i));

		     do i = 1 to hbound (system_keyword (*), 1) while (system_keyword (i) ^= name);
		     end;
		     if i <= hbound (system_keyword (*), 1)
		     then return (system_bit_index (i));

		     call ERROR (7);

		end;

	     end /* finish_production */;

lookup:		proc (tname) returns (ptr);

dcl  tname char (36) var;
dcl  i fixed bin;

		     do i = 1 to nsymbols while (symbols (i).name ^= tname);
		     end;
		     if i > nsymbols
		     then do;
			     i, nsymbols = nsymbols + 1;
			     symbols (nsymbols).name = tname;
			     symbols (nsymbols).nt_ptr = null;
			end;

		     symbols (i).unused = "0"b;
		     return (addr (symbols (i)));
		end lookup;


scan:	     proc (rp);

dcl  rp ptr;
dcl (i, j) fixed bin;
dcl (pp, q) ptr;

/* This routine does a recursive walk of the tree changing any non-terminal pointers
   from a pointer to the symbol to a pointer to the allocated node */

		do i = 1 to rp -> nt.nump;		/* scan each production of this non-terminal */
		     pp = rp -> nt.prod (i);
		     do j = 1 to pp -> pr.numt;	/* scan each brother of this production */
			if ^ pp -> pr (j).terminal
			then do;
			     if ^ pp -> pr (j).processed then do;
				q = pp -> pr (j).datap -> symbol.nt_ptr;
				if q = null then do;
				     search_name = pp -> pr (j).datap -> symbol.name;
				     call ERROR (8);
				end;
				pp -> pr (j).datap = q;
				pp -> pr (j).processed = "1"b;
				call scan (q);
			     end;
			end;
		     end;
		end;

	     end scan;

	end parse_bnf;

/*  */

mark:	proc (p, mark_value);

dcl  p ptr;
dcl  mark_value bit (1) aligned;
dcl (i, j) fixed bin;
dcl  pp ptr;
dcl  save_depth fixed bin;
dcl  save_depth1 fixed bin;
dcl  k fixed bin;

/* This routine walks the tree and marks each compatible set of  attributes.
   It does this by keeping a stack of all terminal symbols above the current node of the tree
   that are immediate brothers to non-terminal nodes that are direct ancestors of the current node. That is,
   terminal symbols in the same production as the ancestor non-terminal. Before recursing to
   a lower level (when finding a non-terminal in the tree walk) all immediate brothers (of the same
   production as the non-terminal) that are terminal nodes, are placed on the stack. When a terminal
   node is encountered, it is placed on the stack and "reflect" is called
   to mark all terminals on the stack as being compatible.

*/

	     do i = 1 to p -> nt.nump;
		pp = p -> nt.prod (i);
		save_depth = depth;
		do j = 1 to pp -> pr.numt;
		     if pp -> pr (j).terminal
		     then do;
			depth = depth + 1;
			stack (depth) = pp -> pr (j).value;
		     end;
		end;
		do j = 1 to pp -> pr.numt;
		     save_depth1 = depth;
		     do k = 1 to pp -> pr.numt;
			if (^ pp -> pr (k).terminal) & (j ^= k) then call markt (pp -> pr (k).datap, mark_value);
		     end;
		     if pp -> pr (j).terminal then call reflect (pp -> pr (j).value, mark_value);
		     else call mark (pp -> pr (j).datap, mark_value);
		     depth = save_depth1;
		end;
		depth = save_depth;
	     end;
	     return;

	end mark;

markt:	proc (p, mark_value);

dcl  p ptr;
dcl  mark_value bit (1) aligned;
dcl (dx, v) fixed bin;
dcl (i, j) fixed bin;
dcl  pp ptr;


	     do i = 1 to p -> nt.nump;
		pp = p -> nt.prod (i);
		do j = 1 to pp -> pr.numt;
		     if pp -> pr (j).terminal
		     then do;
			v = pp -> pr (j).value;
			do dx = 1 to depth while (stack (dx) ^= v);
			end;

			if dx > depth
			then do;
				depth = depth + 1;
				stack (depth) = v;
			     end;
		     end;
		     else call markt (pp -> pr (j).datap, mark_value);
		end;
	     end;
	     return;

	end markt;

reflect:	proc (x, mark_value);

dcl  x fixed bin;
dcl  mark_value bit (1) aligned;

dcl  i fixed bin;

	     do i = 1 to depth;
		matrix (x, stack (i)) = mark_value;
		matrix (stack (i), x) = mark_value;
	     end;

	end reflect;


/*  */

gc_set_new: entry;

	gc_new = "1"b;
	return;

gc_reset_new: entry;

	gc_new = "0"b;
	return;

gc_set_diff: entry;

	gc_diff = "1"b;
	return;

gc_reset_diff: entry;

	gc_diff = "0"b;
	return;

/*  */

%include pl1_attribute_table;

     end generate_compatible;




		    print_pl1_version.pl1           11/15/82  1837.9rew 11/15/82  1509.1       31149



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


/* A tool to print pl1_version information in bound_pl1_ */

print_pl1_version:
	procedure;

/* Written:  12 Dec 1979 by Peter Krupp */

/* external entries */

dcl  ioa_ entry options(variable);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count entry() returns (fixed bin);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  com_err_$suppress_name entry options(variable);
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  component_info_$name entry (ptr, char(32), ptr, fixed bin(35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin(35));

/* automatic */

dcl  path_arg_length fixed bin;
dcl  path_arg_ptr ptr;
dcl  object_dir char(168);
dcl  object_entry char(32);
dcl  nargs fixed bin;
dcl  code fixed bin(35);
dcl  null_ref_name char(0);
dcl  bound_seg_ptr ptr init(null());
dcl  area_ret_ptr ptr;
dcl  call_terminate bit(1) aligned initial("0"b);

/* internal static */

dcl (my_name char(17) initial("print_pl1_version"),
     path_arg_no fixed bin init(1),
     copy_sw fixed bin(2) init(0),
     seg_sw fixed bin(1) init(0),
     component_name char(32) init("pl1_version")) int static options(constant);

/* based */

dcl  path_arg char(path_arg_length) based(path_arg_ptr);
dcl  1 pl1_version_struc based,
	2 pl1_version char(256) var,
	2 pl1_release char(3) var;

/* builtin */

dcl  (addr,null) builtin;

/* condition */

dcl  cleanup condition;

/* include files */

%include component_info;

/* program */

	on cleanup
	begin;
	     if call_terminate & bound_seg_ptr ^= null()
	     then call hcs_$terminate_noname(bound_seg_ptr,code);
	end;


/* Determine number of arguments in command invocation */

	nargs = cu_$arg_count();
	if nargs ^= 1
	then do;
		call com_err_$suppress_name(0,my_name,"Usage: print_pl1_version <path>");
		return;
	     end;

/* Get the pathname and validate it */

	call cu_$arg_ptr(path_arg_no,path_arg_ptr,path_arg_length,code);
	call expand_pathname_(path_arg,object_dir,object_entry,code);
	if code ^= 0
	then go to ERROR;

/* Get pointer to segment and component */

	call_terminate = "1"b;
	call hcs_$initiate(object_dir,object_entry,null_ref_name,seg_sw,copy_sw,bound_seg_ptr,code);

	if bound_seg_ptr = null()
	then go to ERROR;

	ci.dcl_version = 1;
	call component_info_$name(bound_seg_ptr,component_name,addr(ci),code);
	if code ^= 0
	then go to ERROR;

/* Print the version information */

	call ioa_("^a: pl1_version=""^a""",my_name,ci.text_start -> pl1_version);
	call ioa_("^a: pl1_release=""^a""",my_name,ci.text_start -> pl1_release);

/* Terminate the segment */

	call hcs_$terminate_noname(bound_seg_ptr,code);
	return;

/* Error exit: print a message and quit */

ERROR:
	call com_err_(code,my_name);

	if call_terminate
	then call hcs_$terminate_noname(bound_seg_ptr,code);

	return;

	end /* print_pl1_version */;




		    tmg.pl1                         11/15/82  1837.9rew 11/15/82  1508.9       62631



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


table:
tmg:	proc(name);

dcl	name char(*);

dcl	(in_pos,in_length,ll,out_pos,line_no,unique,
	 code,n,m,i,j) fixed bin,
	(input_pt,output_pt,output_hold) ptr,
	had_if bit(1),
	first_time bit(1) int static init("1"b),
	c char(1),
	(vf,vg,sourcename,outputname) char(32) varying,
	what char(8),
	op_code char(12) varying,
	line char(132) varying,
	ent char(32),
	(temppath,dir,wdir) char(168);

dcl	sw(16) label local int static;

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

dcl	n_special fixed bin int static init(16),
	special(16) char(8) init("if","ifnot","flipto","jump","put",
	 "fetch","get_fx2","compile","cplalt","cplsave","load","add",
	 "switch","erase","bump","drop") int static;

dcl	n_tests fixed bin int static init(11),
	test(11) char(4) init("q2","q3","a2","a3","c2","c3","z2","z3",
	 "atm2", "atm3", "atm4") int static;

dcl	n_switches fixed bin int static init(5),
	switches(5) char(8) init("code","op","type1","type2","type3") int static;

dcl	(com_err_,ioa_,ioa_$rsnp,ioa_$rsnpnnl) entry options(variable),
	hcs_$initiate_count entry(char(*),char(*),char(*),fixed bin,
	 fixed bin,ptr,fixed bin),
	expand_path_ entry(ptr,fixed bin,ptr,ptr,fixed bin),
	get_wdir_ entry() returns(char(168)),
	tssi_$get_segment entry(char(*),char(*),ptr,ptr,fixed bin),
	tssi_$finish_segment entry(ptr,fixed bin(24),bit(36) aligned,ptr,fixed bin);

dcl (	nl	init("
"),
	quote	init(""""),
	star	init("*"),
	tab	init("	"),
	colon	init(":")) char(1) int static;

dcl	my_name char(3) int static init("tmg");

dcl	input char(in_length) aligned based(input_pt);

dcl	output char(262144) aligned based(output_pt);

dcl	1 output_structure aligned based(output_pt),
	2 skip		unaligned char(out_pos - 1),
	2 output_line	unaligned char(132);

	if first_time
	then do;
	     sw(1) = if;
	     sw(2) = ifnot;
	     sw(3) = flipto;
	     sw(4) = jump;
	     sw(5) = put;
	     sw(6) = fetch;
	     sw(7) = get_fx2;
	     sw(8) = compile;
	     sw(9) = cplalt;
	     sw(10) = cplsave;
	     sw(11) = load;
	     sw(12) = add;
	     sw(13) = switch;
	     sw(14) = erase;
	     sw(15) = bump;
	     sw(16) = drop;
	     first_time = "0"b;
	     end;

	temppath = name;
	call expand_path_(addr(temppath),length(name),addr(dir),addr(ent),code);

	if code ^= 0
	then do;
	     call com_err_(code,my_name,temppath);
	     return;
	     end;

	n = index(ent," ");
	if n = 0 then n = 33;
	n = n - 1;

	sourcename = substr(ent,1,n) || ".table";
	outputname = substr(ent,1,n) || ".alm";

	call hcs_$initiate_count(dir,(sourcename),"",in_length,1,input_pt,code);

	if input_pt = null
	then do;
	     call com_err_(code,my_name,sourcename);
	     return;
	     end;

	if in_length = 0
	then do;
	     call com_err_(0,my_name,"Zero length input.");
	     return;
	     end;

	wdir = get_wdir_();
	call tssi_$get_segment(wdir,(outputname),output_pt,output_hold,code);

	if code ^= 0
	then do;
out_err:	     call com_err_(code,my_name,outputname);
	     return;
	     end;

	in_length = divide(in_length,9,17,0);
	in_pos, out_pos, unique = 1;
	line_no = 0;
	had_if = "0"b;

find_nl:	if in_pos >= in_length then goto done;

	ll = index(substr(input,in_pos),nl);

	if ll = 0 then goto done;
	line_no = line_no + 1;

	if ll = 1
	then do;
	     in_pos = in_pos + 1;
put_nl:	     substr(output,out_pos,1) = nl;
	     out_pos = out_pos + 1;
	     goto find_nl;
	     end;

	line = substr(input,in_pos,ll);
	in_pos = in_pos + ll;

	c = substr(line,1,1);

	if c = quote
	then do;
put_line:	     substr(output,out_pos,length(line)) = line;
	     out_pos = out_pos + length(line);
	     goto find_nl;
	     end;

	if c = star
	then do;

	     if ll = 3
	     then if substr(line,2,1) ^= star then goto star_err;
		else do;
		     call ioa_$rsnp("^-zero^-0,128",output_line,n);
		     out_pos = out_pos + n;
		     goto put_lab;
		     end;

	     if ll = 2
	     then do;
put_lab:		if had_if
		then do;
		     call ioa_$rsnpnnl("L^d:",output_line,n,unique);
		     out_pos = out_pos + n;
		     unique = unique + 1;
		     had_if = "0"b;
		     end;

		goto find_nl;
		end;

star_err:	     call com_err_(0,my_name,"Illegal use of ""*"" in line # ^d:^/^a",line_no,line);
	     goto find_nl;
	     end;

	/* check for labels */

labels:	n = index(line,colon);

	if n ^= 0
	then do;
	     substr(output,out_pos,n) = substr(line,1,n);
	     out_pos = out_pos + n;

	     if n = length(line)-1 then goto put_nl;

	     line = substr(line,n+1);
	     goto labels;
	     end;

	/* having eliminated all labels, the first character
	   on the line should now be a tab */

	if substr(line,1,1) ^= tab
	then do;
err:	     call com_err_(0,my_name,"Syntax error in line # ^d:^/^a",line_no,line);
	     goto find_nl;
	     end;

	/* pickup op code */

	n = index(substr(line,2),tab);
	if n = 0 then n = length(line) - 1;

	op_code = substr(line,2,n-1);

	/* check for one of our special pseudo-ops */

	do i = 1 to n_special;
	     if op_code = special(i) then goto found;
	     end;

	/* not special op code */

	goto put_line;

	/* have pseudo-op, get variable field */

found:	if n >= length(line) - 1 then vf = "";
	else do;
	     m = index(substr(line,n+2),tab);
	     if m = 0 then m = length(line)-n-1;
	     vf = substr(line,n+2,m-1);
	     end;

	goto sw(i);

	/* conditional, check to make sure vf specifies legal test */

if:
ifnot:	do j = 1 to n_tests;
	     if vf = test(j) then goto if_ok;
	     end;

	what = "Test";

err2:	call com_err_(0,my_name,"^a ""^a"" not known, ""^a"" on line # ^d:^/^a",what,vf,op_code,
	 line_no,line);
	goto find_nl;

if_ok:	call ioa_$rsnpnnl("^-vfd^-18/L^d,9/^d,9/128+^d^a",output_line,n,unique,i,j,line);
	had_if = "1"b;
	goto inc;

	/* switch, extract code from variable field */

switch:	n = index(vf,",");
	if n = 0
	then do;
	     call com_err_(0,my_name,"Variable field error, switch on line # ^d:^/^a",line_no,line);
	     goto find_nl;
	     end;

	vg = substr(vf,n+1);

	do j = 1 to n_switches;
	     if vg = switches(j) then goto switch_ok;
	     end;

	what = "Switch";
	vf = vg;
	goto err2;

switch_ok:
	call ioa_$rsnpnnl("^-vfd^-18/^a,9/13,9/128+^d^a",output_line,n,substr(vf,1,n-1),
	 j,line);
	goto inc;

drop:
bump:
erase:
flipto:
jump:
put:
fetch:
get_fx2:
compile:
cplalt:
cplsave:
load:
add:	call ioa_$rsnpnnl("^-vfd^-18/^a,9/^d,9/128^a",output_line,n,vf,i,line);
inc:	out_pos = out_pos + n;
	goto find_nl;

done:	call tssi_$finish_segment(output_pt,out_pos*9 - 9,"1010"b,output_hold,code);

	if code ^= 0 then goto out_err;
	end;




		    update_pl1_version.pl1          11/15/82  1837.9rew 11/15/82  1509.0       55935



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


/* A tool to update pl1_version information in bound_pl1_ directly */

update_pl1_version:
	procedure;

/* Written:  12 Dec 1979 by Peter Krupp */

/* external entries */

dcl  ioa_ entry options(variable);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count entry() returns (fixed bin);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  com_err_$suppress_name entry options(variable);
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  component_info_$name entry (ptr, char(32), ptr, fixed bin(35));
dcl  gen_pl1_version_ entry (1 structure, 2 char(256) var aligned, 2 char(3) var aligned, char(3) var, fixed bin(35));
dcl  get_group_id_ entry () returns (char (32));
dcl  hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin(35));

/* automatic */

dcl  ACCESS_NAME char(32) aligned;
dcl  release char(3) var;
dcl  release_arg_length fixed bin;
dcl  release_arg_ptr ptr;
dcl  path_arg_length fixed bin;
dcl  path_arg_ptr ptr;
dcl  object_dir char(168);
dcl  object_entry char(32);
dcl  nargs fixed bin;
dcl  code fixed bin(35);
dcl  null_ref_name char(0);
dcl  bound_seg_ptr ptr init(null());
dcl  area_ret_ptr ptr;
dcl  cleanup_access bit(1) aligned initial("0"b);
dcl  call_restore_acl_and_terminate bit(1) aligned initial("0"b);

dcl  1 old_acl_entry aligned,
	2 access_name char(32),
	2 modes bit(36),
	2 zero_pad bit(36),
	2 status_code fixed bin(35);
dcl  1 new_acl_entry like old_acl_entry aligned;

/* internal static */

dcl (my_name char(18) initial("update_pl1_version"),
     release_arg_no fixed bin init(2),
     path_arg_no fixed bin init(1),
     copy_sw fixed bin(2) init(0),
     seg_sw fixed bin(1) init(0),
     acl_count fixed bin init(1),
     component_name char(32) init("pl1_version")) int static options(constant);

/* external static */

dcl  error_table_$user_not_found fixed bin(35) ext;

/* based */

dcl  path_arg char(path_arg_length) based(path_arg_ptr);
dcl  release_arg char(release_arg_length) based(release_arg_ptr);
dcl  1 pl1_version_struc based,
	2 pl1_version char(256) var,
	2 pl1_release char(3) var;

/* builtin */

dcl  (addr,null,length) builtin;

/* condition */

dcl  cleanup condition;

/* include files */

%include component_info;

/* program */

	on cleanup
	begin;
	     if call_restore_acl_and_terminate
	     then call restore_acl_and_terminate;
	end;


/* Determine number of arguments in command invocation */

	nargs = cu_$arg_count();
	if nargs ^= 2
	then do;
		call com_err_$suppress_name(0,my_name,"Usage: update pl1_version <path> {<release> | EXL}");
		return;
	     end;

/* Get the pathname and validate it */

	call cu_$arg_ptr(path_arg_no,path_arg_ptr,path_arg_length,code);
	call expand_pathname_(path_arg,object_dir,object_entry,code);
	if code ^= 0
	then go to ERROR;

/* Get the release and validate its length */

	call cu_$arg_ptr(release_arg_no,release_arg_ptr,release_arg_length,code);
	release = release_arg;

	if length(release) > 3
	then do;
	          call com_err_(0,my_name,"The length of release may not be greater than 3");
		return;
	     end;

/* Get current acl of bound segment if it exists */

	ACCESS_NAME = get_group_id_();
	old_acl_entry.access_name = ACCESS_NAME;
	call hcs_$list_acl(object_dir,object_entry,null(),area_ret_ptr,addr(old_acl_entry),acl_count,code);
	
	if code ^= 0
	then go to ERROR;

	if old_acl_entry.status_code ^= error_table_$user_not_found
	then cleanup_access = "1"b;

/* Get pointer to segment and component */

	call_restore_acl_and_terminate = "1"b;
	call hcs_$initiate(object_dir,object_entry,null_ref_name,seg_sw,copy_sw,bound_seg_ptr,code);

	if bound_seg_ptr = null()
	then go to ERROR;

	ci.dcl_version = 1;
	call component_info_$name(bound_seg_ptr,component_name,addr(ci),code);
	if code ^= 0
	then go to ERROR;

/* Now try to get rw access to bound segment */

	new_acl_entry.access_name = ACCESS_NAME;
	new_acl_entry.modes = "101"b; /* rw */
	new_acl_entry.zero_pad = "0"b;
	call hcs_$add_acl_entries(object_dir,object_entry,addr(new_acl_entry),acl_count,code);

	if code ^= 0
	then go to ERROR;

/* At this point update_pl1_version has rw access to the bound segment (usually bound_pl1_) */
/* and may alter it. */

	call gen_pl1_version_(ci.text_start -> pl1_version_struc,release,code);

	if code ^= 0
	then go to ERROR;

	call ioa_("^a: pl1_version=""^a""",my_name,ci.text_start -> pl1_version);
	call ioa_("^a: pl1_release=""^a""",my_name,ci.text_start -> pl1_release);

/* Restore acl to original state */

	call restore_acl_and_terminate;
	return;

/* Error exit: print a message and quit */

ERROR:
	call com_err_(code,my_name);

	if call_restore_acl_and_terminate
	then call restore_acl_and_terminate;

	return;

%page;
/* Delete new acl entry and restore the old acl entry if one existed */

restore_acl_and_terminate:
	procedure;

/* automatic */

dcl  1 delete_acl aligned,
	2 access_name char(32),
	2 status_code fixed bin(35);

/* program */

	delete_acl.access_name = ACCESS_NAME;
	call hcs_$delete_acl_entries(object_dir,object_entry,addr(delete_acl),acl_count,code);

	if cleanup_access
	then call hcs_$add_acl_entries(object_dir,object_entry,
		addr(old_acl_entry),acl_count,code);

	if bound_seg_ptr ^= null()
	then call hcs_$terminate_noname(bound_seg_ptr,code);

	end /* restore_acl_and_terminate */;

	end /* update_pl1_version */;





		    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
