


		    bcdmp.pl1                       09/09/83  1357.7rew 09/09/83  1006.5       48906


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
bcdmp: proc (seg_ptr);

/* Procedure to dump a GCOS segment, printing less information than dump_segment.
   Entry bcdmp prints bcw, then for each record, the rcw and its offset, and the
   BCD or ASCII contents (BCD translated to ASCII for printing). Binary card
   records just have their rcw and offset printed.

   Entry gcdmp prints just bcw and rcws, and their offsets. No record contents are
   printed.

   Entry set_max_line_len gives the line length of the terminal, and by implication,
   the number of rcw-offset pairs that will fit on a line (20 chars per).
   The segment and offset to be dumped are specified by a pointer argument. Dumping
   always begins at the beginning of a GCOS block (on a 320-word boundary). If the
   offset in the pointer does not specify such an address, it will be rounded
   DOWN, so dumping will begin at the start of the block in which the offset falls.

   This procedure can be called as a subroutine, or from db:
   :=bcdmp(segno|offset)

   or by the dump_gcos (dgc) command, which accepts a pathname, offset, line length,
   and -bcd (or -ch) argument.


   WRITTEN BY T. CASEY, JULY 1974

*/

dcl  gcos_cv_gebcd_ascii_ ext entry (ptr, fixed bin, ptr);

dcl (command_query_
     , ioa_, ioa_$nnl
     , com_err_
     , db
     ) ext entry options (variable);

%include query_info_;

dcl  word bit (36) aligned based;
dcl  char_string char (200) based;

dcl 1 bcw aligned based (block_ptr),
    2 bsn bit (18) unaligned,
    2 length bit (18) unaligned;

dcl 1 rcw aligned based (record_ptr),
    2 length bit (18) unaligned,
    2 eof bit (6) unaligned,
    2 zeros bit (2) unaligned,
    2 media_code bit (4) unaligned,
    2 report_code bit (6) unaligned;

dcl (seg_ptr, block_ptr, record_ptr) ptr;
dcl  offset fixed bin (35);
dcl (block_len, record_len, cur_line_len, i, medium) fixed bin;
dcl  max_line_len fixed bin int static init (80);

dcl  reply char (4) varying;
dcl  me char (5);
dcl  ascii_line char (200);

dcl  bcdsw bit (1) aligned init ("1"b);

dcl (addr, addrel, fixed, index, rel, substr) builtin;

	me = "bcdmp";

start:
	block_ptr = seg_ptr;
	offset = fixed (rel (block_ptr));
	cur_line_len = 0;

	i = mod (offset, 320);
	if i ^= 0 then do;
	     offset = offset - i;
	     block_ptr = addrel (block_ptr, -i);
	     call com_err_ (0, me, "will start at offset: ^6o", offset);
	end;

start_block:
	block_len = fixed (bcw.length);

	if cur_line_len ^= 0 then do;
	     call ioa_ ("");
	     cur_line_len = 0;
	end;

	call ioa_ ("^/^6o ^w", offset, block_ptr -> word);
	if block_ptr -> word = (36)"0"b then do;
	     call com_err_ (0, me, "bcw = 0; aborting dump");
	     goto exit;
	end;

	if block_len = 0 then goto next_block;

	offset = offset + 1;
	record_ptr = addrel (block_ptr, 1);

next_record:
	record_len = fixed (rcw.length);

	if record_len > block_len then do;
	     call com_err_ (0, me, "bad rcw:");
	     goto new_line;
	end;

	if bcdsw then do;

	     if record_len = 0 then goto new_line;

	     ascii_line = "";

	     medium = fixed (rcw.media_code);

	     if medium >= 5 then			/* ascii */
		ascii_line = substr (addrel (record_ptr, 1) -> char_string, 1, record_len*4);

	     else if medium = 1 then			/* binary card */
		ascii_line = "BINARY CARD";

	     else do;				/* else assume bcd */
		call gcos_cv_gebcd_ascii_ (addrel (record_ptr, 1), record_len*6, addr (ascii_line));

/* COMMENT OUT: so we can see the !1 or !2 or whatever, at the end of the last word
   substr (ascii_line, 1+index (ascii_line, "!")) = ""; /* END COMMENT OUT */
		substr (ascii_line, 1+record_len*6) = ""; /* but blank out the garbage after the last word */
	     end;

	     call ioa_ ("^6o ^w ^a", offset, record_ptr -> word, ascii_line);
	end;

	else do;
	     if cur_line_len = 0 then goto new_line;
	     if cur_line_len + 20 > max_line_len then
new_line:		do;
		call ioa_$nnl ("^/^6o ^w", offset, record_ptr -> word);
		cur_line_len = 20;
	     end;
	     else do;
		call ioa_$nnl (" ^6o ^w", offset, record_ptr -> word);
		cur_line_len = cur_line_len + 20;
	     end;
	end;

	if rcw.eof = "001111"b then do;
	     query_info.yes_or_no_sw = "1"b;
	     call command_query_ (addr (query_info), reply, me, "eof in rcw; do you wish to continue?");
	     if reply = "no" then goto exit;
	end;

	offset = offset + record_len + 1;
	record_ptr = addrel (record_ptr, record_len+1);
	block_len = block_len - record_len - 1;

	if block_len < 0 then do;
	     call com_err_ (0, me, "warning - remaining block length went negative - calling db");
	     call db;
	end;

	if block_len <= 0 then
next_block:    do;
	     block_ptr = addrel (block_ptr, 320);
	     offset = fixed (rel (block_ptr));
	     goto start_block;
	end;

	goto next_record;

exit:

/* terminate the seg here, if we add code to initiate it later */

	call com_err_ (0, me, "returning to caller");
	return;

/* Entry to request printing of just block and record control words */

gcdmp:	entry (seg_ptr);

	me = "gcdmp";
	bcdsw = "0"b;
	goto start;

/* Entry to set max_line_length */

set_max_line_len: entry (ll);

dcl  ll fixed bin;

	max_line_len = ll;
	return;

     end bcdmp;
  



		    dump_gcos.pl1                   09/09/83  1357.7rew 09/09/83  1006.5       59211


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


dump_gcos: dgc: proc;

/* Command to dump a GCOS standard system format file, doing less printing
   than dump_segment or dump_segment -bcd.

   USAGE: dgc pathname -octal_offset- -bcd -line_length (-ll) n

   If octal offset is omitted, it defaults to zero. If it is given, it is
   rounded DOWN to the beginning of the 320 (decimal) word block in which
   it falls. Dumping always begins on a 320-word boundary.

   Dumping will proceed until the user QUIT's, or until an end of file (octal 17)
   is found (in which case the user will be given the choice of quitting or
   continuing), or a block control word of all zeros is found, which always
   terminates the dump.

   If -bcd (or -ch) is given, the contents of BCD or ASCII records is printed
   (the BCD being converted to ASCII for printing), preceeded by the rcw and its
   offset. For binary card records, the offset and rcw, and the words BINARY CARD
   are printed.

   If -bcd is not given, just bcw and rcws (and their offsets) are printed.

   The -line_length n argument may be used to control the number of rcws placed
   on each line. The default is 80, which is room for 4 rcws and their offsets.
   Once set, the line length is remembered in internal static for the remainder
   of the process.

   WRITTEN BY	T. Casey		July 1974

   MODIFIED BY	S. Akers		September 1981

				Changed error_table_$badarg
				to error_table_$badopt.

				Fixed "USAGE" error to prevent
				garbage in error message.

*/

/* D E C L A R A T I O N S  */

/* External Entries */

dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl (cv_dec_check_, cv_oct_check_) entry (char (*), fixed bin (35)) returns (fixed bin);
dcl (ioa_, com_err_) entry options (variable);
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl (bcdmp, bcdmp$gcdmp) entry (ptr);
dcl  bcdmp$set_max_line_len entry (fixed bin);
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));

/* Work Variables */
dcl  argp ptr;
dcl  argl fixed bin;
dcl  arg char (argl) based (argp);
dcl (argno, nargs) fixed bin;

dcl  code fixed bin (35);

dcl  err_msg char (200) varying;
dcl  err_arg char (168);
dcl  numeric_arg fixed bin;
dcl  given_path char (168) init ("");
dcl  dirname char (168);
dcl  ename char (32);

dcl  offset fixed bin init (0);
dcl (bcdsw, expecting_ll) bit (1) aligned init ("0"b);

dcl (error_table_$noarg, error_table_$badopt) ext fixed bin (35);

dcl  plen fixed bin;
dcl  segptr ptr init (null);
dcl  bitcount fixed bin (24);
dcl  callptr ptr;

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

dcl  cleanup condition;

/* P R O C E D U R E */

	on condition (cleanup) begin;
	     if segptr ^= null then
		call hcs_$terminate_noname (segptr, code);
	end;

	call cu_$arg_count (nargs);
	if nargs = 0
	then do;
	     code = 0;
	     err_msg = "USAGE: dgc path offset -bcd -line_length n";
call_com_err:  call com_err_ (code, "dump_gcos", err_msg, err_arg, numeric_arg);
exit:	     if segptr ^= null then do;
		call hcs_$terminate_noname (segptr, code);
		if code ^= 0 then do;
		     err_msg = "from hcs_$terminate_noname ^a";
		     segptr = null;			/* avoid infinite loop */
show_expanded_path:					/* come here from below */
		     err_arg = substr (dirname, 1, index (dirname, " ")-1) || ">"
			|| substr (ename, 1, index (ename, " ")-1);
		     goto call_com_err;
		end;
	     end;
	     return;
	end;

arg_loop:	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 then do;
		err_msg = "from cu_$arg_ptr ^s^d";
		numeric_arg = argno;
		goto call_com_err;
	     end;

	     if expecting_ll then do;
		expecting_ll = "0"b;
		numeric_arg = cv_dec_check_ (arg, code);
		if code ^= 0 then do;
		     code = 0;			/* not an error_table_ code */
		     err_msg = "bad line length argument: ^a";
		     err_arg = arg;
		end;

		call bcdmp$set_max_line_len (numeric_arg);
	     end;

	     else if substr (arg, 1, 1) = "-" then do;	/* control */
		if arg = "-bcd" | arg = "-ch" then
		     bcdsw = "1"b;
		else if arg = "-ll" | arg = "-line_length" then
		     expecting_ll = "1"b;
		else do;
		     code = error_table_$badopt;
		     err_arg = arg;
		     err_msg = "^a";
		     goto call_com_err;
		end;
	     end;					/* end control arg */

	     else do;				/* path or offset */
		numeric_arg = cv_oct_check_ (arg, code);
		if code ^= 0 then do;		/* not an octal number */
		     if given_path = "" then do;	/* if path not already given */
			given_path = arg;		/* assume this is it */
			plen = argl;		/* for expand_path_ */
		     end;

		     else do;
			if offset ^= 0 then		/* if offset given already */
			     err_msg = "unknown argument: ^a";
			err_arg = arg;
			goto call_com_err;
		     end;
		end;				/* end code ^= 0 */

		else offset = numeric_arg;
	     end;

	end arg_loop;

	if expecting_ll then do;
	     err_msg = "line length, after ^a";
	     err_arg = arg;
noarg:	     code = error_table_$noarg;
	     goto call_com_err;
	end;

	if given_path = "" then do;
	     err_msg = "pathname of file to be dumped";
	     goto noarg;
	end;

	call expand_path_ (addr (given_path), plen, addr (dirname), addr (ename), code);
	if code ^= 0 then do;
	     err_msg = "from expand_path_ ^a";
	     err_arg = given_path;
	     goto call_com_err;
	end;

	call hcs_$initiate_count (dirname, ename, "", bitcount, 0, segptr, code);
	if segptr = null then do;
	     err_msg = "from hcs_$initiate_count ^a";
	     goto show_expanded_path;
	end;
	else code = 0;				/* clear possible segknown */

	bitcount = divide (bitcount-1, 36, 17, 0);	/* compute offset of last word, from bitcount */
	if offset > bitcount then do;
	     call com_err_ (0, "dump_gcos", "offset (^o) is past last word (^o); last block will be dumped.", offset, bitcount);
	     offset = bitcount;
	end;

	callptr = ptr (segptr, offset);

	if bcdsw then
	     call bcdmp (callptr);
	else call bcdmp$gcdmp (callptr);

	goto exit;

end dump_gcos;
 



		    gcos_build_library.pl1          09/09/83  1357.7rew 09/09/83  1006.5      142308


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_build_library: gcbl: build: proc;

/* This procedure builds a catalog for a GCOS system-loadable file. The
   catalog contains 2 words per module: program name (in BCD), and offset (of
   the preface record preceeding the module). This format is similar to the
   "GECALL TABLE" that is kept in core by the real GCOS, and it differs from
   the format of the catalog produced by SYSEDIT for a  random system loadable
   file (commonly used for ** files).

   WARNING: This command can not be used to manipulate a random system loadable
   file. See the GCOS PLM (AN77 for a detailed description of the differences
   between a random system loadable file, a tape system loadable file, and a
   simulator format software library. NOTE: THERE IS NO SUCH PLM.

   The catalog occupies the first 1000 words of the file, and has room for 499
   name-offset pairs.

   Usage: gcbl input_path output_path -brief -append append_path

   input_path

   is the pathname of the input file. This file may or may not already have a
   catalog. The file may have been created by this
   procedure (in which case it has a catalog), or by gcos_extract_module or
   gcos_pull_tapefile (in which case it does NOT have a catalog).

   output_path

   is the pathname of the file into which the modules in the input file (plus
   those in the optional append file) are to be copied, preceeded by a catalog.
   If this file already exists, it will be overwritten with no warning.

   append_path

   is the pathname of a file whose contents are to be appended to those of the
   input file (i.e., copied to the end of the output file) before the new catalog
   is built. This file is optional. If it is given, the pathname must be
   preceeded by one of the two control arguments: -append, or -append_cat,
   depending on whether or not the file TO BE APPENDED has a catalog.

   The following is no longer the case but is kept for historical reference.
   NOTE that when an append file is given, either with or without a catalog,
   the input file is assumed to have a catalog, and otherwise the input file
   is assumed NOT to have a catalog. This might appear at first to be an arbitrary
   and unwise assumption, but use of earlier versions of this procedure has shown
   that the appending function is always used to add modules to a library that is
   already being used by the simulator (and thus has a catalog). (End of not true.)

   NOTE that existing modules are NOT replaced by the appending function. The only
   way to replace an existing module with a different version of itself is
   to extract from the existing library, into a new file, all the modules EXCEPT
   the one(s) to be replaced, extract the new versions of those modules into the
   new file (they will be appended to those previously extracted into the file),
   and then build a catalog for the new file.


   WRITTEN BY DICK SNYDER .... 1971
   MODIFIED BY T. CASEY JUNE 1974, AUGUST 1974
   Modified: Ron Barstad  2.0  83-02-28  Added dcl precision to conform to standards
                                         Added version (start with 2.0)
   Modified: Ron Barstad  2.1  83-04-20  Removed catalog-nocatalog restriction

   */


/*  D  E  C  L  A  R  A  T  I  O  N  S      */

/*  External Entries  */

dcl  ios_$detach ext entry (char (*), char (*), char (*), bit (72));
dcl  ios_$attach ext entry (char (*), char (*), char (*), char (*), bit (72));
dcl  ios_$seek ext entry (char (*), char (*), char (*), fixed bin(24), bit (72));
dcl (ios_$read, ios_$write) ext entry (char (*), pointer, fixed bin(24), fixed bin(24), fixed bin(24), bit (72));
dcl  ios_$setsize ext entry (char (*), fixed bin(24), bit (72));
dcl (ioa_, com_err_) ext entry options (variable);
dcl (elindex, offset) fixed bin(24);
dcl  progname char (6);
dcl  gcos_cv_gebcd_ascii_ ext entry (pointer, fixed bin(24), pointer, fixed bin(24));

dcl  cu_$arg_count entry (fixed bin, fixed bin(35));
dcl  cu_$arg_ptr ext entry (fixed bin(24), ptr, fixed bin(24), fixed bin(35));

/*  Work Variables */

dcl  nargs fixed bin(17);
dcl  argp ptr;
dcl  argl fixed bin(24);
dcl  arg char (argl) based (argp);
dcl  argno fixed bin(24);

dcl  cleanup condition;

dcl  err_msg char (200) varying;

dcl  cat char (4000) aligned init (" ");		/* place to build catalog */
dcl  buffer char (4000) aligned init (" ");		/* buffer */
dcl  first_word fixed bin(35) based (addr(buffer));         /* first word of buffer */

dcl 1 catblk aligned based (catp),			/* catalog image */
    2 nxt fixed bin(24),				/* pointer to next cat blk */
    2 no_ent fixed bin(24),				/* no. of entries in this cat blk */
    2 elblock (499),				/* room for 499 entries */
      3 element bit (36) unaligned,			/* prog name */
      3 address fixed bin(24);				/* offset in file */

dcl  catp pointer;
dcl (i, j, k) fixed bin(24);				/* temps */

dcl  st bit (72);					/* ios status */
dcl (load_origin, pgm_length, transfer_addr, load_increment, reloc_len) fixed bin(24); /* temps */

dcl 1 status aligned based (addr (st)),			/* overlay for ios_ status */
    2 code fixed bin (35),				/* standard error code */
    2 fill bit (9) unaligned,
    2 eof bit (1) unaligned;				/* eof bit */

dcl 1 gecall aligned based (callp),			/* overlay for gecall parameters */
    2 prog_name bit (36) unaligned,			/* bcd pgm name */
    2 origin bit (18) unaligned,			/* place to begin loading */
    2 filler bit (18) unaligned,
    2 xfer_addr bit (18) unaligned;			/* transfer address */
dcl  callp pointer;

dcl 1 preface aligned based (prefp),			/* model of preface record */
    2 data_check fixed bin(24),				/* checksum of following data words */
    2 rel_check fixed bin(24),				/* checksum of following reloc. words */
    2 rel_abs fixed bin(24),				/* 0=absolute|^0=relocatable */
    2 name bit (36) unaligned,			/* name of pgm */
    2 entry bit (18) unaligned,			/* entry address */
    2 origin bit (18) unaligned,			/* origin */
    2 reloc_words fixed bin (17) unaligned,		/* no. of relocation words */
    2 data_words fixed bin (17) unaligned,		/* no. of data words */
    2 dcws (ndcw) bit (36) unaligned;			/* dcw(s) to load following data records */
dcl  prefp pointer;
dcl  ndcw fixed bin(24);

dcl 1 dcw_model aligned based (dcwp),			/* model of dcw */
    2 data_addr bit (18) unaligned,
    2 zero bit (3) unaligned,
    2 action bit (3) unaligned,
    2 count bit (12) unaligned;			/* number of words to xfer */
dcl  dcwp pointer;

dcl  checker (pgm_length) bit (36) aligned based (ptr);	/* overlay for computing chksum */
dcl  ptr pointer;
dcl  reloc_bits (size) bit (2) based (prefp);		/* overlay for relocation record */

dcl 1 gecos_reloc (size) aligned based (ptr),		/* overlay for each word of loaded pgm */
    2 upper bit (18) unaligned,
    2 lower bit (18) unaligned;
dcl  size fixed bin(24);				/* size of pgm overlay arrays */
dcl  accum fixed bin (71);				/* checksum accumulator */

dcl (input_path, output_path, append_path, err_path) char (168);

dcl  me char (24) int static options (constant) init ("gcos_build_library (2.1)");
dcl  stream_names (2) char (12) int static init (
     "gcbl_input",
     "gcbl_output");

dcl (briefsw
     , catalogsw
     , appendsw
     , append_cat_sw
     , append_path_sw
     , ineof
     , usage_sw
     ) bit (1) aligned init ("0"b);

dcl  path_counter fixed bin(24)init (0);

dcl (error_table_$badopt, error_table_$noarg) ext fixed bin (35);

dcl (addr, divide, mod, substr) builtin;


/*  */

/* P  R  O  C  E  D  U  R  E     */

	on condition (cleanup) call cleanup_proc;

	call cu_$arg_count (nargs, code);

	if nargs < 2 & code = 0 then code = error_table_$noarg;

	if code ^= 0 then
	     do;
	     call com_err_ (code, me);

print_usage:   call ioa_ ("Usage: gcbl INPUT_PATH OUTPUT_PATH {-brief} {-append APPEND_PATH}");

exit:	     call cleanup_proc;

	     return;

	end;

arg_loop:	do argno = 1 to nargs;

	     call cu_$arg_ptr (argno, argp, argl, code);

	     if code ^= 0 then do;
		err_msg = arg;
call_com_err:	call com_err_ (code, me, err_msg, err_path);
		if usage_sw then goto print_usage;
		else goto exit;
	     end;


	     err_path = arg;			/* in case of error in argument processing */

	     if substr (arg, 1, 1) ^= "-" then		/* if not control argument */
