



		    generate_mst.pl1                10/21/92  1109.5rew 10/21/92  1108.3      375174



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




/****^  HISTORY COMMENTS:
  1) change(87-01-19,GDixon), approve(87-04-16,MCR7614),
     audit(87-05-21,Farley), install(87-07-15,MR12.1-1040):
     Add support for storing boot program as first segment of MST image stored
     in a file.
  2) change(87-10-19,Farley), approve(88-02-26,MCR7795),
     audit(88-03-03,Fawcett), install(88-03-15,MR12.2-1035):
     Added default_time_zone statement.
  3) change(87-10-19,Farley), approve(88-02-26,MCR7796),
     audit(88-03-03,Fawcett), install(88-03-15,MR12.2-1035):
     Added default_rpv_data statement.
  4) change(87-11-05,Farley), approve(88-05-13,PBF7795),
     audit(88-05-31,Fawcett), install(88-07-05,MR12.2-1053):
     Corrected default_time_zone code to not require a symbol name
     as part of the statement, as the documentation states.
  5) change(87-11-05,Farley), approve(88-05-13,PBF7796),
     audit(88-05-31,Fawcett), install(88-07-05,MR12.2-1053):
     Corrected default_rpv_data code to not require a symbol name
     as part of the statement, as the documentation states.
  6) change(92-09-21,Schroth), approve(92-10-15,MCR8275),
     audit(92-10-15,WAAnderson), install(92-10-21,MR12.5-1033):
     Corrected uninitialized variable error that was causing tapes to be left
     mounted.  phx21281.
                                                   END HISTORY COMMENTS */


generate_mst: gm: proc;

/* format: off */

/* *	GENERATE_MST
   *
   *	The Multics System Tape generator. This program parses header files and
   *	generates system tapes, performing a lot less error-checking than it should.
   *	Really, this and check_mst ought to be combined, and made reliable, but that
   *	is a project for another day.
   *
   *	Inherited from the dim and distant past; written time and time again by persons
   *	now unknown to us.
   *
   *	Modified 18 February 1981, W. Olin Sibert, to add add_segnames, delete_name,
   *	   and rationalize error message reporting mechanism.
   *	Modified 31 July, 1981, WOS, to add boot_program and data keywords.
   *	Modified: 11 January 1982 by G. Palter to fix add_segnames to not add names
   *	   of components which have no retained entrypoints
          Modified 6/6/82 BIM for boot_program AND first_name.
   *	Modified 8/23/84 JAF to increase name table from 100 to 150 entries
   *	Modified 3/14/85 by Keith Loepere to fix delete_name statement.
   */

/* declarations */

/* argument declarations */

dcl  a_header_path char (argl (1)) unaligned based (argp (1)), /* relative path name of driving header */
     tape_no char (argl (2)) unaligned based (argp (2));	/* numerical designation of output tape */

/* for fetching and aligning arguments */

dcl  argp (10) ptr,					/* array of pointers to unaligned arguments */
     argl (10) fixed bin (17),			/* array of argument lengths */
     code fixed bin (35),				/* error code */
     acount fixed bin (17),				/* ccmmand argument count */
     barg char (argl (i)) unaligned based (argp (i)),

     header_path char (168) aligned,			/* aligned version of argument */

     sysid char (8),				/* system id */
     versid char (8);

dcl  generated_time fixed bin (71);
dcl  generated_time_string char (32);

dcl     i fixed bin (17);				/* do loop index */
dcl  open_message char (100); 			/* message from gm_util1_$open */


/* for attaching */

dcl  path_list_name char (168) aligned,			/* full path name of list of search paths */
     hdrp ptr;					/* pointer to header */

dcl  path_array (10) char (168) aligned;		/* array of path names to be searched */

dcl  sys_desig char (24) aligned var;			/* system designation */
dcl  ion2 char (32) aligned;				/* ioname2 for attaching and detaching tape */

/* for reading */

dcl  numc fixed bin (17),				/* number of characters read */
     ndir fixed bin (17);				/* number of directories to be searched */

dcl  error_label label;				/* for error recovery */

dcl  out_sgna char (32) aligned;

/* for parsing header */

dcl  symp ptr init (null),				/* pointer to current symbol */
     arg char (numc) unaligned based (symp);		/* mask for looking at symbol */

dcl  seg_name char (32)aligned init (""),		/* reference name of segment */
     nnam fixed bin (17);				/* number of names found in header entry */

/* for processing keyword arguments */


/* for creating segment blocks */

dcl  in_p ptr,					/* pointer to segment in searched directory */
     segp ptr,					/* pointer to segment to be written on tape */

     bitcnt fixed bin (24),				/* bit count of segment as found */
     sg_b fixed bin (24),				/* bit count of block to be written */

     tx_l fixed bin (17),				/* length of text section */
     sg_l fixed bin (17);				/* length of block to be written */

dcl  cur_len_for_bitcnt fixed bin (18);			/* current length in words */


dcl  path_ptr ptr,

     1 path aligned based (path_ptr),			/* path name structure */
     2 size fixed bin (17),
     2 name char (168);

dcl  names_ptr ptr,

     1 seg_name_array aligned based (names_ptr),		/* name structure */
     2 count fixed bin (17),
     2 names (max_count),
     3 size fixed bin (17),
     3 name char (32);

dcl  acl_count_ptr ptr,
     acl_block_ptr ptr,
     acl_count fixed bin (17) based (acl_count_ptr);


dcl 1 acla based (acl_block_ptr) aligned,
    2 userid char (32),
    2 mode bit (36),
    2 pad bit (36),
    2 code fixed bin;


dcl  max_count fixed bin (17) static init (150),
     seg_name_l fixed bin (17);			/* to remember length of seg name */


dcl  seg_header_length fixed bin,			/* length of header data in words */
     header_words fixed bin (35),			/* number of words to be written in header write */
     wr_w fixed bin (17),				/* number of wds written in seg write */
     seg_hdrp ptr;					/* pointer to header info */

dcl 1 control_word based aligned,
    2 ident fixed bin (17) unal,			/* identifier portion of control word */
    2 length fixed bin (17) unal,			/* 2 length portion */
    2 col_no fixed bin (17) unal,			/* for 2 collection mark unal,number */
    2 col_sub_no fixed bin (17) unal;			/* for collection mark; */

dcl  cw_ptr ptr,					/* pointer to segment control word */

     header_max_size fixed bin static init (1500),	/* size of header data array */
     header_data (1500) fixed bin (35);			/* actual header data */

dcl (addr, addrel, after, before, bin, bit, clock, divide, fixed, index, length,
     maxlength, null, reverse, rtrim, substr, translate, unspec) builtin;

dcl  o_ln char (132) aligned;

dcl  last_path char (32) aligned;			/* for setting path_found */

dcl  oa_ptr ptr;					/* dcls for setting access in output line */

dcl  error_in_object_segment bit (1) aligned;

dcl  mst_tape_iocbp ptr init (null);
dcl  gm_output_iocbp ptr init (null);

dcl 1 output_access unaligned based (oa_ptr),
    2 (read, execute, write, privileged) bit (1);

dcl  output_access_word char (8) aligned;

dcl  tape_er_count fixed bin (17);			/* for keeping track of tape errors */

/* for system_id feature */

dcl  movewds bit (bitcnt) aligned based,		/* array to move seg into temp */
     real_in_p ptr,					/* save for original seg ptr */
     symbol_name char (32),				/* name of symbol to be overlaid with sysid */
     based_char_32 char (32) based,			/* for moving name  */
     based_bit_72 bit (72) based,
     time_as_bit bit (72),
     id_ptr pointer,
     default_rpv_data char (24) var,
     default_time_zone char (4),
    (lang_index, zone_index) fixed bin,
     unique_name char (15);				/* name of copied segment */

dcl 1 oi aligned like object_info;

dcl  object_segment bit (1) aligned;			/* flag to indicate whether oi is valid for current segment */


/* flag declarations */

dcl (sysid_hit,
     versid_hit,
     db_hit,
     hd_hit,
     do_hit,
     dr_hit,
     path_name_found,
     no_error_was_found,
     cur_length_found,
     bit_count_found,
     cache_found,
     acl_found,
     linkage_found,
     end_found,
     boot_program_has_been_processed,
     segments_have_been_processed
     ) bit (1) aligned;

dcl  sym_is_a_break fixed bin (1),
     eof_was_found fixed bin (1);

/* external declarations */

dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, pointer, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  decode_definition_$full entry (pointer, pointer, pointer) returns (bit (1) aligned);
dcl  delete_$ptr entry (pointer, bit (6), char (*), fixed bin (35));
dcl  gm_error_ entry (fixed bin (35), char (32) aligned, pointer, pointer, char (*),
     pointer, bit (1) aligned, bit (1) aligned, bit (1) aligned, pointer, pointer);
dcl  gm_util_ entry (char (32) aligned, fixed bin (17), pointer, pointer, bit (1) aligned, bit (1) aligned);
dcl  gm_util1_$close entry (pointer, pointer, bit (1) aligned);
dcl  gm_util1_$open entry (pointer, char (168) aligned, fixed bin, char (168) aligned, pointer, char (32) aligned,
     pointer, pointer, char (32) aligned, fixed bin (35), char (*), bit (1) aligned, bit (1) aligned, char (8));
dcl  gm_write_first_seg_ entry (pointer, fixed bin (24), pointer, pointer, bit (1) aligned, fixed bin (35));
dcl  gm_write_boot_program_ entry (ptr, fixed bin(24), char(*), ptr, bit(1) aligned,
				     bit(1) aligned, fixed bin(35));
dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*),
     fixed bin (24), fixed bin, pointer, fixed bin (35));
