1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1992   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Bull Inc., 1987                *
   6         *                                                         *
   7         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   8         *                                                         *
   9         * Copyright (c) 1972 by Massachusetts Institute of        *
  10         * Technology and Honeywell Information Systems, Inc.      *
  11         *                                                         *
  12         *********************************************************** */
  13 
  14 
  15 
  16 
  17 
  18 
  19 
  20 /****^  HISTORY COMMENTS:
  21   1) change(1987-01-19,GDixon), approve(1987-04-16,MCR7614),
  22      audit(1987-05-21,Farley), install(1987-07-15,MR12.1-1040):
  23      Add support for storing boot program as first segment of MST image stored
  24      in a file.
  25   2) change(1987-10-19,Farley), approve(1988-02-26,MCR7795),
  26      audit(1988-03-03,Fawcett), install(1988-03-15,MR12.2-1035):
  27      Added default_time_zone statement.
  28   3) change(1987-10-19,Farley), approve(1988-02-26,MCR7796),
  29      audit(1988-03-03,Fawcett), install(1988-03-15,MR12.2-1035):
  30      Added default_rpv_data statement.
  31   4) change(1987-11-05,Farley), approve(1988-05-13,PBF7795),
  32      audit(1988-05-31,Fawcett), install(1988-07-05,MR12.2-1053):
  33      Corrected default_time_zone code to not require a symbol name
  34      as part of the statement, as the documentation states.
  35   5) change(1987-11-05,Farley), approve(1988-05-13,PBF7796),
  36      audit(1988-05-31,Fawcett), install(1988-07-05,MR12.2-1053):
  37      Corrected default_rpv_data code to not require a symbol name
  38      as part of the statement, as the documentation states.
  39   6) change(1992-09-21,Schroth), approve(1992-10-15,MCR8275),
  40      audit(1992-10-15,WAAnderson), install(1992-10-21,MR12.5-1033):
  41      Corrected uninitialized variable error that was causing tapes to be left
  42      mounted.  phx21281.
  43   7) change(2021-12-21,Swenson), approve(2021-12-21,MCR10106),
  44      audit(2021-12-22,GDixon), install(2022-01-04,MR12.8-1017):
  45      Fix errors in generate_mst that result in garbage error messages emitted
  46      to output listing segment.
  47                                                    END HISTORY COMMENTS */
  48 
  49 
  50 
  51 
  52 
  53 generate_mst: gm: proc;
  54 
  55 /* format: off */
  56 
  57 /* *      GENERATE_MST
  58    *
  59    *      The Multics System Tape generator. This program parses header files and
  60    *      generates system tapes, performing a lot less error-checking than it should.
  61    *      Really, this and check_mst ought to be combined, and made reliable, but that
  62    *      is a project for another day.
  63    *
  64    *      Inherited from the dim and distant past; written time and time again by persons
  65    *      now unknown to us.
  66    *
  67    *      Modified 18 February 1981, W. Olin Sibert, to add add_segnames, delete_name,
  68    *         and rationalize error message reporting mechanism.
  69    *      Modified 31 July, 1981, WOS, to add boot_program and data keywords.
  70    *      Modified: 11 January 1982 by G. Palter to fix add_segnames to not add names
  71    *         of components which have no retained entrypoints
  72           Modified 6/6/82 BIM for boot_program AND first_name.
  73    *      Modified 8/23/84 JAF to increase name table from 100 to 150 entries
  74    *      Modified 3/14/85 by Keith Loepere to fix delete_name statement.
  75    */
  76 
  77 /* declarations */
  78 
  79 /* argument declarations */
  80 
  81 dcl  a_header_path char (argl (1)) unaligned based (argp (1)), /* relative path name of driving header */
  82      tape_no char (argl (2)) unaligned based (argp (2));    /* numerical designation of output tape */
  83 
  84 /* for fetching and aligning arguments */
  85 
  86 dcl  argp (10) ptr,                                         /* array of pointers to unaligned arguments */
  87      argl (10) fixed bin (17),                              /* array of argument lengths */
  88      code fixed bin (35),                                   /* error code */
  89      acount fixed bin (17),                                 /* ccmmand argument count */
  90      barg char (argl (i)) unaligned based (argp (i)),
  91 
  92      header_path char (168) aligned,                        /* aligned version of argument */
  93 
  94      sysid char (8),                                        /* system id */
  95      versid char (8);
  96 
  97 dcl  generated_time fixed bin (71);
  98 dcl  generated_time_string char (32);
  99 
 100 dcl     i fixed bin (17);                                   /* do loop index */
 101 dcl  open_message char (100);                               /* message from gm_util1_$open */
 102 
 103 
 104 /* for attaching */
 105 
 106 dcl  path_list_name char (168) aligned,                     /* full path name of list of search paths */
 107      hdrp ptr;                                              /* pointer to header */
 108 
 109 dcl  path_array (10) char (168) aligned;                    /* array of path names to be searched */
 110 
 111 dcl  sys_desig char (24) aligned var;                       /* system designation */
 112 dcl  ion2 char (32) aligned;                                /* ioname2 for attaching and detaching tape */
 113 
 114 /* for reading */
 115 
 116 dcl  numc fixed bin (17),                                   /* number of characters read */
 117      ndir fixed bin (17);                                   /* number of directories to be searched */
 118 
 119 dcl  error_label label;                                     /* for error recovery */
 120 
 121 dcl  out_sgna char (32) aligned;
 122 
 123 /* for parsing header */
 124 
 125 dcl  symp ptr init (null),                                  /* pointer to current symbol */
 126      arg char (numc) unaligned based (symp);                /* mask for looking at symbol */
 127 
 128 dcl  seg_name char (32)aligned init (""),                   /* reference name of segment */
 129      nnam fixed bin (17);                                   /* number of names found in header entry */
 130 
 131 /* for processing keyword arguments */
 132 
 133 
 134 /* for creating segment blocks */
 135 
 136 dcl  in_p ptr,                                              /* pointer to segment in searched directory */
 137      segp ptr,                                              /* pointer to segment to be written on tape */
 138 
 139      bitcnt fixed bin (24),                                 /* bit count of segment as found */
 140      sg_b fixed bin (24),                                   /* bit count of block to be written */
 141 
 142      tx_l fixed bin (17),                                   /* length of text section */
 143      sg_l fixed bin (17);                                   /* length of block to be written */
 144 
 145 dcl  cur_len_for_bitcnt fixed bin (18);                     /* current length in words */
 146 
 147 
 148 dcl  path_ptr ptr,
 149 
 150      1 path aligned based (path_ptr),                       /* path name structure */
 151      2 size fixed bin (17),
 152      2 name char (168);
 153 
 154 dcl  names_ptr ptr,
 155 
 156      1 seg_name_array aligned based (names_ptr),            /* name structure */
 157      2 count fixed bin (17),
 158      2 names (max_count),
 159      3 size fixed bin (17),
 160      3 name char (32);
 161 
 162 dcl  acl_count_ptr ptr,
 163      acl_block_ptr ptr,
 164      acl_count fixed bin (17) based (acl_count_ptr);
 165 
 166 
 167 dcl 1 acla based (acl_block_ptr) aligned,
 168     2 userid char (32),
 169     2 mode bit (36),
 170     2 pad bit (36),
 171     2 code fixed bin;
 172 
 173 
 174 dcl  max_count fixed bin (17) static init (150),
 175      seg_name_l fixed bin (17);                             /* to remember length of seg name */
 176 
 177 
 178 dcl  seg_header_length fixed bin,                           /* length of header data in words */
 179      header_words fixed bin (35),                           /* number of words to be written in header write */
 180      wr_w fixed bin (17),                                   /* number of wds written in seg write */
 181      seg_hdrp ptr;                                          /* pointer to header info */
 182 
 183 dcl 1 control_word based aligned,
 184     2 ident fixed bin (17) unal,                            /* identifier portion of control word */
 185     2 length fixed bin (17) unal,                           /* 2 length portion */
 186     2 col_no fixed bin (17) unal,                           /* for 2 collection mark unal,number */
 187     2 col_sub_no fixed bin (17) unal;                       /* for collection mark; */
 188 
 189 dcl  cw_ptr ptr,                                            /* pointer to segment control word */
 190 
 191      header_max_size fixed bin static init (1500),          /* size of header data array */
 192      header_data (1500) fixed bin (35);                     /* actual header data */
 193 
 194 dcl (addr, addrel, after, before, bin, bit, clock, divide, fixed, index, length,
 195      maxlength, null, reverse, rtrim, substr, translate, unspec) builtin;
 196 
 197 dcl  last_path char (32) aligned;                           /* for setting path_found */
 198 
 199 dcl  oa_ptr ptr;                                            /* dcls for setting access in output line */
 200 
 201 dcl  error_in_object_segment bit (1) aligned;
 202 
 203 dcl  mst_tape_iocbp ptr init (null);
 204 dcl  gm_output_iocbp ptr init (null);
 205 
 206 dcl 1 output_access unaligned based (oa_ptr),
 207     2 (read, execute, write, privileged) bit (1);
 208 
 209 dcl  output_access_word char (8) aligned;
 210 
 211 dcl  tape_er_count fixed bin (17);                          /* for keeping track of tape errors */
 212 
 213 /* for system_id feature */
 214 
 215 dcl  movewds bit (bitcnt) aligned based,                    /* array to move seg into temp */
 216      real_in_p ptr,                                         /* save for original seg ptr */
 217      symbol_name char (32),                                 /* name of symbol to be overlaid with sysid */
 218      based_char_32 char (32) based,                         /* for moving name  */
 219      based_bit_72 bit (72) based,
 220      time_as_bit bit (72),
 221      id_ptr pointer,
 222      default_rpv_data char (24) var,
 223      default_time_zone char (4),
 224     (lang_index, zone_index) fixed bin,
 225      unique_name char (15);                                 /* name of copied segment */
 226 
 227 dcl 1 oi aligned like object_info;
 228 
 229 dcl  object_segment bit (1) aligned;                        /* flag to indicate whether oi is valid for current segment */
 230 
 231 
 232 /* flag declarations */
 233 
 234 dcl (sysid_hit,
 235      versid_hit,
 236      db_hit,
 237      hd_hit,
 238      do_hit,
 239      dr_hit,
 240      path_name_found,
 241      no_error_was_found,
 242      cur_length_found,
 243      bit_count_found,
 244      cache_found,
 245      acl_found,
 246      linkage_found,
 247      end_found,
 248      boot_program_has_been_processed,
 249      segments_have_been_processed
 250      ) bit (1) aligned;
 251 
 252 dcl  sym_is_a_break fixed bin (1),
 253      eof_was_found fixed bin (1);
 254 
 255 /* external declarations */
 256 
 257 dcl  cu_$arg_count entry (fixed bin);
 258 dcl  cu_$arg_ptr entry (fixed bin, pointer, fixed bin, fixed bin (35));
 259 dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
 260 dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
 261 dcl  decode_definition_$full entry (pointer, pointer, pointer) returns (bit (1) aligned);
 262 dcl  delete_$ptr entry (pointer, bit (6), char (*), fixed bin (35));
 263 dcl  gm_error_ entry (fixed bin (35), char (32) aligned, pointer, pointer, char (*),
 264      bit (1) aligned, bit (1) aligned, bit (1) aligned, pointer, pointer);
 265 dcl  gm_util_ entry (char (32) aligned, fixed bin (17), pointer, pointer, bit (1) aligned, bit (1) aligned);
 266 dcl  gm_util1_$close entry (pointer, pointer, bit (1) aligned);
 267 dcl  gm_util1_$open entry (pointer, char (168) aligned, fixed bin, char (168) aligned, pointer, char (32) aligned,
 268      pointer, pointer, char (32) aligned, fixed bin (35), char (*), bit (1) aligned, bit (1) aligned, char (8));
 269 dcl  gm_write_first_seg_ entry (pointer, fixed bin (24), pointer, pointer, bit (1) aligned, fixed bin (35));
 270 dcl  gm_write_boot_program_ entry (ptr, fixed bin(24), char(*), ptr, bit(1) aligned,
 271                                              bit(1) aligned, fixed bin(35));
 272 dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*),
 273      fixed bin (24), fixed bin, pointer, fixed bin (35));
 274 dcl  hcs_$make_ptr entry (pointer, char (*), char (*), pointer, fixed bin (35));
 275 dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), pointer, fixed bin (35));
 276 dcl  hcs_$set_bc_seg entry (pointer, fixed bin (24), fixed bin (35));
 277 dcl  hcs_$terminate_noname entry (pointer, fixed bin (35));
 278 dcl  ioa_ entry options (variable);
 279 dcl  iox_$control entry (pointer, char (*), pointer, fixed bin (35));
 280 dcl  iox_$put_chars entry (pointer, pointer, fixed bin (21), fixed bin (35));
 281 dcl  object_info_$brief entry (pointer, fixed bin (24), pointer, fixed bin (35));
 282 dcl  parse_file_$parse_file_ptr entry (pointer, fixed bin (17), fixed bin (1), fixed bin (1));
 283 dcl  parse_file_$parse_file_unset_break entry (char (*));
 284 dcl  print_gen_info_ entry (pointer, fixed bin (24), char (*), fixed bin (35));
 285 dcl  unique_chars_ entry (bit (*) aligned) returns (char (15));
 286 
 287 dcl  gm_data_$default_path_list_name char (168) varying external static;
 288 
 289 dcl  date_time_ entry (fixed bin(71), char(*));
 290 
 291 
 292 dcl (error_table_$noarg,
 293      error_table_$noentry,
 294      error_table_$badopt) fixed bin (35) external static;
 295 
 296 dcl  cleanup condition;
 297 
 298 /* ^L */
 299 
 300 /* initializations */
 301 
 302           generated_time = clock ();
 303           segments_have_been_processed = "0"b;
 304           boot_program_has_been_processed = "0"b;
 305 
 306           ndir,
 307           code = 0;
 308 
 309           real_in_p,
 310           in_p = null;
 311 
 312           seg_hdrp = addr (header_data);
 313 
 314           sltep = addrel (seg_hdrp, 1);
 315 
 316           names_ptr = addrel (seg_hdrp, 5);
 317 
 318           seg_hdrp -> control_word.ident = 0;
 319 
 320           oa_ptr = addr (sltep -> slte.access);
 321 
 322           last_path = " ";
 323 
 324           oi.version_number = object_info_version_2;
 325 
 326           on cleanup call CLEANUP_CONDITION_HANDLER;
 327 
 328 /* ^L */
 329 
 330 /* preliminary work */
 331 
 332           sysid_hit, versid_hit, db_hit, dr_hit, do_hit, hd_hit = "0"b;
 333           call cu_$arg_count (acount);
 334           do i = 1 to acount;                               /* fetch arguments */
 335                call cu_$arg_ptr (i, argp (i), argl (i), code);
 336           end;
 337 
 338           if acount < 2 then do;
 339 noarg:         code = error_table_$noarg;
 340                call ERROR ("Argument missing.", "1"b);
 341           end;
 342 
 343           do i = 3 to acount while (i <= acount);           /* process optional args */
 344                if barg = "-dr" | barg = "-directory" then dr_hit = "1"b;
 345                else if barg = "-file" | barg = "-f" then db_hit = "1"b;
 346                else if barg = "-notape" | barg = "notape" then do_hit = "1"b;
 347                else if barg = "-hold" | barg = "-hd" then hd_hit = "1"b;
 348                else if barg = "-sysid" | barg = "-sys_id" then do;
 349                     if i = acount then go to noarg;
 350                     i = i + 1;
 351                     sysid_hit = "1"b;
 352                     sysid = barg;
 353                end;
 354                else if barg = "-versid" | barg = "-vers_id" then do;
 355                     if i = acount then go to noarg;
 356                     i = i + 1;
 357                     versid_hit = "1"b;
 358                     versid = barg;
 359                end;
 360                else do;
 361                     code = error_table_$badopt;
 362                     call ERROR ("Invalid option specified.", "1"b);
 363                end;
 364           end;
 365 
 366           header_path = a_header_path || ".header";         /* make the header name */
 367           i = index (reverse (a_header_path), ">") - 1;     /* locate last ">" */
 368           if i = -1 then sys_desig = a_header_path;
 369           else sys_desig = substr (a_header_path, argl (1) - i + 1, i); /* use it as the system designation */
 370           if ^sysid_hit then sysid = sys_desig;
 371           if ^versid_hit then versid = sysid;
 372           ion2 = tape_no;                                   /* create ioname 2 */
 373           out_sgna = sys_desig || ".list";                  /* create the output listing file name */
 374 
 375           if dr_hit then path_list_name = sys_desig || ".search"; /* create special path list name if used */
 376           else path_list_name = gm_data_$default_path_list_name;
 377 
 378           call gm_util1_$open (addr (path_array), path_list_name, ndir, header_path, hdrp, ion2,
 379                mst_tape_iocbp, gm_output_iocbp, out_sgna, code, open_message, db_hit, do_hit, sysid);
 380           if open_message ^= "" then
 381                call ERROR (open_message, "1"b);
 382 
 383           call parse_file_$parse_file_unset_break (">_!*""."); /* ">","_","!","*",""","." should not be breaks */
 384 
 385 /* ^L */
 386 
 387 next_segment:
 388           path_name_found,
 389           acl_found,
 390           cur_length_found,
 391           bit_count_found,
 392           cache_found,
 393           linkage_found,
 394           end_found = "0"b;
 395           no_error_was_found = "1"b;
 396 
 397           error_label = skip_to_next_seg;
 398 
 399           call GET_NEXT_ARG;                                /* Look at next keyword. */
 400 
 401           if arg = "fini" then do;                          /* If end of tape ... */
 402 close_out:     call gm_util1_$close (gm_output_iocbp, mst_tape_iocbp, hd_hit);
 403                return;                                      /* This is the end. */
 404           end;
 405 
 406           else if arg = "collection" then do;               /* If end of collection ... */
 407                call TEST_BREAK (":");
 408 
 409                sltep -> control_word.length = 1;            /* set length */
 410                sltep -> control_word.ident = 2;             /* set identifying portion */
 411                call GET_NEXT_ARG;
 412 
 413                if index (arg, ".") = 0
 414                then do;
 415                     sltep -> control_word.col_no = cv_dec_check_ (arg, code);
 416                     if code ^= 0 then
 417 C_ERROR:            do;
 418                          call ERROR ("Malformed collection number " || arg, "1"b);
 419                     end;
 420                     sltep -> control_word.col_sub_no = 0;
 421                end;
 422                else do;
 423                     sltep -> control_word.col_no = cv_dec_check_ (before (arg, "."), code);
 424                     if code ^= 0 then go to C_ERROR;
 425                     sltep -> control_word.col_sub_no = cv_dec_check_ (after (arg, "."), code);
 426                     if code ^= 0 then go to C_ERROR;
 427                end;
 428 
 429                call TEST_BREAK (";");
 430                call ioa_ ("Writing collection ^d.^d mark.", sltep -> control_word.col_no, sltep -> control_word.col_sub_no);
 431                call WRITE_COLLECTION;
 432           end;
 433 
 434           else if arg = "name" then                         /* If beginning of segment. */
 435                call PROCESS_SEGMENT (NORMAL_SEG);
 436 
 437           else if arg = "object" then
 438                call PROCESS_SEGMENT (WHOLE_OBJECT_SEG);
 439 
 440           else if arg = "text" then
 441                call PROCESS_SEGMENT (TEXT_ONLY_SEG);
 442 
 443           else if arg = "data" then
 444                call PROCESS_SEGMENT (DATA_SEG);
 445 
 446           else if arg = "first_name" then do;
 447                if segments_have_been_processed then         /* Should be first thing in header. */
 448                     call ERROR ("first_name statement encountered after other segment definitions.", "0"b);
 449                call PROCESS_SEGMENT (FIRST_SEG);
 450           end;
 451 
 452           else if (arg = "boot_program") then do;           /* Must come first */
 453                if segments_have_been_processed | boot_program_has_been_processed then
 454                     call ERROR ("boot_program statement encountered after other segment definitions.", "0"b);
 455                call PROCESS_SEGMENT (BOOT_PROGRAM_SEG);
 456           end;
 457 
 458           else if arg = "fabricate" then
 459                call PROCESS_SEGMENT (FABRICATED_SEG);
 460 
 461           else                                              /* Error. */
 462                call ERROR ("Unrecognized primary keyword.", "0"b);
 463 
 464 
 465           go to next_segment;
 466 
 467 /* ^L */
 468 
 469 PROCESS_SEGMENT: proc (seg_type);
 470 
 471 dcl  seg_type fixed bin;                                    /* segment type */
 472 
 473 
 474 /* This next allows first_name to follow boot_program */
 475 
 476           if seg_type = BOOT_PROGRAM_SEG
 477           then boot_program_has_been_processed = "1"b;
 478           else segments_have_been_processed = "1"b;
 479 
 480           call TEST_BREAK (":");
 481 
 482           call GATHER_NAMES;                                /* Gather up the names. */
 483 
 484           call INIT_SEGMENT;                                /* Initiate segment and get lengths. */
 485 
 486           error_label = skip_to_next_statement;
 487 
 488 seg_loop:
 489           call GET_NEXT_ARG;                                /* Get next keyword. */
 490 
 491 /* add_segnames statement */
 492 
 493           if (arg = "add_segnames") | (arg = "include_segnames") then /* Add all segnames to the list of names */
 494                call GATHER_SEGNAMES ();
 495 
 496 /* delete_name statement */
 497 
 498           else if (arg = "delete_name") | (arg = "delete_names") then
 499                call DELETE_NAMES ();
 500 
 501 /* pathname statement */
 502 
 503           else if (arg = "path_name") | (arg = "pathname") then do;
 504                if acl_found then
 505                     call ERROR ("""path_name"" keyword found after ""acl"" keyword.", "0"b);
 506                path_name_found = "1"b;
 507                call TEST_BREAK (":");
 508 
 509                call GET_NEXT_ARG;
 510                path.size = numc;
 511                path.name = arg;                             /* take path name from arg because it may be > 32 chars */
 512                slte.branch_required = "1"b;
 513 
 514                seg_header_length = seg_header_length + 1 + divide (numc + 3, 4, 17, 0); /* add it to header length */
 515                if seg_header_length > header_max_size then
 516                     call ERROR ("Header buffer area overflow.", "0"b);
 517                cw_ptr = addrel (sltep, seg_header_length); /* set control word mask */
 518                call TEST_BREAK (";");
 519           end;
 520 
 521 /* access statement */
 522 
 523           else if arg = "access" then do;
 524                call TEST_BREAK (":");
 525                slte.access = "0000"b;
 526                do while (arg ^= ";");
 527                     call GET_NEXT_ARG;
 528                     if arg = "read" then substr (slte.access, 1, 1) = "1"b;
 529                     else if arg = "write" then substr (slte.access, 3, 1) = "1"b;
 530                     else if arg = "execute" then substr (slte.access, 2, 1) = "1"b;
 531                     else if arg = "privileged" then substr (slte.access, 4, 1) = "1"b;
 532                     else call ERROR ("Invalid argument.", "0"b);
 533 
 534                     call GET_NEXT_BREAK;
 535                     if (arg ^= ",") & (arg ^= ";") then
 536                          call ERROR ("Invalid break.", "0"b);
 537                end;
 538           end;
 539 
 540 /* per_process statement */
 541 
 542           else if arg = "per_process" then
 543                slte.per_process = YES_NO ();
 544 
 545 /* wired statement */
 546 
 547           else if arg = "wired" then do;
 548                slte.wired = YES_NO ();
 549                if slte.wired then slte.link_sect_wired = "1"b;
 550                if ^path_name_found then slte.paged = ^slte.wired;
 551           end;
 552 
 553 /* init_seg statement */
 554 
 555           else if arg = "init_seg" then do;
 556                slte.init_seg = YES_NO ();
 557                if slte.init_seg then slte.paged = "1"b;
 558           end;
 559 
 560 /* temp_seg statement */
 561 
 562           else if arg = "temp_seg" then do;
 563                slte.temp_seg = YES_NO ();
 564                if slte.temp_seg then slte.paged = "1"b;
 565                slte.init_seg = slte.temp_seg;
 566           end;
 567 
 568 /* firmware */
 569 
 570           else if arg = "firmware" then do;
 571                slte.firmware_seg = YES_NO ();
 572                if slte.firmware_seg
 573                then slte.wired = "1"b;
 574           end;
 575 
 576 /* paged statement */
 577 
 578           else if arg = "paged" then
 579                slte.paged = YES_NO ();
 580 
 581 /* cur_length statement */
 582 
 583           else if arg = "cur_length" then do;
 584                call TEST_BREAK (":");
 585                cur_len_for_bitcnt = GET_NUM ();
 586                call TEST_BREAK (";");
 587                slte.cur_length = bit (divide (cur_len_for_bitcnt + 1023, 1024, 9, 0), 9);
 588                if ^bit_count_found then
 589                     slte.bit_count = bit (bin (cur_len_for_bitcnt * 36, 24));
 590                cur_length_found = "1"b;
 591           end;
 592 
 593 /* ringbrack statement */
 594 
 595           else if arg = "ringbrack" then do;
 596                call TEST_BREAK (":");
 597                slte.ringbrack (1) = bit (bin (GET_NUM (), 3));
 598                call GET_NEXT_BREAK;
 599                if arg = "," then do;
 600                     slte.ringbrack (2) = bit (bin (GET_NUM (), 3));
 601                     call GET_NEXT_BREAK;
 602                     if arg = "," then do;
 603                          slte.ringbrack (3) = bit (bin (GET_NUM (), 3));
 604                          call TEST_BREAK (";");
 605                     end;
 606                     else if arg = ";" then
 607                          slte.ringbrack (3) = slte.ringbrack (2);
 608                     else
 609                          call ERROR ("Invalid break.", "0"b);
 610                end;
 611                else if arg = ";" then
 612                     slte.ringbrack (3), slte.ringbrack (2) = slte.ringbrack (1);
 613                else
 614                     call ERROR ("Invalid break.", "0"b);
 615           end;
 616 
 617 /* wired_link statement */
 618 
 619           else if arg = "wired_link" then
 620                slte.link_sect_wired = YES_NO ();
 621 
 622 /* combine_link statement */
 623 
 624           else if arg = "combine_link" then
 625                slte.combine_link = YES_NO ();
 626 
 627 /* acl statement */
 628 
 629           else if arg = "acl" then do;
 630                call TEST_BREAK (":");
 631 
 632                if ^acl_found then do;
 633                     acl_count_ptr = cw_ptr;                 /* set pointer to ACL entry count */
 634                     acl_count = 0;
 635                     cw_ptr = addrel (cw_ptr, 1);            /* set pointer to scw */
 636                     seg_header_length = seg_header_length + 1;
 637                     if seg_header_length > header_max_size then
 638                          call ERROR ("Header buffer area overflow.", "0"b);
 639                     acl_found = "1"b;
 640                     slte.acl_provided = "1"b;
 641                end;
 642 
 643                acl_count = acl_count + 1;
 644                acl_block_ptr = cw_ptr;                      /* set pointer for ACL fill-in */
 645                seg_header_length = seg_header_length + 11;
 646                if seg_header_length > header_max_size then
 647                     call ERROR ("Header buffer area overflow.", "0"b);
 648                cw_ptr = addrel (cw_ptr, 11);
 649 
 650                call GET_NEXT_ARG;
 651                acl_block_ptr -> acla.mode = "0"b;
 652                if arg ^= "null" then do i = 1 to numc;
 653                     if substr (arg, i, 1) = "r" then
 654                          substr (acl_block_ptr -> acla.mode, 1, 1) = "1"b;
 655                     else if substr (arg, i, 1) = "e" then
 656                          substr (acl_block_ptr -> acla.mode, 2, 1) = "1"b;
 657                     else if substr (arg, i, 1) = "w" then
 658                          substr (acl_block_ptr -> acla.mode, 3, 1) = "1"b;
 659                     else
 660                          call ERROR ("Invalid argument.", "0"b);
 661                end;
 662 
 663                acl_block_ptr -> acla.pad = "0"b;
 664                acl_block_ptr -> acla.code = 0;
 665 
 666                call TEST_BREAK (",");
 667 
 668                call GET_NEXT_ARG;
 669                acl_block_ptr -> acla.userid = arg;
 670 
 671                call TEST_BREAK (";");
 672           end;
 673 
 674 /* bit_count statement */
 675 
 676           else if arg = "bit_count" then do;
 677                call TEST_BREAK (":");
 678                slte.bit_count = bit (bin (GET_NUM (), 24));
 679                call TEST_BREAK (";");
 680                if ^cur_length_found then
 681                     slte.cur_length = bit (divide (divide (bin (slte.bit_count, 24) + 35, 36, 18, 0) + 1023, 1024, 9, 0));
 682                bit_count_found = "1"b;
 683           end;
 684 
 685 /* max_length statement */
 686 
 687           else if arg = "max_length" then do;
 688                call TEST_BREAK (":");
 689                slte.max_length = bit (bin (GET_NUM (), 9));
 690                call TEST_BREAK (";");
 691           end;
 692 
 693 /* cache statement */
 694 
 695           else if arg = "cache" then do;
 696                slte.cache = YES_NO ();
 697                cache_found = "1"b;
 698           end;
 699 
 700 /* sys_id statement */
 701 
 702           else if (arg = "sys_id") | (arg = "sysid") then do;
 703                call TEST_BREAK (":");
 704                call GET_NEXT_ARG;
 705                symbol_name = arg;
 706                if real_in_p = null then
 707                     call COPY_SEGMENT;
 708                call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
 709                if code ^= 0 then
 710                     call ERROR ("Unable to find sysid symbol.", "1"b);
 711                id_ptr -> based_char_32 = sysid;
 712                call TEST_BREAK (";");
 713           end;
 714 
 715 /* vers_id statement */
 716 
 717           else if (arg = "vers_id") | (arg = "versid") then do;
 718                call TEST_BREAK (":");
 719                call GET_NEXT_ARG;
 720                symbol_name = arg;
 721                if real_in_p = null then
 722                     call COPY_SEGMENT;
 723                call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
 724                if code ^= 0 then
 725                     call ERROR ("Unable to find versid symbol.", "1"b);
 726                id_ptr -> based_char_32 = versid;
 727                call TEST_BREAK (";");
 728           end;
 729 
 730 /* generation_time statement */
 731 
 732           else if (arg = "generation_time") then do;
 733                call TEST_BREAK (":");
 734                call GET_NEXT_ARG;
 735                symbol_name = arg;
 736                if real_in_p = null then
 737                     call COPY_SEGMENT;
 738                call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
 739                if code ^= 0 then
 740                     call ERROR ("Unable to find generation_time symbol.", "1"b);
 741                time_as_bit = unspec (generated_time);
 742                id_ptr -> based_bit_72 = time_as_bit;
 743                call TEST_BREAK (";");
 744           end;
 745 
 746 /* generation_time_string statement */
 747 
 748           else if (arg = "generation_time_string") then do;
 749                call TEST_BREAK (":");
 750                call GET_NEXT_ARG;
 751                symbol_name = arg;
 752                if real_in_p = null then
 753                     call COPY_SEGMENT;
 754                call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
 755                if code ^= 0 then
 756                     call ERROR ("Unable to find generation_time_string symbol.", "1"b);
 757                call date_time_ (generated_time, generated_time_string);
 758                generated_time_string = translate (generated_time_string,
 759                     " ", /* SPACE */
 760                     "         "/* TAB */);
 761                id_ptr -> based_char_32 = generated_time_string;
 762                call TEST_BREAK (";");
 763           end;
 764 
 765 /* default_time_zone statement */
 766 
 767           else if (arg = "default_time_zone") then do;
 768                symbol_name = "default_time_zone";
 769                if real_in_p = null then
 770                     call COPY_SEGMENT;
 771                call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
 772                if code ^= 0 then
 773                     call ERROR ("Unable to find default_time_zone symbol.", "1"b);
 774                call GET_NEXT_BREAK;
 775                if (arg ^= ":") & (arg ^= ";") then
 776                     call ERROR ("Invalid break.", "0"b);
 777                if arg = ":" then do;                        /* value defined */
 778                     call GET_NEXT_ARG;
 779                     default_time_zone = arg;
 780                     call TEST_BREAK (";");
 781                end;
 782                else default_time_zone = date_time_$format ("^za", generated_time, "", "");
 783                                                             /* use current perprocess time zone */
 784                substr (id_ptr -> based_char_32, 1, 4) = default_time_zone;
 785                symbol_name = rtrim (symbol_name) || "_delta";
 786                call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
 787                if code ^= 0 then
 788                     call ERROR ("Unable to find default_time_zone delta symbol.", "1"b);
 789                do lang_index = 1 to ti_zone.number_lang;
 790                     do zone_index = 1 to ti_zone.number_zone;
 791                          if ti_zone.short (lang_index, zone_index) = default_time_zone then goto found_time_zone;
 792                     end;
 793                end;
 794                call ERROR ("Unable to find default_time_zone in time_info_.", "1"b);
 795 found_time_zone:
 796                time_as_bit = unspec (ti_zone.delta (lang_index, zone_index));
 797                id_ptr -> based_bit_72 = time_as_bit;
 798           end;
 799 
 800 /* default_rpv_data statement */
 801 
 802           else if (arg = "default_rpv_data") then do;
 803                call TEST_BREAK (":");
 804                symbol_name = "default_rpv_data";
 805                if real_in_p = null then
 806                     call COPY_SEGMENT;
 807                call hcs_$make_ptr (in_p, unique_name, symbol_name, id_ptr, code);
 808                if code ^= 0 then
 809                     call ERROR ("Unable to find default_rpv_data symbol.", "1"b);
 810                default_rpv_data = "";
 811                call GET_NEXT_SYM;
 812                do while (arg ^= ";");
 813                     if length (default_rpv_data) + length (arg) + 1 > maxlength (default_rpv_data) then
 814                          call ERROR ("Maximum length of default_rpv_data has been exceeded.", "1"b);
 815                     default_rpv_data = default_rpv_data || arg || " ";
 816                     call GET_NEXT_SYM;
 817                end;
 818                substr (id_ptr -> based_char_32, 1, 24) = default_rpv_data;
 819           end;
 820 
 821 /* abs_seg statement */
 822 
 823           else if arg = "abs_seg" then
 824                slte.abs_seg = YES_NO ();
 825 
 826 /* linkage statement */
 827 
 828           else if arg = "linkage" then do;
 829                call TEST_BREAK (";");
 830                if (seg_type ^= NORMAL_SEG) & (seg_type ^= WHOLE_OBJECT_SEG) then   /* "linkage" illegal others */
 831                     call ERROR ("Linkage keyword with no segment block.", "0"b);
 832                slte.link_provided = "1"b;
 833 
 834                if seg_type = NORMAL_SEG then do;            /* name followed by linkage,want text only */
 835                     sg_l, wr_w = oi.tlng;
 836                     sg_b = sg_l * 36;
 837                end;
 838 
 839                if no_error_was_found then
 840                     call WRITE_SEGMENT (seg_type);
 841 
 842                sg_l, wr_w = oi.llng;                        /* set link block length, words to be written */
 843                sg_b = oi.llng * 36;                         /* set linkage block bit count */
 844 
 845                segp = oi.linkp;
 846                seg_name = substr (seg_name, 1, seg_name_l) || ".link";
 847                seg_name_array.count, nnam = 1;
 848                seg_name_array.names (1).name = seg_name;
 849                seg_name_array.names (1).size = seg_name_array.names (1).size + 5;
 850                cw_ptr, path_ptr = addrel (names_ptr, 10);
 851                seg_header_length = 14;
 852 
 853                call gm_util_ (seg_name, seg_type, sltep, segp, "1"b, "0"b); /* initiate linkage slte */
 854 
 855                acl_found,
 856                cur_length_found,
 857                bit_count_found,
 858                cache_found = "0"b;
 859                linkage_found = "1"b;
 860           end;
 861 
 862 /* end statement */
 863 
 864           else if arg = "end" then do;
 865                end_found = "1"b;
 866                call TEST_BREAK (";");
 867 
 868                if no_error_was_found then
 869                     call WRITE_SEGMENT (seg_type);
 870 
 871                if linkage_found then do;                    /* Now do defs. */
 872                     sg_l, wr_w = oi.dlng;
 873                     sg_b = oi.dlng * 36;
 874 
 875                     segp = oi.defp;
 876                     seg_name = substr (seg_name, 1, seg_name_l) || ".defs";
 877                     seg_name_array.names (1).name = seg_name;
 878                     cw_ptr = addrel (names_ptr, 10);
 879                     seg_header_length = 14;
 880 
 881                     call gm_util_ (seg_name, seg_type, sltep, segp, "0"b, "1"b);
 882 
 883                     acl_found,
 884                     cur_length_found,
 885                     bit_count_found,
 886                     cache_found = "0"b;
 887 
 888                     if no_error_was_found then
 889                          call WRITE_SEGMENT (seg_type);
 890                end;
 891 
 892                call TERM_SEGMENT;
 893                return;                                      /* Back to caller. */
 894           end;
 895 
 896           else
 897                call ERROR ("Illegal keyword.", "0"b);
 898 
 899           go to seg_loop;
 900 
 901 
 902 
 903 skip_to_next_statement:
 904           do while (arg ^= ";");
 905                call GET_NEXT_SYM;
 906           end;
 907 
 908           go to seg_loop;
 909 
 910 
 911 /* ^L */
 912 
 913 GATHER_NAMES: proc;
 914 
 915           do nnam = 1 by 1 while (nnam <= max_count);       /* Pick up names one by one. */
 916                call GET_NEXT_ARG;
 917                seg_name_array.names (nnam).size = numc;
 918                seg_name_array.names (nnam).name = arg;
 919                seg_name_array.count = nnam;
 920 
 921                call GET_NEXT_BREAK;
 922                if arg = ";" then do;                        /* Return when names are finished. */
 923                     seg_header_length = 5 + nnam * 9;
 924                     path_ptr, cw_ptr = addrel (names_ptr, nnam * 9 + 1);
 925                     return;
 926                end;
 927                else if arg ^= "," then
 928                     call ERROR ("Invalid break.", "0"b);
 929           end;
 930 
 931           call ERROR ("Too many names.", "0"b);
 932 
 933 
 934      end GATHER_NAMES;
 935 
 936 /* ^L */
 937 
 938 GATHER_SEGNAMES: proc ();
 939 
 940 /* This procedure adds all the segmames in a bound object segment to the list of names
 941    in the SLTE, thus avoiding the necessity of updating the header every time a component
 942    is added to a bound segment, and making the header considerably smaller as well.
 943    */
 944 
 945 dcl  idx fixed bin;
 946 dcl  current_name_count fixed bin;
 947 dcl 1 def aligned like decode_definition_full;
 948 dcl  defp pointer;
 949 dcl  segname char (32);
 950 
 951 
 952           call TEST_BREAK (";");                            /* No arguments may follow */
 953 
 954           defp = oi.defp;
 955           if (defp = null ()) | (^oi.bound) | (^object_segment) then  /* Must be both valid obj seg & bound. */
 956                call ERROR ("The add_segnames statement may only be used with bound object segments.", "0"b);
 957 
 958           if (acl_found | path_name_found) then             /* Since names array is built before ACL or pathname */
 959                call ERROR ("The add_segnames statement must come before either of ""acl"" or ""path_name"".", "0"b);
 960 
 961           current_name_count = seg_name_array.count;        /* So we can check that we aren't duplicating names */
 962           nnam = seg_name_array.count;                      /* Remember it here, in case we don't find anything */
 963 
 964           do while (^decode_definition_$full (defp, addr (def), addr (oi))); /* loop through all definitions in the seg */
 965                defp = def.next_def;                         /* continue to next one, next time */
 966                if ^def.ignore & (def.section = "segn")
 967                then do;                                     /* It's a segname definition, so process it */
 968                     segname = substr (def.symbol, 1, def.symbol_lng);
 969                     do idx = 1 to current_name_count;       /* Is it already in the name array? */
 970                          if seg_name_array.names (idx).name = segname then
 971                               goto TRY_NEXT_DEFINITION;     /* Yes. Ignore it. */
 972                          end;
 973 
 974                     nnam = seg_name_array.count + 1;        /* Otherwise, add it to the array */
 975                     if nnam > max_count then
 976                          call ERROR ("Too many names.", "0"b);
 977 
 978                     seg_name_array.names (nnam).size = length (rtrim (segname));
 979                     seg_name_array.names (nnam).name = segname;
 980                     seg_name_array.count = nnam;
 981                     end;
 982 TRY_NEXT_DEFINITION:                                        /* skip to next one */
 983                end;
 984 
 985           seg_header_length = 5 + nnam * 9;                 /* update the size */
 986           path_ptr, cw_ptr = addrel (names_ptr, nnam * 9 + 1);
 987 
 988           return;
 989           end GATHER_SEGNAMES;
 990 
 991 /* ^L */
 992 
 993 DELETE_NAMES: proc;
 994 
 995 /* This procedure is used to remove names from the name array if they are not to be
 996    included; it is used to eliminate extraneous segnames which were included by a
 997    previous add_segnames statement.
 998    */
 999 
1000 dcl (idx, jdx) fixed bin;
1001 dcl  segname char (32);
1002 
1003 
1004           call TEST_BREAK (":");
1005 
1006           if (acl_found | path_name_found) then             /* Since names array is built before ACL or pathname */
1007                call ERROR ("The delete_name statement must come before either of ""acl"" or ""path_name"".", "0"b);
1008 
1009           nnam = seg_name_array.count;
1010 
1011           do while (arg ^= ";");                            /* Find all the names to delete */
1012                call GET_NEXT_ARG ();
1013 
1014                segname = arg;
1015                do idx = 1 to seg_name_array.count;          /* See if we can find the specified name */
1016                     if seg_name_array.names (idx).name = segname then do; /* Found it */
1017                          if nnam = 1 then                   /* You'd make it invisible, would you.... */
1018                               call ERROR ("The delete_name statement would leave no names on the segment.", "0"b);
1019 
1020                          do jdx = idx to nnam - 1;          /* percolate all the other names down */
1021                               seg_name_array.names (jdx) = seg_name_array.names (jdx + 1);
1022                               end;
1023 
1024                          nnam = nnam - 1;                   /* record the change in number of names */
1025                          seg_name_array.count = nnam;
1026                          goto GET_NEXT_NAME_TO_DELETE;      /* All done with this one */
1027                          end;
1028                     end;
1029 
1030                call ERROR ("Name to be deleted is not in name array for segment.", "0"b); /* Sorry */
1031 
1032 GET_NEXT_NAME_TO_DELETE:
1033                call GET_NEXT_BREAK ();
1034 
1035                if (arg ^= ",") & (arg ^= ";") then
1036                     call ERROR ("Invalid break.", "0"b);
1037                end;
1038 
1039           seg_header_length = 5 + nnam * 9;
1040           path_ptr, cw_ptr = addrel (names_ptr, nnam * 9 + 1);
1041 
1042           return;                                           /* All done deleting names */
1043           end DELETE_NAMES;
1044 
1045 /* ^L */
1046 
1047 INIT_SEGMENT: proc;
1048 
1049 
1050           seg_name = seg_name_array.names (1).name;
1051           seg_name_l = seg_name_array.names (1).size;
1052 
1053           object_segment = "0"b;                            /* until shown otherwise, assume it's not */
1054 
1055           if seg_type ^= FABRICATED_SEG then do;
1056                do i = 1 to ndir while (in_p = null ());
1057                     call hcs_$initiate_count (path_array (i), seg_name, "", bitcnt, 0, in_p, code);
1058                     if (in_p = null ()) & (code ^= error_table_$noentry) then
1059                          call ERROR ("Invalid pathname in path list.", "1"b);
1060                end;
1061                if in_p = null () then
1062                     call ERROR ("Missing segment.", "0"b);
1063 
1064                call print_gen_info_ (in_p, bitcnt, "gm_output", code);
1065           end;
1066 
1067           else do;                                          /* no seg block,prepare to write out 0 length scw */
1068                sg_l = 0;
1069                slte.bit_count = "0"b;
1070                slte.cur_length = "0"b;
1071           end;
1072 
1073           call gm_util_ (seg_name, seg_type, sltep, segp, "0"b, "0"b); /* initiate segment block slte */
1074 
1075           if seg_type ^= FABRICATED_SEG then do;
1076                if seg_type ^= DATA_SEG then do;             /* Get object info for anything but pure data */
1077                     call object_info_$brief (in_p, bitcnt, addr (oi), code);
1078                     if (oi.linkp = null) | (code ^= 0) then do;
1079                          call ERROR ("Bad object segment.", "0"b);
1080                          slte.combine_link = "0"b;
1081                     end;
1082                     else object_segment = "1"b;             /* segment is a legitimate object segment, so oi is valid. */
1083                end;
1084                else slte.combine_link = "0"b;               /* Certainly don't combine for non-object */
1085 
1086                if seg_type = TEXT_ONLY_SEG then do;         /* text keyword, set up text segment */
1087                     tx_l = oi.tlng;                         /* set block length from linkage pointer offset */
1088                     wr_w, sg_l = tx_l;                      /* set up text segment */
1089                     sg_b = sg_l * 36;                       /* set bit count of "t" or "tl" seg block */
1090                end;
1091                else do;                                     /* not object,take whole segment for now */
1092                     sg_b = bitcnt;
1093                     sg_l, wr_w = divide (bitcnt+35, 36, 17, 0);
1094                end;
1095 
1096                segp = in_p;
1097           end;
1098 
1099 
1100      end INIT_SEGMENT;
1101 
1102 
1103 /* ^L */
1104 
1105 COPY_SEGMENT: proc;
1106 
1107 
1108           real_in_p = in_p;
1109           unique_name = unique_chars_ ("0"b);
1110           call hcs_$make_seg ("", unique_name, unique_name, 1010b, in_p, code);
1111           if in_p = null () then
1112                call ERROR ("Unable to create segment in process directory.", "1"b);
1113           in_p -> movewds = real_in_p -> movewds;           /* make new segment */
1114           call hcs_$set_bc_seg (in_p, bitcnt, code);
1115           segp = in_p;
1116 
1117 
1118      end COPY_SEGMENT;
1119 
1120 
1121 
1122 TERM_SEGMENT: proc;
1123 
1124 
1125           if in_p ^= null then do;
1126                if real_in_p ^= null then do;                /* sysid seg, must delete */
1127                     call delete_$ptr (in_p, "100100"b, "generate_mst", code);
1128                     if code ^= 0 then
1129                          call ERROR ("Unable to terminate segment in process directory.", "1"b);
1130                     in_p = real_in_p;                       /*  reset to original ptr */
1131                     real_in_p = null;
1132                end;
1133                call hcs_$terminate_noname (in_p, code);     /* terminate the found segment */
1134                if code ^= 0 then
1135                     call ERROR ("Unable to terminate found segment.", "1"b);
1136                else in_p = null;
1137           end;
1138 
1139 
1140      end TERM_SEGMENT;
1141 
1142      end PROCESS_SEGMENT;
1143 
1144 
1145 /* ^L */
1146 
1147 WRITE_SEGMENT: proc (seg_type);
1148 
1149 dcl  seg_type fixed bin;
1150 
1151 
1152 /* insert access in output line */
1153 
1154           output_access_word = "";                          /* initialize all access fields to blank */
1155           if output_access.read then substr (output_access_word, 1, 1) = "R";
1156           if output_access.execute then substr (output_access_word, 2, 1) = "E";
1157           if output_access.write then substr (output_access_word, 3, 1) = "W";
1158           if output_access.privileged then substr (output_access_word, 4, 1) = "P";
1159           if output_access_word = "" then
1160                call ERROR ("Invalid argument.", "0"b);
1161 
1162 /* set bit count, cur_length if necessary */
1163 
1164           if ^(cur_length_found | bit_count_found) then
1165           if seg_type ^= FABRICATED_SEG then do;
1166                     slte.bit_count = bit (sg_b, 24);
1167                     slte.cur_length = bit (divide (divide (sg_b + 35, 36, 18, 0) + 1023, 1024, 9, 0), 9);
1168                end;
1169 
1170 
1171 /* Compute cache access */
1172 
1173           if ^cache_found                                   /* believe given spec */
1174           then if slte.per_process then slte.cache = "1"b;
1175                else if output_access.write
1176                | slte.init_seg
1177                | slte.temp_seg then slte.cache = "0"b;
1178                else slte.cache = "1"b;
1179 
1180           cw_ptr -> control_word.ident = 1;                 /* set identity of segment control word */
1181           cw_ptr -> control_word.length = sg_l;
1182           header_words = seg_header_length+2;               /* add hcw,scw length */
1183           seg_hdrp -> control_word.length = seg_header_length;
1184 
1185 /* write first segment */
1186 
1187           if (seg_type = FIRST_SEG) | (seg_type = BOOT_PROGRAM_SEG) then do;
1188                if seg_type = FIRST_SEG then
1189                     call gm_write_first_seg_ (sltep, sg_b, in_p, mst_tape_iocbp, error_in_object_segment, code);
1190                else if do_hit then;                         /* Do nothing if -notape specified */
1191                else call gm_write_boot_program_ (in_p, sg_b, (seg_name), mst_tape_iocbp, db_hit, error_in_object_segment, code);
1192 
1193                if code ^= 0 then do;
1194 TAPE_ER:            if error_in_object_segment then
1195                          call ERROR ("Bad object segment.", "1"b);
1196                     else call ERROR ("Unrecoverable tape error.", "1"b);
1197                end;
1198 
1199                if (db_hit | do_hit) then
1200                     tape_er_count = 0;
1201                else call iox_$control (mst_tape_iocbp, "error_count", addr (tape_er_count), code);
1202 
1203                if tape_er_count ^= 0 then call ERROR ("Error writing first segment.", "1"b);
1204           end;
1205 
1206 /* write out the header */
1207 
1208           else do;
1209                call iox_$put_chars (mst_tape_iocbp, seg_hdrp, header_words*4, code);
1210                if code ^= 0 then go to TAPE_ER;
1211 
1212 /* now write out the segment */
1213 
1214                if (seg_type = NORMAL_SEG)
1215                 | (seg_type = WHOLE_OBJECT_SEG)
1216                 | (seg_type = TEXT_ONLY_SEG)
1217                 | (seg_type = DATA_SEG) then do;
1218 
1219                     call iox_$put_chars (mst_tape_iocbp, segp, wr_w * 4, code);
1220                     if code ^= 0 then go to TAPE_ER;
1221                end;
1222           end;
1223 
1224           return;
1225 
1226 
1227 
1228 WRITE_COLLECTION: entry;
1229 
1230 
1231           call iox_$put_chars (mst_tape_iocbp, sltep, 8, code);
1232           if code ^= 0 then go to TAPE_ER;
1233 
1234           return;
1235 
1236 
1237      end WRITE_SEGMENT;
1238 
1239 
1240 /* ^L */
1241 
1242 GET_NEXT_SYM: proc;
1243 
1244 
1245           call parse_file_$parse_file_ptr (symp, numc, sym_is_a_break, eof_was_found);
1246           if eof_was_found = 1 then                         /* error,eof found before "fini" */
1247                call ERROR ("Physical end of header reached before logical end.", "1"b);
1248 
1249           return;
1250 
1251 
1252      end GET_NEXT_SYM;
1253 
1254 
1255 
1256 GET_NEXT_ARG: proc;
1257 
1258 
1259           call GET_NEXT_SYM;
1260 
1261           if sym_is_a_break = 1 then                        /* Should not be a break. */
1262                call ERROR ("Break found when keyword or argument expected.", "0"b);
1263 
1264           return;
1265 
1266 
1267 GET_NEXT_BREAK: entry;
1268 
1269           call GET_NEXT_SYM;
1270 
1271           if sym_is_a_break = 0 then                        /* Must be a break. */
1272                call ERROR ("Invalid break.", "0"b);
1273 
1274           return;
1275 
1276 
1277      end GET_NEXT_ARG;
1278 
1279 
1280 
1281 TEST_BREAK: proc (break);
1282 
1283 dcl  break char (1) aligned;                                /* break char to be checked */
1284 
1285           call GET_NEXT_BREAK;
1286 
1287           if arg ^= break then
1288                call ERROR ("Invalid break.", "0"b);
1289 
1290           return;
1291 
1292 
1293      end TEST_BREAK;
1294 
1295 
1296 /* ^L */
1297 
1298 YES_NO:   proc returns (bit (1) unal);
1299 
1300 dcl  switch bit (1) aligned;
1301 
1302 
1303           call TEST_BREAK (":");
1304           call GET_NEXT_ARG;
1305           if arg = "yes" then switch = "1"b;
1306           else if arg = "no" then switch = "0"b;
1307           else call ERROR ("Invalid argument.", "0"b);
1308 
1309           call TEST_BREAK (";");
1310 
1311           return (switch);
1312 
1313 
1314      end YES_NO;
1315 
1316 
1317 
1318 GET_NUM:  proc returns (fixed bin);
1319 
1320 
1321           call GET_NEXT_ARG;
1322           return (bin (fixed (arg, 6), 17));
1323 
1324 
1325      end GET_NUM;
1326 
1327 
1328 /* ^L */
1329 
1330 CLEANUP_CONDITION_HANDLER: proc;
1331 
1332 
1333           call gm_error_ (0, seg_name, symp, hdrp, "Cleanup handler invoked.", "1"b, end_found,
1334                "0"b, in_p, gm_output_iocbp);
1335 
1336           call gm_util1_$close (gm_output_iocbp, mst_tape_iocbp, hd_hit);
1337 
1338 
1339      end CLEANUP_CONDITION_HANDLER;
1340 
1341 
1342 
1343 ERROR:    proc (gm_message, fatal);               /* normal error handler */
1344 
1345 dcl  gm_message char (*),                                   /* gm error message */
1346      fatal bit (1) aligned;                                 /* fatal error switch */
1347 
1348 
1349           call gm_error_ (code, seg_name, symp, hdrp, gm_message, fatal, end_found, "0"b, in_p,
1350                gm_output_iocbp);
1351 
1352           if ^fatal then
1353                go to error_label;
1354           else
1355                go to close_out;
1356 
1357 
1358      end ERROR;
1359 
1360 
1361 
1362 skip_to_next_seg:
1363           if end_found then do while (sym_is_a_break = 0);
1364                call GET_NEXT_SYM;
1365           end;
1366           else do;
1367                do while (arg ^= "end");
1368                     call GET_NEXT_SYM;
1369                end;
1370                call GET_NEXT_SYM;
1371           end;
1372           end_found = "0"b;
1373           if arg ^= ";" then
1374                go to skip_to_next_seg;
1375           else
1376           go to next_segment;
1377 
1378 
1379 %page; %include gm_data;
1380 %page; %include slte;
1381 %page; %include object_info;
1382 %page; %include decode_definition_str;
1383 %page; %include time_names;
1384 
1385      end generate_mst;