get_path:		do;				/* must be a pathname */
						/* which one is it? */

		if append_path_sw then		/* if previous argument was -append or -append_cat */
get_append:	     do;
		     append_path = arg;		/* save path */
		     append_path_sw = "0"b;		/* remember we got it */
		end get_append;

		else if path_counter = 0 then		/* if we have no paths */
get_input:	     do;				/* has to be input_path */
		     input_path = arg;		/* save it */
		     path_counter = 1;		/* remember we got it */
		end get_input;

		else if path_counter = 1 then		/* if we have input path */
get_output:	     do;				/* this has to be output */
		     output_path = arg;		/* save it */
		     path_counter = 2;		/* remember we got it */
		end get_output;

		else do;				/* if we have both, this is garbage */
		     usage_sw = "1"b;		/* tell user how to use command */
		     err_msg = "unidentified non-control argument: ^a";
		     code = 0;
		     goto call_com_err;
		end;

	     end get_path;

	     else if arg = "-bf" | arg = "-brief" then
		briefsw = "1"b;

	     else if arg = "-append" then do;
append_arg:	appendsw, catalogsw = "1"b;
		append_path_sw = "1"b;
	     end;

	     else if arg = "-append_cat" then do;
		append_cat_sw = "1"b;
		goto append_arg;
	     end;

	     else do;
		code = error_table_$badopt;
		err_msg = "^a";
		goto call_com_err;
	     end;

	end arg_loop;

	if path_counter ^= 2 then do;			/* complain if required paths missing */
	     err_msg = "";
noarg_err:     code = error_table_$noarg;
	     usage_sw = "1"b;			/* show user required args */
	     goto call_com_err;
	end;

	if append_path_sw then do;			/* if we were waiting for append path
						   and it was not there, complain */
	     err_msg = "append_path";
	     goto noarg_err;
	end;

	err_path = output_path;			/* in case of error initializing output file */


	call ios_$attach ("gcbl_output", "file_", output_path, "", st);
	if code ^= 0 then do;
attach_err:    err_msg = "from ios_$attach ^a";
	     goto call_com_err;
	end;

	call ios_$setsize ("gcbl_output", 36, st);
	if code ^= 0 then do;
setsize_err:   err_msg = "from ios_$setsize ^a";
	     goto call_com_err;
	end;

	call ios_$seek ("gcbl_output", "last", "first", 1000, st);
	if code ^= 0 then do;
	     err_msg = "from ios_$seek last 1000 ^a";
	     goto call_com_err;
	end;

	call ios_$seek ("gcbl_output", "write", "first", 1000, st);
	if code ^= 0 then do;
	     err_msg = "from ios_$seek write 1000 ^a";
	     goto call_com_err;
	end;

/* copy entire input (or append) file into output file */

attach_input:					/* come here to attach input or append file for reading */
	err_path = input_path;			/* in case of error while reading */
	call ios_$attach ("gcbl_input", "file_", input_path, "r", st);
	if code ^= 0 then
	     goto attach_err;

	call ios_$setsize ("gcbl_input", 36, st);
	if code ^= 0 then
	     goto setsize_err;

	/*** The input or append library is determined to have or not have
               a catalog by inspection. If the first word is 0, then it is a 
               simulator library and has a catalog. If the first word not=0,
               then the lib does not have a catalog and is a native gcos lib.
                Neither catalogsw, nor append_cat_sw is examined.            */
	call ios_$read ("gcbl_input", addr (buffer), 0, 1000, j, st);
	if code ^= 0 then goto read_err;
	if first_word ^= 0 then goto no_skip_cat;
	else
skip_catalog:  do;
	     call ios_$seek ("gcbl_input", "read", "first", 1000, st);
	     if code ^= 0 then do;
seek_read_err:	err_msg = "from ios_$seek read 1000 ^a";
		goto call_com_err;
	     end;
	end skip_catalog;

/* Come here to read next 1000 words from input or append file */

loop:	call ios_$read ("gcbl_input", addr (buffer), 0, 1000, j, st);
	if code ^= 0 then do;
read_err:	     err_msg = "from ios_$read ^a";
	     goto call_com_err;
	end;

no_skip_cat:
	if status.eof then ineof = "1"b;		/* remember end of file, since we clear status by writing */

	call ios_$write ("gcbl_output", addr (buffer), 0, j, k, st);
	if code ^= 0 then do;
write_err:     err_msg = "from ios_$write ^a";
	     err_path = output_path;
	     goto call_com_err;
	end;

	if ^ineof then go to loop;			/* go read next block, if not end of file */

	if appendsw then do;			/* eof on input...append now?? */
	     ineof = "0"b;
	     appendsw = "0"b;			/* after next eof we won't append again */
	     catalogsw = append_cat_sw;		/* if append file has catalog, skip over it */
	     call ios_$detach ("gcbl_input", "", "", st); /* detach input file */
	     if code ^= 0 then do;
		err_msg = "from ios_$detach ^a";
		goto call_com_err;
	     end;

	     input_path = append_path;
	     goto attach_input;			/* go attach and read append file */
	end;

/* Fall thru here to start reading thru output file and building catalog */

	err_path = output_path;			/* in case of error on output file */

	call ios_$seek ("gcbl_output", "read", "first", 1000, st); /* seek to first preface record for reading */
	if code ^= 0 then
	     goto seek_read_err;

	call ios_$seek ("gcbl_output", "write", "first", 0, st); /* seek to start of empty catalog for writing */
	if code ^= 0 then do;
	     err_msg = "from ios_$seek write first ^a";
	     goto call_com_err;
	end;


	catp = addr (cat);				/* place to build catalog */
	prefp = addr (buffer);			/* place to read preface records into */
	catblk.nxt = 0;				/* clear rel ptr to next catalog block (there never is
						   another catalog block) */
	elindex = 1;				/* first modue - first catalog position */
	offset = 1000;				/* offset of its preface record */

read:	call ios_$read ("gcbl_output", prefp, 0, 1000, j, st); /* read the preface record */
	if code ^= 0 then goto read_err;

	elblock (elindex).element = preface.name;	/* copy name */
	elblock (elindex).address = offset;		/* copy preface offset */
	elindex = elindex + 1;			/* bump index */
	if elindex = 500 then do;
	     code = 0;
	     err_msg = "catalog overflow - more than 499 modules in file: ^a";
	     goto call_com_err;
	end;

	if ^briefsw then do;			/* unless told not to, print name and offset */
	     call gcos_cv_gebcd_ascii_ (addr (preface.name), 6, addr (progname), j);
	     call ioa_ ("^a ^o", progname, offset);
	end;

/* Count DCWs, by looking for one with action code = "000"b */

	do ndcw = 1 to 58				/* there may be up to 58 of them in a block */
		while (substr (preface.dcws (ndcw), 22, 3) ^= "000"b);
	end;

	offset = offset+6+ndcw+preface.data_words+preface.reloc_words; /* compute offset of next preface record */

	call ios_$seek ("gcbl_output", "read", "first", offset, st); /* seek to it */
	if code ^= 0 then do;
	     err_msg = "from ios_$seek read next_preface ^a";
	     goto call_com_err;
	end;

	if ^eof then go to read;			/* if not end of file on seek, go read it */

	call ioa_ ("end of file");

	catblk.no_ent = elindex-1;			/* compute total elements in catalog */
	call ios_$write ("gcbl_output", addr (cat), 0, 1000, j, st); /* write catalog into file */
	if code ^= 0 then
	     goto write_err;

	goto exit;				/* all done */


cleanup_proc: proc;

	     do i = 1 to 2;
		call ios_$detach (stream_names (i), "", "", st);
	     end;
	     return;
	end cleanup_proc;

     end gcos_build_library;



		    gcos_build_patchfile.pl1        09/09/83  1357.7rew 09/09/83  1006.5      114084


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


/*
   ********************************************************************************************
   ********************************************************************************************
   *
   *
   *	G C O S   B U I L D   P A T C H F I L E
   *
   *
   *  The gcos_build_patchfile command is used to build a patch file to be used by the
   *  GCOS Environment Simulator.  The arguments to the command are the name of the
   *  Multics ASCII segment containing the patches and the name of the resulting
   *  patchfile.  In order to have the patches applied by MME GECALL the patchfile
   *  must be called gcos_system_software_patchfile_ and must be locatable by the
   *  search rules.
   *
   *
   *  Written by M. R. Jordan,  September 1977
   *
   ********************************************************************************************
   ********************************************************************************************
*/


gcos_build_patchfile: gbp: proc ();

dcl  ME char (20) static internal options (constant) init ("gcos_build_patchfile");
dcl  NL char (1) static internal options (constant) init ("
");
dcl  aclinfo_ptr ptr init (null ());
dcl  addr builtin;
dcl  arg char (arg_len) based (arg_ptr);
dcl  arg_len fixed bin;
dcl  arg_num fixed bin;
dcl  arg_ptr ptr;
dcl  ascii_module_name char (6);
dcl  bit_count fixed bin (24);
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  divide builtin;
dcl  dummy fixed bin;
dcl  end_of_info bit (1);
dcl  error_table_$bad_arg fixed bin (35) ext;
dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  error_table_$too_many_names fixed bin (35) ext;
dcl  error_table_$translation_failed fixed bin (35) ext;
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  fixed builtin;
dcl  gcos_cv_ascii_gebcd_ entry (ptr, fixed bin, ptr, fixed bin);
dcl  get_temp_segments_ entry (char (*), (*)ptr, fixed bin (35));
dcl  hbound builtin;
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  highest_severity fixed bin init (0);
dcl  i fixed bin;
dcl  in_dirname char (168);
dcl  in_ename char (32);
dcl  in_line char (in_line_len) based (in_line_ptr);
dcl  in_line_len fixed bin (20);
dcl  in_line_num fixed bin;
dcl  in_line_ptr ptr;
dcl  in_seg char (in_seg_len) based (in_seg_ptr);
dcl  in_seg_len fixed bin (20);
dcl  in_seg_offset fixed bin (20);
dcl  in_seg_ptr ptr;
dcl  index builtin;
dcl  ioa_ entry options (variable);
dcl  last_name bit (36);
dcl  length builtin;
dcl  n fixed bin;
dcl  nargs fixed bin;
dcl  null builtin;
dcl  number_of_patches fixed bin;
dcl  out_dirname char (168);
dcl  out_ename char (32);
dcl  out_seg_bit_count fixed bin (24);
dcl  out_seg_ptr ptr init (null ());
dcl  patch_ptr ptr;
dcl  rel builtin;
dcl  release_temp_segments_ entry (char (*), (*)ptr, fixed bin (35));
dcl  search builtin;
dcl  substr builtin;
dcl  table_ptr ptr;
dcl  temp_ptr (2) ptr init ((2)null ());
dcl  temp_segments_cleanup_needed bit (1) aligned init ("0"b);
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));
dcl  tssi_cleanup_needed bit (1) aligned init ("0"b);

dcl 1 patch (number_of_patches+1) aligned based (patch_ptr),
    2 location fixed bin (17),
    2 content fixed bin (35);


dcl 1 patch_file aligned based (out_seg_ptr),
    2 version fixed bin,
    2 number_of_names fixed bin,
    2 module (130560),
      3 name bit (36),
      3 first_patch_offset bit (18) unal,
      3 number_of_patches fixed bin (17) unal;

dcl 1 table (87040) aligned based (table_ptr),
    2 name bit (36),
    2 location fixed bin (17),
    2 content fixed bin (35) ;

/*

   Make sure there are at least enough arguments to get started.

*/


	call cu_$arg_count (nargs);
	if nargs < 2 then do;
	     call com_err_ (error_table_$noarg, ME, "^/Usage is: gcos_build_patchfile patches patchfile");
	     return;
	end;

	on cleanup call Cleanup ();


/*

   Process the pathname of the input file containing patches.

*/


	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "referencing argument 1.");
	     return;
	end;

	call Process_Input_Pathname ();
	if code ^= 0 then return;


/*

   Process the patchfile pathname.

*/


	call cu_$arg_ptr (2, arg_ptr, arg_len, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "referencing argument 2.");
	     return;
	end;

	call Process_Output_Pathname ();
	if code ^= 0 then return;


/*

   Process the remaining arguments.  These should all be control arguments.


*/


	do arg_num = 3 to nargs;

	     call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "referencing argument ^d.", arg_num);
		return;
	     end;

	     call Process_Argument ();
	     if code ^= 0 then return;

	end;


	temp_segments_cleanup_needed = "1"b;
	call get_temp_segments_ (ME, temp_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME);
	     return;
	end;

	table_ptr = temp_ptr (1);

	call Process_Patch_Cards ();

	if code ^= 0 then return;


	if highest_severity < 3 then do;

	     call Sort_Patches ();
	     if code ^= 0 then return;

	     call Generate_Patch_File ();
	     if code ^= 0 then return;

	end;
	else call com_err_ (error_table_$translation_failed, ME);


give_up:

	call tssi_$finish_segment (out_seg_ptr, out_seg_bit_count, "110"b, aclinfo_ptr, code);
	tssi_cleanup_needed = "0"b;


	call release_temp_segments_ (ME, temp_ptr, code);
	temp_segments_cleanup_needed = "0"b;


	return;

Process_Input_Pathname: proc ();


	     call expand_pathname_ (arg, in_dirname, in_ename, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, """^a""", arg);
		return;
	     end;


	     call hcs_$initiate_count (in_dirname, in_ename, "", bit_count, 0, in_seg_ptr, code);
	     if in_seg_ptr = null () then do;
		call com_err_ (code, ME, """^a^[>^]^a""", in_dirname, (in_dirname ^= ">"), in_ename);
		return;
	     end;
	     else code = 0;
	     in_seg_len = divide (bit_count, 9, 20, 0);


	     in_seg_offset = 1;
	     in_line_len = 0;
	     in_line_num = 0;
	     in_line_ptr = null ();


	     return;


	end Process_Input_Pathname;

Process_Output_Pathname: proc ();

	     call expand_pathname_ (arg, out_dirname, out_ename, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, """^a""", arg);
		return;
	     end;


	     tssi_cleanup_needed = "1"b;
	     call tssi_$get_segment (out_dirname, out_ename, out_seg_ptr, aclinfo_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, """^a^[>^]^a""", out_dirname, (out_dirname ^= ">"), out_ename);
		return;
	     end;


	     return;


	end Process_Output_Pathname;

Process_Argument: proc ();


	     code = error_table_$badopt;
	     call com_err_ (code, ME, """^a""", arg);


	     return;


	end Process_Argument;

Get_Input_Line: proc ();


dcl  in_char (in_seg_len) char (1) based (in_seg_ptr) unal;


/*

   Make sure we still have text to process.  If not, quit while
   we're ahead.

*/


loop:

	     if in_seg_offset >= in_seg_len then do;
		end_of_info = "1"b;
		return;
	     end;
	     else end_of_info = "0"b;


/*

   Get the next line from the source.

*/


	     in_line_ptr = addr (in_char (in_seg_offset));

	     in_line_len = index (substr (in_seg, in_seg_offset), NL)-1;
	     if in_line_len < 0 then in_line_len = in_seg_len-in_seg_offset+1;
	     in_line_num = in_line_num+1;


/*

   Now update the offset of the next line.

*/


	     in_seg_offset = in_seg_offset+in_line_len+1;


	     if in_line_len < 78 then do;
		call Error (3, "1"b, "Missing or incomplete program name.", "");
		goto loop;
	     end;

	     if substr (in_line, 7, 9) ^= " octal   " &
	     substr (in_line, 7, 9) ^= " OCTAL   " then do;
		call Error (3, "1"b, "Source is not an ""octal"" line.", "");
		goto loop;
	     end;


	     return;


	end Get_Input_Line;

Octal_Value: proc (text)returns (fixed bin (35));


dcl  i fixed bin;
dcl  result fixed bin (35);
dcl  text char (*);


	     i = search (text, " ,")-1;
	     if i < 0 then i = length (text);
	     else if substr (text, i+1, 1) = "," then do;
		call Error (3, "1"b, "Bad delimiter in octal field.  ""^a""", substr (text, i+1, 1));
		return (0);
	     end;

	     result = cv_oct_check_ (substr (text, 1, i), code);
	     if code ^= 0 then do;
		call Error (3, "1"b, "Bad octal value.  ""^a""", substr (text, 1, i));
		return (0);
	     end;


	     return (result);


	end Octal_Value;

Process_Patch_Cards: proc ();


	     end_of_info = "0"b;
	     number_of_patches = 0;

	     do i = 1 to hbound (table, 1) while (^end_of_info);

		call Get_Input_Line ();

		ascii_module_name = substr (in_line, 73, 6);
		call gcos_cv_ascii_gebcd_ (addr (ascii_module_name), 6, addr (table (i).name), n);
		table (i).location = Octal_Value (substr (in_line, 1, 7));
		table (i).content = Octal_Value (substr (in_line, 16, 13));

		number_of_patches = number_of_patches+1;

	     end;


	     if ^end_of_info then do;
		code = error_table_$too_many_names;
		call com_err_ (code, ME, "Too many patches.");
		return;
	     end;


	     return;


	end Process_Patch_Cards;

Sort_Patches: proc ();


dcl  i fixed bin;
dcl  j fixed bin;

dcl 1 R (number_of_patches) aligned based (table_ptr),
    2 K bit (36),
    2 data1 fixed bin (17),
    2 data2 fixed bin (35) ;

dcl 1 Record aligned,
    2 Key bit (36),
    2 data1 fixed bin (17),
    2 data2 fixed bin (35) ;


	     do j = 2 to number_of_patches;

		i = j-1;
		Record = R (j);


l:

		if Key < K (i) then do;
		     R (i+1) = R (i);
		     i = i-1;
		     if i>0 then goto l;
		end;

		R (i+1) = Record;


	     end;


	     return;


	end Sort_Patches;

Generate_Patch_File: proc ();


	     patch_file.version = 1;
	     n = 0;
	     last_name = (36)"0"b;


	     do i = 1 to number_of_patches;

		if table (i).name ^= last_name then do;

		     n = n+1;
		     last_name = table (i).name;
		     patch_file.module (n).name = table (i).name;
		     patch_file.module (n).first_patch_offset = (18)"0"b;
		     patch_file.module (n).number_of_patches = 0;

		end;

	     end;


	     patch_file.number_of_names = n;
	     patch_ptr = addr (patch_file.module (n+1));


	     n = 0;
	     last_name = (36)"0"b;


	     do i = 1 to number_of_patches;

		if table (i).name ^= last_name then do;

		     last_name = table (i).name;
		     n = n+1;

		     patch_file.module (n).first_patch_offset = rel (addr (patch (i)));

		end;

		patch_file.module (n).number_of_patches = patch_file.module (n).number_of_patches+1;
		patch (i).location = table (i).location;
		patch (i).content = table (i).content;

	     end;


	     out_seg_bit_count = fixed (rel (addr (patch (number_of_patches+1))), 18)*36;


	     return;


	end Generate_Patch_File;

Cleanup:	proc ();


	     if tssi_cleanup_needed then do;
		call tssi_$clean_up_segment (aclinfo_ptr);
		tssi_cleanup_needed = "0"b;
	     end;


	     if temp_segments_cleanup_needed then do;
		call release_temp_segments_ (ME, temp_ptr, code);
		temp_segments_cleanup_needed = "0"b;
	     end;


	     return;


	end Cleanup;

Error:	proc (severity, print_source, message, arg);


dcl  arg char (*);
dcl  message char (*);
dcl  print_source bit (1) aligned;
dcl  severity fixed bin;


dcl  HEADING (4) char (16) init (
     "WARNING",
     "ERROR SEVERITY 2",
     "ERROR SEVERITY 3",
     "ERROR SEVERITY 4");


	     call ioa_ ("^/^a, LINE ^d.", HEADING (severity), in_line_num);
	     call ioa_ (message, arg);
	     if print_source then call ioa_ ("SOURCE:^/^a", in_line);


	     if severity>highest_severity then highest_severity = severity;


	     if severity = 4 then goto give_up;


	     return;


	end Error;


     end gcos_build_patchfile;



		    gcos_extract_module.pl1         09/09/83  1357.7rew 09/09/83  1006.5      131193


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_extract_module: gcem: extract: proc;

