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