dcl  hcs_$make_ptr entry (pointer, char (*), char (*), pointer, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), pointer, fixed bin (35));
dcl  hcs_$set_bc_seg entry (pointer, fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_noname entry (pointer, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  iox_$control entry (pointer, char (*), pointer, fixed bin (35));
dcl  iox_$put_chars entry (pointer, pointer, fixed bin (21), fixed bin (35));
dcl  object_info_$brief entry (pointer, fixed bin (24), pointer, fixed bin (35));
dcl  parse_file_$parse_file_ptr entry (pointer, fixed bin (17), fixed bin (1), fixed bin (1));
dcl  parse_file_$parse_file_unset_break entry (char (*));
dcl  print_gen_info_ entry (pointer, fixed bin (24), char (*), fixed bin (35));
dcl  unique_chars_ entry (bit (*) aligned) returns (char (15));

dcl  gm_data_$default_path_list_name char (168) varying external static;

dcl  date_time_ entry (fixed bin(71), char(*));


dcl (error_table_$noarg,
     error_table_$noentry,
     error_table_$badopt) fixed bin (35) external static;

dcl  cleanup condition;

/*  */

/* initializations */

          generated_time = clock ();
	segments_have_been_processed = "0"b;
	boot_program_has_been_processed = "0"b;

	ndir,
	code = 0;

	real_in_p,
	in_p = null;

	seg_hdrp = addr (header_data);

	sltep = addrel (seg_hdrp, 1);

	names_ptr = addrel (seg_hdrp, 5);

	seg_hdrp -> control_word.ident = 0;

	oa_ptr = addr (sltep -> slte.access);

	last_path = " ";

	oi.version_number = object_info_version_2;

	on cleanup call CLEANUP_CONDITION_HANDLER;

/*  */

/* preliminary work */

	sysid_hit, versid_hit, db_hit, dr_hit, do_hit, hd_hit = "0"b;
	call cu_$arg_count (acount);
	do i = 1 to acount;				/* fetch arguments */
	     call cu_$arg_ptr (i, argp (i), argl (i), code);
	end;

	if acount < 2 then do;
noarg:	     code = error_table_$noarg;
	     call ERROR ("Argument missing.", "1"b);
	end;

	do i = 3 to acount while (i <= acount);		/* process optional args */
	     if barg = "-dr" | barg = "-directory" then dr_hit = "1"b;
	     else if barg = "-file" | barg = "-f" then db_hit = "1"b;
	     else if barg = "-notape" | barg = "notape" then do_hit = "1"b;
	     else if barg = "-hold" | barg = "-hd" then hd_hit = "1"b;
	     else if barg = "-sysid" | barg = "-sys_id" then do;
		if i = acount then go to noarg;
		i = i + 1;
		sysid_hit = "1"b;
		sysid = barg;
	     end;
	     else if barg = "-versid" | barg = "-vers_id" then do;
		if i = acount then go to noarg;
		i = i + 1;
		versid_hit = "1"b;
		versid = barg;
	     end;
	     else do;
		code = error_table_$badopt;
		call ERROR ("Invalid option specified.", "1"b);
	     end;
	end;

	header_path = a_header_path || ".header";	/* make the header name */
	i = index (reverse (a_header_path), ">") - 1;	/* locate last ">" */
	if i = -1 then sys_desig = a_header_path;
	else sys_desig = substr (a_header_path, argl (1) - i + 1, i); /* use it as the system designation */
	if ^sysid_hit then sysid = sys_desig;
	if ^versid_hit then versid = sysid;
	ion2 = tape_no;				/* create ioname 2 */
	out_sgna = sys_desig || ".list";		/* create the output listing file name */

	if dr_hit then path_list_name = sys_desig || ".search"; /* create special path list name if used */
	else path_list_name = gm_data_$default_path_list_name;

	call gm_util1_$open (addr (path_array), path_list_name, ndir, header_path, hdrp, ion2,
	     mst_tape_iocbp, gm_output_iocbp, out_sgna, code, open_message, db_hit, do_hit, sysid);
	if open_message ^= "" then
	     call ERROR (open_message, "1"b);

	call parse_file_$parse_file_unset_break (">_!*""."); /* ">","_","!","*",""","." should not be breaks */

/*  */

next_segment:
	path_name_found,
	acl_found,
	cur_length_found,
	bit_count_found,
	cache_found,
	linkage_found,
	end_found = "0"b;
	no_error_was_found = "1"b;

	error_label = skip_to_next_seg;

	call GET_NEXT_ARG;				/* Look at next keyword. */

	if arg = "fini" then do;			/* If end of tape ... */
close_out:     call gm_util1_$close (gm_output_iocbp, mst_tape_iocbp, hd_hit);
	     return;				/* This is the end. */
	end;

	else if arg = "collection" then do;		/* If end of collection ... */
	     call TEST_BREAK (":");

	     sltep -> control_word.length = 1;		/* set length */
	     sltep -> control_word.ident = 2;		/* set identifying portion */
	     call GET_NEXT_ARG;

	     if index (arg, ".") = 0
	     then do;
		sltep -> control_word.col_no = cv_dec_check_ (arg, code);
		if code ^= 0 then 
C_ERROR:		do;
		     call ERROR ("Malformed collection number " || arg, "1"b);
		end;
		sltep -> control_word.col_sub_no = 0;
	     end;
	     else do;
		sltep -> control_word.col_no = cv_dec_check_ (before (arg, "."), code);
		if code ^= 0 then go to C_ERROR;
		sltep -> control_word.col_sub_no = cv_dec_check_ (after (arg, "."), code);
		if code ^= 0 then go to C_ERROR;
	     end;

	     call TEST_BREAK (";");
	     call ioa_ ("Writing collection ^d.^d mark.", sltep -> control_word.col_no, sltep -> control_word.col_sub_no);
	     call WRITE_COLLECTION;
	end;

	else if arg = "name" then			/* If beginning of segment. */
	     call PROCESS_SEGMENT (NORMAL_SEG);

	else if arg = "object" then
	     call PROCESS_SEGMENT (WHOLE_OBJECT_SEG);

	else if arg = "text" then
	     call PROCESS_SEGMENT (TEXT_ONLY_SEG);

	else if arg = "data" then
	     call PROCESS_SEGMENT (DATA_SEG);

	else if arg = "first_name" then do;
	     if segments_have_been_processed then	/* Should be first thing in header. */
		call ERROR ("first_name statement encountered after other segment definitions.", "0"b);
	     call PROCESS_SEGMENT (FIRST_SEG);
	end;

	else if (arg = "boot_program") then do; 	/* Must come first */
	     if segments_have_been_processed | boot_program_has_been_processed then
		call ERROR ("boot_program statement encountered after other segment definitions.", "0"b);
	     call PROCESS_SEGMENT (BOOT_PROGRAM_SEG);
	end;

	else if arg = "fabricate" then
	     call PROCESS_SEGMENT (FABRICATED_SEG);

	else					/* Error. */
	     call ERROR ("Unrecognized primary keyword.", "0"b);


	go to next_segment;

/*  */

PROCESS_SEGMENT: proc (seg_type);

dcl  seg_type fixed bin;				/* segment type */


/* This next allows first_name to follow boot_program */

          if seg_type = BOOT_PROGRAM_SEG
	then boot_program_has_been_processed = "1"b;
	else segments_have_been_processed = "1"b;

	call TEST_BREAK (":");

	call GATHER_NAMES;				/* Gather up the names. */

	call INIT_SEGMENT;				/* Initiate segment and get lengths. */

	error_label = skip_to_next_statement;

seg_loop:
	call GET_NEXT_ARG;				/* Get next keyword. */

/* add_segnames statement */

	if (arg = "add_segnames") | (arg = "include_segnames") then /* Add all segnames to the list of names */
	     call GATHER_SEGNAMES ();

/* delete_name statement */

	else if (arg = "delete_name") | (arg = "delete_names") then
	     call DELETE_NAMES ();

/* pathname statement */

	else if (arg = "path_name") | (arg = "pathname") then do;
	     if acl_found then
		call ERROR ("""path_name"" keyword found after ""acl"" keyword.", "0"b);
	     path_name_found = "1"b;
	     call TEST_BREAK (":");

	     call GET_NEXT_ARG;
	     path.size = numc;
	     path.name = arg;			/* take path name from arg because it may be > 32 chars */
	     slte.branch_required = "1"b;

	     seg_header_length = seg_header_length + 1 + divide (numc + 3, 4, 17, 0); /* add it to header length */
	     if seg_header_length > header_max_size then
		call ERROR ("Header buffer area overflow.", "0"b);
	     cw_ptr = addrel (sltep, seg_header_length); /* set control word mask */
	     call TEST_BREAK (";");
	end;

/* access statement */

	else if arg = "access" then do;
	     call TEST_BREAK (":");
	     slte.access = "0000"b;
	     do while (arg ^= ";");
		call GET_NEXT_ARG;
		if arg = "read" then substr (slte.access, 1, 1) = "1"b;
		else if arg = "write" then substr (slte.access, 3, 1) = "1"b;
		else if arg = "execute" then substr (slte.access, 2, 1) = "1"b;
		else if arg = "privileged" then substr (slte.access, 4, 1) = "1"b;
		else call ERROR ("Invalid argument.", "0"b);

		call GET_NEXT_BREAK;
		if (arg ^= ",") & (arg ^= ";") then
		     call ERROR ("Invalid break.", "0"b);
	     end;
	end;

/* per_process statement */

	else if arg = "per_process" then
	     slte.per_process = YES_NO ();

/* wired statement */

	else if arg = "wired" then do;
	     slte.wired = YES_NO ();
	     if slte.wired then slte.link_sect_wired = "1"b;
	     if ^path_name_found then slte.paged = ^slte.wired;
	end;

/* init_seg statement */

	else if arg = "init_seg" then do;
	     slte.init_seg = YES_NO ();
	     if slte.init_seg then slte.paged = "1"b;
	end;

/* temp_seg statement */

	else if arg = "temp_seg" then do;
	     slte.temp_seg = YES_NO ();
	     if slte.temp_seg then slte.paged = "1"b;
	     slte.init_seg = slte.temp_seg;
	end;

/* firmware */

	else if arg = "firmware" then do;
	     slte.firmware_seg = YES_NO ();
	     if slte.firmware_seg
	     then slte.wired = "1"b;
	end;

/* paged statement */

	else if arg = "paged" then
	     slte.paged = YES_NO ();

/* cur_length statement */

	else if arg = "cur_length" then do;
	     call TEST_BREAK (":");
	     cur_len_for_bitcnt = GET_NUM ();
	     call TEST_BREAK (";");
	     slte.cur_length = bit (divide (cur_len_for_bitcnt + 1023, 1024, 9, 0), 9);
	     if ^bit_count_found then
		slte.bit_count = bit (bin (cur_len_for_bitcnt * 36, 24));
	     cur_length_found = "1"b;
	end;

/* ringbrack statement */

	else if arg = "ringbrack" then do;
	     call TEST_BREAK (":");
	     slte.ringbrack (1) = bit (bin (GET_NUM (), 3));
	     call GET_NEXT_BREAK;
	     if arg = "," then do;
		slte.ringbrack (2) = bit (bin (GET_NUM (), 3));
		call GET_NEXT_BREAK;
		if arg = "," then do;
		     slte.ringbrack (3) = bit (bin (GET_NUM (), 3));
		     call TEST_BREAK (";");
		end;
		else if arg = ";" then
		     slte.ringbrack (3) = slte.ringbrack (2);
		else
		     call ERROR ("Invalid break.", "0"b);
	     end;
	     else if arg = ";" then
		slte.ringbrack (3), slte.ringbrack (2) = slte.ringbrack (1);
	     else
		call ERROR ("Invalid break.", "0"b);
	end;

/* wired_link statement */

	else if arg = "wired_link" then
	     slte.link_sect_wired = YES_NO ();

/* combine_link statement */

	else if arg = "combine_link" then
	     slte.combine_link = YES_NO ();

/* acl statement */

	else if arg = "acl" then do;
	     call TEST_BREAK (":");

	     if ^acl_found then do;
		acl_count_ptr = cw_ptr;		/* set pointer to ACL entry count */
		acl_count = 0;
		cw_ptr = addrel (cw_ptr, 1);		/* set pointer to scw */
		seg_header_length = seg_header_length + 1;
		if seg_header_length > header_max_size then
		     call ERROR ("Header buffer area overflow.", "0"b);
		acl_found = "1"b;
		slte.acl_provided = "1"b;
	     end;

	     acl_count = acl_count + 1;
	     acl_block_ptr = cw_ptr;			/* set pointer for ACL fill-in */
	     seg_header_length = seg_header_length + 11;
	     if seg_header_length > header_max_size then
		call ERROR ("Header buffer area overflow.", "0"b);
	     cw_ptr = addrel (cw_ptr, 11);

	     call GET_NEXT_ARG;
	     acl_block_ptr -> acla.mode = "0"b;
	     if arg ^= "null" then do i = 1 to numc;
		if substr (arg, i, 1) = "r" then
		     substr (acl_block_ptr -> acla.mode, 1, 1) = "1"b;
		else if substr (arg, i, 1) = "e" then
		     substr (acl_block_ptr -> acla.mode, 2, 1) = "1"b;
		else if substr (arg, i, 1) = "w" then
		     substr (acl_block_ptr -> acla.mode, 3, 1) = "1"b;
		else
		     call ERROR ("Invalid argument.", "0"b);
	     end;

	     acl_block_ptr -> acla.pad = "0"b;
	     acl_block_ptr -> acla.code = 0;

	     call TEST_BREAK (",");

	     call GET_NEXT_ARG;
	     acl_block_ptr -> acla.userid = arg;

	     call TEST_BREAK (";");
	end;

/* bit_count statement */

	else if arg = "bit_count" then do;
	     call TEST_BREAK (":");
	     slte.bit_count = bit (bin (GET_NUM (), 24));
	     call TEST_BREAK (";");
	     if ^cur_length_found then
		slte.cur_length = bit (divide (divide (bin (slte.bit_count, 24) + 35, 36, 18, 0) + 1023, 1024, 9, 0));
	     bit_count_found = "1"b;
	end;

/* max_length statement */

	else if arg = "max_length" then do;
	     call TEST_BREAK (":");
	     slte.max_length = bit (bin (GET_NUM (), 9));
	     call TEST_BREAK (";");
	end;

/* cache statement */

	else if arg = "cache" then do;
	     slte.cache = YES_NO ();
	     cache_found = "1"b;
	end;

/* sys_id statement */

	else if (arg = "sys_id") | (arg = "sysid") then do;
	     call TEST_BREAK (":");
	     call GET_NEXT_ARG;
	     symbol_name = arg;
	     if real_in_p = null then
		call COPY_SEGMENT;
	     call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
	     if code ^= 0 then
		call ERROR ("Unable to find sysid symbol.", "1"b);
	     id_ptr -> based_char_32 = sysid;
	     call TEST_BREAK (";");
	end;

/* vers_id statement */

	else if (arg = "vers_id") | (arg = "versid") then do;
	     call TEST_BREAK (":");
	     call GET_NEXT_ARG;
	     symbol_name = arg;
	     if real_in_p = null then
		call COPY_SEGMENT;
	     call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
	     if code ^= 0 then
		call ERROR ("Unable to find versid symbol.", "1"b);
	     id_ptr -> based_char_32 = versid;
	     call TEST_BREAK (";");
	end;

/* generation_time statement */

	else if (arg = "generation_time") then do;
	     call TEST_BREAK (":");
	     call GET_NEXT_ARG;
	     symbol_name = arg;
	     if real_in_p = null then
		call COPY_SEGMENT;
	     call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
	     if code ^= 0 then
		call ERROR ("Unable to find generation_time symbol.", "1"b);
	     time_as_bit = unspec (generated_time);
	     id_ptr -> based_bit_72 = time_as_bit;
	     call TEST_BREAK (";");
	end;

/* generation_time_string statement */

	else if (arg = "generation_time_string") then do;
	     call TEST_BREAK (":");
	     call GET_NEXT_ARG;
	     symbol_name = arg;
	     if real_in_p = null then
		call COPY_SEGMENT;
	     call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
	     if code ^= 0 then
		call ERROR ("Unable to find generation_time_string symbol.", "1"b);
	     call date_time_ (generated_time, generated_time_string);
	     generated_time_string = translate (generated_time_string,
		" ", /* SPACE */
		"	"/* TAB */);
	     id_ptr -> based_char_32 = generated_time_string;
	     call TEST_BREAK (";");
	end;

/* default_time_zone statement */

	else if (arg = "default_time_zone") then do;
	     symbol_name = "default_time_zone";
	     if real_in_p = null then
		call COPY_SEGMENT;
	     call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
	     if code ^= 0 then
		call ERROR ("Unable to find default_time_zone symbol.", "1"b);
	     call GET_NEXT_BREAK;
	     if (arg ^= ":") & (arg ^= ";") then
		call ERROR ("Invalid break.", "0"b);
	     if arg = ":" then do;			/* value defined */
		call GET_NEXT_ARG;
		default_time_zone = arg;
		call TEST_BREAK (";");
	     end;
	     else default_time_zone = date_time_$format ("^za", generated_time, "", "");
						/* use current perprocess time zone */
	     substr (id_ptr -> based_char_32, 1, 4) = default_time_zone;
	     symbol_name = rtrim (symbol_name) || "_delta";
	     call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
	     if code ^= 0 then
		call ERROR ("Unable to find default_time_zone delta symbol.", "1"b);
	     do lang_index = 1 to ti_zone.number_lang;
		do zone_index = 1 to ti_zone.number_zone;
		     if ti_zone.short (lang_index, zone_index) = default_time_zone then goto found_time_zone;
		end;
	     end;
	     call ERROR ("Unable to find default_time_zone in time_info_.", "1"b);
found_time_zone:
	     time_as_bit = unspec (ti_zone.delta (lang_index, zone_index));
	     id_ptr -> based_bit_72 = time_as_bit;
	end;

/* default_rpv_data statement */

	else if (arg = "default_rpv_data") then do;
	     call TEST_BREAK (":");
	     symbol_name = "default_rpv_data";
	     if real_in_p = null then
		call COPY_SEGMENT;
	     call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
	     if code ^= 0 then
		call ERROR ("Unable to find default_rpv_data symbol.", "1"b);
	     default_rpv_data = "";
	     call GET_NEXT_SYM;
	     do while (arg ^= ";");
		if length (default_rpv_data) + length (arg) + 1 > maxlength (default_rpv_data) then
		     call ERROR ("Maximum length of default_rpv_data has been exceeded.", "1"b);
		default_rpv_data = default_rpv_data || arg || " ";
		call GET_NEXT_SYM;
	     end;
	     substr (id_ptr -> based_char_32, 1, 24) = default_rpv_data;
	end;

/* abs_seg statement */

	else if arg = "abs_seg" then
	     slte.abs_seg = YES_NO ();

/* linkage statement */

	else if arg = "linkage" then do;
	     call TEST_BREAK (";");
	     if (seg_type ^= NORMAL_SEG) & (seg_type ^= WHOLE_OBJECT_SEG) then   /* "linkage" illegal others */
		call ERROR ("Linkage keyword with no segment block.", "0"b);
	     slte.link_provided = "1"b;

	     if seg_type = NORMAL_SEG then do;		/* name followed by linkage,want text only */
		sg_l, wr_w = oi.tlng;
		sg_b = sg_l * 36;
	     end;

	     if no_error_was_found then
		call WRITE_SEGMENT (seg_type);

	     sg_l, wr_w = oi.llng;			/* set link block length, words to be written */
	     sg_b = oi.llng * 36;			/* set linkage block bit count */

	     segp = oi.linkp;
	     seg_name = substr (seg_name, 1, seg_name_l) || ".link";
	     seg_name_array.count, nnam = 1;
	     seg_name_array.names (1).name = seg_name;
	     seg_name_array.names (1).size = seg_name_array.names (1).size + 5;
	     cw_ptr, path_ptr = addrel (names_ptr, 10);
	     seg_header_length = 14;

	     call gm_util_ (seg_name, seg_type, sltep, segp, "1"b, "0"b); /* initiate linkage slte */

	     acl_found,
	     cur_length_found,
	     bit_count_found,
	     cache_found = "0"b;
	     linkage_found = "1"b;
	end;

/* end statement */

	else if arg = "end" then do;
	     end_found = "1"b;
	     call TEST_BREAK (";");

	     if no_error_was_found then
		call WRITE_SEGMENT (seg_type);

	     if linkage_found then do;		/* Now do defs. */
		sg_l, wr_w = oi.dlng;
		sg_b = oi.dlng * 36;

		segp = oi.defp;
		seg_name = substr (seg_name, 1, seg_name_l) || ".defs";
		seg_name_array.names (1).name = seg_name;
		cw_ptr = addrel (names_ptr, 10);
		seg_header_length = 14;

		call gm_util_ (seg_name, seg_type, sltep, segp, "0"b, "1"b);

		acl_found,
		cur_length_found,
		bit_count_found,
		cache_found = "0"b;

		if no_error_was_found then
		     call WRITE_SEGMENT (seg_type);
	     end;

	     call TERM_SEGMENT;
	     return;				/* Back to caller. */
	end;

	else
	     call ERROR ("Illegal keyword.", "0"b);

	go to seg_loop;



skip_to_next_statement:
	do while (arg ^= ";");
	     call GET_NEXT_SYM;
	end;

	go to seg_loop;


/*  */

GATHER_NAMES: proc;

	do nnam = 1 by 1 while (nnam <= max_count);	/* Pick up names one by one. */
	     call GET_NEXT_ARG;
	     seg_name_array.names (nnam).size = numc;
	     seg_name_array.names (nnam).name = arg;
	     seg_name_array.count = nnam;

	     call GET_NEXT_BREAK;
	     if arg = ";" then do;			/* Return when names are finished. */
		seg_header_length = 5 + nnam * 9;
		path_ptr, cw_ptr = addrel (names_ptr, nnam * 9 + 1);
		return;
	     end;
	     else if arg ^= "," then
		call ERROR ("Invalid break.", "0"b);
	end;

	call ERROR ("Too many names.", "0"b);


     end GATHER_NAMES;

/*  */

GATHER_SEGNAMES: proc ();

/* This procedure adds all the segmames in a bound object segment to the list of names
   in the SLTE, thus avoiding the necessity of updating the header every time a component
   is added to a bound segment, and making the header considerably smaller as well.
   */

dcl  idx fixed bin;
dcl  current_name_count fixed bin;
dcl 1 def aligned like decode_definition_full;
dcl  defp pointer;
dcl  segname char (32);


	call TEST_BREAK (";");			/* No arguments may follow */

	defp = oi.defp;
	if (defp = null ()) | (^oi.bound) | (^object_segment) then	/* Must be both valid obj seg & bound. */
	     call ERROR ("The add_segnames statement may only be used with bound object segments.", "0"b);

	if (acl_found | path_name_found) then		/* Since names array is built before ACL or pathname */
	     call ERROR ("The add_segnames statement must come before either of ""acl"" or ""path_name"".", "0"b);

	current_name_count = seg_name_array.count;	/* So we can check that we aren't duplicating names */
	nnam = seg_name_array.count;			/* Remember it here, in case we don't find anything */

	do while (^decode_definition_$full (defp, addr (def), addr (oi))); /* loop through all definitions in the seg */
	     defp = def.next_def;			/* continue to next one, next time */
	     if ^def.ignore & (def.section = "segn")
	     then do;				/* It's a segname definition, so process it */
		segname = substr (def.symbol, 1, def.symbol_lng);
		do idx = 1 to current_name_count;	/* Is it already in the name array? */
		     if seg_name_array.names (idx).name = segname then
			goto TRY_NEXT_DEFINITION;	/* Yes. Ignore it. */
		     end;

		nnam = seg_name_array.count + 1;	/* Otherwise, add it to the array */
		if nnam > max_count then
		     call ERROR ("Too many names.", "0"b);

		seg_name_array.names (nnam).size = length (rtrim (segname));
		seg_name_array.names (nnam).name = segname;
		seg_name_array.count = nnam;
		end;
TRY_NEXT_DEFINITION:				/* skip to next one */
	     end;

	seg_header_length = 5 + nnam * 9;		/* update the size */
	path_ptr, cw_ptr = addrel (names_ptr, nnam * 9 + 1);

	return;
	end GATHER_SEGNAMES;

/*  */

DELETE_NAMES: proc;

/* This procedure is used to remove names from the name array if they are not to be
   included; it is used to eliminate extraneous segnames which were included by a
   previous add_segnames statement.
   */

dcl (idx, jdx) fixed bin;
dcl  segname char (32);


	call TEST_BREAK (":");

	if (acl_found | path_name_found) then		/* Since names array is built before ACL or pathname */
	     call ERROR ("The delete_name statement must come before either of ""acl"" or ""path_name"".", "0"b);

	nnam = seg_name_array.count;

	do while (arg ^= ";");			/* Find all the names to delete */
	     call GET_NEXT_ARG ();

	     segname = arg;
	     do idx = 1 to seg_name_array.count;	/* See if we can find the specified name */
		if seg_name_array.names (idx).name = segname then do; /* Found it */
		     if nnam = 1 then		/* You'd make it invisible, would you.... */
			call ERROR ("The delete_name statement would leave no names on the segment.", "0"b);

		     do jdx = idx to nnam - 1;	/* percolate all the other names down */
			seg_name_array.names (jdx) = seg_name_array.names (jdx + 1);
			end;

		     nnam = nnam - 1;		/* record the change in number of names */
		     seg_name_array.count = nnam;
		     goto GET_NEXT_NAME_TO_DELETE;	/* All done with this one */
		     end;
		end;

	     call ERROR ("Name to be deleted is not in name array for segment.", "0"b); /* Sorry */

GET_NEXT_NAME_TO_DELETE:
	     call GET_NEXT_BREAK ();

	     if (arg ^= ",") & (arg ^= ";") then
		call ERROR ("Invalid break.", "0"b);
	     end;

	seg_header_length = 5 + nnam * 9;
	path_ptr, cw_ptr = addrel (names_ptr, nnam * 9 + 1);

	return;					/* All done deleting names */
	end DELETE_NAMES;

/*  */

INIT_SEGMENT: proc;


	seg_name = seg_name_array.names (1).name;
	seg_name_l = seg_name_array.names (1).size;

	object_segment = "0"b;			/* until shown otherwise, assume it's not */

	if seg_type ^= FABRICATED_SEG then do;
	     do i = 1 to ndir while (in_p = null ());
		call hcs_$initiate_count (path_array (i), seg_name, "", bitcnt, 0, in_p, code);
		if (in_p = null ()) & (code ^= error_table_$noentry) then
		     call ERROR ("Invalid pathname in path list.", "1"b);
	     end;
	     if in_p = null () then
		call ERROR ("Missing segment.", "0"b);

	     call print_gen_info_ (in_p, bitcnt, "gm_output", code);
	end;

	else do;					/* no seg block,prepare to write out 0 length scw */
	     sg_l = 0;
	     slte.bit_count = "0"b;
	     slte.cur_length = "0"b;
	end;

	call gm_util_ (seg_name, seg_type, sltep, segp, "0"b, "0"b); /* initiate segment block slte */

	if seg_type ^= FABRICATED_SEG then do;
	     if seg_type ^= DATA_SEG then do;		/* Get object info for anything but pure data */
		call object_info_$brief (in_p, bitcnt, addr (oi), code);
		if (oi.linkp = null) | (code ^= 0) then do;
		     call ERROR ("Bad object segment.", "0"b);
		     slte.combine_link = "0"b;
		end;
		else object_segment = "1"b;		/* segment is a legitimate object segment, so oi is valid. */
	     end;
	     else slte.combine_link = "0"b;		/* Certainly don't combine for non-object */

	     if seg_type = TEXT_ONLY_SEG then do;	/* text keyword, set up text segment */
		tx_l = oi.tlng;			/* set block length from linkage pointer offset */
		wr_w, sg_l = tx_l;			/* set up text segment */
		sg_b = sg_l * 36;			/* set bit count of "t" or "tl" seg block */
	     end;
	     else do;				/* not object,take whole segment for now */
		sg_b = bitcnt;
		sg_l, wr_w = divide (bitcnt+35, 36, 17, 0);
	     end;

	     segp = in_p;
	end;


     end INIT_SEGMENT;


/*  */

COPY_SEGMENT: proc;


	real_in_p = in_p;
	unique_name = unique_chars_ ("0"b);
	call hcs_$make_seg ("", unique_name, unique_name, 1010b, in_p, code);
	if in_p = null () then
	     call ERROR ("Unable to create segment in process directory.", "1"b);
	in_p -> movewds = real_in_p -> movewds;		/* make new segment */
	call hcs_$set_bc_seg (in_p, bitcnt, code);
	segp = in_p;


     end COPY_SEGMENT;



TERM_SEGMENT: proc;


	if in_p ^= null then do;
	     if real_in_p ^= null then do;		/* sysid seg, must delete */
		call delete_$ptr (in_p, "100100"b, "generate_mst", code);
		if code ^= 0 then
		     call ERROR ("Unable to terminate segment in process directory.", "1"b);
		in_p = real_in_p;			/*  reset to original ptr */
		real_in_p = null;
	     end;
	     call hcs_$terminate_noname (in_p, code);	/* terminate the found segment */
	     if code ^= 0 then
		call ERROR ("Unable to terminate found segment.", "1"b);
	     else in_p = null;
	end;


     end TERM_SEGMENT;

     end PROCESS_SEGMENT;


/*  */

WRITE_SEGMENT: proc (seg_type);

dcl  seg_type fixed bin;


/* insert access in output line */

	output_access_word = "";			/* initialize all access fields to blank */
	if output_access.read then substr (output_access_word, 1, 1) = "R";
	if output_access.execute then substr (output_access_word, 2, 1) = "E";
	if output_access.write then substr (output_access_word, 3, 1) = "W";
	if output_access.privileged then substr (output_access_word, 4, 1) = "P";
	if output_access_word = "" then
	     call ERROR ("Invalid argument.", "0"b);

/* set bit count, cur_length if necessary */

	if ^(cur_length_found | bit_count_found) then
	if seg_type ^= FABRICATED_SEG then do;
		slte.bit_count = bit (sg_b, 24);
		slte.cur_length = bit (divide (divide (sg_b + 35, 36, 18, 0) + 1023, 1024, 9, 0), 9);
	     end;


/* Compute cache access */

	if ^cache_found				/* believe given spec */
	then if slte.per_process then slte.cache = "1"b;
	     else if output_access.write
	     | slte.init_seg
	     | slte.temp_seg then slte.cache = "0"b;
	     else slte.cache = "1"b;

	cw_ptr -> control_word.ident = 1;		/* set identity of segment control word */
	cw_ptr -> control_word.length = sg_l;
	header_words = seg_header_length+2;		/* add hcw,scw length */
	seg_hdrp -> control_word.length = seg_header_length;

/* write first segment */

	if (seg_type = FIRST_SEG) | (seg_type = BOOT_PROGRAM_SEG) then do;
	     if seg_type = FIRST_SEG then
		call gm_write_first_seg_ (sltep, sg_b, in_p, mst_tape_iocbp, error_in_object_segment, code);
	     else if do_hit then;			/* Do nothing if -notape specified */
	     else call gm_write_boot_program_ (in_p, sg_b, (seg_name), mst_tape_iocbp, db_hit, error_in_object_segment, code);

	     if code ^= 0 then do;
TAPE_ER:		if error_in_object_segment then
		     call ERROR ("Bad object segment.", "1"b);
		else call ERROR ("Unrecoverable tape error.", "1"b);
	     end;

	     if (db_hit | do_hit) then
		tape_er_count = 0;
	     else call iox_$control (mst_tape_iocbp, "error_count", addr (tape_er_count), code);

	     if tape_er_count ^= 0 then call ERROR ("Error writing first segment.", "1"b);
	end;

/* write out the header */

	else do;
	     call iox_$put_chars (mst_tape_iocbp, seg_hdrp, header_words*4, code);
	     if code ^= 0 then go to TAPE_ER;

/* now write out the segment */

	     if (seg_type = NORMAL_SEG)
	      | (seg_type = WHOLE_OBJECT_SEG)
	      | (seg_type = TEXT_ONLY_SEG)
	      | (seg_type = DATA_SEG) then do;

		call iox_$put_chars (mst_tape_iocbp, segp, wr_w * 4, code);
		if code ^= 0 then go to TAPE_ER;
	     end;
	end;

	return;



WRITE_COLLECTION: entry;


	call iox_$put_chars (mst_tape_iocbp, sltep, 8, code);
	if code ^= 0 then go to TAPE_ER;

	return;


     end WRITE_SEGMENT;


/*  */

GET_NEXT_SYM: proc;


	call parse_file_$parse_file_ptr (symp, numc, sym_is_a_break, eof_was_found);
	if eof_was_found = 1 then			/* error,eof found before "fini" */
	     call ERROR ("Physical end of header reached before logical end.", "1"b);

	return;


     end GET_NEXT_SYM;



GET_NEXT_ARG: proc;


	call GET_NEXT_SYM;

	if sym_is_a_break = 1 then			/* Should not be a break. */
	     call ERROR ("Break found when keyword or argument expected.", "0"b);

	return;


GET_NEXT_BREAK: entry;

	call GET_NEXT_SYM;

	if sym_is_a_break = 0 then			/* Must be a break. */
	     call ERROR ("Invalid break.", "0"b);

	return;


     end GET_NEXT_ARG;



TEST_BREAK: proc (break);

dcl  break char (1) aligned;				/* break char to be checked */

	call GET_NEXT_BREAK;

	if arg ^= break then
	     call ERROR ("Invalid break.", "0"b);

	return;


     end TEST_BREAK;


/*  */

YES_NO:	proc returns (bit (1) unal);

dcl  switch bit (1) aligned;


	call TEST_BREAK (":");
	call GET_NEXT_ARG;
	if arg = "yes" then switch = "1"b;
	else if arg = "no" then switch = "0"b;
	else call ERROR ("Invalid argument.", "0"b);

	call TEST_BREAK (";");

	return (switch);


     end YES_NO;



GET_NUM:	proc returns (fixed bin);


	call GET_NEXT_ARG;
	return (bin (fixed (arg, 6), 17));


     end GET_NUM;


/*  */

CLEANUP_CONDITION_HANDLER: proc;


	call gm_error_ (0, seg_name, symp, hdrp, "Cleanup handler invoked.", addr (o_ln), "1"b, end_found,
	     "0"b, in_p, gm_output_iocbp);

	call gm_util1_$close (gm_output_iocbp, mst_tape_iocbp, hd_hit);


     end CLEANUP_CONDITION_HANDLER;



ERROR:	proc (gm_message, fatal);		/* normal error handler */

dcl  gm_message char (*),				/* gm error message */
     fatal bit (1) aligned;				/* fatal error switch */


	call gm_error_ (code, seg_name, symp, hdrp, gm_message, addr (o_ln),
	     fatal, end_found, "0"b, in_p, gm_output_iocbp);

	if ^fatal then
	     go to error_label;
	else
	     go to close_out;


     end ERROR;



skip_to_next_seg:
	if end_found then do while (sym_is_a_break = 0);
	     call GET_NEXT_SYM;
	end;
	else do;
	     do while (arg ^= "end");
		call GET_NEXT_SYM;
	     end;
	     call GET_NEXT_SYM;
	end;
	end_found = "0"b;
	if arg ^= ";" then
	     go to skip_to_next_seg;
	else
	go to next_segment;


%page; %include gm_data;
%page; %include slte;
%page; %include object_info;
%page; %include decode_definition_str;
%page; %include time_names;

     end generate_mst;




		    gm_data_.alm                    02/06/76  1321.0rew 02/06/76  1255.1        5229



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

			segdef 	default_path_list_name
default_path_list_name:	dec	34
			aci	">system_library_tools>gm_path_list"
			end




		    gm_error_.pl1                   07/29/81  1304.2rew 07/28/81  1357.2       38331



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

gm_error_: proc (code, seg_name, symbol_ptr, header_ptr, arg_error_message, line_ptr,
	     fatal_error_occurred, terminator_was_just_processed, fini_was_found, fseg_ptr, iocb_ptr);

/* argument declarations */

dcl  code fixed bin (35),				/* error code */
     seg_name char (32) aligned,			/* name of segment for which error occurred */
     symbol_ptr ptr,				/* pointer to current header symbol */
     header_ptr ptr,				/* pointer to header */
     arg_error_message char (*),			/* error message */
     line_ptr ptr,					/* pointer to line in output file */
     fatal_error_occurred bit (1),			/* fatal error flag */
     terminator_was_just_processed bit (1),		/* indicates whether or not header must be parsed */
     fini_was_found bit (1),				/* on at finding "fini" in header */
     fseg_ptr ptr,					/* pointer to initiated segment */
     iocb_ptr ptr;

/* program declarations */

dcl (addr, null, substr) builtin;

dcl  line char (95) based (line_ptr),			/* mask for modifying line in output file */
     error_message char (100) varying;			/* error message */


dcl (char_index, char_num) fixed bin (17),		/* for printing current header line */
     cur_ptr ptr,					/* pointer to current header line */
     cur_line char (char_num) based (cur_ptr),		/* current line mask */
     header (100000) char (1) based;

dcl  num_chars_read fixed bin (17),			/* characters read in header parse */
     symbol_is_a_break fixed bin (1),			/* returned from parse_file_ */
     eof_was_found fixed bin (1),			/* ditto */


     symbol char (num_chars_read)based (symbol_ptr);	/* mask for looking at current symbol */

/* external entries */

dcl  com_err_ entry options (variable),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     ioa_ entry options (variable),
     parse_file_$parse_file_cur_line ext entry (fixed bin, fixed bin),
     parse_file_$parse_file_ptr ext entry (ptr, fixed bin, fixed bin (1), fixed bin (1)),
     iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));

/*  */
/* set the error message */
	error_message = arg_error_message;

BEGIN:


	call com_err_ (code, "generate_mst", error_message);

	code = 0;
	error_message = "";

	if seg_name ^= "" then do;
	     call ioa_ ("Last segment name encountered in header was ^a", seg_name);
	     if symbol_ptr ^= null then do;
		call parse_file_$parse_file_cur_line (char_index, char_num);
		cur_ptr = addr (header_ptr -> header (char_index));
		call ioa_ ("current line is ^/^a", cur_line);
	     end;
	end;

	if iocb_ptr ^= null then do;
	     line_ptr -> line = "******";		/* blank out line and fill in stars */
	     substr (line_ptr -> line, 43) = error_message;
	     call iox_$put_chars (iocb_ptr, line_ptr, 500, code);
	end;

	if (fatal_error_occurred) then return;

	if fseg_ptr ^= null then do;			/* terminate the initiated segment */
	     call hcs_$terminate_noname (fseg_ptr, code);
	     if code ^= 0 then do;			/* fatal error */
		error_message = "Unable to terminate found segment.";
		fatal_error_occurred = "1"b;
		go to BEGIN;
	     end;
	     else fseg_ptr = null;
	end;

	if (fini_was_found) then return;
	if (terminator_was_just_processed) then return;

	else if symbol_ptr ^= null then do;		/* find "end" statement or terminator */
ERR_LOOP:
	     call parse_file_$parse_file_ptr (symbol_ptr, num_chars_read, symbol_is_a_break, eof_was_found);
	     if symbol = "fini" then do;
		fini_was_found = "1"b;
		return;
	     end;

	     if eof_was_found = 1 then do;		/* fatal error */
		fatal_error_occurred = "1"b;
		error_message = "Physical end of header reached before end statement.";
		go to BEGIN;
	     end;

	     if symbol = "end" then do;
		terminator_was_just_processed = "1"b;
		return;
	     end;

	     go to ERR_LOOP;

	end;

	return;

     end gm_error_;




		    gm_util1_.pl1                   05/17/85  1650.4rew 05/17/85  1447.7      107397



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

/* Modified 9/79 by R.J.C. Kissel to handle 6250 bpi tapes. */
/* Modified 3 February 1980, M. R. Jordan, to use parse_tape_reel_name_. */
/* Modified 1 April 1981, W. Olin Sibert, to fix bug in above, and convert for strings as error messages */
/* Modified 31 July 1981, WOS, to always detach mst_tape even if errors occurred in closing it */
/* Modified 1985-05-16, BIM: set async mode on tape attachment, clean up
		    some of the archaisms. */

/* format: style3,ind3,dclind6,idind32 */
gm_util1_:
   procedure;

dcl   a_ptr		        ptr,		/* pointer to array of directories to be searched */
      a_path_list_name	        char (168) aligned,	/* path name of list of directories */
      number_of_directories	        fixed bin (17),	/* number of directories to be searched */
      header_path		        char (168),		/* path name of driving header */
      header_dir		        char (168),		/* directory porion of header path */
      header_ent		        char (32),		/* entry portion of header path */
      header_ptr		        ptr,		/* pointer to header */
      a_ioname2		        char (32) aligned,	/* ioname 2 for attaching tape */
      output_seg_name	        char (32) aligned,	/* name of output listing */
      code		        fixed bin (35),	/* error code */
      error_message		        char (*),		/* error type */
      sysid		        char (8),		/* system id */
      time		        char (256),		/* time string */
      do_sw		        bit (1) aligned,	/* discard output switch */
      db_sw		        bit (1) aligned,	/* debug switch for file attachment */
      mst_tape_iocbp	        ptr,
      gm_output_iocbp	        ptr;


dcl   path_list_iocbp	        static ptr init (null);


dcl   (list_has_been_attached, tape_has_been_attached, output_file_was_created)
			        fixed bin static;

dcl   initial_state		        fixed bin static init (0),
      attached_state	        fixed bin static init (1),
      open_state		        fixed bin static init (2);

dcl   atom		        char (32) aligned;

dcl   atd			        char (256) varying;

dcl   b_path_list_name	        char (168) int static,/* static copies of arguments for call to close */
      path_list_name	        char (length_pnl) based (addr (b_path_list_name)),
      length_pnl		        fixed bin int static,
      ioname2		        char (32) int static;

dcl   line_read		        char (168) aligned,	/* buffer for ios_read */
      num_chars_read	        fixed bin (21);	/* number of characters read into buffer */

dcl   i			        fixed bin (17);	/* do loop index */
dcl   j			        fixed bin;

dcl   path_array		        (number_of_directories) char (168) based (a_ptr);
						/* for looking at path array */
dcl   t_err		        fixed bin (17);	/* number of tape errors */
dcl   s_db_sw		        bit (1) aligned static;

/* external variables */

dcl   error_table_$short_record       ext fixed bin (35);
dcl   error_table_$end_of_info        ext fixed bin (35);

/* external entries */


%include iox_entries;
%include iox_modes;

declare	absolute_pathname_		  entry (character (*), character (*), fixed binary (35));
declare	expand_pathname_		  entry (character (*), character (*), character (*), fixed binary (35));
declare	date_time_$format		  entry (character (*), fixed binary (71), character (*), character (*))
				  returns (character (250) var);

dcl   com_err_$suppress_name	        ext entry options (variable),
      ioa_		        entry options (variable),
      ioa_$ioa_switch	        entry options (variable),
      parse_file_$parse_file_init_name
			        entry (char (*), char (*), ptr, fixed bin (35));

dcl   (addr, before, clock, index, null, rtrim, substr)
			        builtin;		/*  */
open:
   entry (a_ptr, a_path_list_name, number_of_directories, header_path, header_ptr, a_ioname2, mst_tape_iocbp,
        gm_output_iocbp, output_seg_name, code, error_message, db_sw, do_sw, sysid);

      number_of_directories = 0;
      error_message = "";

      length_pnl = index (a_path_list_name, " ") - 1;
      if length_pnl < 0
      then length_pnl = 168;
      b_path_list_name = a_path_list_name;
      ioname2 = a_ioname2;

      s_db_sw = db_sw | do_sw;


      list_has_been_attached, tape_has_been_attached, output_file_was_created = initial_state;


/*  attach the path list  */
/* ---------------------- */

      call iox_$attach_name ("path_list", path_list_iocbp, "vfile_ " || path_list_name, null (), code);
      if code ^= 0
      then
         do;
	  error_message = "Unable to reference search file";
	  go to ERROR;
         end;
      else list_has_been_attached = attached_state;

      call iox_$open (path_list_iocbp, Stream_input, "0"b, code);
      if code ^= 0
      then
         do;
	  error_message = "Unable to reference search file";
	  go to ERROR;
         end;

      else list_has_been_attached = open_state;

/*  fill the path name array  */
/* -------------------------- */

      do i = 1 to 10;
         call iox_$get_line (path_list_iocbp, addr (line_read), 168, num_chars_read, code);
         if code ^= 0
         then
	  do;
	     if code = error_table_$short_record
	     then
	        do;
		 num_chars_read = num_chars_read + 1;	/* adjust for no new line character */
		 code = 0;
	        end;
	     else if code = error_table_$end_of_info
	     then
	        do;
		 code = 0;
		 go to FINISHED_LIST;
	        end;
	     else
	        do;
		 error_message = "Unable to read path list";
		 go to ERROR;
	        end;
	  end;
         num_chars_read = num_chars_read - 1;
         line_read = substr (line_read, 1, num_chars_read); /* strip off trailing CR */
         call absolute_pathname_ (substr (line_read, 1, num_chars_read), path_array (i), code);
         if code ^= 0
         then
	  do;
	     error_message = "Unable to expand pathname in path list";
	     go to ERROR;
	  end;
         number_of_directories = number_of_directories + 1; /*
						   if status.end_of_data = "1"b then go to FINISHED_LIST;
						   */
      end;

/*
   if (^status.end_of_data)			/* too many path names */
/*
   then do;
   error_message = "Too many names in path list";
   go to ERROR;
   end;
*/

FINISHED_LIST:					/*  initiate the header  */
						/* --------------------- */
      call expand_pathname_ (header_path, header_dir, header_ent, code);
      if code ^= 0
      then
         do;
	  error_message = "Unable to expand header pathname";
	  go to ERROR;
         end;

      call parse_file_$parse_file_init_name (header_dir, header_ent, header_ptr, code);
      if code ^= 0
      then
         do;
	  error_message = "Unable to initiate header";
	  go to ERROR;
         end;

/*  attach the tape  */
/* ----------------- */

      atd = "";
      if do_sw
      then atd = "discard_";
      else if db_sw
      then atd = "vfile_ " || ioname2;
      else
         do;
	  atd = "tape_mult_ ";
	  i = index (ioname2, ",");
	  if i = 0
	  then atd = atd || rtrim (ioname2);
	  else
	     do;
	        atd = atd || before (ioname2, ",");
	        do while (i ^= 0);
		 j = index (substr (ioname2, i + 1), ",");
		 if j = 0
		 then atom = substr (ioname2, i + 1);
		 else
		    do;
		       j = j + i;
		       atom = substr (ioname2, i + 1, j - i - 1);
		    end;
		 if atom = "7track"
		 then atd = atd || " -tk 7";
		 else if atom = "9track"
		 then atd = atd || " -tk 9";
		 else if index (atom, "=800") ^= 0
		 then atd = atd || " -den 800";
		 else if index (atom, "=1600") ^= 0
		 then atd = atd || " -den 1600";
		 else if index (atom, "=6250") ^= 0
		 then atd = atd || " -den 6250";
		 else if atom = "800"
		 then atd = atd || " -den 800";
		 else if atom = "1600"
		 then atd = atd || " -den 1600";
		 else if atom = "6250"
		 then atd = atd || " -den 6250";
		 else atd = atd || " -com " || atom;
		 i = j;
	        end;
	     end;
	  if index (atd, " -den") = 0
	  then atd = atd || " -den 800";
	  atd = atd || " -wrt";
         end;

      call iox_$attach_name ("mst_tape", mst_tape_iocbp, (atd), null (), code);
      if code ^= 0
      then
         do;
	  error_message = "Unable to attach tape";
	  go to ERROR;
         end;
      else tape_has_been_attached = attached_state;

      call iox_$open (mst_tape_iocbp, Stream_output, "0"b, code);
      if code ^= 0
      then
         do;
	  error_message = "Unable to attach tape";
	  go to ERROR;
         end;

      else tape_has_been_attached = open_state;

      if ^(do_sw | db_sw)
      then call iox_$modes (mst_tape_iocbp, "async", "", (0));
						/* Set tape to async mode */

/*  initiate the output file  */
/* -------------------------- */

      call iox_$attach_name ("gm_output", gm_output_iocbp, "vfile_ " || output_seg_name, null (), code);
      if code ^= 0
      then
         do;
	  error_message = "Unable to create output file";
	  go to ERROR;
         end;
      else output_file_was_created = attached_state;

      call iox_$open (gm_output_iocbp, Stream_output, "0"b, code);
      if code ^= 0
      then
         do;
	  error_message = "Unable to create output file";
	  go to ERROR;
         end;

      else output_file_was_created = open_state;

      time = date_time_$format ("date_time", clock (), "", "");

      call ioa_$ioa_switch (gm_output_iocbp, "^-^-Generation of System ^a on Tape ^a at ^a^/^/", sysid, ioname2, time);

      call ioa_$ioa_switch (gm_output_iocbp, "^-NAME^-^-     DATE CHANGED^-      AUTHOR^-      LANG^-PATHNAME^/^/");

      call ioa_ ("begin generation");

ERROR:
      return;

/*  */

close:
   entry (gm_output_iocbp, mst_tape_iocbp, hold_sw);

dcl   hold_sw		        bit (1) aligned;

dcl   error_code		        fixed bin (35);

      error_code = 0;
      if output_file_was_created ^= initial_state
      then
         do;
	  if output_file_was_created = open_state
	  then call iox_$close (gm_output_iocbp, error_code);
	  output_file_was_created = attached_state;
	  if error_code = 0
	  then call iox_$detach_iocb (gm_output_iocbp, error_code);
	  output_file_was_created = initial_state;
	  if error_code ^= 0
	  then call com_err_$suppress_name (error_code, "gm_util1_", "detach ^a", path_list_name);
         end;

      if tape_has_been_attached ^= initial_state
      then
         do;
	  if s_db_sw = "0"b
	  then
	     do;
	        t_err = 0;
	        if tape_has_been_attached = open_state
	        then call iox_$control (mst_tape_iocbp, "error_count", addr (t_err), error_code);
	        call ioa_ ("tape errors = ^d", t_err);
	     end;
	  if tape_has_been_attached = open_state
	  then call iox_$close (mst_tape_iocbp, error_code);
	  tape_has_been_attached = attached_state;
	  if ^hold_sw
	  then if error_code = 0
	       then call iox_$detach_iocb (mst_tape_iocbp, error_code);
	       else call iox_$detach_iocb (mst_tape_iocbp, (0));
						/* If code is already nonzero, preserve it */
	  tape_has_been_attached = initial_state;
	  if error_code ^= 0
	  then call com_err_$suppress_name (error_code, "gm_util1_", "detach tape");
         end;

      if list_has_been_attached ^= initial_state
      then
         do;
	  if list_has_been_attached = open_state
	  then call iox_$close (path_list_iocbp, error_code);
	  list_has_been_attached = attached_state;
	  if error_code = 0
	  then call iox_$detach_iocb (path_list_iocbp, error_code);
	  list_has_been_attached = initial_state;
	  if error_code ^= 0
	  then call com_err_$suppress_name (error_code, "gm_util1_", "detach ^a", path_list_name);
         end;

      return;

   end gm_util1_;




		    gm_util_.pl1                    06/04/84  1616.5rew 06/04/84  1242.3       39915



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

gm_util_: proc (seg_name, seg_type, sltep, seg_ptr, seg_is_linkage, seg_is_defs);

/* *	GM_UTIL_
   *
   *	This repulsive utility program diddles with SLT entries to be written onto
   *	a system tape, in a fashion which is not particularly obvious even after
   *	considerable study.
   */

/* Modified 31 July 1981, W. Olin Sibert, to use gm_data.incl.pl1 for segment type values */

/* argument declarations */

dcl  seg_name char (32) aligned,			/* name of segment whose slte is being initialized */
     seg_type fixed bin (17),				/* primary keyword type (name,first_name,etc.) */
     seg_ptr ptr,					/* pointer to the segment */
     seg_is_linkage bit (1) aligned,			/* on if slte is for linkage segment */
     seg_is_defs bit (1) aligned;			/* on if slte is for defs segment */

dcl (seg_word2 init ("110010000000010000000000000100000000"b), /* specifies re access,cache,paged,combine_link */
     seg_word3 init ("000000000000000000000000000000000000"b), /* specifies ringbrackets of 0,0,0 */
     link_word2 init ("111110000000011000000011011000000000"b),
						/*  when anded with word two of an slte for a linkage section,
						   saves access, paged, per_process,
						   init_seg, temp_seg, link_sect and link_sect_wired */
     link_word3 init ("000000000111111111000000000000000000"b),
						/* when anded with word three of linkage slte, saves ringbracks */
     defs_word2 init ("000010000000000000000000000001000000"b),
						/* When anded with word two of defs slte, saves cache */
     defs_word3 init ("000000000000000000000000000000000000"b)) bit (36) aligned static;
						/* when anded with word three of defs slte, save nothing */

dcl  word_mask bit (36) aligned based;			/* mask for above strings */

dcl (word2_ptr,
     word3_ptr,
     word4_ptr) ptr;				/* pointers to slte data words */

dcl  addrel builtin;

/*  */

/*  initializations  */
/* ------------------- */

	word2_ptr = addrel (sltep, 1);
	word3_ptr = addrel (sltep, 2);
	word4_ptr = addrel (sltep, 3);


/*  */

/*  initiate linkage slte  */
/* ------------------------- */

	if (seg_is_linkage) then do;

	     slte.link_sect = "1"b;			/* set switch indicating this is a linkage section */

	     if slte.combine_link = "1"b then do;	/* if the combine link switch is on  */
		slte.access = "1000"b;		/*  then default access is READ  */
		slte.per_process = "0"b;
		slte.init_seg = "1"b;
	     end;

	     else					/*  if the combine link switch is not on  */
		slte.access = "1010"b;		/* give the linkage RW  */

	     word2_ptr -> word_mask = word2_ptr -> word_mask & link_word2; /* initiate word 2 of slte */

	     slte.temp_seg, slte.init_seg = "1"b;	/* make all .link segments go away */

	     word3_ptr -> word_mask = word3_ptr -> word_mask & link_word3; /* initiate word 3 of slte */

	     word4_ptr -> word_mask = "0"b;		/* initiate word 4 of slte */
	end;

/*  */
/*  initiate defs slte  */
/* ------------------------- */

	else if (seg_is_defs) then do;

	     slte.defs = "1"b;			/* set switch indicating this is a defs section */

	     word2_ptr -> word_mask = word2_ptr -> word_mask & defs_word2; /* initiate word 2 of slte */

	     word3_ptr -> word_mask = word3_ptr -> word_mask & defs_word3; /* initiate word 3 of slte */

	     word4_ptr -> word_mask = "0"b;		/* initiate word 4 of slte */

	     slte.access = "1000"b;
	     slte.init_seg = "1"b;
	     slte.paged = "1"b;
	end;

/*  */

/*  initiate slte for segments  */
/* ------------------------------ */

	else do;

	     sltep -> word_mask = "0"b;		/* initiate word 1 of slte */

	     word2_ptr -> word_mask = seg_word2;	/* initiate word 2 of slte */

	     word3_ptr -> word_mask = seg_word3;	/* initiate word 3 of slte */

	     word4_ptr -> word_mask = "0"b;		/* initiate word 4 of slte */

	     if seg_type = FABRICATED_SEG		/* fabricate */
	     then sltep -> slte.access = "1010"b;	/* READ, WRITE */
	end;

%page; %include gm_data;
%page; %include slte;

     end gm_util_;




		    gm_write_boot_program_.pl1      07/16/87  1350.3r   07/15/87  1602.4       38223



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



/****^  HISTORY COMMENTS:
  1) change(87-01-19,GDixon), approve(87-04-16,MCR7614),
     audit(87-05-21,Farley), install(87-07-15,MR12.1-1040):
     Add support for storing boot program as first segment of MST image stored
     in a file.
                                                   END HISTORY COMMENTS */


gm_write_boot_program_:
     procedure (P_seg_ptr, P_bc, P_seg_name, P_iocbp, P_file, P_object_error, P_code);

/* format: off */

/* *	GM_WRITE_BOOT_PROGRAM_
   *
   *	This procedure writes the supplied program to the bootload_program area of the label.
   *	Of course, this only works if a genuine tape is being written. This is taken care of
   *	by generate_mst itself.
   *
   *	Cribbed from gm_write_first_seg_, 31 July, 1981, W. Olin Sibert
   */

dcl  P_seg_ptr pointer parameter;			/* pointer to segment */
dcl  P_bc fixed bin (24) parameter;			/* length of segment */
dcl  P_seg_name char (*) parameter;			/* Name of program (for label audit trail) */
dcl  P_iocbp pointer parameter;			/* IOCB for tape writing */
dcl  P_file bit(1) aligned parameter;			/* -file given */
dcl  P_object_error bit (1) aligned parameter;		/* Error in object segment flag */
dcl  P_code fixed bin (35) parameter;			/* error code */

dcl  code fixed bin (35);
dcl  iocbp pointer;

dcl 1 bpi aligned like boot_program_info automatic;
dcl 1 control_word aligned,
      2 type fixed bin (17) unaligned,
      2 count fixed bin (18) uns unal;
dcl (name_len, seg_len) fixed bin (21);
dcl 1 oi aligned like object_info automatic;

dcl  iox_$close entry (pointer, fixed bin (35));
dcl  iox_$control entry (pointer, char (*), pointer, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35));
dcl  iox_$open entry (pointer, fixed bin, bit (1) aligned, fixed bin (35));
dcl  object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));

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

dcl BOOTLOAD_PROGRAM fixed bin internal static options (constant) init (-1);
/*  */

	iocbp = P_iocbp;

	oi.version_number = object_info_version_2;
	call object_info_$brief (P_seg_ptr, P_bc, addr (oi), code);
						/* take text portion only */
	if code ^= 0 then do;
	     P_object_error = "1"b;			/* so main routine will know */
	     goto FINISHED;
	     end;
	else P_object_error = "0"b;

	bpi.version = BOOT_PROGRAM_INFO_VERSION_1;
	bpi.boot_program_ptr = oi.textp;
	bpi.boot_program_text_length = oi.tlng;
	bpi.boot_program_name = P_seg_name;

	if P_file then do;
	   control_word.type = BOOTLOAD_PROGRAM;
	   name_len = divide(length(bpi.boot_program_name), CHARS_PER_WORD, 18, 0);
	   seg_len = bpi.boot_program_text_length;
	   control_word.count = name_len + seg_len;
	   call iox_$put_chars (iocbp, addr(control_word),
	      size(control_word) * CHARS_PER_WORD, code);
	   if code ^= 0 then goto FINISHED;
	   call iox_$put_chars (iocbp, addr(bpi.boot_program_name),
	      name_len * CHARS_PER_WORD, code);
	   if code ^= 0 then goto FINISHED;
	   call iox_$put_chars (iocbp, bpi.boot_program_ptr,
	      seg_len * CHARS_PER_WORD, code);
	   if code ^= 0 then goto FINISHED;
	   end;
	else do;
	   call iox_$close (iocbp, code);		/* First, close it, so it can be opened again with the */
	   if code ^= 0 then goto FINISHED;		/* boot_program in the label */

	   call iox_$control (iocbp, "boot_program", addr (bpi), code);
	   if code ^= 0 then goto FINISHED;		/* Put out the boot program */

	   call iox_$open (iocbp, Stream_output, "0"b, code); /* Now, open it again */
	   if code ^= 0 then goto FINISHED;
	   end;

FINISHED: P_code = code;
	return;

%page; %include iox_modes;
%page; %include object_info;
%page; %include system_constants;
%page; %include tape_mult_boot_info;

	end gm_write_boot_program_;




		    gm_write_first_seg_.pl1         06/04/84  1616.5rew 06/04/84  1242.3       32940



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

gm_write_first_seg_: proc (sltep, seg_bitcnt, fseg_ptr, iocb_ptr, object_segment_error, code);


/*

   The first segment is written out as follows:

   1) a header control word

   2) the slte data

   3) padding of minus ones to make up 22 written words

   4) a segment control word.  the right half of this word contains a value of
   32 less than the actual word length of the first segment

   (the 24 words thus written plus the first 8 words of tape record information
   make up the first 32 words on the tape)

   5) the segment itself, beginning at word 33



   */

/* Modified 31 July 1981, W. Olin Sibert, for gm_write_boot_program_ compatibility */

/*  argument declarations  */

dcl  fseg_ptr ptr;					/* pointer to segment */

dcl  seg_bitcnt fixed bin (24);			/* length of segment */
dcl  code fixed bin (35);				/* error code */

/*  program declarations  */


dcl  1 minus_one aligned static options (constant),	/* for writing padding */
       2 part1 bit (6 * 36) init ((216)"1"b),
       2 part2 bit (6 * 36) init ((216)"1"b),
       2 part3 bit (6 * 36) init ((216)"1"b),
       2 part4 bit (4 * 36) init ((144)"1"b);

dcl 1 control_word aligned,				/* control word structure */
       2 ident fixed bin (17) unal,
       2 length fixed bin (17) unal;

dcl  first_ptr ptr,					/* pointer to word 33 of segment */
     first_seg_word_length fixed bin (17);		/* number of words to be written */

dcl  object_segment_error bit (1) aligned;

dcl  iocb_ptr ptr;

dcl size builtin;

% include slte;
% include object_info;

dcl  1 oi aligned like object_info;

dcl  iox_$put_chars entry (ptr, ptr, fixed bin (35), fixed bin(35)),
     object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));

dcl  (addr, addrel, bin, bit, divide) builtin;

/*  */
	object_segment_error = "0"b;

	oi.version_number = object_info_version_2;

	call object_info_$brief (fseg_ptr, seg_bitcnt, addr (oi), code);
						/* take text portion only */
	if code ^= 0 then do;
	     object_segment_error = "1"b;		/* so main routine will know */
	     return;
	end;

	first_seg_word_length = oi.tlng + oi.dlng;
	slte.cur_length = bit (divide (first_seg_word_length+1023, 1024, 9, 0), 9); /* reset current length */
	slte.bit_count = bit (bin(first_seg_word_length * 36, 24), 24);	/* and bitcount */
	first_seg_word_length = first_seg_word_length - 32;
	control_word.ident = 0;			/* create a header control word */
	control_word.length = 10110b;	/* relative offset of end of header */

	call iox_$put_chars (iocb_ptr, addr (control_word), 4, code);
	if code ^= 0 then return;

	call iox_$put_chars (iocb_ptr, sltep, size (slte)*4, code);
	if code ^= 0 then return;

	call iox_$put_chars (iocb_ptr, addr (minus_one), (22-size (slte))*4, code);
	if code ^= 0 then return;

	control_word.ident = 1;	/* set up a segment control word */
	control_word.length = first_seg_word_length; /* subtract header length */

	first_ptr = addrel (oi.textp, 32);		/* prepare for writing from word 33 */

	call iox_$put_chars (iocb_ptr, addr (control_word), 4, code);
	if code ^= 0 then return;

	call iox_$put_chars (iocb_ptr, first_ptr, first_seg_word_length*4, code);

	return;

     end gm_write_first_seg_;




		    mst_tools_.pl1                  07/16/87  1350.3r   07/15/87  1602.4      201717



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

/* format: style2 */

mst_tools_:
     procedure;

/* NOT A RETAINED ENTRYPOINT */

copy_mst:
     entry;
	function = "copy_mst";
	severityp = addr (copy_mst_severity_);
	go to join;
excerpt_mst:
     entry;
	function = "excerpt_mst";
	severityp = addr (excerpt_mst_severity_);
	go to join;
list_mst:
     entry;
	function = "list_mst";
	severityp = addr (list_mst_severity_);

/***** Old style MST utilities, used for BOS tapes (and copying Multics tapes) */
/* from merge_mst. */
/* Bernard Greenberg, 1/12-13/76
   10/20/76 for tapes with defs
   2/80 by Michael R.Jordan to add call to parse_tape_reel_name_ and fix bugs.
  Modified so it would compile again, and maybe still work afterwards,
    10/21/80 W.Olin Sibert 
  Modified by J.A.Bush to copy boot labels from input to output tapes 
  Modified 10/82 BIM remove merge, write.
  Modified 05/85 GW May call tape_mult_ in async mode to avoid sync padding. */


/****^  HISTORY COMMENTS:
  1) change(87-01-12,GDixon), approve(87-04-16,MCR7614),
     audit(87-05-21,Farley), install(87-07-15,MR12.1-1040):
     Support copying from or to disk file images of a Multics System Tape, in
     addition to copying from/to tapes.  Also, add severity variables to report
     success/failure of copy/excerpt/list operations.
                                                   END HISTORY COMMENTS */


	declare check_star_name_$entry entry (character (*), fixed binary (35));
	declare cu_$arg_count	 entry (fixed bin, fixed bin (35));
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare (
	        ioa_,
	        com_err_,
	        com_err_$suppress_name
	        )			 entry options (variable);
	declare date_time_		 entry (fixed bin (71), char (*));
	declare absolute_pathname_	 entry (char (*), char (*), fixed bin (35));
	declare get_shortest_path_	 entry (char (*)) returns (char (168));
	declare get_temp_segments_	 entry (char (*), (*) ptr, fixed bin (35));
	declare get_wdir_		 entry returns (char (168));
	declare initiate_file_$create	 entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24),
				 fixed bin (35));
	declare object_info_$display	 entry (ptr, fixed bin (24), ptr, fixed bin (35));
	declare pathname_		 entry (char (*), char (*)) returns (char (168));
	declare parse_tape_reel_name_	 entry (char (*), char (*));
	declare release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
	declare terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	declare unique_chars_	 entry (bit (*)) returns (char (15));

	declare ap		 pointer;
	declare al		 fixed bin (21);
	declare argx		 fixed bin;
	declare arg_count		 fixed bin;
	declare arg		 character (al) based (ap);
	declare optp		 ptr;
	declare optl		 fixed bin (21);
	declare opt		 char (optl) based (optp);

	declare boot_label		 bit (1) aligned;
	declare code		 fixed bin (35);
	declare date_time_compiled	 char (32);
	declare function		 char (32);

	declare (in, out)		 pointer;
	declare out_seg_ptr		 pointer;
	declare severityp		 pointer;

	declare temp_seg_ptrs	 (3) ptr;
	declare header_ptr		 pointer defined (temp_seg_ptrs (1));
	declare contents_ptr	 pointer defined (temp_seg_ptrs (2));
	declare boot_program_guts_ptr	 pointer defined (temp_seg_ptrs (3));

	declare (name_len, seg_len)	 fixed bin (18) uns unal;
	declare header_wc		 fixed bin (18) uns unal;
	declare copy		 (seg_len) bit (36) aligned based;

	declare 1 select_list	 aligned,
		2 count		 fixed bin,
		2 names		 (get_arg_count ()),
		  3 arg_ptr	 pointer,
		  3 arg_length	 fixed bin (21);

	declare atd		 char (256);
	declare (in_den, out_den)	 fixed bin;
	declare (in_file_name, out_file_name)
				 character (168);
	declare (in_tape_name, out_tape_name)
				 character (32);
	declare inout		 fixed bin,
	        (
	        UNSET		 init (0),
	        IN		 init (1),
	        OUT		 init (2)
	        )			 fixed bin int static options (constant);

	declare (copy_mst_severity_, excerpt_mst_severity_, list_mst_severity_)
				 fixed bin (35) ext static init (0);
	declare error_table_$bad_arg	 fixed bin (35) ext static;
	declare error_table_$badopt	 fixed bin (35) ext static;
	declare error_table_$end_of_info
				 fixed bin (35) ext static;
	declare error_table_$inconsistent
				 fixed bin (35) ext static;
	declare error_table_$noarg	 fixed bin (35) ext static;

	dcl     cleanup		 condition;

	dcl     1 control_word	 aligned,
		2 type		 fixed bin (17) unaligned,
		2 count		 fixed bin (18) uns unal;

	dcl     1 collection_mark	 aligned,
		2 major		 fixed bin (17) unaligned,
		2 minor		 fixed bin (17) unaligned;

	dcl     1 oi		 like object_info aligned;

	dcl     1 header		 aligned based (header_ptr),
		2 slte		 like slte_uns,
		2 segnam		 like segnam;

	dcl     severity		 fixed bin (35) based (severityp);

	declare (expect_seg, expect_link, expect_defs)
				 bit (1) aligned;


	declare COPY		 char (32) init ("copy_mst") int static options (constant);
	declare LIST		 char (32) init ("list_mst") int static options (constant);
	declare EXCERPT		 char (32) init ("excerpt_mst") int static options (constant);
	declare (addr, char, codeptr, convert, divide, index, length, ltrim, null, rtrim, size)
				 builtin;



join:
	severity = 4;				/* assume error  */
	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, function);
		return;
	     end;

	if arg_count = 0
	then
USAGE:
	     do;
		if function = COPY
		then call com_err_$suppress_name (0, function, "Usage: copy_mst INPUT_SPEC OUTPUT_SPEC");
		else if function = LIST
		then call com_err_$suppress_name (0, function, "Usage: list_mst TAPE");
		else if function = EXCERPT
		then call com_err_$suppress_name (0, function, "Usage: excerpt_mst TAPE name1 name2 ... nameN");
		return;
	     end;

	boot_label = "0"b;
	in, out, temp_seg_ptrs = null;		/* init for cleanup */
	on cleanup call clean_up;

/* Parse */

	if function = COPY
	then if arg_count < 2
	     then go to USAGE;

	in_tape_name, in_file_name, out_tape_name, out_file_name = "";
	in_den, out_den = UNSET;
	inout = UNSET;
	select_list.count = 0;

	do argx = 1 to arg_count;
	     call cu_$arg_ptr (argx, ap, al, (0));
	     if index (arg, "-") = 1
	     then do;
		     if arg = "-input_volume" | arg = "-ivol"
		     then do;
			     in_tape_name, in_file_name = "";
			     inout = IN;
			     if argx = arg_count
			     then do;
				     call com_err_ (error_table_$noarg, function,
					"^a must be followed by a tape volume name.", arg);
				     go to RETURN;
				end;
			     else do;
				     argx = argx + 1;
				     call cu_$arg_ptr (argx, optp, optl, (0));
				     in_tape_name = opt;
				end;
			end;
		     else if arg = "-input_file" | arg = "-if"
		     then do;
			     in_tape_name, in_file_name = "";
			     inout = UNSET;
			     if argx = arg_count
			     then do;
				     call com_err_ (error_table_$noarg, function,
					"^a must be followed by a file name.", arg);
				     go to RETURN;
				end;
			     else do;
				     argx = argx + 1;
				     call cu_$arg_ptr (argx, optp, optl, (0));
				     in_file_name = opt;
				end;
			end;
		     else if (arg = "-output_volume" | arg = "-ovol") & function = COPY
		     then do;
			     out_tape_name, out_file_name = "";
			     inout = OUT;
			     if argx = arg_count
			     then do;
				     call com_err_ (error_table_$noarg, function,
					"^a must be followed by a tape volume name.", arg);
				     go to RETURN;
				end;
			     else do;
				     argx = argx + 1;
				     call cu_$arg_ptr (argx, optp, optl, (0));
				     out_tape_name = opt;
				end;
			end;
		     else if (arg = "-output_file" | arg = "-of") & function = COPY
		     then do;
			     out_tape_name, out_file_name = "";
			     inout = UNSET;
			     if argx = arg_count
			     then do;
				     call com_err_ (error_table_$noarg, function,
					"^a must be followed by a file name.", arg);
				     go to RETURN;
				end;
			     else do;
				     argx = argx + 1;
				     call cu_$arg_ptr (argx, optp, optl, (0));
				     out_file_name = opt;
				end;
			end;
		     else if arg = "-density" | arg = "-den"
		     then do;
			     if argx = arg_count
			     then do;
				     call com_err_ (error_table_$noarg, function,
					"^a must be followed by a tape density.", arg);
				     go to RETURN;
				end;
			     else do;
				     argx = argx + 1;
				     call cu_$arg_ptr (argx, optp, optl, (0));
				     if opt = "800" | opt = "1600" | opt = "6250"
				     then do;
					     if inout = IN
					     then in_den = convert (in_den, opt);
					     else if inout = OUT
					     then out_den = convert (in_den, opt);
					     else do;
						     call com_err_ (error_table_$inconsistent, function,
							"^a ^a must follow either -ivol or -ovol.", arg,
							opt);
						     go to RETURN;
						end;
					end;
				     else do;
					     call com_err_ (error_table_$bad_arg, function,
						"^a ^a^/Allowed densities are: 800, 1600, 6250.", arg, opt);
					     go to RETURN;
					end;
				end;
			end;
		     else do;
			     call com_err_ (error_table_$badopt, function, arg);
			     go to RETURN;
			end;
		end;
	     else if in_tape_name = "" & in_file_name = ""
	     then in_tape_name = arg;
	     else if (out_tape_name = "" & out_file_name = "") & function = COPY
	     then out_tape_name = arg;
	     else if function = LIST | function = EXCERPT
	     then do;
		     call check_star_name_$entry (arg, code);
		     if code ^= 0 & code ^= 1 & code ^= 2
		     then do;
			     call com_err_ (code, function, "^a", arg);
			     go to RETURN;
			end;
		     select_list.count = select_list.count + 1;
		     select_list.arg_ptr (select_list.count) = ap;
		     select_list.arg_length (select_list.count) = al;
		end;
	     else do;
		     call com_err_ (error_table_$bad_arg, function, arg);
		     go to RETURN;
		end;
	end;

/* We know what we want */

	call get_temp_segments_ (function, temp_seg_ptrs, (0));

/* There is always an input tape */

	call get_in_medium ();

/* Output if copy */

	if function = COPY
	then do;
		call get_out_medium ();
	     end;


/* YET ANOTHER VERSION OF SEGMENT_LOADER */

	severity = 0;				/* no errors now */
	expect_seg, expect_link, expect_defs = "0"b;

loop:
	call get_data (addr (control_word), size (control_word));
	if control_word.type = 0			/* read the control word */
	then do;					/* header control word */
		header_wc = control_word.count;
		call get_data (header_ptr, header_wc);	/* read in header */
		expect_seg = "1"b;
		if function = COPY
		then do;
			call put_data (addr (control_word), size (control_word));
			call put_data (header_ptr, header_wc);
		     end;

	     end;

	else if control_word.type = 1
	then do;					/*  A segment */
		expect_seg = "0"b;
		seg_len = control_word.count;
		call get_data (contents_ptr, seg_len);	/* get real seg */

		if expect_link
		then do;
			if ^header.slte.link_sect
			then call MST_format_error ("missing linkage segment");

			expect_link = "0"b;
			expect_defs = "1"b;
		     end;

		else if expect_defs
		then do;
			if ^header.slte.defs
			then call MST_format_error ("missing defs segment");

			expect_defs = "0"b;

		     end;

		else do;
			if header.slte.defs | header.slte.link_sect
			then call MST_format_error ("unexpected link or defs segment");
			expect_link = header.slte.link_provided;
		     end;

		if function = COPY
		then do;
			call put_data (addr (control_word), size (control_word));
			call put_data (contents_ptr, control_word.count);
		     end;

		else /* tree */
		     if NAME_MATCHES ()
		then if function = LIST
		     then do;
			     oi.version_number = 2;
			     call object_info_$display (contents_ptr, (header.slte.bit_count), addr (oi), code);
			     if code = 0
			     then do;
				     call date_time_ (oi.compile_time, date_time_compiled);
				     date_time_compiled = rtrim (oi.compiler || " " || date_time_compiled);
				end;
			     else date_time_compiled = "";
			     call ioa_ ("^a^35t^d^-words ^a", NAME (), control_word.count, date_time_compiled);
			end;
		     else if function = EXCERPT
		     then do;
			     call ioa_ ("Excerpting ^a.", pathname_ (get_wdir_ (), NAME ()));
			     call initiate_file_$create (get_wdir_ (), NAME (), RW_ACCESS, out_seg_ptr, ""b, 0,
				code);
			     if out_seg_ptr = null
			     then do;
				     call com_err_ (code, function, "Could not write ^a>^a.", get_wdir_ (),
					NAME ());
				     severity = 4;
				     go to loop;
				end;
			     out_seg_ptr -> copy = contents_ptr -> copy;
			     call terminate_file_ (out_seg_ptr, (header.slte.bit_count), TERM_FILE_TRUNC_BC_TERM,
				(0));
			end;
	     end;
	else if control_word.type = 2
	then do;					/* Collection mark */

		if expect_link | expect_defs
		then call MST_format_error ("missing defs or link segment");
		call get_data (addr (collection_mark), 1);

		call ioa_ ("Processed collection ^d.^d", collection_mark.major, collection_mark.minor);
		if function = COPY
		then do;

			call put_data (addr (control_word), size (control_word));
			call put_data (addr (collection_mark), 1);
		     end;

		expect_seg = "1"b;
	     end;

	else call MST_format_error ("unrecognized control word");
	go to loop;


/* Subroutines that read and write */

get_arg_count:
     proc returns (fixed bin);

	dcl     arg_count		 fixed bin,
	        code		 fixed bin (35);

	call cu_$arg_count (arg_count, code);
	return (arg_count);
     end get_arg_count;


get_in_file:
     proc;

	call absolute_pathname_ (in_file_name, in_file_name, code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "-if ^a", in_file_name);
		go to RETURN;
	     end;

	in_file_name = get_shortest_path_ (in_file_name);

	call iox_$attach_name ("mst_tools_.input." || unique_chars_ (""b), in, "vfile_ " || in_file_name || " -old",
	     codeptr (mst_tools_), code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "Cannot attach input file ^a", in_file_name);
		go to RETURN;
	     end;

	call iox_$open (in, Stream_input, ("0"b), code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "Cannot open input file ^a", in_file_name);
		go to RETURN;
	     end;

	call get_data (addr (control_word), size (control_word));
	if control_word.type = -1
	then do;					/* bootload program control word */
						/* It is written as a name, followed by the pgm.	*/

		boot_program_info.version = BOOT_PROGRAM_INFO_VERSION_1;
						/* set version */
		boot_label = "1"b;			/* set flag to copy onto output tape */
		name_len = divide (length (boot_program_info.boot_program_name), CHARS_PER_WORD, 18, 0);
		seg_len = control_word.count - name_len;/* set copy length */
		call get_data (addr (boot_program_info.boot_program_name), name_len);
		call get_data (boot_program_guts_ptr, seg_len);
						/* copy boot program in to temp seg */
		boot_program_info.boot_program_ptr = boot_program_guts_ptr;
						/* set new boot program ptr */
		boot_program_info.boot_program_text_length = seg_len;
	     end;
	else do;
		boot_label = "0"b;
		call iox_$close (in, (0));
		call iox_$open (in, Stream_input, ""b, (0));
	     end;

     end get_in_file;


get_in_medium:
     proc;

	if in_file_name ^= ""
	then call get_in_file ();
	else if in_tape_name ^= ""
	then call get_in_tape ();
	else do;
		call com_err_ (error_table_$noarg, function,
		     "An input tape or file must be specified via -ivol or -if.");
		go to RETURN;
	     end;
     end get_in_medium;

get_in_tape:
     proc;

	call parse_tape_reel_name_ (in_tape_name, atd);
	if in_den ^= UNSET
	then atd = rtrim (atd) || " -density " || ltrim (char (in_den));

	call iox_$attach_name ("mst_tools_.input." || unique_chars_ (""b), in, "tape_mult_ " || rtrim (atd),
	     codeptr (mst_tools_), code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "Cannot attach input tape ^a", atd);
		go to RETURN;
	     end;

	call iox_$open (in, Stream_input, ("0"b), code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "Cannot open input tape ^a", atd);
		go to RETURN;
	     end;

	boot_program_info.version = BOOT_PROGRAM_INFO_VERSION_1;
						/* set version */
	call iox_$control (in, "get_boot_program", addr (boot_program_info), code);
	if code ^= 0
	then do;					/* can't do it */
		call com_err_ (code, function, "getting the input tape boot label");
		go to RETURN;
	     end;

	if boot_program_info.boot_program_ptr ^= null
	then do;					/* if this tape has a boot label... */
		boot_label = "1"b;			/* set flag to copy onto output tape */
		seg_len = boot_program_info.boot_program_text_length;
						/* set copy length */
		boot_program_guts_ptr -> copy = boot_program_info.boot_program_ptr -> copy;
						/* copy boot program in to temp seg */
		boot_program_info.boot_program_ptr = boot_program_guts_ptr;
						/* set new boot program ptr */
	     end;
     end get_in_tape;


get_out_file:
     proc;

	call absolute_pathname_ (out_file_name, out_file_name, code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "-if ^a", out_file_name);
		go to RETURN;
	     end;

	out_file_name = get_shortest_path_ (out_file_name);

	call iox_$attach_name ("mst_tools_.output." || unique_chars_ (""b), out, "vfile_ " || out_file_name,
	     codeptr (mst_tools_), code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "Cannot attach output file ^a", out_file_name);
		go to RETURN;
	     end;

	call iox_$open (out, Stream_output, ("0"b), code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "Cannot open output file ^a", out_file_name);
		go to RETURN;
	     end;

	if boot_label
	then do;					/* bootload program control word */
						/* It is written as a name, followed by the pgm.	*/

		name_len = divide (length (boot_program_info.boot_program_name), CHARS_PER_WORD, 18, 0);
		seg_len = boot_program_info.boot_program_text_length;

		control_word.type = -1;
		control_word.count = name_len + seg_len;

		call put_data (addr (control_word), size (control_word));
		call put_data (addr (boot_program_info.boot_program_name), name_len);
		call put_data (boot_program_guts_ptr, seg_len);
						/* copy boot program in to temp seg */
	     end;

     end get_out_file;


get_out_medium:
     proc;

	if out_file_name ^= ""
	then call get_out_file ();
	else if out_tape_name ^= ""
	then call get_out_tape ();
	else do;
		call com_err_ (error_table_$noarg, function,
		     "An output tape or file must be specified via -ovol or -of.");
		go to RETURN;
	     end;

     end get_out_medium;

get_out_tape:
     proc;
	call parse_tape_reel_name_ (out_tape_name, atd);
	if out_den ^= UNSET
	then atd = rtrim (atd) || " -density " || ltrim (char (out_den));

	call iox_$attach_name ("mst_tools_.output." || unique_chars_ (""b), out,
	     "tape_mult_ " || rtrim (atd) || " -write", codeptr (mst_tools_), code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "Cannot attach output tape ^a.", out_tape_name);
		go to RETURN;
	     end;

	if boot_label
	then do;					/* if we have to copy input boot label program */
		call iox_$control (out, "boot_program", addr (boot_program_info), code);
		if code ^= 0
		then do;				/* can't do it */
			call com_err_ (code, function, "writing boot label program");
			go to RETURN;
		     end;
	     end;

	call iox_$open (out, Stream_output, ("0"b), code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "Cannot open output tape ^a.", out_tape_name);
		go to RETURN;
	     end;
	call iox_$modes (out, "async", (""), (0));
     end get_out_tape;


put_data:
     proc (data_ptr, data_words);
	declare data_ptr		 pointer;
	declare data_words		 fixed bin (18) uns unal;

	call iox_$put_chars (out, data_ptr, data_words * 4, code);
	if code ^= 0
	then do;
		call com_err_ (code, function, "Fatal error writing output MST^[ ^a^;^s^]^[ ^a^;^s^].",
		     (out_tape_name ^= ""), out_tape_name, (out_file_name ^= ""), out_file_name);
		severity = 4;
		go to RETURN;
	     end;
	return;

get_data:
     entry (data_ptr, data_words);

	call iox_$get_chars (in, data_ptr, data_words * 4, (0), code);
	if code = error_table_$end_of_info
	then go to DONE;
	else if code ^= 0
	then do;
		call com_err_ (code, function, "Fatal error reading input MST^[ ^a^;^s^]^[ ^a^;^s^].",
		     (in_tape_name ^= ""), in_tape_name, (in_file_name ^= ""), in_file_name);
		severity = 4;
		go to RETURN;
	     end;
	else return;

     end put_data;

NAME:
     procedure returns (character (32));


	return (header.segnam.names (1).name);
     end NAME;

NAME_MATCHES:
     procedure returns (bit (1) aligned);
	declare starx		 fixed bin;
	declare match_star_name_	 entry (character (*), character (*), fixed binary (35));

	if select_list.count = 0
	then return ("1"b);

	do starx = 1 to select_list.count;
	     begin;
		declare starname		 char (select_list.names (starx).arg_length)
					 based (select_list.names (starx).arg_ptr);

		call match_star_name_ (NAME (), starname, code);

		if code = 0
		then return ("1"b);
	     end;
	end;
	return ("0"b);

     end NAME_MATCHES;

MST_format_error:
     procedure (what);
	declare what		 char (*);

	call com_err_ (0, function, "MST format error, ^a. Use check_mst to diagnose it.", what);
	severity = 4;
	go to RETURN;
     end;

RETURN:
DONE:
	call clean_up;
	return;

clean_up:
     procedure;
	if in ^= null
	then call clean_up_switch (in);
	if out ^= null
	then call clean_up_switch (out);

	if temp_seg_ptrs (1) ^= null
	then call release_temp_segments_ (function, temp_seg_ptrs, (0));

	in, out, temp_seg_ptrs = null;
     end clean_up;

clean_up_switch:
     procedure (switch);

	declare switch		 pointer;

	call iox_$close (switch, (0));
	call iox_$detach_iocb (switch, (0));

     end clean_up_switch;







/* format: off */
%page; %include access_mode_values;
%page; %include iox_entries;
%page; %include iox_modes;
%page; %include object_info;
%page; %include slt;
%page; %include slte;
%page; %include system_constants;
%page; %include tape_mult_boot_info;
%page; %include terminate_file;
     end;




		    print_gen_info_.pl1             08/26/75  1438.2rew 08/26/75  1335.5       39348



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

print_gen_info_: proc (p, bc, stream, code);

dcl  p ptr,
     bc fixed bin,
     stream char (*),
     code fixed bin;

dcl 1 oi like object_info aligned;

dcl 1 info aligned,
    2 pad bit (36),
    2 dtm bit (36);

dcl (len, i) fixed bin,
     dirname char (168) aligned,
     ename char (32) aligned,
     time char (16),
     component_only bit (1) aligned init ("0"b),
     tran_id char (12) aligned,
     author char (24) aligned,
     based_name char (len) based (sp),
    (symb_ptr, sp, sblkp, bmp) ptr,
    (error_table_$oldobj, error_table_$not_bound, error_table_$bad_segment) fixed bin ext,
    (addrel, fixed, null) builtin;

dcl 1 spec based aligned,				/* special structure for looking at old symbol sections */
    2 pad bit (36) aligned,
    2 pad_again bit (9) unal,
    2 zeros bit (9) unal;


dcl (ioa_$ioa_stream, get_bound_seg_info_, hcs_$fs_get_path_name, hcs_$get_bc_author, hcs_$status_) entry options (variable),
     date_time_$fstime entry (bit (36) aligned, char (*)),
     date_time_ entry (fixed bin (71), char (*));

join:	
	code = 0;

	call hcs_$fs_get_path_name (p, dirname, i, ename, code); /* get name of segment */
	if code ^= 0 then return;

	oi.version_number = object_info_version_2;
	call get_bound_seg_info_ (p, bc, addr (oi), bmp, symb_ptr, code);
	if code ^= 0 then if (code = error_table_$not_bound) | (code = error_table_$oldobj) then code = 0;
	else if code = error_table_$bad_segment then do;	/* non-standard object segment */
	     call hcs_$get_bc_author (dirname, ename, author, code); /* get author of seg */
	     if code ^= 0 then return;
	     call hcs_$status_ (dirname, ename, 1, addr (info), null, code); /* get DTM */
	     if code ^= 0 then return;
	     call date_time_$fstime (info.dtm, time);			/* convert */
	     call ioa_$ioa_stream (stream, "^32a  ^16a  ^24aNON-OBJECT ^44a^/", ename, time, author, dirname);
	     return;
	end;
	else return;

	call date_time_ (oi.compile_time, time);	/* get time of creation */
	if oi.userid = "" then call hcs_$get_bc_author (dirname, ename, oi.userid, code);

	if ^component_only then			/* If we want the entire segment ... */
	call ioa_$ioa_stream (stream, "^32a  ^16a  ^24a^12a^44a", ename, time, oi.userid, oi.compiler, dirname);

/* Now check to aee if the segment is a bound segment */

	if bmp ^= null then do;			/* if this is a bound seg with a bindmap ... */
	     do i = 1 to bmp -> bindmap.n_components;	/* loop through all of them */
		sblkp = addrel (oi.symbp, bmp -> bindmap.component (i).symb_start); /* get pointer to symbol section */
		len = fixed (bmp -> bindmap.component (i).name.name_lng, 18);
		ename = addrel (symb_ptr, bmp -> bindmap.component (i).name.name_ptr) -> based_name;
		if component_only then if ename ^= comp_name then goto next_component;
		if sblkp -> spec.zeros then do;	/* new format symbol section */
		     call date_time_ (sblkp -> sb.obj_creation_time, time); /* get time of compilation/assembly */
		     len = fixed (sblkp -> sb.uid_length, 18);
		     author = addrel (sblkp, sblkp -> sb.uid_offset) -> based_name;
		     tran_id = sblkp -> sb.generator;	/* get name of compiler */
		end;
		else do;				/* old style symbol section for this component */
		     call date_time_ (sblkp -> symbol_header.times.translation, time);
		     author = "";
		     tran_id = bmp -> bindmap.component (i).comp_name;
		end;
		call ioa_$ioa_stream (stream, "  ^32a^16a  ^24a^12a", ename, time, author, tran_id);
		if component_only then return;
next_component:	
	     end;
	end;
	if component_only then do;
	     code = error_table_$not_bound;
	     return;
	end;

	if ^component_only then
	call ioa_$ioa_stream (stream, " ");
	return;

component: entry (p, bc, stream, code, comp_name);

dcl  comp_name char (*);

	component_only = "1"b;
	goto join;
						/*  */
% include symbol_block;
% include symbol_header;
% include bind_map;
% include object_info;

     end;



		    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