/* This procedure extracts one or more modules from a (tape format) GCOS
   system loadable file, or a simulator format software library, placing them in
   an output file. The names of the modules are given in a control file.

   WARNING: This command can not be used to manipulate a random system loadable
   file. For a detailed description of the differences
   between a random system loadable file, a tape system loadable file, and a
   simulator format software library see the simulator manual (AN05) and
   the GCOS System Editor manual (DD30).

   USAGE: gcem control_path input_path output_path -brief

   control_path

   is the pathname of a segment containing the names of the modules to be
   extracted, in lower case ascii, each on a separate line. (Such a segment
   can be created by the gcos_library_summary command, using the -brief control
   argument, and preceeding it by the file_output command, and then editing the
   resulting segment to remove the names of unwanted modules; or the
   segment can be created directly by any of the Multics editors.)

   input_path

   is the pathname of a file containing gcos modules. It may be a file copied from
   a GCOS total system tape, or it may be a simulator library, beginning with
   a simulator-format catalog of the module names and locations. The file is
   determined to be a native GCOS or simulator format file by inspection. The
   -no_catalog  arg is no longer necessary.

   output_path

   is the pathname of the output file into which the extracted modules are to be
   written. If the file already exists, it will be appended to, enabling the
   construction of a single library from several smaller ones.

   The names of each module copied will be printed on user_output,
   unless the -brief control argument is given.  The names of any requested modules
   that are not found in the input file will be printed on error_output.


   WRITTEN BY DICK SNYDER .... 1971
   MODIFIED BY T. CASEY JUNE 1974, AUGUST 1974
  Change:	Ron Barstad  2.0 83-07-29  Repaired obsolete hcs_$initiate_count call
                                     Removed need for -no_catalog

   */


/* 	D   E   C   L   A   R   A   T   I   O   N   S				 */


/* 	External Entries						 */


dcl  ios_$read ext entry (char (*) aligned, pointer, fixed bin, fixed bin, fixed bin, bit (72) aligned);
dcl  ios_$write ext entry (char (*), pointer, fixed bin, fixed bin, fixed bin, bit (72) aligned);
dcl  ios_$detach ext entry (char (*), char (*), char (*), bit (72) aligned);
dcl  expand_path_ ext entry (pointer, fixed bin, pointer, pointer, fixed bin (35));
dcl  hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin, fixed bin, pointer, fixed bin (35));
dcl  delete_$ptr ext entry (ptr, bit (6), char (*), fixed bin (35));
dcl (ioa_, ioa_$nnl, ioa_$rsnnl, com_err_) ext entry options (variable);
dcl  ios_$attach ext entry (char (*), char (*), char (*), char (*), bit (72) aligned);
dcl  ios_$setsize ext entry (char (*), fixed bin, bit (72) aligned);
dcl  ios_$seek ext entry (char (*), char (*), char (*), fixed bin(21), bit (72) aligned);
dcl  gcos_cv_gebcd_ascii_ ext entry (pointer, fixed bin, pointer, fixed bin);
dcl  cu_$arg_count ext entry (fixed bin);
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  get_temp_segment_ entry (char(*), ptr, fixed bin(35));
dcl  release_temp_segment_ entry (char(*), ptr, fixed bin(35));

/*  Work Variables */

dcl  nargs fixed bin;
dcl  argp ptr;
dcl  argl fixed bin;
dcl  arg char (argl) based (argp);
dcl  argno fixed bin;

dcl  cleanup condition;

dcl  err_msg char (200) varying;


dcl (i1, i2, i3, i4, pref_data, pref_reloc) fixed bin;
dcl (i, j, word_no, bc, segl, doff) fixed bin;		/* temps */
dcl  k fixed bin (21);
dcl  control char (segl) based (temp_segp);
dcl  temp_segp pointer;
dcl  control_orig char (segl) based (segp);
dcl  segp pointer;
dcl  word_one fixed bin (35);			/* first word of input file */
dcl  ename char (32);
dcl  dir char (168);
dcl  string char (6);

dcl  st bit (72) aligned ;				/* ios status */

dcl 1 status aligned based (addr (st)),			/* overlay for ios_ status */
    2 code fixed bin (35),				/* standard error code */
    2 fill bit (9) unaligned,
    2 eof bit (1) unaligned;				/* eof bit */

dcl 1 preface aligned based (prefp),			/* model of preface record */
    2 data_check fixed bin,				/* checksum of following data words */
    2 rel_check fixed bin,				/* checksum of following reloc. words */
    2 rel_abs fixed bin,				/* 0=absolute|^0=relocatable */
    2 name bit (36) unaligned,			/* name of pgm */
    2 entry bit (18) unaligned,			/* entry address */
    2 origin bit (18) unaligned,			/* origin */
    2 reloc_words fixed bin (17) unaligned,		/* no. of relocation words */
    2 data_words fixed bin (17) unaligned,		/* no. of data words */
    2 dcws (ndcw) bit (36) unaligned;			/* dcw(s) to load following data records */
dcl  prefp pointer;
dcl  ndcw fixed bin;

dcl (control_path, input_path, output_path, err_path) char (168);
dcl (briefsw					/* omit printing of names of extracted modules */
     , nocatsw					/* file does not begin with a catalog */
     , usage_sw					/* print usage message if error on command line */
     ) bit (1) aligned init ("0"b);

dcl  path_counter fixed bin init (0);

dcl  me char (25) int static init ("gcos_extract_module (2.0)");

dcl  ascii_newline char (1) int static init ("
");

dcl (error_table_$badopt, error_table_$noarg) ext fixed bin (35);


/* 	NOTE: Declaration of buffer should be last declaration in case	 */
/* 	buffer should overflow.					 */

dcl  buffer bit (131400);				/* preface and relocation blk buffer */

dcl (addr, divide, index, mod, null, substr, translate) builtin;

/*  */

/*  P     R     O     C     E     D     U     R     E    */

	on condition (cleanup) call cleanup_proc;

	segp, temp_segp = null;

	call cu_$arg_count (nargs);

/* IF WRONG NUMBER OF ARGS, PRINT USAGE MESSAGE AND QUIT */

	if nargs < 3 then
print_usage:   do;
	     call ioa_ ("Usage: gcem CONTROL_PATH INPUT_PATH OUTPUT_PATH {-brief}");
exit:	     call cleanup_proc;
	     return;
	end print_usage;
arg_loop:	do argno = 1 to nargs;

	     call cu_$arg_ptr (argno, argp, argl, code);

	     if code ^= 0 then do;
		err_msg = arg;
call_com_err:	call com_err_ (code, me, err_msg, err_path);
		if usage_sw then goto print_usage;
		else goto exit;
	     end;


	     err_path = arg;			/* in case of error, be ready */

	     if substr (arg, 1, 1) ^= "-" then		/* if not control argument */
get_path:		do;				/* must be pathname */
		if path_counter = 0 then		/* which pathname? how many do we have already? */
get_control:	     do;				/* if none, first one is control file */
		     call expand_path_ (argp, argl, addr (dir), addr (ename), code);
		     if code ^= 0 then do;
			err_msg = "from expand_path_ ^a";
			goto call_com_err;
		     end;

		     call ioa_$rsnnl ("^a>^a", control_path, bc, dir, ename); /* put pathname together */

		     call hcs_$initiate_count (dir, ename, "", bc, 0, segp, code);

		     if segp = null then do;
			err_path = control_path;
			err_msg = "from hcs_$initiate_count ^a";
			goto call_com_err;
		     end;

		     segl = divide (bc, 9, 17, 0);

		     call get_temp_segment_(me, temp_segp, code);
		     if code ^= 0 then do;
			call com_err_(code, me, "Unable to make temporary copy of input_path.");
			goto exit;
		     end;
		     control = control_orig;		/* make a working copy */
		     path_counter = 1;		/* remember that we have control_path */
		end get_control;

		else if path_counter = 1 then		/* if we already have control_path */
get_input:	     do;				/* this must be input_path */
		     input_path = arg;
		     call ios_$attach ("gcem_input", "file_", input_path, "r", st);
		     if code ^= 0 then do;
attach_err:		err_msg = "from ios_$attach ^a";
			goto call_com_err;
		     end;

		     call ios_$setsize ("gcem_input", 36, st);
		     if code ^= 0 then do;
setsize_err:		err_msg = "from ios_$setsize ^a";
			goto call_com_err;
		     end;

		     path_counter = 2;		/* remember that we have input_path */
		end get_input;

		else if path_counter = 2 then		/* but if we have input path already */
get_output:	     do;				/* this must be output_path */
		     output_path = arg;
		     call ios_$attach ("gcem_output", "file_", output_path, "", st);
		     if code ^= 0 then
			goto attach_err;

		     call ios_$setsize ("gcem_output", 36, st);
		     if code ^= 0 then
			goto setsize_err;

		     path_counter = 3;		/* remember that we have all 3 pathnames */
		end get_output;

		else do;				/* can't be a pathname - must be garbage */
		     usage_sw = "1"b;		/* tell user how to use command */
		     err_msg = "unidentified non-control argument: ^a";
		     code = 0;
		     goto call_com_err;
		end;

	     end get_path;

	     else if arg = "-bf" | arg = "-brief" then
		briefsw = "1"b;

	     else if arg = "-no_catalog" then
		nocatsw = "1"b;

	     else do;
		code = error_table_$badopt;
		err_msg = "^a";
		goto call_com_err;
	     end;

	end arg_loop;

	if path_counter ^= 3 then do;			/* complain if all 3 pathnames not given */
	     code = error_table_$noarg;
	     err_msg = "";
	     usage_sw = "1"b;
	     goto call_com_err;
	end;

/* initialize */

	prefp = addr (buffer);			/* pointer to buffer for ios_ */

	k = 0;					/* offset of first preface record
						   (relative to doff) */

	err_path = input_path;			/* higher probablility of input errors */

/* determine if the input file has a catalog:
   if the first word of the file =0 then this is a simulator file with a catalog
   if the first word not=0 then this is a native GCOS file without a catalog
*/
	call ios_$seek ("gcem_input", "read", "first", 0, st);
	if code ^= 0 then do;
	     err_msg = "from ios_$seek read first word: ^a";
	     goto call_com_err;
	end;

	call ios_$read ("gcem_input", addr(word_one), 0, 1, j, st);
	if code ^= 0 then do;
	     err_msg = "from ios_$read of word one: ^a";
	     goto call_com_err;
	end;

	if word_one = 0
	     then doff = 1000;		/* has catalog */
	     else doff = 0;
%page;
/* Main loop begins here */

seek_preface: call ios_$seek ("gcem_input", "read", "first", k+doff, st);
	if code ^= 0 then do;
seek_err:	     err_msg = "from ios_$seek read start-of-preface ^a";
	     goto call_com_err;
	end;

	if status.eof then do;			/* check for end of file */
	     call ioa_ ("^/end of file");

	     control = translate (control, "", " ");	/* translate blanks to fill (177) chars */
	     call com_err_ (0, me, "Following modules not found in ^a^/^a", input_path, control);

	     goto exit;
	end;


read:	call ios_$read ("gcem_input", prefp, 0, 3650, j, st); /* read preface record */
	if code ^= 0 then do;
read_err:	     err_msg = "from ios_$read ^a";
	     goto call_com_err;
	end;

/* Count DCWs, by looking for one with action code = "000"b */

	do ndcw = 1 to 58				/* there may be up to 58 of them in a block */
		while (substr (preface.dcws (ndcw), 22, 3) ^= "000"b);
	end;

	pref_reloc = preface.reloc_words;		/* copy data from preface */
	pref_data = preface.data_words;

	i4 = pref_data + pref_reloc + 6 + ndcw;		/* compute number of words to copy */
						/* (or to skip over, if this one not to be copied) */
						/* NOTE that this number includes the preface record,
						   which is copied along with the data */

	call gcos_cv_gebcd_ascii_ (addr (preface.name), 6, addr (string), i); /* convert prog name to ascii */
						/* and see if that name is in the control file */
	i1 = index (string, " ");			/* find the end of it */
	if i1 = 0 then i1 = 7;			/* if no trailing blank, must be 6 chars */

	i3 = 1;					/* start search from beginning */
search_control: i2 = index (substr (control, i3), substr (string, 1, i1-1)); /* look for the name in the control file */
	if i2 ^= 0 then do;				/* if its there, extract the module - maybe */
						/* Aviod extracting module "b" because "abc" occurs
						   in the control file. Check that name in control file is
						   delimited by blanks or newlines (or beginning of file) */
	     if substr (control, i2+i1-1, 1) ^= ascii_newline then /* name must end in newline */
		if substr (control, i2+i1-1, 1) ^= " " then /* or blank */
		     goto keep_searching;		/* or we do not copy it */
	     if i2 ^= 1 then			/* except for first name in control file */
		if substr (control, i2-1, 1) ^= ascii_newline then /* name must begin with newline */
		     if substr (control, i2-1, 1) ^= " " then /* or blank */
keep_searching:		do;			/* or we do not copy it */
			i3 = i2 + i1 - 1;		/* move search pointer past this name */
			if i3 + i1 - 1 > segl then	/* if name is longer than remainder of file */
			     goto next_preface;	/* give up and go look at next preface record */
			else goto search_control;	/* else keep looking for it */
		     end;

	     if ^briefsw then			/* print name unless asked not to */
		call ioa_ ("^a will be copied", string);

	     substr (control, i2, i1) = "";		/* blank out name and trailing blank or newline */

	     call ios_$seek ("gcem_input", "read", "read", -j, st); /* move read pointer back to beginning of preface */
	     if code ^= 0 then goto seek_err;

copyloop:	     if i4 < 3650 then i3 = i4;
	     else i3 = 3650;
	     call ios_$read ("gcem_input", prefp, 0, i3, j, st);
	     if code ^= 0 then goto read_err;
	     if i4 > j then i2 = j;
	     else i2 = i4;
	     call ios_$write ("gcem_output", prefp, 0, i2, i1, st);
	     if code ^= 0 then do;
		err_path = output_path;
		err_msg = "from ios_$write ^a";
		goto call_com_err;
	     end;

	     i4 = i4 -i1;
	     if i4 > 0 then go to copyloop;
	end;

	if control = "" then do;			/* if all requested modules copied, quit */
	     call ioa_ ("^/all requested modules copied");
	     goto exit;
	end;

next_preface:
	k = k+6+ndcw+pref_data+pref_reloc;		/* compute offset of next preface block */

	goto seek_preface;				/* go seek to it */


cleanup_proc: proc;
	     call ios_$detach ("gcem_input", "", "", st);
	     call ios_$detach ("gcem_output", "", "", st);
	     if temp_segp ^= null then
		call release_temp_segment_(me, temp_segp, code);

	     return;
	end cleanup_proc;

     end gcos_extract_module;
   



		    gcos_library_summary.pl1        09/09/83  1357.7rew 09/09/83  1006.5      102159


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_library_summary: gcls: summary: proc;

/* This procedure prints a summary of the contents of a GCOS tape-format
   system-loadable file, or a simulator format software library, or
   a gcos format system-loadable file.

   USAGE:  gcls pathname {-control_args}
           -control_args are: -brief | -preface | -no_catalog | -gcos

   If no control arguments are given, the file is assumed to begin with a
   catalog (containing the name and offset of each module in the file), and the
   catalog is printed. If -preface is given, a catalog is assumed to be present,
   and it is skipped over, and the preface record at the beginning of each
   module is printed. If -no_catalog is given, the file is assumed to begin
   with the first preface record, and the preface records are printed. If -brief
   is given, only the names of the modules are printed, whether catalog or
   preface record printing was specified. -gcos arg will cause the pathname
   to be interpreted as a Gcos format file and its contents will be listed.

   Written by Dick Snyder .... 1971
   Modified  by T. Casey JUNE 1974, AUGUST 1974
   Modified:  Ron Barstad  02/04/83  To work on Gcos format files with -gcos arg
                                     Add version indicator, start with 2.0

   */


/*  D   E   C   L   A   R   A   T   I   O   N   S     */


/*  External Entries       */


dcl  ios_$detach ext entry (char (*), char (*), char (*), bit (72) aligned);
dcl  ios_$read ext entry (char (*), pointer, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned);
dcl (ioa_, ioa_$nnl, com_err_) ext entry options (variable);
dcl  ios_$attach ext entry (char (*), char (*), char (*), char (*), bit (72) aligned);
dcl  ios_$setsize ext entry (char (*), fixed bin(24), bit (72) aligned);
dcl  ios_$seek ext entry (char (*), char (*), char (*), fixed bin(24), bit (72) aligned);
dcl  gcos_cv_gebcd_ascii_ ext entry (pointer, fixed bin(24), pointer, fixed bin(24));
dcl  cu_$arg_count ext entry (fixed bin);
dcl  cu_$arg_ptr ext entry (fixed bin(24), ptr, fixed bin(24), fixed bin(35));

/*  Work Variables */


dcl  nargs fixed bin(17);
dcl  argp ptr;
dcl  argl fixed bin(24);
dcl  arg char (argl) based (argp);
dcl  argno fixed bin(24);

dcl  cleanup condition;

dcl  err_msg char (200) varying;

dcl (i1, i2, i3, i4) fixed bin(24);
dcl (i, j, k, word_no) fixed bin(24);			/* temps */
dcl  doff fixed bin(24)init (0);
dcl  string char (6);
dcl  word_one fixed bin (35);			/* first word of input file */

dcl  st bit (72) aligned ;				/* ios status */
dcl  seek_save fixed bin(24);				/* holds seek offset */

dcl 1 status aligned based (addr (st)),			/* overlay for ios_ status */
    2 code fixed bin (35),				/* standard error code */
    2 fill bit (9) unaligned,
    2 eof bit (1) unaligned;				/* eof bit */

dcl 1 preface aligned based (prefp),			/* model of preface record */
    2 data_check fixed bin(24),				/* checksum of following data words */
    2 rel_check fixed bin(24),				/* checksum of following reloc. words */
    2 rel_abs fixed bin(24),				/* 0=absolute|^0=relocatable */
    2 name bit (36) unaligned,			/* name of pgm */
    2 entry bit (18) unaligned,			/* entry address */
    2 origin bit (18) unaligned,			/* origin */
    2 reloc_words fixed bin (17) unaligned,		/* no. of relocation words */
    2 data_words fixed bin (17) unaligned,		/* no. of data words */
    2 dcws (ndcw) bit (36) unaligned;			/* dcw(s) to load following data records */
dcl  prefp pointer;
dcl  ndcw fixed bin(24);
dcl 1 catalog based (prefp),
    2 fill fixed bin(24),
    2 no_ent fixed bin(24),
    2 elements (499),
      3 name bit (36) aligned,
      3 address fixed bin(24);

dcl  me char (20) init ("gcos_library_summary");
dcl  version char (4) init ("2.1");

dcl (briefsw					/* print names only */
     , prefsw					/* skip over catalog and print preface records */
     , nocatsw					/* no catalog - print preface records */
     , usage_sw					/* print usage message if error on command line */
     ) bit (1) aligned init ("0"b);

dcl  pathname char (168) init ("");

dcl (error_table_$badopt, error_table_$noarg) ext fixed bin (35);

dcl (addr, divide, fixed, mod, substr) builtin;

dcl 1 gcatlog aligned based (prefp),
    2 gav fixed bin (17) unal,
    2 gcat fixed bin (17) unal,
    2 g2fil bit(36) unal,
    2 gentry (15) unal,
3 gname bit(36),
    3 gfill (3) bit (36),
    2 g3fill bit (36) unal;
dcl gcosw bit (1) init ("0"b);
/* 	NOTE: Declaration of buffer should be last declaration in case	 */
/* 	buffer should overflow.					 */

dcl  buffer bit (131400);				/* preface and relocation blk buffer */
%page;
/*  P  R  O  C  E  D  U  R  E     */

	call ioa_ ("^a (^a)",me,version);

	on condition (cleanup) call cleanup_proc;

	call cu_$arg_count (nargs);

/* IF NO ARGS, PRINT USAGE MESSAGE AND QUIT */

	if nargs = 0 then do;
print_usage:   call ioa_ ("Usage: gcls PATH {-control_args}");
	     return;
	end;

arg_loop:	do argno = 1 to nargs;

	     call cu_$arg_ptr (argno, argp, argl, code);

	     if code ^= 0 then do;
		err_msg = arg;
call_com_err:	call com_err_ (code, me, err_msg);
		call cleanup_proc;
		if usage_sw then goto print_usage;
		return;
	     end;

	     if substr (arg, 1, 1) ^= "-" then do;
		if pathname ^= "" then do;
		     err_msg = "unidentified non-control argument: " || arg;
		     goto call_com_err;
		end;

		err_msg,
		     pathname = arg;		/* don't bother with expand_path_ since file dim does */
	     end;

	     else if arg = "-bf" | arg = "-brief" then
		briefsw = "1"b;

	     else if arg = "-preface" then
		prefsw = "1"b;

	     else if arg = "-no_catalog" then	/* ignored */
		nocatsw = "1"b;

	     else if arg = "-gc" | arg = "-gcos" then do;
		gcosw = "1"b;
	     end;
	     else do;
		code = error_table_$badopt;
		err_msg = arg;
		goto call_com_err;
	     end;

	end arg_loop;

	if pathname = "" then do;			/* complain if pathname not given */
	     code = error_table_$noarg;
	     err_msg = "";
	     usage_sw = "1"b;			/* print usage message after complaining */
	     goto call_com_err;
	end;

	prefp = addr (buffer);
	call ios_$attach ("gcls_input", "file_", pathname, "r", st);
	if status.code ^= 0 then do;
	     err_msg = err_msg || " from ios_$attach";
	     goto call_com_err;
	end;

	call ios_$setsize ("gcls_input", 36, st);
	if status.code ^= 0 then do;
	     err_msg = err_msg || " from ios_$setsize";
	     goto call_com_err;
	end;

%page;
/* gcos ** file */
	if gcosw then do;
	     call ioa_ ("Gcos ** file catalog list for ^a", pathname);
get_nextg:     call ios_$read ("gcls_input", prefp, 0, 64, j, st);
	     if status.code ^= 0 then do;
		err_msg = err_msg || " from GCOS ios_$read";
		go to call_com_err;
	     end;
	     do j = 1 to 15;
		if gcatlog.gentry (j).gname ^= "000000000000000000"b then do;
		     call gcos_cv_gebcd_ascii_ (addr (gcatlog.gentry (j).gname), 6, addr (string), i);
		     call ioa_ ("^a", string);
		end;
	     end;
	     if gcatlog.gcat = 0 then do;
		call ioa_ ("^/end of catalog.");
		call cleanup_proc;
		return;
	     end;
	     call ios_$seek ("gcls_input", "read", "first", gcatlog.gcat * 64, st);
	     if status.code ^= 0 then do;
		err_msg = err_msg || " from GCOS ios_$seek";
		go to call_com_err;
	     end;
	     go to get_nextg;
	end;
%page;
/* determine if the input file has a catalog:
   if the first word of the file =0 then this is a simulator file with a catalog
   if the first word not=0 then this is a native GCOS file without a catalog
*/
	call ios_$seek ("gcls_input", "read", "first", 0, st);
	if code ^= 0 then do;
	     err_msg = "from ios_$seek read first word: ^a";
	     goto call_com_err;
	end;

	call ios_$read ("gcls_input", addr(word_one), 0, 1, j, st);
	if code ^= 0 then do;
	     err_msg = "from ios_$read of word one: ^a";
	     goto call_com_err;
	end;

	if word_one = 0
	     then nocatsw = "0"b;		/* has catalog */
	     else nocatsw = "1"b;

	call ios_$seek ("gcls_input", "read", "first", 0, st);
	if code ^= 0 then do;
	     err_msg = "from ios_$seek read first word: ^a";
	     goto call_com_err;
	end;
%page;
/* not gcos ** file */
	if ^nocatsw then do;			/* if file has a catalog (the default) */
	     if ^prefsw then do;			/* and we were not requested to print preface records */
						/* then print the catalog */


		call ios_$read ("gcls_input", prefp, 0, 1000, j, st); /* read catalog */
		if status.code ^= 0 then do;
		     err_msg = err_msg || " from ios_$read";
		     goto call_com_err;
		end;

		do j = 1 to catalog.no_ent;
		     call gcos_cv_gebcd_ascii_ (addr (catalog.elements (j).name), 6, addr (string), i);
						/* get name in ascii */
		     if briefsw
			then call ioa_ ("^a", string); /* print name only, if -brief given */
		     else
		     call ioa_ ("^a^-^o", string, catalog.elements (j).address); /* else print name and offset */
		end;
		call ioa_ ("^/end of catalog");

		call cleanup_proc;
		return;
	     end;					/* END OF "PRINT CATALOG" DO GROUP */

	     else					/* we want to skip over the catalog */
	     doff = 1000;				/* which is exactly 1000 words long */

	end;					/* END OF "THERE IS A CATALOG" DO GROUP */

	else doff = 0;				/* no catalog to skip over */

	k = 0;					/* offset of first preface record (relative to doff) */

seek_preface:
	call ios_$seek ("gcls_input", "read", "first", k+doff, st); /* seek to start of next preface record */
	if status.code ^= 0 then do;			/* error ? */
	     err_msg = err_msg || " from ios_$seek";
	     goto call_com_err;
	end;

	if status.eof then do;
	     call ioa_ ("^/end of file");
	     call cleanup_proc;
	     return;
	end;

read:	call ios_$read ("gcls_input", prefp, 0, 3650, j, st); /* read preface record */
	if status.code ^= 0 then do;
	     err_msg = err_msg || " from ios_$read";
	     goto call_com_err;
	end;

/* Count DCWs, by looking for one with action code = "000"b */

	do ndcw = 1 to 58				/* there may be up to 58 of them in a block */
		while (substr (preface.dcws (ndcw), 22, 3) ^= "000"b);
	end;

	call gcos_cv_gebcd_ascii_ (addr (preface.name), 6, addr (string), i); /* convert prog name to ascii */
	if briefsw then do;				/* if -brief given, print name only -
						   and not rest of contents of preface record */
	     call ioa_ ("^a", string);
	     goto next_preface;
	end;
	call ioa_ ("preface of ^a", string);
	i1 = fixed (preface.entry, 18);
	i2 = fixed (preface.origin, 18);		/* convert interesting data */
	i3 = preface.reloc_words;
	i4 = preface.data_words;

	call ioa_ ("entry ^w, origin ^w, reloc_words ^w, data_words, ^w", i1, i2, i3, i4);

	do i = 1 to ndcw;				/* loop to print dcws */

	     i1 = fixed (preface.dcws (i));
	     call ioa_$nnl ("^w  ", i1);
	end;

	call ioa_ ("^2/");


/*  get offset of next preface record and seek to it */

next_preface:

	k = k+6+ndcw+preface.data_words+preface.reloc_words; /* offset of next preface block */

	goto seek_preface;				/* go seek to it */

cleanup_proc: proc;

	     call ios_$detach ("gcls_input", "", "", st);
	     return;
	end cleanup_proc;

     end gcos_library_summary;
 



		    gcos_list_patchfile.pl1         09/09/83  1357.7rew 09/09/83  1006.5       56475


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


/* *******************************************************************************************
   *******************************************************************************************
   *
   *
   *	Written by M. R. Jordan, September 1977
   *
   *******************************************************************************************
   ******************************************************************************************* */


gcos_list_patchfile: glp: proc ();

dcl  ME char (19) static internal options (constant) init ("gcos_list_patchfile");
dcl  addr builtin;
dcl  arg char (arg_len) based (arg_ptr);
dcl  arg_index fixed bin;
dcl  arg_len fixed bin;
dcl  arg_ptr ptr;
dcl  ascii_module_name char (6);
dcl  bcd_to_ascii_ entry (bit (*), char (*));
dcl  code fixed bin (35);
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  dirname char (168);
dcl  ename char (32);
dcl  error_table_$bigarg fixed bin (35) ext;
dcl  error_table_$improper_data_format fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  gcos_cv_ascii_gebcd_ entry (ptr, fixed bin, ptr, fixed bin);
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  i fixed bin;
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  length builtin;
dcl  module_name bit (36);
dcl  module_name_index fixed bin;
dcl  nargs fixed bin;
dcl  null builtin;
dcl  number_of_patches fixed bin;
dcl  patch_file_ptr ptr;
dcl  patch_location char (12) varying;
dcl  patch_ptr ptr;
dcl  ptr builtin;
dcl  substr builtin;

dcl 1 patch (number_of_patches) aligned based (patch_ptr),
    2 location fixed bin (17),
    2 content fixed bin (35);


dcl 1 patch_file aligned based (patch_file_ptr),
    2 version fixed bin,
    2 number_of_names fixed bin,
    2 module (130560),
      3 name bit (36) unal,
      3 first_patch_offset bit (18) unal,
      3 number_of_patches fixed bin (17) unal;

	call cu_$arg_count (nargs);
	if nargs < 1 then do;
	     call com_err_ (error_table_$noarg, ME, "^/Usage is:  gcos_list_patchfile patchfile {modulename ...}");
	     return;
	end;


	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "referencing argument 1");
	     return;
	end;

	call Process_Patchfile_Name ();
	if code ^= 0 then return;


	if nargs = 1 then call Print_Patch_Cards ();
	else do;

	     call ioa_ ("^2/_m_o_d_u_l_e  _l_o_c_a_t_i_o_n  _c_o_n_t_e_n_t");

	     do arg_index = 2 to nargs;

		call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
		if code ^= 0 then do;
		     call com_err_ (code, ME, "referencing argument ^d", arg_index);
		     return;
		end;

		if length (arg) > length (ascii_module_name) then do;
		     code = error_table_$bigarg;
		     call com_err_ (code, ME, """^a""", arg);
		end;

		ascii_module_name = arg;
		call gcos_cv_ascii_gebcd_ (addr (ascii_module_name), 6, addr (module_name), i);

		call Get_Module_Name_Index ();
		call List_Patches ();

	     end;

	end;


	return;

