/* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style4 */ load_tandd_library: ltdl: proc; /* load_tandd_library - command to load the ITR, Firmware and Diagnostic (IFAD) tape (formally the firmware tape) into a keyed sequential vfile_ named tandd_deck_file Written by J. A. Bush 11/78 Modified by J. A. Bush 12/79 for multiple ifad file changes and to add copy feature Modified by J. A. Bush 8/80 to add -density control arg and spell error_table_$inconsistent correctly Modified by J. A. Bush 8/81 to add binary deck tape processing capabilities Modified by J. A. Bush 2/82 to accept gcos partial hdr label as EOV Modified by G. C. Dixon 6/83 to add -patches control argument. Modified by P. K. Farley 6/84 to fix cat_key when only FW (NO ITRs) is on tape. */ /* external entries */ dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$delete_record entry (ptr, fixed bin (35)); dcl iox_$seek_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl date_time_ entry (fixed bin (52), char (*)); dcl (com_err_, ioa_$ioa_switch) entry options (variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl bcd_to_ascii_ entry (bit (*), char (*) aligned); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl gload_$allow_zero_checksums entry (char (*), char (*), char (*), ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); /* constants */ dcl pname char (18) int static options (constant) init ("load_tandd_library"); dcl (opn_sqi init (4), /* open for sequential input */ opn_sqo init (5), /* open for sequential output */ opn_ksu init (10), /* open for keyed sequential update */ opn_so init (2)) fixed bin int static options (constant); /* open for stream output */ dcl buf_size fixed bin (21) int static options (constant) init (4 * 1024); /* 1k buffer is plenty */ dcl bcd_obj bit (78) int static options (constant) init ("53202020202020462241252363"b3); /* "$ object" in bcd */ dcl bcd_dkend bit (72) int static options (constant) init ("532020202020202442254524"b3); /* "$ dkend" in bcd */ dcl g_label bit (72) int static options (constant) init /* = "ge 600 btl " in bcd */ ("272520200600002022634320"b3); dcl hdra char (18) static options (constant) init ("Edit Deck Assm"); dcl hdrb char (42) static options (constant) init ("N__a_m_e T__y_p_e D__a_t_e"); dcl hdra1 char (5) static options (constant) init ("Ident"); dcl hdrb1 char (46) static options (constant) init ("C__o_d_e M__o_d_e_l R__e_v._"); dcl hdrb2 char (12) static options (constant) init ("T__y_p_e"); dcl hdrb3 char (111) static options (constant) init ("S__e_a_r_c_h K__e_y C__o_m_p O__f_f_s_e_t L__e_n_g_t_h (_B__y_t_e_s)_"); dcl hdra2 char (2) static options (constant) init ("SS"); dcl hdra3 char (40) static options (constant) init ("Record Location Record"); dcl hdra4 char (7) static options (constant) init ("Multics"); dcl hdrb4 char (30) static options (constant) init ("A__p_p_l_i_c_a_b_l_e"); dcl fmt1 char (53) static options (constant) init ("^[^5-^12s^; ^[^6x^1s^;^6a^] ^4a ^4a ^2a/^2a/^2a "); dcl fmt2 char (33) static options (constant) init ("^[^6a ^6a ^2a^s^;^3s^4a^2-^]^]"); dcl fmt3 char (58) static options (constant) init ("^-^[ ^[^;^[yes^;no ^]^]^;^2s^21a ^2d ^6o ^8d^]^/"); dcl density (5) char (5) static options (constant) init ("d6250", "d1600", "d800", "d556", "d200"); dcl cleanup condition; dcl (addr, addrel, char, clock, currentsize, fixed, index, ltrim, null, rel, rtrim, substr, unspec, bin, hbound, string) builtin; /* automatic */ dcl (code, scode, tdec) fixed bin (35); dcl rec_len fixed bin (21); dcl (cfile, pfile, crec, nwds, dlen, c_rtrycnt, rtrycnt, bcnt, psz) fixed bin; dcl (m, i, j, lx, al, line_count, page_no, denno) fixed bin; dcl fnp_key fixed bin init (0); dcl (ap, bptr, cvp, cvp1, cptr, segp, catp, svp) ptr; dcl tempp (2) ptr; dcl (m_att_desc, c_att_desc, l_att_desc) char (64); dcl obj_buf char (80) aligned; /* buffer to hold current object card image */ dcl err_card char (80) aligned; dcl id_buf char (18) aligned; /* buffer to hold current ident block image */ dcl ident_buf (40) bit (36); /* load buffer */ dcl dir char (168); dcl ename char (32); dcl (current_key, cat_key) char (24) init (""); dcl work_key char (256) varying; dcl tape_name char (16); dcl time_string char (24); /* Current date and time */ dcl (dtype, fnp_type) char (4); dcl (sstype, cden) char (5); dcl t_stat bit (12) aligned; dcl (cat_build, first_deck, eot, one_eof, hdr_sw, first_ff, cont_sw) bit (1) init ("0"b); dcl (list, firmware_sw, deckfile_sw, config_sw, cd_sw) bit (1) init ("0"b); dcl (attach_copy, copy_at_eof, first_write, fnp_tape, build_fnp_cat, patches) bit (1) init ("0"b); dcl (dk_end, trm, first_rcd, obj_card, id_ld, v_patch, eof, err, lib, at_bot) bit (1); /* static */ dcl (error_table_$wrong_no_of_args, error_table_$bad_arg, error_table_$tape_error, error_table_$no_record, error_table_$inconsistent, error_table_$end_of_info) ext fixed bin (35); dcl (tiocb_ptr, fiocb_ptr, liocb_ptr, ciocb_ptr) ptr static; dcl (t_attached, f_attached, l_attached, c_attached) bit (1) int static init ("0"b); /* structures and based variables */ dcl 1 r_card based (cptr) aligned, /* template for a binary card image */ (2 type bit (12), /* card type */ 2 count fixed bin (5), /* number of wds controlled */ 2 ld_add bit (18), /* loading address */ 2 pad (psz) bit (36), 2 data (r_card.count) bit (36), 2 nxt_c_wd bit (36)) unaligned; /* to get nxt control wd */ dcl 1 id_blk based (addr (id_buf)) aligned, /* template for ident block */ (2 ident char (6), /* module identification */ 2 revision, 3 rev_dot char (4), /* char string "rev." */ 3 rev char (2), /* alpa-numeric revision */ 2 type_code, 3 pad char (3), 3 type char (3)) unaligned; /* module type (itr, mdr or firmware) */ dcl 1 o_card based (addr (obj_buf)) aligned, /* template for an object card */ (2 pad1 char (15), 2 library char (6), /* col 16 - either "hmpcj1" or "htnd " */ 2 ld_type char (1), /* col 22, module type */ 2 ss_type char (1), /* col 23, subsystem type */ 2 pad2 char (3), 2 m_applic char (1), /* Multics applicability, non blank means not applicable */ 2 pad3 char (15), 2 model char (6), /* for hmpcj1 decks, controller model # */ 2 version char (6), /* for hmpcj1 decks, model version # */ 2 pad4 char (5), 2 assem char (1), /* "m" for mpc assembler, "g" for gmap */ 2 call_name char (6), /* module call name, or gecall name */ 2 ttl_date char (6), /* date module assembled */ 2 edit_name char (4)) unaligned; /* module edit name */ dcl 1 o_patch based (addr (err_card)) aligned, /* template for octal patch card */ (2 add char (6), /* patch address */ 2 blk1 char (1), 2 octal char (5), /* either "octal" or "mask " */ 2 blk2 char (3), 2 p_fld char (57), /* variable filed (patch data) */ 2 comment char (8)) unaligned; /* comment field */ dcl 1 h_patch based (addr (err_card)) aligned, /* template for hex patch card */ (2 h_add char (6), /* (c1) hex patch address */ 2 cr char (1), /* (c7) = "c" for cs, "r" for r/w mem */ 2 hex char (3), /* (c8) = "hex" for hex patch */ 2 pad1 char (5), 2 inst char (8), /* (c16) 2 - 4 hex digit instructions */ 2 pad2 char (13), 2 rev char (6), /* (c37) should equal word 2 of deck id block */ 2 pad3 char (42), 2 lbl char (4)) unaligned; /* (c73) = deck edit name */ dcl 1 p_blk aligned, /* patch card image storage */ 2 p_cnt fixed bin, /* number of valid patches */ 2 p_card (200) char (80); /* patch card image */ dcl 1 cata based (catp) aligned, /* template for itr or mdr catalog */ 2 n_entries fixed bin, /* number of catalog entries */ 2 key (1 refer (cata.n_entries)) char (24); /* entry search keys */ dcl 1 rsi like rs_info aligned; /* auto copy of record status info */ dcl arg char (al) based (ap); dcl id_bbuf bit (108) based (cvp); dcl bit_buf bit (rec_len * 9) based (prptr); rs_info_ptr = null; call cu_$arg_ptr (1, ap, al, code); /* get reel id - MUST BE 1st */ if code ^= 0 then do; call com_err_ (error_table_$wrong_no_of_args, pname, "^/Usage:^-^a reel_id {-control_args}", pname); return; end; m_att_desc = "tape_nstd_ " || arg; /* start attach description */ i = index (arg, ","); /* Check for commas in tape name */ if i > 1 then tape_name = substr (arg, 1, i - 1); /* If comma, use stuff before */ else tape_name = arg; /* Otherwise use the whole thing */ l_att_desc = "vfile_ " || tape_name; /* start listing attach description */ call date_time_ (clock (), time_string); /* Convert date and time. */ dir = get_wdir_ (); /* Get working directory. */ j = 2; call cu_$arg_ptr (j, ap, al, code); /* look for more arguments */ do while (code = 0); /* do while there are args */ if arg = "-track" | arg = "-tk" then do; /* next arg must be 7 or 9 */ j = j + 1; call cu_$arg_ptr (j, ap, al, code); /* get track arg */ if code ^= 0 then do; /* error */ call com_err_ (code, pname, "obtaining ""-track"" specification."); return; end; tdec = cv_dec_check_ (arg, code); /* convert to dec. for check */ if code ^= 0 then go to bad_arg; /* must be numeric */ if tdec ^= 7 & tdec ^= 9 then go to bad_arg; /* and only 7 or 9 */ if attach_copy then /* if track specification of copy tape */ c_att_desc = rtrim (c_att_desc) || " -track " || ltrim (char (tdec)); /* insert leading blank */ else m_att_desc = rtrim (m_att_desc) || " -track " || ltrim (char (tdec)); /* insert leading blank */ end; else if arg = "-density" | arg = "-den" then do; /* next arg must be density value */ j = j + 1; call cu_$arg_ptr (j, ap, al, code); if code ^= 0 then do; call com_err_ (code, pname, "obtaining ""-density"" specification."); return; end; tdec = cv_dec_check_ (arg, code); if code ^= 0 then go to bad_arg; if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then do; if attach_copy then do; /* if setting density on copy tape */ c_att_desc = rtrim (c_att_desc) || " -density " || ltrim (char (tdec)); cd_sw = "1"b; /* set indicator */ end; else m_att_desc = rtrim (m_att_desc) || " -density " || ltrim (char (tdec)); end; else go to bad_arg; /* make him get it right */ end; else if arg = "-output_dir" | arg = "-odr" then do; /* user will specify path */ j = j + 1; call cu_$arg_ptr (j, ap, al, code); if code ^= 0 then do; call com_err_ (code, pname, "obtaining ""-output_dir"" specification."); return; end; call absolute_pathname_ (arg, dir, code); /* expand it */ if code ^= 0 then do; call com_err_ (code, pname, "expanding pathname ""^a""", arg); return; end; end; else if arg = "-copy" | arg = "-cp" then do; /* user wantsd to make copy of ifad tape */ j = j + 1; call cu_$arg_ptr (j, ap, al, code); if code ^= 0 then do; call com_err_ (code, pname, "obtaining ""-copy"" tape reel specification."); return; end; c_att_desc = "tape_nstd_ " || arg; /* generate initial copy attach description */ attach_copy = "1"b; /* set flag */ end; else if arg = "-list" | arg = "-ls" then list = "1"b; /* user just wants listing */ else if arg = "-firmware" | arg = "-fw" then firmware_sw = "1"b; /* user just wants firmware loaded */ else if arg = "-deckfile" | arg = "-dkf" then deckfile_sw = "1"b; /* user just wants deckfile loaded */ else if arg = "-config" then config_sw = "1"b; /* base tape loading on current configuration */ else if arg = "-fnp_tape" then fnp_tape = "1"b; /* user wants to load fnp bin. deck tape */ else if arg = "-patches" then patches = "1"b;/* user wants to allow patched cards having 0 checksums */ else do; bad_arg: call com_err_ (error_table_$bad_arg, pname, "argument number ^d: ""^a""", j, arg); return; end; j = j + 1; call cu_$arg_ptr (j, ap, al, code); end; if (firmware_sw & deckfile_sw) then do; /* check for consistency in control args */ call com_err_ (error_table_$inconsistent, pname, "-firmware and -deckfile"); return; end; if (firmware_sw & list) then do; /* illegal combination */ call com_err_ (error_table_$inconsistent, pname, "-firmware and -list"); return; end; if (firmware_sw & attach_copy) then do; /* illegal combination */ call com_err_ (error_table_$inconsistent, pname, "-firmware and -copy"); return; end; if (firmware_sw & fnp_tape) then do; /* illegal combination */ call com_err_ (error_table_$inconsistent, pname, "-firmware and -fnp_tape"); return; end; if config_sw then /* if user wants deckfile tailored */ call set_fig; /* go set up config parameters */ call get_temp_segments_ (pname, tempp, code); /* get temp segs for tape and catalog buffers */ if code ^= 0 then do; /* can't allocate buffer */ call com_err_ (code, pname, "getting temporary segments"); return; end; bptr = tempp (1); /* set tape buffer segment ptr */ catp = tempp (2); /* set calalog buffer segment ptr */ cata.n_entries = 0; /* initialy set to 0 entries */ /* attach and open tape using the "tape_nstd_" io module */ call iox_$attach_name ("tape_sw", tiocb_ptr, m_att_desc, null, code); if code ^= 0 then do; call com_err_ (code, pname, "attaching tape"); return; end; t_attached = "1"b; call iox_$open (tiocb_ptr, opn_sqi, "0"b, code); /* open for seq. input */ if code ^= 0 then do; call com_err_ (code, pname, "opening tape for sequential input"); call detach_tape_file; return; end; /* attach and open tandd_deck_file */ if ^list & ^firmware_sw then do; /* don't attach deck file if we are just producing listing */ call iox_$attach_name ("dkfile_sw", fiocb_ptr, "vfile_ " || rtrim (dir) || ">tandd_deck_file", null, code); if code ^= 0 then do; call com_err_ (code, pname, "attaching tandd_deck_file"); call detach_tape_file; return; end; f_attached = "1"b; call iox_$open (fiocb_ptr, opn_ksu, "0"b, code); /* open for keyed_sequential update */ if code ^= 0 then do; call com_err_ (code, pname, "opening tandd_deck_file for keyed_sequential_update"); call detach_tape_file; return; end; end; /* attach and open copy tape using the "tape_nstd_" io module */ if attach_copy then do; /* only attach copy if indicated */ c_att_desc = rtrim (c_att_desc) || " -write";/* add write ring spec */ call iox_$attach_name ("copy_sw", ciocb_ptr, c_att_desc, null, code); if code ^= 0 then do; call com_err_ (code, pname, "attaching copy tape"); call detach_tape_file; return; end; c_attached = "1"b; call iox_$open (ciocb_ptr, opn_sqo, "0"b, code); /* open for seq. output */ if code ^= 0 then do; call com_err_ (code, pname, "opening copy tape for sequential output"); call detach_tape_file; return; end; end; on cleanup call detach_tape_file; /* set up clean up handler */ /* main processing loop */ pfile, cfile, page_no = 1; /* set first file number and listing page number */ denno, crec = 0; /* and record */ unspec (rsi) = "0"b; /* clear rcecord status structure */ rsi.version = rs_info_version_2; /* set structure version for vfile_ */ at_bot = "1"b; /* set bot indicator */ do while (^eot); /* read tape until 2 eofs */ call read_deck (eof, err); /* read in next object deck */ if err | (eof & one_eof) | eot then do; /* if error condition or 2 eofs */ eot = "1"b; /* thats all there is to do */ if attach_copy then call copy_eof; /* if we are copying tape,write out 2nd eof */ if fnp_tape & ^err & ^list then do; /* write out fnp catalog record */ current_key = "cata." || rtrim (cat_key); /* form completed key */ call insert_deck (catp, cata.n_entries * 24 + 4, err); /* and write catalog to deck file */ if ^err then call update_list (3); /* add catalog record to listing file */ end; end; else if eof then do; /* if eof */ one_eof = "1"b; /* set flag */ if attach_copy then /* if we are copying tape */ if ^copy_at_eof then /* and copy tape is not already at end of file */ call copy_eof; /* go write eof on copy tape */ if cat_build & ^fnp_tape then do; /* if we were building catalog */ cat_build, first_deck = "0"b; /* reset flags */ if index (cat_key, "itr.") ^= 0 then do; /* if building itr catalog */ if id_blk.type = "itr" | id_blk.type = "mdr" then do; /* last entry must be firmware */ call com_err_ (0, pname, "Last object deck on itr file is not firmware"); call com_err_ (0, pname, "Last object card image is:^/""^a""", obj_buf); eot = "1"b; /* set flag to abort */ go to exit; end; else do; /* no errors form catalog name */ do i = cata.n_entries to 1 by -1 while (index (cata.key (i), ".") > 4); end; /* find first firmware deck */ cat_key = rtrim (cat_key) || substr (cata.key (i + 1), 8, 6) || "." || substr (cata.key (i + 1), 20, 2); end; end; current_key = "cata." || rtrim (cat_key) || "." || ltrim (char (cfile - 1)); /* set current key */ call insert_deck (catp, cata.n_entries * 24 + 4, err); /* and write catalog to deck file */ if err then eot = "1"b; /* if fatal error */ else call update_list (3); /* add catalog record to listing file */ end; if ^fnp_tape then /* if not loading fnp deck tape.. */ hdr_sw, cont_sw = "0"b; /* reset continue flag for listing file */ end; else do; /* good read, process deck */ one_eof = "0"b; /* reset eof flag if set */ if list then /* if just producing listing, take all decks */ call update_list (1); /* go add entry to listing file */ else if fnp_tape then go to i_deck; /* no applicability check for fnp decks */ else if ck_applic () then /* only take deck if Multics applicable */ if ^firmware_sw then do; /* if just loading firmware, don't insert deck into deckfile */ i_deck: call make_key; /* produce insertion key */ call insert_deck (bptr, dlen * 4, err); /* copy current deck into deckfile */ if err then eot = "1"b; /* if error return, abort */ else call update_list (2); /* add current deck entry to listing file */ end; end; exit: end; call detach_tape_file; /* we are all done, cleanup */ return; /* and return */ /* read_deck - internal procedure to read in the next sequential object deck from the tape */ read_deck: proc (end_file, abort); dcl (end_file, abort) bit (1); obj_card, id_ld, first_rcd, end_file, abort = "0"b; /* reset flags */ dk_end = "0"b; /* reset deck end flag */ p_blk.p_cnt = 0; /* initialize patch count */ if pfile < cfile then pfile = cfile; /* update listing file designator if necessary */ prptr = bptr; /* set initial blk ptr to base of tape buff */ cvp, cvp1 = null; do while (^dk_end); /* loop until entire deck is read in */ rtrycnt = 0; /* reset retries */ retry_rd: call iox_$read_record (tiocb_ptr, prptr, buf_size, rec_len, code); if code ^= 0 then do; if code ^= error_table_$end_of_info then/* if not end of file */ if code = error_table_$tape_error then do; if at_bot then do; /* still at bot probably wrong density */ denno = denno + 1; /* increment density number */ if denno > hbound (density, 1) then /* can't set it so abort */ go to get_stat; call iox_$control (tiocb_ptr, "rewind", null, code); call iox_$control (tiocb_ptr, density (denno), null, code); /* set density */ go to retry_rd; /* and go try again */ end; rtrycnt = rtrycnt + 1; /* increment retry count */ if rtrycnt = 11 then do; /* if we have retried max number of times */ get_stat: call iox_$control (tiocb_ptr, "saved_status", addr (t_stat), scode); call com_err_ (code, pname, "Tape status = ^4.3b, while reading record ^d, file ^d after 10 retries", t_stat, crec, cfile); abort = "1"b; /* set abort indicator */ return; end; call iox_$control (tiocb_ptr, "backspace_record", null, code); go to retry_rd; end; else do; /* not a tape error report it and abort */ call com_err_ (code, pname, "While reading record ^d, file ^d", crec, cfile); abort = "1"b; /* set abort indicator */ return; /* and return */ end; else do; /* end of file */ end_file = "1"b; /* set eof indicator */ cfile = cfile + 1; /* increment position indicators */ crec = 0; return; end; end; if rec_len = 56 then /* check for partial hdr label (GCOS EOV) */ if substr (bit_buf, 1, 72) = g_label then if substr (bit_buf, 145, 216) = "0"b then do; /* if true, partial hdr label */ eot = "1"b; /* set EOV flags */ return; end; if ^first_rcd then do; /* if first record of deck */ bcnt = bcw.bsn; /* load block serial number */ first_rcd = "1"b; if fnp_tape & at_bot then /* get set to build fnp catalog key */ build_fnp_cat = "1"b; at_bot = "0"b; /* cannot be at bot anymore */ end; else do; /* if not first record, check BSN */ bcnt = bcnt + 1; /* increment our block count */ if bcw.bsn ^= bcnt then do; /* something wrong here */ call com_err_ (0, pname, "Block serial number error at record ^d, file ^d", crec, cfile); call com_err_ (0, pname, "Block serial number was ^d, S/B ^d", bcw.bsn, bcnt); abort = "1"b; /* set abort flag */ return; end; end; lrptr = addr (gc_phy_rec.gc_phy_rec_data (1)); /* get pointer to first logical record */ nwds = 0; do while (nwds < bcw.blk_size); /* iterate through all logical records */ if rcw.media_code = 2 then do; /* bcd card image */ if substr (gc_log_rec_bits, 1, 78) = bcd_obj then do; /* object card */ call bcd_to_ascii_ (gc_log_rec_bits, obj_buf); /* convert to ascii */ obj_card = "1"b; /* indicate that we have gotten object card */ if build_fnp_cat then do; /* if we need to build fnp catalog record */ if o_card.edit_name = "2000" then /* is this an 18x fnp */ fnp_type = "6670"; /* yes, set type */ else if o_card.edit_name = "0300" then /* is it a 355 fnp */ fnp_type = "6600"; else do; /* neither one, can't be fnp tape */ call com_err_ (0, pname, "^a ""^a"", ^a", "First object deck image on fnp tape has edit name", o_card.edit_name, "which is not the first deck on a fnp binary deck tape"); abort = "1"b; return; end; cat_key = "fnp.pol." || fnp_type; /* start catalog key */ l_att_desc = rtrim (l_att_desc) || ".fnp." || fnp_type; /* add to list att. desc. */ build_fnp_cat = "0"b; end; end; else do; /* must be dkend or patch card */ if o_card.library = "hmpcj1" & ^id_ld then do; /* if hmpcj1 lib and we haven't been here */ id_ld = "1"b; /* set flag so we don't come back */ if cvp1 = null then /* if only 1 binary card */ cvp1 = cvp; call load_ident; /* load ident block */ end; if substr (gc_log_rec_bits, 1, 72) = bcd_dkend then /* dkend card */ dk_end = "1"b; /* set terminate condition */ else call ck_patch (abort); /* go check for patch card */ if abort then return; /* if error, get out */ end; end; else if rcw.media_code = 1 then /* binary card image */ if ^obj_card then do; /* but no $ object card yet */ call com_err_ (0, pname, "Binary card image preceeds $ object card at record ^d, file ^d", crec, cfile); abort = "1"b; return; end; else do; cvp1 = cvp; /* save ptr to last logical record */ cvp = lrptr; /* save ptr to current logical record */ end; else do; /* not a bcd or binary card image */ call com_err_ (0, pname, "Card type ^o detected at record ^d, file ^d", rcw.media_code, crec, cfile); abort = "1"b; return; end; nwds = nwds + rcw.rsize + 1; /* increment number of words */ lrptr = addrel (lrptr, currentsize (gc_log_rec)); /* set next logical record */ end; crec = crec + 1; /* increment current record number */ prptr = addrel (prptr, currentsize (gc_phy_rec)); /* append next block */ end; dlen = fixed (rel (prptr)) + 1; /* set total deck length in words */ end read_deck; /* */ /* load_ident - int procedure to load last 2 binary card images of hmpcj1 deck and extract the ident block */ load_ident: proc; svp = lrptr; /* save logical record ptr */ lrptr = cvp1; /* set rcw ptr */ lx = 0; /* set initial load index */ do while (gc_log_rec.rcw.media_code = 1); /* process only binary cards */ cptr = addrel (lrptr, 1); psz = 4; /* set initial pad size to 4 */ m = r_card.count; /* set initial count */ trm = "0"b; do while (^trm); /* load all words on card */ do i = 1 to r_card.count; ident_buf (lx + i) = r_card.data (i); /* copy data */ end; lx = lx + r_card.count; /* update load index */ if m = rcw.rsize - 8 | substr (r_card.nxt_c_wd, 1, 12) ^= "2005"b3 then trm = "1"b; /* all done */ else do; cptr = addr (r_card.nxt_c_wd); /* set for nxt control word */ psz = 0; /* pad size = 0 */ m = m + r_card.count; /* increment counter */ end; end; lrptr = addrel (lrptr, currentsize (gc_log_rec)); /* set next logical record */ if rcw.media_code ^= 1 & rcw.media_code ^= 2 then /* ck for new blk */ if lrptr -> bcw.bsn = bcnt then /* if looks like bcw */ lrptr = addrel (lrptr, 1); /* go to nxt word */ end; /* we have all of the ident block loaded, now lets find the words we are interested in */ trm = "0"b; do i = 1 to 40 while (^trm); if ident_buf (i) = "444723224663"b3 then /* if word = "mpcbot" in bcd */ trm = "1"b; end; cvp = addr (ident_buf (i - 10)); /* cvp pts to beginning of ident block */ call bcd_to_ascii_ (id_bbuf, id_buf); /* convert ident block to ascii */ lrptr = svp; /* restore logical record ptr */ end load_ident; /* update_list - int procedure to add current deck entry to listing file */ update_list: proc (ltype); dcl ltype fixed bin (2); if ^l_attached then do; /* if listing file not attached, do it now */ call iox_$attach_name ("list_sw", liocb_ptr, rtrim (l_att_desc) || ".list", null, code); if code ^= 0 then do; call com_err_ (code, pname, "attaching listing file"); eot = "1"b; go to exit; end; l_attached = "1"b; call iox_$open (liocb_ptr, opn_so, "0"b, code); /* open for stream output */ if code ^= 0 then do; call com_err_ (code, pname, "opening listing file for stream_output"); eot = "1"b; go to exit; end; end; dtype, sstype = ""; lib = "0"b; /* reset lib switch */ if fnp_tape then do; /* if loading fnp bin. deck tape */ sstype = "pol "; /* this stands for Partial OnLine */ dtype = "fnp "; end; else if o_card.library = "hmpcj1" then do; /* mpc library */ lib = "1"b; /* set lib switch */ if id_blk.type ^= "itr" & id_blk.type ^= "mdr" then /* if firmware */ dtype = " fw "; else substr (dtype, 2, 3) = id_blk.type; /* set itr or mdr type */ end; else do; /* must be htnd library */ if o_card.ld_type = "m" then dtype = "mast"; /* pas2 master deck */ else if o_card.ld_type = "s" then dtype = "slav"; else if o_card.ld_type = "p" then dtype = "prog"; /* program deck */ else if o_card.ld_type = "r" then dtype = "rloc"; /* relocatable deck */ else dtype = "data"; if o_card.ss_type = "p" then sstype = "polt"; else if o_card.ss_type = "m" then sstype = "molt"; else if o_card.ss_type = "c" then sstype = "colt"; else if o_card.ss_type = "h" then sstype = "heal"; else if o_card.ss_type = "u" then sstype = "util"; else if o_card.ss_type = "s" then if o_card.m_applic = " " then sstype = "isol"; else sstype = "solt"; end; if ^list then /* if just producing a listing, don't bother */ call iox_$control (fiocb_ptr, "record_status", addr (rsi), code); /* get record position */ if ^hdr_sw & (ltype ^= 3 | (ltype = 3 & line_count > 26)) then /* if we need a header */ call put_hdr; /* put it out */ call ioa_$ioa_switch (liocb_ptr, fmt1 || fmt2 || fmt3, (ltype = 3), fnp_tape, o_card.call_name, o_card.edit_name, dtype, substr (o_card.ttl_date, 1, 2), substr (o_card.ttl_date, 3, 2), substr (o_card.ttl_date, 5, 2), lib, id_blk.ident, o_card.model, id_blk.rev, sstype, list, fnp_tape, (o_card.m_applic = " "), current_key, addr (rsi.descriptor) -> rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18), rsi.record_length); line_count = line_count + 1; /* increment line count */ if line_count >= 25 then hdr_sw = "0"b; /* we need a new page header */ if p_blk.p_cnt ^= 0 then /* if patches exist... */ call put_patch; /* list them too */ if attach_copy then /* if we are writing copy tape */ if ltype ^= 3 then /* and this is not a catalog record */ call write_copy; /* copy this deck too */ end update_list; /* put_hdr - internal procedure to output a listing page header */ put_hdr: proc; call ioa_$ioa_switch (liocb_ptr, "^[^|^]^-^a ^[POL^4s^;^a,^-^a ^2d^[ (cont't)^;^]^],^61tTime - ^a, Page - ^2d^/", first_ff, "Library -", fnp_tape, o_card.library, "Tape File Number -", pfile, cont_sw, time_string, page_no); call ioa_$ioa_switch (liocb_ptr, "^a ^[FNP ^a ^a^1s^;^2s^a^] ^a^[^;^71tContents of ^a>tandd_deck_file^]^/", "Contents of", fnp_tape, fnp_type, "Binary Deck Tape", "ITR, Firmware And Diagnostic (IFAD) Tape", tape_name, list, dir); call ioa_$ioa_switch (liocb_ptr, " ^[ call^; ^] ^a ^[^a^2-^s^;^s ^a^2-^]^-^[ ^[^a^]^;^2s ^a^]", (o_card.call_name ^= "" & ^fnp_tape), hdra, lib, hdra1, hdra2, list, ^fnp_tape, hdra4, hdra3); call ioa_$ioa_switch (liocb_ptr, " ^[ N__a_m_e^; ^] ^a ^[^a^s^;^s^a^2-^]^-^[^[^a^]^;^2s ^a^]^/", (o_card.call_name ^= "" & ^fnp_tape), hdrb, lib, hdrb1, hdrb2, list, ^fnp_tape, hdrb4, hdrb3); hdr_sw, cont_sw, first_ff = "1"b; /* form feeds no longer inhibited */ line_count = 0; /* reset line counter */ page_no = page_no + 1; /* increment listing page number */ end put_hdr; /* put_patch - internal procedure to add patch card images to listing file */ put_patch: proc; if ^hdr_sw then call put_hdr; /* if we need a new page header, do it */ call ioa_$ioa_switch (liocb_ptr, "The following patch cards are contained in the above deck:^/"); line_count = line_count + 1; /* increment line count */ if line_count >= 25 then call put_hdr; /* put out header if required */ do i = 1 to p_blk.p_cnt; /* output all patches */ call ioa_$ioa_switch (liocb_ptr, "^-^a^/", p_blk.p_card (i)); line_count = line_count + 1; if line_count >= 25 then call put_hdr; /* put out header if requeired */ end; p_blk.p_cnt = 0; /* initialize count */ end put_patch; /* ck_patch - internal procedure to check a bcd card image for a ligit patch card */ ck_patch: proc (err_bit); dcl err_bit bit (1); call bcd_to_ascii_ (gc_log_rec_bits, err_card); v_patch = "0"b; /* reset patch flag */ if h_patch.hex = "hex" then /* if hex patch */ if o_card.assem = "m" then /* and deck produced with mpc assembler */ if h_patch.cr = "c" | h_patch.cr = "r" then /* for cs or r/w mem */ if h_patch.lbl = o_card.edit_name then /* if label matches */ if h_patch.rev = string (id_blk.revision) then /* and rev matches */ v_patch = "1"b; /* valid hex patch */ if ^v_patch then /* if it wasn't hex patch */ if o_patch.octal = "octal" | o_patch.octal = "mask" then v_patch = "1"b; /* valid octal patch */ if v_patch then do; /* if one of the above */ p_blk.p_cnt = p_blk.p_cnt + 1; /* increment patch count */ p_blk.p_card (p_blk.p_cnt) = err_card; /* copy image */ end; else do; /* not valid patch abort */ call com_err_ (0, pname, "BCD card image at record ^d, file ^d is not $ object, $ dkend, or valid patch card:^/""^a""", crec, cfile, err_card); err_bit = "1"b; end; end ck_patch; /* make_key - int procedure to make up a key for insertion into the deckfile based on object card info */ make_key: proc; current_key = ""; /* initialize key first */ if fnp_tape then do; /* make special key for fnp bin deck tapes */ fnp_key = fnp_key + 1; /* increment fnp key number */ current_key = "fnp." || fnp_type || ".pol." || ltrim (char (fnp_key)) || "." || substr (o_card.edit_name, 1, 2); end; else if o_card.library = "hmpcj1" then do; /* if mpc deck */ if id_blk.type ^= "itr" & id_blk.type ^= "mdr" then /* if firmware deck */ current_key = string (id_blk.type_code) || "."; /* set firmware identification */ else current_key = id_blk.type || "."; /* itr or mdr */ current_key = rtrim (current_key) || id_blk.ident || "." || o_card.edit_name; current_key = rtrim (current_key) || "." || id_blk.rev; /* set revision */ end; else do; /* must be htnd deck */ if o_card.ss_type = "s" then /* take care of special cases first */ current_key = "pas." || substr (o_card.edit_name, 1, 3); /* isolts deck */ else if o_card.ss_type = "u" then /* utility deck */ current_key = "utl." || o_card.call_name; else current_key = o_card.ss_type || "lt." || o_card.call_name; /* most common case */ return; end; cata.n_entries = cata.n_entries + 1; /* increment number of catalog entries */ cata.key (n_entries) = current_key; /* and add current entry to catalog */ end make_key; /* insert_deck - int procedure to insert current deck into the T & D deckfile */ insert_deck: proc (bufp, buf_len, isd_abort); dcl bufp ptr; dcl buf_len fixed bin (21); dcl isd_abort bit (1); isd_abort = "0"b; /* reset abort flag */ reseek: work_key = current_key; /* copy working key */ call iox_$seek_key (fiocb_ptr, work_key, rec_len, code); /* set key for insertion */ if code ^= error_table_$no_record then do; /* if record already exists */ if code = 0 then do; /* check for common itr */ if index (current_key, ".common.") ^= 0 then /* common itr */ return; /* its already in deckfile */ call iox_$delete_record (fiocb_ptr, code); go to reseek; /* try again */ end; else do; /* some other problem, tell user */ call com_err_ (code, pname, "attempting to seek to record whose key is ""^a""", work_key); isd_abort = "1"b; /* and abort */ return; end; end; call iox_$write_record (fiocb_ptr, bufp, buf_len, code); /* write the record */ if code ^= 0 then do; /* fatal error */ call com_err_ (code, pname, "attempting to write record whose key is ""^a"" to the tandd_deck_file", work_key); isd_abort = "1"b; /* set abort flag */ end; end insert_deck; /* ld_fw_deck - procedure to load core image of firmware deck into a segment named "fw.." */ ld_fw_deck: proc; ename = "fw." || id_blk.ident || "." || o_card.edit_name || "." || id_blk.rev; /* form firmware seg name */ call hcs_$initiate (dir, ename, "", 0, 0, segp, code); /* attempt to initiate seg */ if segp = null then do; /* seg does not exist, create it */ call hcs_$make_seg (dir, ename, "", 01010b, segp, code); if segp = null then do; /* error creating segment */ call com_err_ (code, pname, "Unable to create ^a>^a", dir, ename); return; end; end; if patches then call gload_$allow_zero_checksums (pname, dir, ename, bptr, segp, 0, addr (gload_data), code);/* load the core image */ else call gload_ (bptr, segp, 0, addr (gload_data), code); /* load the core image */ if code ^= 0 then do; /* loading error */ call com_err_ (code, pname, "^a^/attempting to load core image of ^a>^a", gload_data.diagnostic, dir, ename); return; end; call hcs_$set_bc_seg (segp, fixed (gload_data.text_len) * 36, code); /* set bit count of fw seg */ if code ^= 0 then do; /* error setting bit count */ call com_err_ (code, pname, "Unable to set bit count of ^a>^a", dir, ename); return; end; end ld_fw_deck; /* ck_applic - int procdure to check for current deck Multics Applicability. If deck is appicable, "1"b is returned */ ck_applic: proc returns (bit (1)); if o_card.m_applic ^= " " then do; /* only take deck if Multics applicable */ if o_card.library = "hmpcj1" then /* if itr deck */ if id_blk.type = "itr" then /* space to nxt file */ call space_file; /* space to nxt file */ else ; else if o_card.ss_type = "h" then /* space over heals files */ call space_file; /* space to nxt file */ return ("0"b); /* return false */ end; else do; /* Multics applicable */ if config_sw then /* if tailoring deckfile via current config */ if ^ck_fig () then /* and current deck does not meet requirments */ return ("0"b); /* return false */ if o_card.library = "hmpcj1" then do; /* if itr, mdr or firmware deck */ if id_blk.type = "mdr" then /* if current deck an mdr */ if firmware_sw then do; eot = "1"b; /* and we are only loading firmware, thats it */ return ("0"b); end; else ; else if id_blk.type ^= "itr" then /* else if firmware deck */ if ^deckfile_sw then /* and not just loading deckfile */ call ld_fw_deck; /* go load core image for BOS */ if ^first_deck & ^firmware_sw then do; /* if first deck of current file */ cat_build, first_deck = "1"b; /* set flag so we don't come back */ cata.n_entries = 0; /* reset number of catalog entries */ if id_blk.type = "mdr" then cat_key = "mdr."; /* mdr deck */ else cat_key = "itr."; /* itr or fw */ if id_blk.type = "mdr" then do; /* if building mdr catalog */ if o_card.ss_type = "t" then sstype = "tape "; /* tape catalog */ else if o_card.ss_type = "p" then sstype = "print"; /* printer catalog */ else if o_card.ss_type = "c" then sstype = "card "; /* card catalog */ else if o_card.ss_type = "d" then sstype = "disk "; /* disk catalog */ else do; /* unknown type */ call com_err_ (0, pname, "Unknown subsystem type (col 23) on $ object card"); call com_err_ (0, pname, "Last $ object card image is: ^/""^a""", obj_buf); first_deck = "0"b; /* check next $ object card */ return ("1"b); end; cat_key = rtrim (cat_key) || sstype; /* complete mdr catalog key */ end; end; end; end; return ("1"b); /* return true */ end ck_applic; /* write_copy - subroutine to write current deck to copy tape */ write_copy: proc; if ^first_write then do; /* if this is the first time thru, set density */ first_write = "1"b; /* set flag so we don't come back */ if cd_sw | denno ^= 0 then do; /* if user specified density */ if denno ^= 0 & ^cd_sw then /* if master tape not standard density */ cden = density (denno); /* set copy to same (if not user specified) */ call iox_$control (ciocb_ptr, cden, null, code); end; end; prptr = bptr; /* set block ptr to first phy. record */ do while (bin (rel (prptr)) < dlen - 1 & ^eot); /* wrt entire deck */ c_rtrycnt = 0; /* initialize retry count */ retry_cp: call iox_$write_record (ciocb_ptr, prptr, (bcw.blk_size + 1) * 4, code); if code ^= 0 then /* if error */ if code = error_table_$tape_error then do; /* if write error */ c_rtrycnt = c_rtrycnt + 1; /* increment retry count */ if c_rtrycnt > 10 then do; /* exceeded error threshold */ call iox_$control (ciocb_ptr, "saved_status", addr (t_stat), scode); call com_err_ (code, pname, "Tape status = ^4.3b, while writing copy tape after 10 retrys", t_stat); eot = "1"b; end; else do; call iox_$control (ciocb_ptr, "backspace_record", null, scode); call iox_$control (ciocb_ptr, "erase", null, scode); go to retry_cp; end; end; else do; /* not a tape error */ call com_err_ (code, pname, "while writing copy tape"); eot = "1"b; /* set abort flag */ end; else prptr = addrel (prptr, currentsize (gc_phy_rec)); /* no error advance to next block */ end; copy_at_eof = "0"b; /* we are no longer at an eof mark */ end write_copy; /* set_fig - int procedure to set up config parameters for the "-config" option */ set_fig: proc; /* this procedure will be implemented later when new config cards are installed */ end set_fig; /* ck_fig - internal procedure to check current deck against config parameters */ ck_fig: proc returns (bit (1)); /* this procedure will be implemented later when new config cards are installed */ return ("1"b); end ck_fig; /* detach_tape_file - internal procedure to detach and close tape and file */ detach_tape_file: proc; /* procedure to close and detach tape */ if t_attached then do; call iox_$close (tiocb_ptr, code); call iox_$detach_iocb (tiocb_ptr, code); call release_temp_segments_ (pname, tempp, code); /* release our temp segments */ t_attached = "0"b; end; if l_attached then do; call iox_$close (liocb_ptr, code); call iox_$detach_iocb (liocb_ptr, code); l_attached = "0"b; end; if f_attached then do; call iox_$close (fiocb_ptr, code); call iox_$detach_iocb (fiocb_ptr, code); f_attached = "0"b; end; if c_attached then do; /* if copy tape attached */ call iox_$close (ciocb_ptr, code); call iox_$detach_iocb (ciocb_ptr, code); c_attached = "0"b; end; end detach_tape_file; /* space_file - int procedure to formward space to nxt tape file */ space_file: proc; call iox_$control (tiocb_ptr, "forward_file", null, code); cfile = cfile + 1; /* set correct position */ crec = 0; one_eof = "1"b; /* set eof flag */ end space_file; /* copy_eof - subroutine to write end of file mark on copy tape */ copy_eof: proc; call iox_$control (ciocb_ptr, "write_eof", null, code); copy_at_eof = "1"b; /* set copy eof flag */ end copy_eof; %include gcos_ssf_records; %include gload_data; %include rs_info; end load_tandd_library; */ ----------------------------------------------------------- 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 */