Process_Patchfile_Name: proc ();


	     call expand_pathname_ (arg, dirname, ename, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, """^a""", arg);
		return;
	     end;


	     call hcs_$initiate (dirname, ename, "", 0, 0, patch_file_ptr, code);
	     if patch_file_ptr = null () then do;
		call com_err_ (code, ME, """^a^[>^]^a""", dirname, (dirname ^= ">"), ename);
		return;
	     end;
	     else code = 0;


	     if patch_file.version ^= 1 then do;
		code = error_table_$improper_data_format;
		call com_err_ (code, ME, "patchfile version number is bad");
		return;
	     end;


	     return;


	end Process_Patchfile_Name;

Print_Patch_Cards: proc ();


	     do module_name_index = 1 to patch_file.number_of_names;


		call bcd_to_ascii_ (patch_file.module (module_name_index).name, ascii_module_name);
		patch_ptr = ptr (patch_file_ptr, patch_file.module (module_name_index).first_patch_offset);
		number_of_patches = patch_file.module (module_name_index).number_of_patches;


		do i = 1 to number_of_patches;

		     call ioa_$rsnnl ("^w", patch_location, 0, patch (i).location);
		     patch_location = substr (patch_location, 7, 6);
		     call ioa_ ("^6a^1xoctal^3x^w^45x^6a", patch_location, patch (i).content, ascii_module_name);

		end;


	     end;


	     return;


	end Print_Patch_Cards;

Get_Module_Name_Index: proc ();


dcl  l fixed bin;
dcl  u fixed bin;
dcl  floor builtin;
dcl  divide builtin;


	     l = 1;
	     u = patch_file.number_of_names;


	     do while (u >= l);

		module_name_index = floor (divide ((l+u), 2, 17));

		if module_name < patch_file.module (module_name_index).name then u = module_name_index-1;
		else if module_name > patch_file.module (module_name_index).name then l = module_name_index+1;
		else return;

	     end;


	     module_name_index = 0;


	     return;


	end Get_Module_Name_Index;

List_Patches: proc ();


	     if module_name_index > patch_file.number_of_names | module_name_index < 1 then do;
		call ioa_ ("^2/^6a^3xNO PATCHES", ascii_module_name);
		return;
	     end;


	     patch_ptr = ptr (patch_file_ptr, patch_file.module (module_name_index).first_patch_offset);
	     number_of_patches = patch_file.module (module_name_index).number_of_patches;


	     call ioa_ ("^2/^6a^3x^6o^3x^w", ascii_module_name, patch (1).location, patch (1).content);


	     do i = 2 to number_of_patches;

		call ioa_ ("^9x^6o^3x^w", patch (i).location, patch (i).content);

	     end;


	     return;


	end List_Patches;


     end gcos_list_patchfile;
 



		    gcos_pull_tapefile.pl1          09/09/83  1357.7rew 09/09/83  1006.6      289944


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_pull_tapefile: gcpt: pull: proc;

/* This command copies files from a GCOS tape into the Multics storage system.
   Since it was designed to read files from a total system tape, from which the
   gcos simulator libraries are built, it accepts records longer than 320 words.
   It reads the header label preceeding each file, prints the name and file
   sequence number, and asks the user if the file is to be copied. If the answer
   is yes, it asks for a pathname, and copies the file into it. Then it continues
   with the next file. This process is terminated either by a reply of "cancel", or
   "quit", or "q" to the question, or an end-of-reel label or partial label
   being encountered on the tape.

   USAGE: gcpt tape_number {-control_args}

   tape_number

   is a character string used in the mount message to the Multics operator.
   It need not match any field in the tape labels. See -attached, below.

   -attached, -att

   may be given in place of tape_number to indicate that the tape has been
   retained (see -retain, below) from a previous use of this command, and
   is therefore already mounted.

   -retain, -ret

   causes the tape to remain mounted when processing by this command is completed.
   This saves work for the Multics operator, if several attempts to read the tape
   are to be made.

   -detach, -det

   causes the tape to be detached and dismounted, before any attempt is
   made to attach the currently specified tape. If this is the only argument given,
   the tape will be detached and no other processing will take place.

   -skip n

   causes n files to be skipped over before the user is asked if files are to
   be copied. (Questioning starts with the n+1st file.)

   -gsr

   Allows standard size (320 word or less) records to be copied into the Multics
   storage system in a format readable by other Multics tools that manipulate
   GCOS files. Records shorter than 320 words are padded out to 320 words, allowing
   a read of 320 words to obtain exectly one record. This argument should not be
   used when reading a total system tape.

   -dcw

   Requests program to assume files are tape format System Loadable Files,
   as produced by SYSEDIT, and to interpret the DCW blocks, verifying their
   consistency with the data records, and adjusting record lengths, if necessary,
   before writing them to the output file.

   -no_label, -nl

   Indicates that there are no header or trailer labels, and that every file
   is to be treated as data.

   -brief, -bf

   Causes certain warning messages and informative messages not to be printed.

   -long, -lg

   Causes hardware status, labels, and length and first word of all data records,
   to be printed on the terminal.

   -long_brief, -lb

   Causes hardware status and labels, but NOT length and first word of data records,
   to be printed on the terminal.

   -debug, -db

   Causes db to be called after the call to com_err_ and before the call
   to cleanup_proc, when any errors occur.

   -block n

   Allows tape buffer size to be increased from the default of 3842 words,
   up to a maximum of 4096 words.

   -density

   Allows tape density to be specified. Default is 1600.

   WRITTEN BY T. CASEY AUGUST 1974
   MODIFIED BY T.CASEY NOVEMBER 1974 TO FIX BUGS
   Modified: Ron Barstad  2.0  83-02-28  Changed incl query_info_ to query_info
                                        Added version indicator (start with 2.0)
   Modified: Ron Barstad  2.1  83-04-15  Added -density, -block and changed defaults.

*/
%page;
/*  D E C L A R A T I O N S      */

%include query_info;

/*  External Entries       */


dcl  com_err_ ext entry options (variable);
dcl  command_query_ ext entry options (variable);
dcl  cu_$arg_count ext entry (fixed bin);
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  db ext entry;
dcl  decode_nstd_status_ ext entry (bit (72) aligned, char (*) varying);
dcl  gcos_cv_gebcd_ascii_ ext entry (ptr, fixed bin, ptr, fixed bin(21));
dcl  ioa_ ext entry options (variable);

dcl  ios_$attach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);
dcl  ios_$detach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);
dcl  ios_$order ext entry
    (char (*) aligned, char (*) aligned, ptr, bit (72) aligned);
dcl  ios_$read ext entry
    (char (*) aligned, ptr, fixed bin(21), fixed bin(21), fixed bin(21), bit (72) aligned);
dcl  ios_$seek ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, bit (72) aligned);
dcl  ios_$setsize ext entry
    (char (*) aligned, fixed bin, bit (72) aligned);
dcl  ios_$tell ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(21), bit (72) aligned);
dcl  ios_$write ext entry
    (char (*) aligned, ptr, fixed bin(21), fixed bin(21), fixed bin(21), bit (72) aligned);

dcl (error_table_$noarg, error_table_$badopt, error_table_$inconsistent, error_table_$ioname_not_found, error_table_$bad_arg)
     ext static fixed bin (35);

/*  Work Variables */

/* Argument processing */
dcl  nargs fixed bin;
dcl  argp ptr;
dcl  argl fixed bin;
dcl  arg char (argl) based (argp);
dcl  argno fixed bin;

/* Character strings */

dcl  buf_arg char (32) varying;
dcl  buffer char (16384) aligned;			/* 4096 words */
dcl  den_arg char (32) varying;
dcl  err_msg char (200) varying;
dcl  pname char (168) aligned;			/* pathname to copy into, given by user */
dcl  err_path char (168) varying;
dcl  answer char (168) varying;
dcl  intape char (32) varying;                               /* tape number to read from */
dcl  tape_request char (64) aligned;
dcl  me char (24) int static options(constant) init ("gcos_pull_tapefile (2.1)");
dcl  ascii_name char (12) aligned;
dcl  valid_den (5) char (4) int static options(constant) init ("200", "556", "800", "1600", "6250");

/* Switches - init off */

dcl (
     longsw					/* print codes or labels or length and word one */
     , long_brief					/* do not print length and wordone */
     ) bit (1) aligned int static init ("0"b);              /* keep for -attach invocation */

dcl (
     attached					/* -attached given */
     , briefsw					/* -brief given */
     , debugsw					/* -debug given - call db if any errors occur */
     , dcwsw					/* -dcw given - interpret dcw blocks and delete extra words */
     , detach					/* -detach given */
     , eorsw					/* end of reel, or user said "quit" */
     , gsr					/* -gsr given */
     , no_label					/* no_label given: tape has no labels */
     , notdcw					/* on after inconsistent dcw block found in file */
     , out_of_synch					/* on if initial tape position not at header label */
     , print_hdwr_status				/* hardware status returned from nstd_ */
     , retain					/* -retain given */
     , skipit					/* user said -skip n and we are not yet at file n+1 */
     , tape_is_attached				/* either -attached given, or we attached a tape */
     ) bit (1) aligned init ("0"b);

/* Fixed bin */

dcl  bufsize fixed bin (21);

dcl (						/* fixed bin init (0) */
     dcw_block_len					/* computed length of dcw or data block */
     , dcw_index					/* index of current dcw in block */
     , dcw_word_count				/* sum of dcw.counts */
     , expected_arg					/* says which of -skip n or -block n was given */
     , filecount					/* which file are we at */
     , i                                                    /* just an index counter */
     , in_elements					/* elements read from input */
     , out_elements					/* elements written to output */
     , ndcw					/* number of dcws in block */
     , numeric_arg					/* value of n after -skip or -block */
     , read_count					/* to help get back into synch */
     , rec_count					/* counter for tape records in one file */
     , skipcount					/* number of files user said to skip */
     , word_count					/* sum of reloc and data word counts in dcw block */
     )fixed bin (21) init (0);

/* To keep track of what we are expecting next from the tape */

dcl (expected_input, next_expected_input, unexpected_input) fixed bin;

/* Names for things we are expecting, for program readability */

dcl (
     data_to_be_copied init (1)
     , header_label init (2)
     , trailer_label init (3)
     , eof_after_header init (4)
     , eof_after_trailer init (5)
     , eof_after_forward_file init (6)
     , eof init (7)
     , label init (8)
     , data init (9)
     , next_file init (10)
     )fixed bin int static options(constant);


/* Bit string */
dcl  st bit (72) aligned;

/* Based */
dcl  code fixed bin (35) aligned based (addr (st));

dcl 1 stat_word based (addr (st)),
    2 hdwr_status bit (1) unaligned,
    2 fill bit (25) unaligned,
    2 major bit (4) unaligned,
    2 minor bit (6) unaligned,
    2 word2 bit (36) aligned;				/* to allow printing of second half */

dcl 1 label_model aligned based (buffp),
    2 filler (8) fixed bin,
    2 filename bit (72);

dcl 1 partial_label aligned based (buffp),
    2 fill (4) bit (36) aligned,
    2 zero_words (6) bit (36) aligned,			/* if all zero, this is a partial label */
    2 fill2 (4) bit (36) aligned;

dcl 1 preface aligned based (buffp),			/* dcw block - called preface for historical reasons */
    2 (data_check, rel_chekc, rel_abs) fixed bin (35),
    2 name bit (36),
    2 (entry, origin) bit (18) unaligned,
    2 (reloc_words, data_words) fixed bin (17) unaligned,
    2 dcw (ndcw),
      3 data_addr bit (18) unaligned,
      3 zero bit (3) unaligned,
      3 action bit (3) unaligned,
      3 count bit (12) unaligned;


dcl  w (4096) bit (36) aligned based (buffp);

dcl  wordone bit (36) aligned based (buffp);		/* overlay for first word of buffer */

/* Pointer */
dcl  buffp pointer;

/* Builtin */
dcl (addr, divide, fixed, hbound, mod, null, rtrim, substr, unspec) builtin;

dcl  cleanup condition;

%page;
/*  P R O C E D U R E      */


	buffp = addr (buffer);
	on condition (cleanup) call cleanup_proc;

	call cu_$arg_count (nargs);

/* Initialize */

	den_arg = "1600";
	buf_arg = "3842";
	bufsize = 3842;
	intape = "";
	tape_request = "";

/* IF NO ARGS, PRINT USAGE MESSAGE AND QUIT */

	if nargs = 0 then do;
	     code = error_table_$noarg;
	     err_msg = "Usage: gcpt REEL_NUMBER OR -attached {-control_args}";
	     goto call_com_err;
	end;

arg_loop:	do argno = 1 to nargs;

	     call cu_$arg_ptr (argno, argp, argl, code);

	     if code ^= 0 then do;
		err_msg = arg;
call_com_err:	call com_err_ (code, me, err_msg, err_path, numeric_arg);
		if print_hdwr_status then
		     call ioa_ ("(^a)", answer);

		if debugsw then do;
		     call ioa_ ("CALLING DB:");
		     call db;
		end;

clean_out:	call cleanup_proc;
		return;
	     end;

	     err_path = arg;			/* in case of arg error */
	     code = 0;

	     if expected_arg ^= 0 then do;
		numeric_arg = cv_dec_check_ (arg, code);

		if expected_arg = 1 then do;		/* -skip n */
		     expected_arg = 0;
		     if code ^= 0 then do;
			code = error_table_$bad_arg;	/* cv_dec_check_ does not return an error_table_ code */
			err_msg = "bad skip count: ^a";
			goto call_com_err;
		     end;
		     skipcount = numeric_arg;
		end;

		else if expected_arg = 2 then do;	/* -block n */
		     expected_arg = 0;
		     if code ^= 0 then do;
			code = error_table_$bad_arg;
bad_buf_size:		err_msg = "bad buffer size: ^a";
			goto call_com_err;
		     end;
		     if numeric_arg > 4096 then
			goto bad_buf_size;
		     bufsize = numeric_arg;
		     buf_arg = arg;
		end;

		else if expected_arg = 3 then do;	/* -density n */
		     den_arg = "";
		     expected_arg = 0;
		     if code ^= 0 then do;
			code = error_table_$bad_arg;
			err_msg = "tape density missing or contains non-numerics: ^a";
			goto call_com_err;
		     end;
		     do i = 1 to hbound(valid_den,1);
			if arg = valid_den(i)
			     then den_arg = arg;
		     end;
		     if den_arg = "" then do;
			code = error_table_$bad_arg;
			err_msg = "not a known tape density: ^a";
			goto call_com_err;
		     end;
		end;

		else do;
		     err_msg = "program bug";
		     goto call_com_err;
		end;
	     end;					/* end of expected arg do group */

	     else if substr (arg, 1, 1) ^= "-" then do;	/* must be tape number */
		if intape ^= "" then do;		/* if it was already given */
		     err_msg = "unknown non-control argument: ^a";
		     goto call_com_err;
		end;
		intape = arg;
	     end;					/* end of tape number do group */

	     else do;				/* control arg */
		if arg = "-att" | arg = "-attached" then do;
		     attached = "1"b;
		     tape_is_attached = "1"b;
		end;
		else if arg = "-bk" | arg = "-block" then
		     expected_arg = 2;
		else if arg = "-db" | arg = "-debug" then
		     debugsw = "1"b;
		else if arg = "-den" | arg = "-density" then
		     expected_arg = 3;
		else if arg = "-dcw" then
		     dcwsw = "1"b;
		else if arg = "-det" | arg = "-detach" then
		     detach = "1"b;
		else if arg = "-gsr" then
		     gsr = "1"b;
		else if arg = "-lg" | arg = "-long" then do;
		     longsw = "1"b;
		     long_brief = "0"b;
		end;
		else if arg = "-lb" | arg = "-long_brief" then
		     longsw, long_brief = "1"b;
		else if arg = "-nl" | arg = "-no_label" | arg = "-no_labels" then
		     no_label = "1"b;
		else if arg = "-ret" | arg = "-retain" then
		     retain = "1"b;
		else if arg = "-skip" then
		     expected_arg = 1;
		else if arg = "-bf" | arg = "-brief" then
		     briefsw = "1"b;
		else do;
		     code = error_table_$badopt;
		     err_msg = "^a";
		     goto call_com_err;
		end;
	     end;					/* end control arg do group */

	end arg_loop;

/* Check correctness of args */

	if expected_arg ^= 0 then do;
	     err_msg = "after ^a";
	     code = error_table_$noarg;
	     goto call_com_err;
	end;

	if attached then do;			/* tape attached already */
	     if intape ^= "" then do;			/* can't give tape number too */
		err_msg = "tape_number and -attached";
inconsistent:	code = error_table_$inconsistent;
		goto call_com_err;
	     end;
	     if detach then do;
		err_msg = "-detach and -attached";
		goto inconsistent;
	     end;
	end;					/* end tape attached do group */

	else do;					/* tape not already attached */
	     if detach then do;
		call ios_$detach ("gcpt_input", "", "", st);
		if code ^= 0 then
		     if code ^= error_table_$ioname_not_found then do; /* don't blow up if there was no tape attached */
			err_msg = "from ios_$detach the previously retained tape";
			goto tape_error;
		     end;
		if nargs = 1 then return;		/* if that's all there is to do */
		detach = "0"b;			/* don't detach the next tape */
	     end;
	     if intape = "" then do;			/* tape number must be given */
		err_msg = "tape_number";
		code = error_table_$noarg;
		goto call_com_err;
	     end;
	end;					/* end tape not attached do group */

/* Attach input tape */

	if ^attached then do;
	     tape_request = rtrim(intape||",den="||den_arg||",block="||buf_arg);
	     err_path = "tape " || intape;		/* for error messages */
	     call ios_$attach ("gcpt_input", "nstd_", tape_request, "r", st);
	     if code ^= 0 then do;
		err_msg = "from ios_$attach ^a";
tape_error:					/* come here from other tape errors */
		if hdwr_status then do;
		     call decode_nstd_status_ (st, answer);
		     print_hdwr_status = "1"b;	/* rember to print it after main error message */
		end;

		else if code = error_table_$ioname_not_found then
		     tape_is_attached = "0"b;		/* tell cleanup_proc that tape was not there */
		goto call_com_err;
	     end;					/* end code ^= 0 do group */
	     tape_is_attached = "1"b;			/* for the information of cleanup_proc */
	end;					/* end ^attached do group */

	else					/* tape is attached */
	err_path = "the retained tape";		/* best we can do for error messages */
						/* Initialize */

/* Initialize */
	query_info.suppress_name_sw = "1"b;
	if no_label then				/* if tape has no labels */
	     expected_input = next_file;		/* first record will be data */
	else expected_input = header_label;		/* otherwise it will be a header label */

/* Main read and write loop */

copyloop:	do while (^eorsw);				/* keep reading until end of reel
						   or until user says "quit" */

	     if expected_input = eof_after_forward_file then /* if user does not want file copied */
		call ios_$order ("gcpt_input", "forward_file", null, st);
						/* skip over all data records at once, to save time */
	     else do;
		call ios_$read ("gcpt_input", buffp, 0, bufsize, in_elements, st);
						/* else read data or label record */
		read_count = read_count + 1;		/* count reads, to help get into synch,
						   in case initial tape position is not at header label */
	     end;

	     if longsw then do;
		if code ^= 0 then do;
		     call decode_nstd_status_ (st, answer);
		     call ioa_ ("status = ^w ^w (^a)", code, word2, answer);
		end;
		else do;
		     if in_elements ^= 14 then do;	/* if not a label */
			if ^long_brief then		/* let user turn this off separately */
			     call dumper (1);	/* print length and bcw of record */
		     end;

		     else call dumper (2);		/* this is probably a label - dump 14 words */
		end;
	     end;

	     if code ^= 0 then do;

		if hdwr_status			/* is it hadrware status */
		& major = "0100"b			/* is it an end of file mark */
		& (minor = "001111"b		/* eof 7track (17 octal) */
		| minor = "010011"b) then do;		/* eof 9track (23 octal) */
						/* it was end of file */
		     if expected_input = eof_after_header then
			expected_input = next_expected_input; /* either data_to_be_copied,
						   or eof_after_forward_file, depending on user's reply */

		     else if expected_input = eof_after_trailer then
			expected_input = header_label;

		     else if expected_input = eof_after_forward_file then do;
			if no_label then		/* if tape has no labels */
			     expected_input = next_file; /* next record will be first of next file */
			else expected_input = trailer_label; /* otherwise it will be a trailer label */
		     end;

		     else if expected_input = data_to_be_copied then do; /* eof after data records */
			call ios_$tell ("gcpt_output", "write", "first", out_elements, st); /* see how much we wrote */
			if code ^= 0 then do;
			     err_msg = "from ios_$tell write ^a";
			     goto file_error;
			end;
			if mod (out_elements, 1024) ^= 0 then out_elements = out_elements+1024; /* get it in pages */
			out_elements = divide (out_elements, 1024, 17, 0);
						/* tell user */
			call ioa_ ("^d tape records read, ^d Multics records (pages) written", rec_count, out_elements);
			rec_count = 0;		/* reset it for next file */
			call ios_$detach ("gcpt_output", "", "", st); /* detach output file */
			if code ^= 0 then do;
			     err_msg = "from ios_$detach ^a";
			     goto file_error;
			end;
			if no_label then		/* if tape has no labels */
			     expected_input = next_file; /* next record will be first of next file */
			else expected_input = trailer_label; /* otherwise it will be trailer label */
		     end;

		     else if expected_input = header_label then do;
			if read_count = 1 then do;	/* first read - tape was not at header to start */
			     call ioa_ ("^a: Filemark encountered when header label expected.", me);
			     unexpected_input = eof;
tape_out_of_synch:
			     out_of_synch = "1"b;
			     call ioa_ ("Initial tape position was incorrect.
Answer ""no"" to the following question to request search for next header label.
Answer ""quit"" to terminate processing.");
			     goto ask;
			end;

			else if out_of_synch then
			     if unexpected_input = eof then
				goto double_eof;

		     end;
		     else if expected_input = trailer_label | expected_input = next_file then do;
double_eof:		call com_err_ (0, me, "Consecutive end of file marks encountered.
Enter ""no"" to continue reading tape, or ""quit"" to stop.");
			goto ask;
		     end;

		end;				/* end of end-of-file do group */

/* Since nstd_ retries reads 10 times after errors, before returning
   to the caller, there is no point in our retrying again. It is hopeless. */

		else do;
		     if expected_input = eof_after_forward_file then
			err_msg = "From ios_$order forward_file ^a";
		     else err_msg = "From ios_$read ^a";
		     goto tape_error;
		end;

	     end;					/* end of code ^= 0 do group */


	     else if in_elements >= bufsize then do;
		err_msg = "record too long on tape ^a (^d words)";
		numeric_arg = in_elements;
		goto call_com_err;
	     end;

	     else if expected_input = eof_after_header
	     | expected_input = eof_after_trailer then do;
						/* if it had been there, we would have detected it above,
						   as hardware status */
		err_msg = "no filemark after label record on tape ^a";
		goto tape_error;
	     end;

	     else if expected_input = next_file then do;	/* no labels on tape */

		skipit = "0"b;			/* duplicate some of header label processing code */
		filecount = filecount + 1;
		if filecount <= skipcount then skipit = "1"b;
		if ^skipit then do;
		     call ioa_ ("File ^d.", filecount);

		     if ^longsw then		/* if user has seen nothing about file yet */
			call dumper (3);		/* print everything */

		     else do;			/* user has seen dump, if 14 word record,
						   or length and bcw, if ^14words and ^long_brief */
			if long_brief then do;	/* user has not seen length */
			     if in_elements ^= 14 then /* and not dump either */
				call dumper (3);	/* so print both */
			end;			/* dump without header implies 14 word length */

			else do;			/* user has seen something */
			     if in_elements ^= 14 then /* it was length and bcw */
				call dumper (2);	/* so dump first 14 words */
			end;

		     end;				/* having told user something about the file */
		     goto ask_copy;			/* go ask if it should be copied */

		end;				/* end ^skipit do group */

	     end;					/* end expecting next file do group */

	     else if expected_input = header_label then do; /* if expecting header label */
check_for_header:	if in_elements = 14 & wordone = "010111010101010000010000000110000000"b then do; /* (GE/b/b60) */
		     out_of_synch = "0"b;		/* just in case it was on */
		     expected_input = eof_after_header;
						/* translate filename to ascii */
		     call gcos_cv_gebcd_ascii_ (addr (label_model.filename), 12, addr (ascii_name), out_elements);
		     skipit = "0"b;
		     filecount = filecount+1;		/* bump file number */
		     if unspec (partial_label.zero_words) = ""b then do;
			skipit, eorsw = "1"b;	/* partial label indicates end of tape */
			call ioa_ ("Partial label (end of tape).");
		     end;
		     if filecount <= skipcount then
			skipit = "1"b;
		     if ^briefsw | ^skipit then
			if ^eorsw then call ioa_ ("File ^d. is ""^a""", filecount, ascii_name);

/*  Ask user if he wants to copy this file */
		     if ^skipit then do;
ask_copy:			err_msg = "Copy?";
ask:			call command_query_ (addr (query_info), answer, me, err_msg);
		     end;
		     if skipit | answer = "no" | answer = "n" then do;
			if no_label then		/* if unlabeled tape */
			     expected_input = eof_after_forward_file; /* skip to next file */
			else next_expected_input = eof_after_forward_file; /* else get past eof after header first */
		     end;

		     else if answer = "cancel" | answer = "quit" | answer = "q" then
			eorsw = "1"b;		/* pretend we hit end of reel */

		     else if answer ^= "yes" & answer ^= "y" then do; 
			err_msg = "Please answer ""yes"", ""no"", or ""quit"":";
			goto ask;
		     end;

		     else do;
			next_expected_input = data_to_be_copied;

			if dcwsw then do;		/* initialize dcw processing for new file */
			     notdcw = "0"b;
			     ndcw = 0;
			end;

			call command_query_ (addr (query_info), answer, me,
			     "Pathname of file to copy to:");
			pname = answer;		/* varying string to fixed length string */

			call ios_$attach ("gcpt_output", "file_", pname, "", st); /* attach file */
			if code ^= 0 then do;
			     err_msg = "from ios_$attach ^a";
file_error:					/* come here from other output file errors */
			     err_path = pname;
			     goto call_com_err;
			end;
			call ios_$setsize ("gcpt_output", 36, st); /* set element size to 1 word */
			if code ^= 0 then do;
			     err_msg = "from ios_$setsize 36 ^a";
			     goto file_error;
			end;
			call ios_$seek ("gcpt_output", "last", "first", 0, st); /* start at beginning of file */
			if code ^= 0 then do;
			     err_msg = "from ios_$seek last first ^a";
			     goto file_error;
			end;

			if no_label then		/* if no labels, we have the first data record */
			     goto copy_data;	/* so go copy it */

		     end;				/* end answer = yes */
		end;				/* end header label given */

		else do;				/* expected header label not found */
		     if read_count = 1 then do;
			if in_elements = 14 then
			     unexpected_input = label;
			else unexpected_input = data;
			call ioa_ ("^a: Unknown record (^d words) encountered when header label expected.",
			     me, in_elements);
			goto tape_out_of_synch;
		     end;
		     else if ^out_of_synch then
			call ioa_ (" ^a: Expected header label not found; will read until found", me);
		     else if in_elements ^= 14 then	/* if not some kind of label record */
			expected_input = eof_after_forward_file; /* then forward space to save time */
		end;
	     end;					/* end header label expected */

	     else if expected_input = trailer_label then do; /* if eof after file was read */
						/* then we are expecting and EOF or EOR label record */
		if in_elements = 14 & wordone = "010000010101100110010110010000010000"b then do; /* "/bEOF/b/b"? */
		     call ioa_ ("End of File");
		     expected_input = eof_after_trailer;
		end;

		else if in_elements = 14 & wordone = "010000010101100110101001010000010000"b then do; /* "/bEOR/b/b"? */
		     call ioa_ ("End of Reel");
		     eorsw = "1"b;			/* remember eor */
		end;

		else do;				/* neither EOR nor EOF - what is it? */
		     if out_of_synch then do;
			if in_elements = 14 then	/* might be header label! */
			     goto check_for_header;
			else expected_input = eof_after_forward_file;
		     end;
		     else call ioa_ ("^a trailer label missing. processing continues.", me);
		end;
	     end;					/* end trailer label expected */

	     else if expected_input = data_to_be_copied then do; /* if we were expecting a data record, copy it */
copy_data:	rec_count = rec_count + 1;		/* count tape records copied to file */
		if gsr then			/* if user so requested */
		     if in_elements < 320 then	/* we will pad short records */
			in_elements = 320;		/* out to 320 words */

/* When the argument -dcw is given, this code assumes a tape format system
   loadable file, as produced by SYSEDIT, determines what the record lengths
   should be by looking at the dcw blocks, and whenever it finds an input record
   one word longer than it should be, it subtracts 1 from the length before writing it. */

		if dcwsw				/* if user said -dcw */
		then if ^notdcw			/* and we have not found inconsistencies already */
		     then do;			/* then interpret dcw blocks */

			if ndcw = 0 then do;	/* if we are expecting a dcw block */
			     dcw_index = 1;
			     if in_elements > 64 then do; /* too long to be a dcw block */
				call ioa_ ("not dcw block: ^d words.", in_elements);
				goto not_dcw_block;
			     end;

			     else do;		/* length ok for dcw block */
				dcw_word_count = 0; /* sum of dcw.counts */
				do ndcw = 1 to 58;	/* max of 58 dcws, plus 6 others, for 64 word max */
				     dcw_word_count = dcw_word_count + fixed (dcw (ndcw).count);
				     if dcw (ndcw).action = "000"b then goto end_dcw_list;
				end;
end_dcw_list:
				dcw_block_len = ndcw + 6;
				if in_elements ^= dcw_block_len then do;
				     if in_elements = dcw_block_len + 1 /* the case we are looking for */
				     then in_elements = dcw_block_len; /* fix it */
				     else do;	/* otherwise we don't know what's happening */
					call ioa_ ("not dcw block: actual block length = ^d,
computed block length = ^d (^d dcws)",
					     in_elements, dcw_block_len, ndcw);
					goto not_dcw_block;
				     end;

				end;

				word_count = preface.reloc_words + preface.data_words;
				if dcw_word_count ^= word_count then do;
				     call ioa_ ("not dcw block: sum of dcw.counts = ^d,
but reloc + data words = ^d (^d + ^d)",
					dcw_word_count, word_count, preface.reloc_words, preface.data_words);
				     goto not_dcw_block;
				end;

			     end;

			end;

			else do;			/* expecting data block */

			     dcw_block_len = fixed (dcw (dcw_index).count);
			     if in_elements ^= dcw_block_len then do;
				if in_elements = dcw_block_len + 1 then /* the case we are looking for */
				     in_elements = dcw_block_len;
				else do;		/* ??? */
				     call ioa_ ("record length = ^d, dcw.count = ^d", in_elements, dcw_block_len);
				     goto not_dcw_block;
				end;
			     end;

			     dcw_index = dcw_index + 1;
			     if dcw_index > ndcw then /* if we just used the last dcw */
				ndcw = 0;		/* expect a dcw block next */

			end;			/* end expecting data block */

			goto write_output;

not_dcw_block:
			notdcw = "1"b;
			call ioa_ ("will continue copying with no further attempts to interpret dcws");

		     end;				/* end of entire dcw block interpreting code */

write_output:

		call ios_$write ("gcpt_output", buffp, 0, in_elements, out_elements, st); /* write out record into file */
		if code ^= 0 then do;
		     err_msg = "from ios_$write ^a";
		     goto file_error;
		end;
		if in_elements ^= out_elements then do;
		     err_msg = "wrong number of words written to ^a (^d words)";
		     numeric_arg = out_elements;
		     goto file_error;
		end;
	     end;					/* end of copy record do group */

	     else call ioa_ ("Program bug.");		/* can't be else, unless the programmer blew it */
	end copyloop;				/* end of main loop */

/* We fall thru here when eorsw is "1"b - i.e. an end of reel record was read
   (or the user said to quit and we turned it on before the end of the tape) */

	if retain then
	     call ioa_ ("^a: input tape will remain attached.", me);
	else do;
	     call ios_$detach ("gcpt_input", "", "", st);
	     if code ^= 0 then do;
		err_msg = "from ios_$detach ^a";
		goto tape_error;
	     end;
	end;

	return;					/* normal return */


/* END OF MAIN PROCEDURE */

cleanup_proc: proc;					/* called on cleanup condition, and after
						   any error in argument processing or I/O */
	     if retain then do;			/* if user said retain */
		if tape_is_attached then		/* and we do have a tape attached */
		     call ioa_ ("^a: input tape will remain attached", me); /* let him know it's there */
	     end;					/* and don't detach it */
	     else call ios_$detach ("gcpt_input", "", "", st);
	     call ios_$detach ("gcpt_output", "", "", st);
	     return;
	end cleanup_proc;

dumper:	proc (sw);
dcl  sw fixed bin;

	     if sw = 1 | sw = 3 then			/* print length and bcw */
		call ioa_ ("reclen = ^d, wordone = ^w", in_elements, wordone);

	     if sw = 2 | sw = 3 then			/* dump first 14 words of record */
		call ioa_ ("^3(^4(^w ^)^/^)^w ^w",
		w (1), w (2), w (3), w (4), w (5), w (6), w (7),
		w (8), w (9), w (10), w (11), w (12), w (13), w (14));

	     return;
	end dumper;

/* Allow user to hit QUIT, change the long or long_brief mode, and resume processing */

gcpt_long: gcptlg: entry;

dcl  state char (8) aligned;

	buffp = addr (buffer);
	long_brief = "0"b;
	longsw = ^longsw;
	if longsw then do;
	     state = "on";
	end;
	else do;
set_off:	     state = "off";
	end;
print_state: call ioa_ ("gcpt long mode set to ^a", state);
	return;

gcpt_long_brief: gcptlb: entry;

	buffp = addr (buffer);
	long_brief = ^long_brief;
	if long_brief then do;
	     longsw = "1"b;
	     state = "brief";
	     goto print_state;
	end;
	else do;
	     longsw = "0"b;
	     goto set_off;
	end;

     end gcos_pull_tapefile;



		    gcos_reformat_syslib.pl1        09/09/83  1357.7rew 09/09/83  1006.6       80766


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_reformat_syslib: gcrs: ssyfix: proc;

/* This command reformats the softw-syslib file (the library used by GELOAD)
   from the total system tape, so that it can be read by the simulator.

   As read from the total system tape, the file contains 321 word blocks.
   The first appears to be a block control word, and the next 320 make up
   a block that GELOAD interprets itself. If read from a 7 track MTS500,
   the word count is rounded up to the next even number, 322, so a word
   at the end must also be discarded. The number of words to be read is
   therefore an optional argument, with the default being 321. The first
   word is discarded, and the next 320 words are always retained.

   THe first word (the bcw) is checked for sequential bsn's, and block lengths
   of 320 or less, to verify that the correct record length was used for
   reading, and that the words being discarded are really bcw's.

   NOTE that this method of making the file readable by the simulator was
   arrived at experimentally, and is not based on any knowledge of the format
   of the subroutine library or the operation of GELOAD in real GCOS. If either
   of those changes, this command may also have to be changed.

   USAGE: gcrs input_path -output_path- -record_length-

   If output_path is not given, the modifications will be made to the input file.
   Since a temporary is not used, quitting and releasing while updating the
   input file will leave it in an inconsistent state, from which recovery is
   almost impossible.

   If record_length is not given the default is 321. Record_length is
   distinguished from out_path by the fact that it must be numeric.
   It may preceed or follow output_path, and output_path
   need not be given when record_length is given.

   WRITTEN BY T.CASEY AUGUST 1973
   MODIFIED BY T. CASEY AUGUST 1974

*/

/* D  E  C  L  A  R  A  T  I  O  N  S      */

dcl  ioa_ ext entry options (variable);
dcl  com_err_ ext entry options (variable);
dcl  cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  ios_$attach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);
dcl  ios_$detach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);
dcl  ios_$read ext entry
    (char (*) aligned, ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned);
dcl  ios_$seek ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, bit (72) aligned);
dcl  ios_$setsize ext entry
    (char (*) aligned, fixed bin, bit (72) aligned);
dcl  ios_$write ext entry
    (char (*) aligned, ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned);
dcl  cu_$arg_count ext entry (fixed bin);
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35));

/*  Work Variables */

dcl  nargs fixed bin;
dcl  argp ptr;
dcl  argl fixed bin;
dcl  arg char (argl) based (argp);
dcl  argno fixed bin;

dcl  err_msg char (200) varying;

dcl  err_path char (168) varying;

dcl  eofbit bit (1) aligned;
dcl  buffer char (1600) aligned;			/* 400 words */
dcl  blkp ptr;
dcl 1 block aligned based (blkp),
    2 bcw,
      3 bsn bit (18) unaligned,
      3 count bit (18) unaligned;
dcl  old_bsn fixed bin init (0);			/* bsns must begin with 1 */
dcl  new_bsn fixed bin;
dcl  rec_len fixed bin init (321);
dcl (i, j, k) fixed bin;				/* temporaries */
dcl  status bit (72) aligned init (""b);
dcl  code fixed bin (35) aligned based (addr (status));
dcl (inpath, outpath) char (168) aligned init ("");
dcl (instream, outstream) char (32) aligned init ("");
dcl  me char (20) int static aligned init ("gcos_reformat_syslib");
dcl  rw char (1) aligned;

dcl (addr, fixed, substr) builtin;

dcl  cleanup condition;

/* P  R  O  C  E  D  U  R  E     */

	blkp = addr (buffer);
	on condition (cleanup) call cleanup_proc;

	call cu_$arg_count (nargs);

/* IF WRONG NUMBER OF ARGS, PRINT USAGE MESSAGE AND QUIT */

	if nargs = 0 | nargs > 3 then do;
	     err_msg = "USAGE: gcrs input_path -output_path-";
	     goto call_com_err;
	end;

arg_loop:	do argno = 1 to nargs;

	     call cu_$arg_ptr (argno, argp, argl, code);

	     if code ^= 0 then do;
		err_msg = arg;
call_com_err:	call com_err_ (code, me, err_msg, err_path);
		call cleanup_proc;
		return;
	     end;

	     err_path = arg;

	     if argno = 1 then do;			/* default is to update input file */
		inpath, outpath = arg;
		instream, outstream = "gcrs_i/o";
		rw = " ";				/* equivalent to "rw" for ios_$attach */
	     end;

	     else do;				/* see if output_path or record len */
		i = cv_dec_check_ (arg, code);
		if code ^= 0 then do;		/* non numeric */
		     code = 0;			/* clear it - its not an error_table_ code */
		     if outpath ^= inpath then do;	/* outpath already given */
			err_msg = "Unknown argument: ^a";
			goto call_com_err;
		     end;				/* end outpath given */
		     else do;			/* outpath not given - assume this is it */
			outpath = arg;
			outstream = "gcrs_output";
			instream = "gcrs_input";
			rw = "r";			/* attach input file for read only */
		     end;				/* end assume outpath */
		end;				/* end non numeric */
		else rec_len = i;			/* numeric - assume rec_len */
	     end;					/* end not firt arg */

	end arg_loop;

/* Initialize and attach files */

	err_path = inpath;				/* in case of error */
	call ios_$attach (instream, "file_", inpath, rw, status);
	if code ^= 0 then do;
attach_error:  err_msg = "from ios_$attach ^a";
	     goto call_com_err;
	end;
	call ios_$setsize (instream, 36, status);
	if code ^= 0 then do;
setsize_error: err_msg = "from ios_$setsize 36 ^a";
	     goto call_com_err;
	end;

	err_path = outpath;				/* more possibilities of output errors now */

	if outstream ^= instream then do;		/* if separate output file */
	     call ios_$attach (outstream, "file_", outpath, "", status);
	     if code ^= 0 then goto attach_error;
	     call ios_$setsize (outstream, 36, status);
	     if code ^= 0 then goto setsize_error;
	end;

/* whether or not input and output are the same,
   seek the output write pointer to the beginning of the file */
	call ios_$seek (outstream, "write", "first", 0, status);
	if code ^= 0 then do;
	     err_msg = "from ios_$seek write first ^a";
	     goto call_com_err;
	end;

/* Main loop */

read:	call ios_$read (instream, blkp, 0, rec_len, i, status);
	eofbit = substr (status, 46, 1);		/* remember end of file indicator */
	if code ^= 0 then do;
	     err_msg = "from ios_$read ^a";
input_error:   err_path = inpath;
	     goto call_com_err;
	end;

	new_bsn = fixed (bsn);
	if new_bsn ^= old_bsn + 1 then
	     call ioa_ ("^a: block serial number error: previous bsn = ^d, current bsn = ^d.Processing continues",
	     me, old_bsn, new_bsn);
	old_bsn = new_bsn;

	k = fixed (bcw.count);
	if k > 320 then
	     call ioa_ ("^a: bad bcw count: ^d in block ^d. Processing continues.", me, k, new_bsn);

	if i = rec_len then
	     i = 320;				/* throw away the rcw */
	else call ioa_ ("^a: short block read: ^d words in block ^d. Processing continues.", me, i, new_bsn);

	call ios_$write (outstream, blkp, 1, i, j, status); /* the offset of 1 is what gets rid of the rcw */
	if code ^= 0 then do;
	     err_msg = "from ios_$write ^a";
	     goto call_com_err;
	end;
	if i ^= j then do;
	     err_msg = "wrong number of words written to ^a";
	     goto call_com_err;
	end;

	if ^eofbit then goto read;			/* go read next record if there is one */

	else do;					/* end of file */
	     call ioa_ ("^a: Normal end of file on ^a", me, inpath);

	     if instream = outstream then do;		/* if updating input file */
		call ios_$seek (instream, "last", "write", 0, status); /* get rid of garbage at end */
		if code ^= 0 then do;
		     err_msg = "from ios_$seek last write ^a";
		     goto call_com_err;
		end;
	     end;

	     call ios_$detach (instream, "", "", status);
	     if code ^= 0 then do;
		err_msg = "from ios_$detach ^a";
		goto input_error;
	     end;

	     if instream ^= outstream then do;		/* if separate output file, detach it too */
		call ios_$detach (outstream, "", "", status);
		if code ^= 0 then do;
		     err_msg = "from ios_$detach ^a";
		     goto call_com_err;
		end;
	     end;

	     return;

	end;					/* end of end of file do group */


cleanup_proc: proc;

	     call ios_$detach (instream, "", "", status);
	     call ios_$detach (outstream, "", "", status);

	     if code = 0 then			/* if this is cleanup handler */
		if instream = outstream then
		     if instream ^= "" then
			call ioa_ ("^a: WARNING: ^a may have been left in an inconsistent state", me, inpath);

	     return;

	end cleanup_proc;

     end gcos_reformat_syslib;
  



		    gcos_tss_build_library.pl1      04/09/85  1704.7r w 04/08/85  1131.8      401940


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style1,^inddcls,ind4 */
gcos_tss_build_library: gtbl: proc;
/****	Build or update the GTSS fast load software library from
	all or selected parts of GCOS	software files (native or GES)
          and update the GTSS	program descriptors. 

          Based on the command "gcos_lib_obtain_modules" or "glom"

 Usage: gtbl INPUT_LIBS {-control_args}

           INPUT_LIBS  are paths of one or more gcos software files
                       the files may be either native GCOS or simulator format
           -control_args :=  -module_file PATH, -mf PATH
                                         a segment containing a list of modules
                                          to be moved from INPUT_LIBS to output
                             -modules STR..., -mods STR...
                                         names of modules to be moved
                             -program_descriptors PATH, -prgdes PATH
                                         path of a gtss_prgdes_alm_.incl.alm to be updated 
                             -output_library PATH, -olb PATH
                                         path of the gtss_fast_library_
                             -print_catalog, -prcat
                                         print contents of GES format INPUT_LIBS
                             -brief, -bf
                                         don't print catalog or modules moved


  Created:  Dave Ward    78-04-18  As glom
 Modified:  Ron Barstad  83-03-03  1.0 Changed name to gtbl, added version 1.0
                                   Changed to standard or current conventions
                                   Changed command line
                                       -cf to -module_file
                                       -nm to -modules
                                       -ol to -output_library
                                       -no_cat to -format
                                       added -program_descriptors
                                       deleted -olli
                                   Changed reference to XIO to gcos_xio_
                                   Changed reference to HASH to gfms_hash_
                                   Moved inits from dcl to procedure
                                   Changed gtss_bcd_ascii_ calls to gfms_bcd_ascii_
                                   Fixed msf boundry bug, each object wholly contained in a segment.
                                   Added prgdes update functionality
  

 Modified:  Ron Barstad  83-04-14  1.1 Removed need for -format, determine this
                                       by inspection
*/
%page;
/****  P R O C E D U R E  */

        call cu_$arg_count (nargs, e);
        if e = 0 & nargs < 1 then e = error_table_$noarg;
        if e ^= 0 then do;
	      call com_err_ (e, ME, "^/Usage: gtbl INPUT_LIBS {-control_args}");
	      return;
	  end;
        on condition (cleanup) call closer;

/**** Initialize */
/* format: off */
   	all_mods		= TRUE;
   	brief		= FALSE;
   	get_mod_name	= FALSE;
   	need_1_mod_name	= FALSE;
   	no_cat		= FALSE;
   	prgdes		= FALSE;
   	open_prgdes	= FALSE;
	have_output_lib     = FALSE;
	process_mf          = FALSE;
          process_ol          = FALSE;
   	pr_cat		= FALSE;

   	catl		= 1000; /* length of catalog at front of GES format lib. */
   	catl_parm		= 0;
   	cc		= -1;
	copy_names.start    = 0;
   	dcwbc		= 0;
   	init_nm		= 0;
   	libc		= 0;
	msw                 = sys_info$max_seg_size; 
   	ndcw		= 1;
   	obj_num		= 0;
	outc                = -1;
	outl                = 0;
   	wdl		= 0;
          copy_names.nm	= 0;
          lib_stack.libn	= 0;

   	input_lib_path	= "NONE";
   	output_lib_path	= "NONE";
	path                = "NONE";
   	prgdes_path	= "NO_PRGDES";

	mf_fcbp            = null();
	lib_fcbp            = null();
	out_fcbp            = null();
   	prgdes_fcbp	= null();
   	outp		= null();
   	dcwbp		= null();
   	eo_word_loc	= null();
   	reloc_word_loc	= null();
   	rd_word_loc	= null();
   	dcw_loc		= null();

	call date_time_ (clock_(), run_date);
/* format: on */
%page;
/* Process command line */

        do arg_num = 1 to nargs;
	  call cu_$arg_ptr (arg_num, ap, al, e);
	  if e ^= 0 then do;
		call com_err_ (e, ME, "Argument ^i", arg_num);
		goto close_files;
	      end;
	  if al < 1 then do;
		call com_err_ (error_table_$bad_arg, ME, "Zero length parameter (^i). Quitting.", arg_num);
		goto close_files;
	      end;
	  if substr (arg, 1, 1) = "-" then get_mod_name = FALSE;
	  if get_mod_name then do;
		need_1_mod_name = FALSE;		/* Regulates reporting name missing. */
		call next_mod_name (ap, al);
	      end;
	  else
	       if process_mf then call get_module_file;	/* Obtain control file and names therein. */
	  else
	       if process_ol then call get_out_lib;	/* Obtain output file. */
	  else
	       if open_prgdes then call get_prgdes_file;
	  else
	       if (arg = "-prgdes") | (arg = "-program_descriptors") then open_prgdes = TRUE;
	  else
	       if (arg = "-bf") | (arg = "-brief") then brief = TRUE;
	  else
	       if (arg = "-module_file") | (arg = "-mf") then process_mf = TRUE;
	  else
	       if (arg = "-output_library") | (arg = "-olb") then process_ol = TRUE;
	  else
	       if (arg = "-print_catalog") | (arg = "-prcat") then pr_cat = TRUE;
	  else
	       if (arg = "-modules") | (arg = "-mods") | (arg = "-module") | (arg = "-mod")
	  then get_mod_name, need_1_mod_name = TRUE;
	  else
	       if substr (arg, 1, 1) = "-" then do;
		call com_err_ (error_table_$badopt, ME,
		    "Unknown option ""^a"". Quitting.", arg);
		goto close_files;
	      end;
	  else
	       call stack_lib_path;
        end;
%page;
/****	Verify that caller's parameters are acceptable.	*/
        if libn < 1 then do;
	      call com_err_ (error_table_$noarg, ME, "At least one input library must be specified. Quitting.");
	      goto close_files;
	  end;
        if need_1_mod_name then do;
	      call com_err_ (error_table_$noarg, ME, "Missing module name for -modules. Quitting.");
	      goto close_files;
	  end;
        if open_prgdes then do;
	      call com_err_ (error_table_$noarg, ME, "No path supplied for -prgdes. Quitting.");
	      goto close_files;
	  end;
        if process_mf then do;
	      call com_err_ (error_table_$noarg, ME, "No module path supplied for -module_file. Quitting.");
	      goto close_files;
	  end;
        if process_ol then do;
	      call com_err_ (error_table_$noarg, ME, "Missing output path for -output_library. Quitting.");
	      goto close_files;
	  end;

/**** check for some possibly incompatable parameters */
        if prgdes & ^have_output_lib
        then call ioa_$ioa_stream ("error_output",
	       "^/Warning: no output library was specified, the program descriptors will not be updated.");
        else if ^prgdes & have_output_lib
        then call ioa_$ioa_stream ("error_output",
	       "^/Warning: the output library will be updated but no program descriptor file was specified.");

/**** give run date_time */
        if prgdes then call ioa_ ("Updated program descriptors will be labeled ""^a"".", run_date);
%page;
/****	Process input  libraries.	*/
        max_dcw_count = 2 ** length (addr (i) -> dcw.count);/* Constant => if count=0. */
        init_nm = nm;
        if nm > 0 then all_mods = FALSE;		/* Specific modules selected. */
        libc = 0;					/* Current library. */

next_input_library: ;
        libc = libc + 1;
        if libc > libn then do;			/* All input libraries processed. */
	      if nm > 0 then do;
		    if nm = 1 then
		         call ioa_$ioa_stream ("error_output",
			   "Specified module not found on input libraries.");
		    else
		         call ioa_$ioa_stream ("error_output",
			   "^i specified modules not found on input libraries.", nm);
		    if ^brief then do;
			  j = 0;
			  do k = 1 to init_nm;
			      if link (k) > -1 then do;
				    j = j + 1;
				    call ioa_$ioa_stream ("error_output", "^4i. ""^a""", j, mod_name (k));
				end;
			  end;
		        end;
		end;
	      goto close_files;
	  end;
        if get_input_lib () then goto next_input_library;	/* Could not obtain it. */
        /*** look at the first word of the library to see if it is native gcos or simulator format */
        if cp (0) -> just_a_word = "0"b
        then catl = 1000;				/* simulator library */
        else catl = 0;				/* native gcos format */
        if pr_cat then call print_catalog;
        if (brief) & (out_fcbp = null ()) & (nm = 0) then goto next_input_library;

next_dcw_block: ;
        fw = fw + obj_len;
        rl = rl - obj_len;
        if rl > 0 then dcwbp = addrel (dcwbp, obj_len);
        else
	   if word (catl + fw, dcwbp, rl, cc) then goto next_input_library;

        /***	Obtain pointer to relocation bit word (3).	*/
        call get_dcw_block_word (3, reloc_word_loc);

        /***	Locate name field on dcw block record. (4th word). */
        call get_dcw_block_word (4, name_loc);
        call gfms_bcd_ascii_ (name_loc, 6, addr (name_chars));
        dcwbc = dcwbc + 1;				/* Count of dcw blocks. */
        nl = search (name_chars, " ") - 1;
        if nl < 0 then nl = length (name_chars);

        call calculate_object_length (obj_len, total_dcw_count, initial_load_address);
        if obj_len < 1 then do;
	      if (fw = 1) & (catl ^= 0) then do;
		    call ioa_$ioa_stream ("error_output",
		        "Attempting native GCOS format for ""^a"".", input_lib_path);
		    rl, obj_len, catl = 0;
		    goto next_dcw_block;
		end;
	      call com_err_ (error_table_$improper_data_format, ME,
		"Object length calculation negative for ""^a"". Library ""^a"" skipped.",
		name_chars, input_lib_path);
	      goto next_input_library;
	  end;

        if all_mods then f = TRUE;
        else
	   f = lookup (obj_name);
        if f then do;				/* Object named in input library is a
						   module caller specified. */
	      if ^have_output_lib
	      then do;
		    if ^brief then call ioa_ ("Found module ""^a"" in ^a.", name_chars, input_lib_path);
		end;
	      else do;				/* have output lib */
		    if ^prgdes
		    then call copy_obj;
		    else do;			/* have prgdes */
			  if 0 = index (substr (prgdes_seg, start_prgdes, end_prgdes - start_prgdes), "," || obj_name)
			  then do;		/* but prgdes doesn't have module */
				if ^brief
				then call ioa_ (
				         "Call name ""^a"" not found in ^a. Did not add module to ^a.",
				         name_chars, prgdes_path, output_lib_path);
			      end;
			  else /* have out lib, prgdes, and call name */
			       call copy_obj;
		        end;
		end;
/**** debug */  if Debug then do;
		    obj_num = obj_num + 1;
		    if obj_num = 1 then do;		/* Output header. */
			  call ioa_ (
			      "^15xOBJECT   DATA  RELOC");
			  call ioa_ (
			      "^7xNAME^3x^3(  WORDS^)^3xDCWS OBJECT   COMP REMAIN PATH");
		        end;
		    call ioa_ (
		        "^4i. ""^a""^vx^7(^1x^6i^) ^a"
		        , obj_num			/** Count of objects found. */
		        , name_chars		/** Name of object. */
		        , max (0, 6 - nl)		/** Align next field. */
		        , obj_len			/** No. words in object. */
		        , data_wds			/** No. data words. */
		        , reloc_wds			/** No. relocation words. */
		        , ndcw			/** No. DCW's. */
		        , dcwbc			/** Which object on library. */
		        , cc			/** Which msf component of library. */
		        , rl			/** Words remaining in component. */
		        , input_lib_path		/** Multics file name of library. */
		        );
		end;
	  end;
        if all_mods then goto next_dcw_block;
        if nm > 0 then goto next_dcw_block;

close_files: ;
        call closer;
        return;
%page;
db: entry;
        Debug = ^Debug;
        return;
dcl     Debug		 bit (1) static int init ("0"b);
%page;
/**** Command line processing procedures */
get_module_file: proc;
        e = open_file (arg, mf_fcbp);
        if mf_fcbp ^= null () then
	   call msf_manager_$get_ptr (mf_fcbp, 0, USE_EXISTING_COMPONENTS, mfp, mfl, e);
        if e ^= 0 then do;
	      call com_err_ (e, ME, "Module file ""^a"". Quitting.", path);
	      goto close_files;
	  end;
        mfl = divide (mfl, 9, 24, 0);			/* Number characters in control file. */
        process_mf = FALSE;
        j = 1;
        do while (j <= mfl);
	  k = search (substr (mf, j), NL);
	  if k < 1 then k = mfl - j + 2;
	  if k > 1 then call next_mod_name (addr (mfa (j)), k - 1);
	  j = j + k;
        end;
    end get_module_file;
%page;
get_prgdes_file: proc;
        if prgdes then do;
	      call com_err_ (error_table_$inconsistent, ME,
		"File ""^a"" already open for prgdes. Quitting.", prgdes_path);
	      goto close_files;
	  end;
        prgdes_path = arg;
        call expand_pathname_ (prgdes_path, prgdes_dir, prgdes_entry, e);
        if e ^= 0 then goto bad_prgdes_path;
        call initiate_file_ (prgdes_dir, prgdes_entry, RW_ACCESS, prgdes_seg_ptr, prgdes_bit_count, e);
        if e ^= 0 then do;
bad_prgdes_path: call com_err_ (e, ME, "^/Program descriptor file ""^a"" not available. Quitting.", prgdes_path);
	      goto close_files;
	  end;
        prgdes_seg_size = divide (prgdes_bit_count, 9, 24);
        start_prgdes = index (prgdes_seg, "Program descriptor 1.") + 22;
        end_prgdes = index (prgdes_seg, "Program descriptor end.");
        reverse_PRGDES = reverse ("PRGDES  ");
        reverse_prog_desc = reverse ("Program descriptor ");
        open_prgdes = FALSE;
        prgdes = TRUE;
        return;
    end get_prgdes_file;
%page;
get_out_lib: proc;
        if out_fcbp ^= null () then do;
	      call com_err_ (error_table_$inconsistent, ME,
		"Output library ""^a"" already open. Quitting.", output_lib_path);
	      goto close_files;
	  end;
        process_ol = FALSE;
        have_output_lib = TRUE;
        e = open_file (arg, out_fcbp);
        output_lib_path = path;
        if e ^= 0 then
	   if e = error_table_$noentry then do;		/* New output. */
		 outc = -1;			/* so first output component will be 0 */
		 call next_out_comp;
		 outp -> fast_lib_header.id = "gtssflib";
		 outp -> fast_lib_header.num_objects = 0;
		 outl = FAST_LIB_HEADER_LENGTH;	/* Position past the header. */
		 return;
	       end;
	   else do;
out_fail:		 ;
		 call com_err_ (e, ME,
		     "Could not obtain output ""^a"". Quitting.", output_lib_path);
		 goto close_files;
	       end;
        last_outc, outc = 0;				/* init output msf component */
        e = 0;
        do while (e = 0);				/* Position to the end of the output library. */
	  call msf_manager_$get_ptr (out_fcbp, outc, USE_EXISTING_COMPONENTS, outp, outl, e);
	  if outc = 0 then
	       if outp -> fast_lib_header.id ^= "gtssflib" then do;
		     call com_err_ (error_table_$improper_data_format, ME,
		         "Output library ""^a"" header not ""gtssflib"". Quitting.",
		         output_lib_path);
		     goto close_files;
		 end;
	  if e = 0 then do;
		last_outc = outc;
		last_outl = outl;
		last_outp = outp;
		outc = outc + 1;
	      end;
	  else
	       if e ^= error_table_$noentry then goto out_fail;
        end;
        outc = last_outc;
        outp = last_outp;
        outl = last_outl;
        if mod (outl, 36) ^= 0 then do;
	      call com_err_ (e, ME,
		"Component ^i of msf ""^a"" bit count (^i) not modulo 36. Quitting.",
		outc, output_lib_path, outl);
	      goto close_files;
	  end;
        outl = divide (outl, 36, 24, 0);
        return;

dcl     e			 fixed bin (35);		/* error code */
dcl     last_outc		 fixed bin (24);
dcl     last_outl		 fixed bin (24);
dcl     last_outp		 ptr;
    end get_out_lib;
%page;
stack_lib_path: proc;
/****	Stack pointer to and length of library pathname. */
        libn = libn + 1;
        if libn > hbound (input_lib, 1) then do;
	      if (libn - 1) = hbound (input_lib, 1) then
		 call com_err_ (error_table_$too_many_names, ME,
		     "Only provision for ^i input libraries. None starting with ""^a"" used.",
		     hbound (input_lib, 1), arg);
	  end;
        else do;
	      lib_name_loc (libn) = ap;
	      lib_name_len (libn) = al;
	  end;
        return;

    end stack_lib_path;
%page;
/**** Main procedures */
calculate_object_length: proc (ol, tc, da);
/****	 Set parameter (ol) to the total length of the next input
	library object, i.e., length of dcw block (6 + number of dcw's)
	plus the length of object data words and relocation words.
	Set parameter (tc) to the total of the dcw count fields values.
	Set parameter (da) to data address in first DCW.
 */
dcl     ol		 fixed bin (24) parm;	/* object length */
dcl     tc		 fixed bin (24) parm;	/* total count, dcw content fields */
dcl     da		 fixed bin (24) parm;	/* data address */

        call get_dcw_block_word (6, rd_word_loc);		/* Obtain pointer to reloc/data words. */
        ndcw = 0;					/* Count of DCW's. */
        t = 0;					/* Totoal of DCW counts. */
        done_with_dcws = FALSE;
        do dcw_index = 1 to 58 while (done_with_dcws = FALSE);
	  call get_dcw_block_word (6 + dcw_index, dcw_loc);
	  ndcw = ndcw + 1;
	  if count then t = t + fixed (count);
	  else t = t + max_dcw_count;
	  if dcw_index = 1 then da = fixed (data_address);
	  if action = "000"b then done_with_dcws = TRUE;
        end;
        tc = t;
        ol = 6 + reloc_wds + data_wds + ndcw;
        return;

dcl     dcw_index		 fixed bin (24);
dcl     done_with_dcws	 bit (1);
dcl     t			 fixed bin (24);		/* total count */
    end calculate_object_length;
%page;
closer: proc;
/****	Release spaces for file control blocks and terminate files. */

        if lib_fcbp ^= null () then
	   call msf_manager_$close (lib_fcbp);
        if out_fcbp ^= null () then do;
	      /***	Set count of objects in file header.	*/
	      call msf_manager_$get_ptr (out_fcbp, 0, USE_EXISTING_COMPONENTS, outp, (outl), e);
	      if e ^= 0 then
		 call com_err_ (e, ME,
		     "Unable to store number of objects (^i) in header.", obj_num);
	      else
		 outp -> fast_lib_header.num_objects = outp -> fast_lib_header.num_objects + obj_num;
	      call msf_manager_$adjust (out_fcbp, outc, outl * 36, "111"b, e);
	      if e ^= 0 then
		 call com_err_ (e, ME,
		     "Setting bit count to ^i words for ""^a"", component ^i", outl, output_lib_path, outc);
	      call msf_manager_$close (out_fcbp);
	  end;
        if mf_fcbp ^= null () then
	   call msf_manager_$close (mf_fcbp);
        if prgdes then do;
	      prgdes_bit_count = prgdes_seg_size * 9;	/* 9 bits to a byte */
	      call terminate_file_ (prgdes_seg_ptr, prgdes_bit_count, TERM_FILE_TRUNC_BC_TERM, e); /* e doesn't matter*/
	  end;
        return;
    end closer;
%page;
copy_obj: proc;
/****	Copy to the output library.	*/

calc_out_length: ;
        if (msw - outl - OBJECT_HEADER_LENGTH - obj_len) < 1 then do;
	      call next_out_comp;
	      goto calc_out_length;
	  end;
        out_length = msw - outl;			/* Words remaining in current output component. */

        /***	Output object header. */
        out_ptr = addr (out (outl + 1));		/* Pointer to next output word. */
        out_ptr -> object_header.marker = MARKER;
        out_ptr -> object_header.obj_name = obj_name;
        out_ptr -> object_header.obj_len_wds = obj_len;
        out_ptr = addr (out_ptr -> object_header.obj_word1);
        out_length = out_length - OBJECT_HEADER_LENGTH;
        f, outl = outl + OBJECT_HEADER_LENGTH;
        out_ptr = addr (out (outl + 1));		/* Pointer to next output word. */

        in_ptr = dcwbp;				/* Pointer to next input word. */
        remain_words = rl;
        total_moved = 0;
        in_length = obj_len;				/* Words to move. */

        do while (in_length > 0);
	  words_moved = min (remain_words, in_length, out_length); /* Number of words to move. */
	  chars_moved = words_moved * 4;		/* Number of characters to move. */
	  out_ptr -> move_seg = in_ptr -> move_seg;
	  outl = outl + words_moved;
	  in_length = in_length - words_moved;
	  if in_length > 0 then do;			/* More to move. */
		total_moved = total_moved + words_moved;
		out_length = out_length - words_moved;
		if out_length > 0 then out_ptr = addr (out (msw - out_length + 1));
		else do;
		        call next_out_comp;
		        out_ptr = outp;
		        out_length = msw;
		    end;
		remain_words = remain_words - words_moved;
		if remain_words > 0 then in_ptr = addrel (in_ptr, words_moved);
		else /* Position to next input library component. */
		     if word (catl + fw + total_moved, in_ptr, remain_words, cc2) then do;
		        call com_err_ (error_table_$improper_data_format, ME,
			  "Move of object ""^a"" exceeded input library ""^a"" component ^i. Quitting",
			  name_chars, input_lib_path, nc);
		        goto close_files;
		    end;
	      end;
        end;

        if (reloc_abs) | (reloc_wds > 0) then
	   call com_err_ (error_table_$improper_data_format, ME,
	       "Warning, relocation specified (^1b ^i words) object ""^a"", library ""^a""",
	       reloc_abs, reloc_wds, obj_name, input_lib_path);

        if total_dcw_count ^= data_words then /* Lengths differ. */
	   call com_err_ (error_table_$improper_data_format, ME,
	       "Object ""^a"" total dcw count = ^i, data words = ^i (lib ^a).",
	       obj_name, total_dcw_count, data_wds, input_lib_path);

        if ^brief then call ioa_ ("Added module ""^a"" from ^a.", name_chars, input_lib_path);

/**** now add entry to program descriptors */
        if prgdes then do;
	      /***	Obtain pointer to entry location word (5).	*/
	      call get_dcw_block_word (5, eo_word_loc);
	      dcw_block_wds = 6 + ndcw;
	      initial_load_address = initial_load_address - 1024; /* Minus 2000 octal, related to GCOS usage. */
	      if Debug then
		 if initial_load_address < 66 then /* => 102 octal. */
		      call com_err_ (error_table_$improper_data_format, ME,
			"Object ""^a"" biased entry = ^i (lib ^a).",
			obj_name, initial_load_address, input_lib_path);
	      call update_prgdes (obj_name
		, 1				/** Library number. */
		, fixed (outc, 24)			/** Output component. */
		, f + dcw_block_wds			/** Offset to object. */
		, data_words + initial_load_address	/** Program size (words). */
		, fixed (data_words, 24)		/** Object length (words). */
		, fixed (entry_loc)			/** Entry point. */
		, initial_load_address		/** Initial load address. */
		);
	  end;
        return;

dcl     total_moved		 fixed bin (24);		/* total words moved in this object */
dcl     dcw_block_wds	 fixed bin (24);
dcl     f			 fixed bin (24);
dcl     in_length		 fixed bin (24);		/* words left in input seg */
dcl     out_length		 fixed bin (24);		/* words left in output seg */
dcl     words_moved		 fixed bin (24);		/* number of words moved from in to out segs */
dcl     chars_moved		 fixed bin (24);		/* 4 times the words moved */
dcl     min		 builtin;
dcl     move_seg		 char (chars_moved) based aligned; /* the Move Segment */
dcl     out		 (msw) bit (36) aligned based (outp);
dcl     in_ptr		 ptr;
dcl     out_ptr		 ptr;
dcl     remain_words	 fixed bin (24);		/* the number of words left in input to move */
    end copy_obj;
%page;
get_dcw_block_word: proc (n, p);
/****	Set (p) to n-th word of dcw block. 	*/
dcl     n			 fixed bin (24) parm;	/* dcw block word number */
dcl     p			 ptr parm;		/* dcw ptr */
        offset = n - 1;
        if rl > offset then do;
	      p = addrel (dcwbp, offset);
	      return;
	  end;

        if word (catl + fw + offset, p, r, c) then do;
	      call com_err_ (error_table_$improper_data_format, ME,
		"Input terminates with incomplete dcw block. Quitting.");
	      goto close_files;
	  end;
        return;

dcl     r			 fixed bin (24);
dcl     c			 fixed bin (24);
dcl     offset		 fixed bin (24);
    end get_dcw_block_word;
%page;
get_input_lib: proc returns (bit (1));
/****	Return TRUE if next input library could
	NOT be obtained.
*/
        fw = 1;					/* First word. */
        obj_len = 0;				/* Length of  current object. */
        rl = 0;					/* Remaining length of component segment. */
        if lib_fcbp ^= null () then /* Close last library. */
	   call msf_manager_$close (lib_fcbp);
        e = open_file (lib_name, lib_fcbp);
        if e ^= 0 then do;
	      call com_err_ (e, ME,
		"Library ""^a"" not available. Library skipped.", path);
	      return (TRUE);
	  end;
        input_lib_path = path;


        /***	Obtain list of pointers to components and their word lengths. */
        do nc = 0 to hbound (comp, 1);
	  cp (nc) = null ();
	  wl (nc) = 0;
	  call msf_manager_$get_ptr (lib_fcbp, nc, USE_EXISTING_COMPONENTS, cp (nc), bc, e);
	  if e ^= 0 then do;
		if (e = error_table_$noentry) & (nc > 0) then return (FALSE);
		call com_err_ (e, ME,
		    "Component ^i. ^a. Library skipped.", nc, input_lib_path);
		return (TRUE);
	      end;

	  if mod (bc, 36) ^= 0 then do;
		call com_err_ (error_table_$bad_file, ME,
		    "Component ^i of ^a bit count (^i) not multiple of 36. Library skipped.",
		    nc, input_lib_path, bc);
		return (TRUE);

	      end;
	  wl (nc) = divide (bc, 36, 24, 0);
        end;
        call com_err_ (error_table_$bad_file, ME,
	  "Exceeded ^i components in ^a. Library skipped.",
	  hbound (comp, 1) + 1, input_lib_path);
        return (TRUE);

dcl     lib_name		 char (lib_name_len (libc)) based (lib_name_loc (libc));
    end get_input_lib;
%page;
lookup: proc (lookup_name) returns (bit (1));
/****	Return TRUE if lookup_name is specified in module names list. */
dcl     lookup_name		 char (6) var parm;
        k = gfms_hash_ ((lookup_name), hbound (start, 1) + 1);
        ln = 0;
        n = start (k);
        do while (n > 0);				/* Search linked list. */
	  if lookup_name = mod_name (n) then do;	/* Found. */
		if ln = 0 then start (k) = link (n);	/* Start with next entry. */
		else link (ln) = link (n);		/* Link around entry. */
		link (n) = -1;			/* Mark entry found. */
		nm = nm - 1;			/* Reduce name count. */
		return (TRUE);
	      end;
	  ln = n;					/* Record last entry. */
	  n = link (n);				/* Proceed to next entry. */
        end;
        return (FALSE);				/* Not found. */

dcl     k			 fixed bin (24);
dcl     n			 fixed bin (24);
dcl     ln		 fixed bin (24);
    end lookup;
%page;
next_mod_name: proc (p, l);
/****	Store next module name (upper cased) in hash list.
*/
dcl     l			 fixed bin (24) parm;
dcl     p			 ptr parm;
        if l > 6 then call com_err_ (error_table_$bigarg, ME,
	       "Module name ""^a"" truncated to 6 characters.", name);
        nm = nm + 1;
        if nm > hbound (hash_list, 1) then do;
	      if (nm - 1) = hbound (hash_list, 1) then
		 call com_err_ (error_table_$too_many_names, ME,
		     "Only space for ^i module names. Names starting with ""^a"" lost.",
		     hbound (hash_list, 1), name);
	  end;
        else do;
	      mod_name (nm) = translate (name
		, "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
		, "abcdefghijklmnopqrstuvwxyz"
		);
	      /***	Store name in hash list. */
	      k = gfms_hash_ ((mod_name (nm)), hbound (start, 1) + 1);
	      link (nm) = start (k);
	      start (k) = nm;
	  end;
        return;
dcl     name		 char (l) based (p);
dcl     k			 fixed bin (24);
    end next_mod_name;
%page;
next_out_comp: proc;
/****	Obtain next output msf component.
*/
        outc = outc + 1;
        call msf_manager_$get_ptr (out_fcbp, outc, PROVIDE_NEW_COMPONENTS, outp, outl, e);
        if e ^= 0 then do;
	      call com_err_ (e, ME,
		"Can not obtain output ""^a"". Quitting.", output_lib_path);
	      goto close_files;
	  end;
        if mod (outl, 36) ^= 0 then do;
	      call com_err_ (e, ME,
		"Component ^i of msf ""^a"" bit count (^i) not modulo 36. Quitting.",
		outc, output_lib_path, outl);
	      goto close_files;
	  end;
        outl = divide (outl, 36, 24, 0);
        return;
    end next_out_comp;
%page;
open_file: proc (arg, fcbp) returns (fixed bin (35));
/****	Set file control block pointer (fcbp) to
	the msf file named by (arg). Return msf_manager error code.
*/
dcl     arg		 char (*) parm;
dcl     fcbp		 ptr parm;
        l = length (arg);
        k = search (reverse (arg), ">");
        if k > 0 then do;				/* User supplied directory. */
	      dir = substr (arg, 1, l - k);
	      msf = substr (arg, l - k + 2);
	  end;
        else do;
	      if wdl = 0 then do;
		    wd = get_wdir_ ();
		    wdl = search (wd, " ") - 1;
		    if wdl < 0 then wdl = length (wd);
		end;
	      dir = substr (wd, 1, wdl);
	      msf = arg;
	  end;
        path = dir || ">" || msf;
        /***	Open the input library file. */
        fcbp = null ();
        call msf_manager_$open ((dir), (msf), fcbp, e);
        return (e);

dcl     dir		 char (168) var;
dcl     e			 fixed bin (35);		/* error code */
dcl     k			 fixed bin (24);		/* position of > before enttry name */
dcl     l			 fixed bin (24);		/* arg length of path */
dcl     msf		 char (32) var;
    end open_file;
%page;
print_catalog: proc;
        catp = null ();
        if catl = 0 then
	   call ioa_ ("^/Library ^a appears to be native gcos and has no catalog.", input_lib_path);
        else do;
	      catp = cp (0);
	      call ioa_ ("Catalog for ^a:", input_lib_path);
	      do i = 1 to catalog.no_ent;
		call gfms_bcd_ascii_ (addr (catalog.elements (i).name), 6, addr (name_chars));
		call ioa_ ("^4i.^-^a^-^o", i, name_chars, catalog.elements (i).address);
	      end;
	  end;
        return;

dcl     i			 fixed bin (24);
dcl     catp		 ptr;

dcl     1 catalog		 aligned based (catp),
	2 fill		 fixed bin (24),
	2 no_ent		 fixed bin (24),
	2 elements	 (no_ent),
	  3 name		 bit (36),
	  3 address	 fixed bin (24);

    end print_catalog;
%page;
update_prgdes: proc (call_name, lib_num, comp_num, offset, prog_size, load_size, entry_pt, load_addr);
/****     Update prgdes_path with program descriptor info for call_name
	The seg named by prgdes_path (which is a copy of gtss_prgdes_alm_.incl.alm)
	MUST be in the following format:

1----------------------------------------------------------------------------
<front of program: copyright notices, incls, macros, comments, etc.>
segdef    prgdes
prgdes:   null
<some more local labels>
" Program descriptor 1.
CARD:  PRGDES  0,0,0,0,0,0,0,
               card,(CARDCL,1),,.BCMCL
<all the other program descriptors of the form:>
label: PRGDES  <program descriptors>
               STR1,STR2,<call name>{,STRi}
" Program descriptor <last program desc. number>.
CMDL:  PRGDES  <program descriptors>
               cmdl,EXPCL,.TSCLD,.BEXEC,LODX  MUST BE LAST DESCR.
" Program descriptor end.
<all the rest of the code>
          end
----------------------------------------------------------------------------

	Notes:
	     label: is optional.
	     STR1 etc. are optional.
	     The <program descriptors> are for the module <call name>.
		Although, <call name> is third arg of the second line,
		it is also the only occurance on that line. That is, 
		the string "<call name>" is unique in any one prog. desc.
	     The <program descriptors> are either all zero (as in the first
		one) or are these values
		1. library number, always 1
		2. component number of the output library
		3. offset of this object in this component
		4. the program size
		5. the load size
		6. the address of the entry point
		7. the initial load address

	This routine replaces all the program descriptors in prgdes_path
	which contain the given call name.

	The eight parameters to this procedure are the call name and the
	seven numbers required for the program descriptor.
*/
dcl     call_name		 char (6) var parm;
dcl     lib_num		 fixed bin (24) parm;
dcl     comp_num		 fixed bin (24) parm;
dcl     offset		 fixed bin (24) parm;
dcl     prog_size		 fixed bin (24) parm;
dcl     load_size		 fixed bin (24) parm;
dcl     entry_pt		 fixed bin (24) parm;
dcl     load_addr		 fixed bin (24) parm;

/* Initialize */
        found_name = FALSE;
        current_prgdes = start_prgdes;
        prgdes_inc = 0;
        /*** For each match of the call name, back up and replace the program descriptors */
        do while (current_prgdes < end_prgdes);
	  /*** find next reference to call name */
	  current_prgdes_size = end_prgdes - current_prgdes;
	  rel_next_name = index (substr (prgdes_seg, current_prgdes, current_prgdes_size), "," || call_name);
	  if rel_next_name = 0 then goto prgdes_done;	/* call name not found */
	  next_name = rel_next_name + current_prgdes;	/* now absolute */
	  if verify (substr (prgdes_seg, next_name + length (call_name), 1), VALID_FOL_CHAR) ^= 0
	  then goto get_next_prgdes;
	  /*** locate the old prgdes */
	  old_prgdes_last_char = next_name
	      - index (reverse (substr (prgdes_seg, current_prgdes, rel_next_name)), NL) - 1;
	  prgdes_first_char = old_prgdes_last_char
	      - index (reverse (substr (prgdes_seg, current_prgdes, old_prgdes_last_char - current_prgdes))
	      , reverse_PRGDES) + 1;
	  old_prgdes_size = old_prgdes_last_char - prgdes_first_char + 1;
	  if (old_prgdes_size < 1) then do;
		call com_err_ (error_table_$improper_data_format, ME,
		    "Cannot find program descriptors for ""^a"" in ^a. Check format.", call_name, prgdes_path);
		goto close_files;
	      end;
	  /*** build the new prgdes */
	  if substr (prgdes_seg, prgdes_first_char, 1) = "0" /* lib=0 */
	  then update_type = "Added";
	  else update_type = "Replaced";
	  if ^found_name then
	       call ioa_$rsnnl ("^7(^i,^)  "" ^a by gtbl on ^a",
		 new_prgdes, new_prgdes_size,
		 libn, comp_num, offset, prog_size, load_size, entry_pt, load_addr,
		 update_type, run_date);
	  found_name = TRUE;
	  /*** WHEW! Now comes the easy part: updating the seg with the new prgdes */
	  prgdes_inc = new_prgdes_size - old_prgdes_size;
	  if prgdes_inc > 0
	  then do;				/* hole is too small */
		prgdes_move_len = prgdes_seg_size - old_prgdes_last_char;
		prgdes_seg_size = prgdes_seg_size + prgdes_inc;
		call mrl_ (addcharno (prgdes_seg_ptr, old_prgdes_last_char), prgdes_move_len,
		    addcharno (prgdes_seg_ptr, old_prgdes_last_char + prgdes_inc), prgdes_move_len);
	      end;
	  /*** now move it in */
	  substr (prgdes_seg, prgdes_first_char, new_prgdes_size) = new_prgdes;
	  if prgdes_inc < 0				/* hole was too big! blank out rest */
	  then substr (prgdes_seg, prgdes_first_char + new_prgdes_size, -prgdes_inc) = " ";
	  if ^brief then do;
		/*** figure out which prgdes this is */
		this_prgdes = old_prgdes_last_char
		    - index (reverse (substr (prgdes_seg, current_prgdes, old_prgdes_last_char - current_prgdes)),
		    reverse_prog_desc) + 1;
		this_prgdes_num = substr (prgdes_seg, this_prgdes, index (substr (prgdes_seg, this_prgdes, 4), ".") - 1);
		call ioa_ ("^a program descriptor ^a for ""^a"".",
		    update_type, this_prgdes_num, call_name);
	      end;
	  if Debug then call ioa_ ("^a^-^a", call_name, new_prgdes);
get_next_prgdes: ;
	  /*** move up to next prgdes and continue */
	  if prgdes_inc < 0 then prgdes_inc = 0;
	  end_prgdes = end_prgdes + prgdes_inc;
	  current_prgdes = next_name + prgdes_inc + index (substr (prgdes_seg, next_name + prgdes_inc), NL) + 1;
	  prgdes_inc = 0;
        end;
prgdes_done:
        if ^found_name then
	   if ^brief then
	        call ioa_$ioa_stream ("error_output",
	        "Call name ""^a"" not found in ^a. Module WAS added to ^a", call_name, prgdes_path, output_lib_path);
        return;

dcl     current_prgdes	 fixed bin (24);
dcl     current_prgdes_size	 fixed bin (24);
dcl     found_name		 bit (1);
dcl     new_prgdes		 char (100) varying;
dcl     new_prgdes_size	 fixed bin (24);
dcl     next_name		 fixed bin (24);
dcl     old_prgdes_last_char	 fixed bin (24);
dcl     old_prgdes_size	 fixed bin (24);
dcl     prgdes_first_char	 fixed bin (24);
dcl     prgdes_inc		 fixed bin (24);
dcl     prgdes_move_len	 fixed bin (24);
dcl     rel_next_name	 fixed bin (24);
dcl     this_prgdes		 fixed bin (24);
dcl     this_prgdes_num	 char (3) var;
dcl     update_type		 char (8) varying;

    end update_prgdes;
%page;
word: proc (w, p, l, c) returns (bit (1));
/****	Set pointer (p) to word (w) of input msf and
	set the length (l) to number of words available
	in component segment.
	Set (c) to the number of the msf component
	in which the word was found.
	Return FALSE;

	Return TRUE if word (w) not available.
 */
dcl     c			 fixed bin (24) parm;
dcl     l			 fixed bin (24) parm;
dcl     p			 ptr parm;
dcl     w			 fixed bin (24) parm;
        c = -1;
        if w < 1 then return (TRUE);
        k = 0;
        do i = 0 to nc;
	  k = k + wl (i);
	  if w <= k then do;			/* Component located. */
		l = k - w + 1;
		p = addrel (cp (i), wl (i) - l);
		c = i;
		return (FALSE);
	      end;
        end;
        return (TRUE);

dcl     i			 fixed bin (24);
dcl     k			 fixed bin (24);
    end word;
%page;
/* Constants */
dcl     ME		 char (28) static int options (constant) init ("gcos_tss_build_library (1.1)");
dcl     TRUE		 bit (1) static int options (constant) init ("1"b);
dcl     FALSE		 bit (1) static int options (constant) init ("0"b);
dcl     MARKER		 bit (36) static int options (constant) init ("101100011111000000001111111111111000"b);
dcl     USE_EXISTING_COMPONENTS bit (1) static int options (constant) init ("0"b);
dcl     PROVIDE_NEW_COMPONENTS bit (1) static int options (constant) init ("1"b);
dcl     NL		 char (1) static int options (constant) init ("
");
dcl     FAST_LIB_HEADER_LENGTH fixed bin (24) static int options (constant) init (4);
dcl     OBJECT_HEADER_LENGTH	 fixed bin (24) static int options (constant) init (5);
dcl     VALID_FOL_CHAR	 char (4) static int options (constant) init (", 	
");						/* comma, space, tab, new line */
%page;
/**** builtins, conditions, entries, externals (non-variables) */

dcl     (addcharno,
        addr,
        addrel,
        divide,
        fixed,
        hbound,
        index,
        length,
        max,
        mod,
        null,
        reverse,
        search,
        substr,
        translate,
        verify)		 builtin;

dcl     cleanup		 condition;

dcl     clock_		 entry () returns (fixed bin (71));
dcl     com_err_		 entry options (variable);
dcl     cu_$arg_count	 entry (fixed bin (24), fixed bin (35));
dcl     cu_$arg_ptr		 entry (fixed bin (24), ptr, fixed bin (24), fixed bin (35));
dcl     date_time_		 entry (fixed bin (71), char (*));
dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
dcl     get_wdir_		 entry returns (char (168));
dcl     gfms_bcd_ascii_	 entry (ptr, fixed bin (24), ptr);
dcl     gfms_hash_		 entry (char (*), fixed bin (24)) returns (fixed bin (35));
dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl     ioa_		 entry options (variable);
dcl     ioa_$ioa_stream	 entry options (variable);
dcl     ioa_$rsnnl		 entry () options (variable);
dcl     mrl_		 entry options (variable);
dcl     msf_manager_$adjust	 entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
dcl     msf_manager_$close	 entry (ptr);
dcl     msf_manager_$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     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));

dcl     (error_table_$bad_arg,
        error_table_$bad_file,
        error_table_$badopt,
        error_table_$bigarg,
        error_table_$improper_data_format,
        error_table_$inconsistent,
        error_table_$noarg,
        error_table_$noentry,
        error_table_$too_many_names)	 fixed bin (35) ext static;
dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
%page;
/****	Variables for gtbl:
	IDENTIFIER	ATTRIBUTES	*/

dcl     al		 fixed bin (24);
dcl     all_mods		 bit (1);
dcl     ap		 ptr;
dcl     arg		 char (al) based (ap);
dcl     arg_num		 fixed bin (24);
dcl     bc		 fixed bin (24);
dcl     brief		 bit (1);
dcl     catl		 fixed bin (24);
dcl     catl_parm		 fixed bin (24);
dcl     cc		 fixed bin (24);
dcl     cc2		 fixed bin (24);
dcl     dcwbc		 fixed bin (24);
dcl     e			 fixed bin (35);
dcl     end_prgdes		 fixed bin (24);
dcl     f			 bit (1);
dcl     fw		 fixed bin (24);
dcl     get_mod_name	 bit (1);
dcl     have_output_lib	 bit (1);
dcl     i			 fixed bin (24);
dcl     initial_load_address	 fixed bin (24);
dcl     init_nm		 fixed bin (24);
dcl     input_lib_path	 char (168) var;
dcl     j			 fixed bin (24);
dcl     k			 fixed bin (24);
dcl     libc		 fixed bin (24);		/* current input library number */
dcl     lib_fcbp		 ptr;
dcl     max_dcw_count	 fixed bin (24);
dcl     mf		 char (mfl) based (mfp);	/* module file */
dcl     mfa		 (mfl) char (1) based (mfp);
dcl     mfl		 fixed bin (24);
dcl     mfp		 ptr;
dcl     mf_fcbp		 ptr;
dcl     msw		 fixed bin (24);		/* max seg words */
dcl     nargs		 fixed bin (24);
dcl     name_loc		 ptr;
dcl     nc		 fixed bin;
dcl     ndcw		 fixed bin (24);
dcl     need_1_mod_name	 bit (1);
dcl     no_cat		 bit (1);
dcl     obj_len		 fixed bin (24);
dcl     obj_name		 char (6) var based (addr (nl));
dcl     obj_num		 fixed bin (24);
dcl     prgdes		 bit (1);
dcl     prgdes_bit_count	 fixed bin (24);
dcl     prgdes_dir		 char (168);
dcl     prgdes_entry	 char (32);
dcl     prgdes_fcbp		 ptr;
dcl     prgdes_path		 char (168);
dcl     prgdes_seg		 char (prgdes_seg_size) based (prgdes_seg_ptr);
dcl     prgdes_seg_ptr	 ptr;
dcl     prgdes_seg_size	 fixed bin (24);		/* number of chars in prgdes seg */
dcl     process_mf		 bit (1);
dcl     process_ol		 bit (1);
dcl     open_prgdes		 bit (1);
dcl     outc		 fixed bin;		/* output lib component num */
dcl     outl		 fixed bin (24);		/* output lib word length */
dcl     outp		 ptr;			/* output lib pointer */
dcl     output_lib_path	 char (168) var;
dcl     out_fcbp		 ptr;
dcl     path		 char (168) var;
dcl     pr_cat		 bit (1);
dcl     reverse_PRGDES	 char (8);		/* PRGDES spelled backwards */
dcl     reverse_prog_desc	 char (19);		/* Program descriptor backwards */
dcl     rl		 fixed bin (24);
dcl     run_date		 char (16);		/* don't want time zone and day */
dcl     start_prgdes	 fixed bin (24);
dcl     total_dcw_count	 fixed bin (24);
dcl     wd		 char (168);		/* working dir */
dcl     wdl		 fixed bin (24);		/* working dir length */
dcl     just_a_word		 bit (36) based;


/* format: off */
dcl	1 object_name_structure,
	  2 nl		fixed bin(24),	/* Number characters in Name. */
	  2 name_chars	char(6);


dcl	1 msf		aligned
,	  2 nc		fixed bin(24)	/* Number of components. */
,	  2 comp		(0:99)		/* Components:	*/
,	    3 cp		ptr		/* segment.	*/
,	    3 wl		fixed bin(24)	/* number words.	*/
;

dcl	1 copy_names
,	  2 nm		fixed bin(24)       /* Number of module names. */
,	  2 start		(0:1020)fixed bin(24)/* Hash start list.
					   >0 => hash_list entry. */
,	  2 hash_list	(2000)
,	    3 link	fixed bin(24)	/* >0 => previous hash_list entry. */
,	    3 mod_name	char(6)var	/* Module name. */
;

dcl	dcwbp		ptr;
dcl	1 dcw_block	aligned based(dcwbp)
,	  2 data_check	fixed bin(24)	/* Checksum for data words. */
,	  2 rel_check	fixed bin(24)	/* checksum for reloc words */
,	  2 rel_abs	bit(36)		/* 6th bit = "1"b => relocatable. */
,	  2 name		bit(36)		/* name of program (BCD). */
,	  2 word5
,	    3 entry	bit(18)unal	/* entry address. */
,	    3 origin	bit(18)unal	/* origin. */
,	  2 word6
,	    3 reloc_words	fixed bin(17)unal	/* Number of relocation words. */
,	    3 data_words	fixed bin(17)unal	/* Number of data words.	*/
,	  2 dcws		(ndcw)bit(36)
;

dcl	eo_word_loc	ptr;
dcl	1 eo_word		aligned based(eo_word_loc)
,	  2 entry_loc	bit(18)unal
,	  2 origin_loc	bit(18)unal
;

dcl	reloc_word_loc	ptr;
dcl	1 reloc_word	aligned based(reloc_word_loc)
,	  2 fill1		bit( 6)unal
,	  2 reloc_abs	bit( 1)unal	/* "1"b => relocatable. */
,	  2 fill2		bit(29)unal
;

dcl	rd_word_loc	ptr;
dcl	1 rd_word		aligned based(rd_word_loc)
,	  2 reloc_wds	fixed bin(17)unal
,	  2 data_wds	fixed bin(17)unal
;

dcl	dcw_loc		ptr;
dcl	1 dcw		aligned based(dcw_loc)
,	  2 data_address	bit(18)unal
,	  2 zero		bit( 3)unal
,	  2 action	bit( 3)unal
,	  2 count		bit(12)unal
;


dcl	1 lib_stack
,	  2 libn		fixed bin(24) /* total number of input libraries */
,	  2 input_lib	(10)
,	    3 lib_name_loc	ptr
,	    3 lib_name_len	fixed bin(24)
;

dcl	1 fast_lib_header	aligned based
,	  2 id		char(8)
,	  2 num_objects	pic "(8)9"
;

dcl	1 object_header	aligned based
,	  2 marker	bit(36)
,	  2 obj_name	char(8)var
,	  2 obj_len_wds	fixed bin(24)
,	  2 obj_word1	bit(36)
;
%page;
%include gcos_xio_dcl_;
%page;
%include terminate_file;
%page;
%include access_mode_values;
end gcos_tss_build_library;



		    gcos_xio_.pl1                   09/09/83  1357.7rew 09/09/83  1006.7       25659


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
gcos_xio_: proc;
/*
	     Open or close an IO stream with iox__

  Created:  Ron Barstad  83-03-04  based on XIO
*/
%page;
/*  P R O C E D U R E  */
dcl (	cl, sn, mv, pn )	char(*) parm;
dcl	cp		ptr parm;

	call com_err_ (error_table_$badcall, "gcos_xio_",
	     "Valid gcos_xio_ entries are open and close.");
	return;

open:	entry (cl, sn, mv, cp, pn) returns (bit (1));
/** Execute iox routines to "open" the file:
	   1. For caller "cl".
	   2. for stream "sn".
	   3. Mode "mv" = { "1" | "input", "2" | "output" }.
	   4. Caller supplied pointer "cp" for i/o control block.
	   5. To segment "pn".

	   Return "1"b if failure.
	   **/

	if (mv = "1") | (mv = "input") then mode = 1;
	else
	if (mv = "2") | (mv = "output") then mode = 2;
	else do;
	     call com_err_ (error_table_$bad_subr_arg, cl,
		"Mode, ""^a"", not 1 or input nor 2 or output.", mv);
	     return ("1"b);
	end;

	call iox_$attach_ioname (sn, tp, "vfile_ "||pn, ec);
	if ec>0 then do;
	     call iox_$close (tp, ec);
	     call iox_$detach_iocb (tp, ec);
	     if ec = 0 then
		call iox_$attach_ioname (sn, tp, "vfile_ "||pn, ec);
	end;
	if ec>0 then do;
	     call com_err_ (ec, cl, "(attach) stream ""^a"", segment ""^a""", sn, pn);
	     cp = null ();
	     return ("1"b);
	end;

	call iox_$open (tp, mode, "0"b, ec);
	if ec>0 then do;
	     call iox_$close (tp, ec);
	     call iox_$open (tp, mode, "0"b, ec);
	end;
	if ec>0 then do;
	     call com_err_ (ec, cl, "(open) mode ""^a"", stream ""^a"", segment ""^a""", mv, sn, pn);
	     call iox_$detach_iocb (tp, ec);
	     cp = null ();
	     return ("1"b);
	end;
	cp = tp;
	return ("0"b);

close:	entry (cl, cp) returns (bit (1));
/** Execute iox routines to "close" the file:
	   1. For caller "cl".
	   2. With i/o control block pointer "cp".

	   Return "1"b if failure.

	   **/
	call iox_$close (cp, ec);
	if ec>0 then
	     call com_err_ (ec, cl, "(close).");
	call iox_$detach_iocb (cp, ec);
	if ec>0 then
	     call com_err_ (ec, cl, "(detach).");
	if ec>0 then return ("1"b);
	return ("0"b);
%page;
/*  D A T A  */
dcl	tp		ptr;
dcl	mode		fixed bin;
dcl	ec		fixed bin(35);
dcl	com_err_		entry options(variable);
dcl       error_table_$bad_subr_arg fixed bin(35) ext static;
dcl       error_table_$badcall fixed bin(35) ext static;
dcl	iox_$attach_ioname	entry( char(*), ptr, char(*), fixed bin(35));
dcl	iox_$close	entry(ptr,fixed bin(35));
dcl	iox_$detach_iocb	entry(ptr,fixed bin(35));
dcl	iox_$open		entry(ptr, fixed bin, bit(1) aligned, fixed bin(35));
dcl	null		builtin;
     end gcos_xio_;


		    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